package Text::TEI::Markup;

use strict;
use vars qw( $VERSION @EXPORT_OK );
use Encode;
use Exporter 'import';
use XML::LibXML;

$VERSION = '1.0';
@EXPORT_OK = qw( &to_xml &word_tag_wrap );

=head1 NAME

Text::TEI::Markup - a transcription markup syntax for TEI XML

=head1 SYNOPSIS

 use Text::TEI::Markup qw( to_xml );
 my $xml_string = to_xml( file => $markup_file, 
    template => $template_xml_string,
    %opts );  # see below for available options

 use Text::TEI::Markup qw( word_tag_wrap );
 my $word_wrapped_xml = word_tag_wrap( $tei_xml_string );

=head1 DESCRIPTION

TEI XML is a wonderful thing.  The elements defined therein allow a
transcriber to record and represent just about any feature of a text
that he or she encounters.

The problem is the transcription itself.  When I am transcribing a
manuscript, especially if that manuscript is in a bunch of funny
characters on the keymap for another language, I do not want to be
switching back and forth between keyboard layouts in order to type
"<tag attr="attr>" arrow-arrow-arrow-arrow-arrow "</tag> every six
seconds.  It's prone to typo, it's astonishingly slow, and it makes my
wrists hurt just to think about it.  I also don't really want to fire
up an XML editor, select the words or characters that need to be
tagged, and click a lot.  That way is not prone to typo, but it's
still pretty darn slow, and it makes my wrists hurt B<even more> to
think about.

Text::TEI::Markup is my solution to that problem.  It defines a bunch
of single- or double-character sigils that represent tags.  These are
a lot faster and easier to type; I don't have to worry about typos;
and I can do it all with a plain text editor, thus minimizing use of
the mouse.

I have tried to pick sigils that don't conflict with characters that
are found in manuscripts.  I have succeeded for my particular set of
manuscripts, but I have not succeeded for the general case.  If you
like the idea behind this module, you are still almost guaranteed to
hate the sigils I've picked.  That's okay; you can re-define them.

=head2 Extra bonus solution: word wrapping with <w/> and <seg/>

Even if you are happy as a clam in the graphical XML editor of your
choice, this module exports a function that may be useful to you.  The
TEI P5 guidelines include a module called "analysis", which allows the
user to tag sentences, clauses, words, morphemes, or any other sort of
semantic segment of a text.  This is really good for programmatic
applications, but very boring and repetitive to have to tag.

The function B<word_tag_wrap> solves part of this problem for you.  It
takes an XML string as input, looks for words (defined by whitespace
separation) and returns an XML string with each of these words wrapped
in an appropriate tag.  If the word has complex elements
(e.g. editorial expansion), it will be wrapped in a <seg type="word/>
tag.  If not, it will be in a simple <w/> tag.  It handles line breaks
and page breaks within words, as long as there is no trailing
whitespace before the <lb/> (or <pb/>) tag, and as long as the
whitespace after the tag contains a carriage return.

=head1 MARKUP SYNTAX

The input file has a header and a body. The header begins with a
'=HEAD' tag, and consists of a colon-separated list of key_value
pairs.  These keys, which are case insensitive, get directly
substituted into an XML template; the idea is that your TEI header
won't change very much between files, so you write it once with
template values, pass it to &to_xml, and the substitution happens as
if by magic.  The keyword /MAIN/i is reserved for the content between
the <body></body> tags - that is, all the content that will be
generated after the '=BODY' tag.

A very simple template looks like this:
 <?xml version="1.0" encoding="UTF-8">
 <TEI>
   <teiHeader>
     <fileDesc>
       <titleStmt>
         <title>__TITLE__</title>
         <author__AUTHOR__</author>
         <respStmt xml:id="#__MYINITIALS__">
           <resp>Transcription by</resp>
           <name>__MYNAME__</name>
         </respStmt>
       </titleStmt>
     </fileDesc>
   </teiHeader>
   <text>
     <body>
     __MAIN__
     </body>
   </text>
 </TEI>

Your input file should then begin something like this:

 =HEAD
 title:My Summer Vacation: a novel
 author:John Smith
 myinitials:tla
 myname:Tara L Andrews
 =BODY
 The real text begins here.
 ...


The real work begins after the '=BODY' tag.  The currently-defined
sigil list is:

 %SIGILS = ( 
    'comment' => '##',
    'add' => '+',
    'del' => '-',
    'subst' => "\x{b1}",   # Unicode PLUS-MINUS SIGN
    'div' => "\x{a7}",     # Unicode SECTION SIGN
    'p' => "\x{b6}",       # Unicode PILCROW SIGN
    'ex' => '\\',
    'expan' => '^',
    'abbr' => [ '{', '}' ],
    'num' => '%',
    'pb' => [ '[', ']' ],
    'hi' => '*',
    );

Non-identical matched sets of sigla (e.g. '{}' for abbreviations)
should be specified in a listref, as seen here.

Whitespace is only significant at the end of lines.  If a line which
contains non-tag text (i.e. words) ends in whitespace, it is assumed
that the previous word is a complete word.  If the line ends with a
non-whitespace character, it is assume that the word continues onto
the next line.

All the sigils must be balanced, and they must nest properly.
Remember that this is a shorthand for XML.  I could be convinced to
try to autocorrect some unbalanced sigils, but it would be worth at
least a few pints of cider (or, of course, a patch.)

=head1 SUBROUTINES

=over 4

=item B<to_xml>( file => '$filename', %opts );

Takes the name of a file that holds a marked-up version of text.
Returns a TEI XML string to represent that text.

Options include:

=over 4

=item C<template>

a string containing the XML template that you want to use for the
markup.  If none is specified, there is a default.  That default is
useful for me, but is very unlikely to be useful for you.

=item C<fileopen_mode>

a mode string to pass to the open() call on the file.  Default "<:utf8".

=item C<number_conversion> 

a subroutine ref that will calculate the value of number
representations.  Useful for, e.g., Latin numerals.  This is optional
- if nothing is passed, no number value calculation will be attempted.

=item C<sigils> 

a hashref containing the preferred sigil representations of TEI tags.
Defaults to the list above.

=item C<wrap_words> 

Defaults to "true".  If you pass a false value, the word wrapping will
be skipped.

=item C<format>

Defaults to 0.  Controls whether rudimentary formatting is applied to
the XML returned.  Possible values are 0, 1, and "more than 1".  See
XML::LibXML::Document::to_string for more information.  (Personally I
just xmllint it separately.)

=back

The return string is run through the basic formatting mechanism
provided by XML::LibXML.  You may wish to pass it through a pretty
printer more to your taste.

=cut

# Default list of funky signs I use.
# TODO: Add header support
my %SIGILS = ( 
    'comment' => '##',
    'add' => '+',
    'del' => '-',
    'subst' => "\x{b1}",
    'div' => "\x{a7}",
    'p' => "\x{b6}",
    'ex' => '\\',
    'expan' => '^',
    'abbr' => [ '{', '}' ],
    'num' => '%',
    'pb' => [ '[', ']' ],
    'hi' => '*',
    # 'head' => "\x{86}",
    );

sub to_xml {
    my %opts = (
	'number_conversion' => undef,
	'fileopen_mode' => '<:utf8',
	'wrap_words' => 1,
	'sigils' => \%SIGILS,
	'template' => undef,
	'format' => 0,
	@_,
    );

    unless( defined( $opts{'file'} ) ) {
	warn "No file specified!  Doing nothing.";
	return undef;
    }

    if( ref( $opts{'number_conversion'} ) ne 'CODE' ) {
	warn "number_conversion argument must be a subroutine ref";
	$opts{'number_conversion'} = undef;
    }

    my $inbody;
     
    my $rc = open( FILE, $opts{'fileopen_mode'}, $opts{'file'} );
    unless( $rc ) {
	warn "Could not open $opts{'file'}: $@";
	return undef;
    }

    my $tmpl;
    if( defined $opts{'template'} ) {
	$tmpl = $opts{'template'};
    } else {
	my @tmpl_lines = <DATA>;
	$tmpl = join( '', @tmpl_lines );
    }

    my $main_xml;

    my( $in_p, $in_div ) = ( undef, undef );
    while(<FILE>) {
	chomp;
	next if /^\s*$/;
	s/^\s*//;
	
	if( /^=BODY/ ) {
	    $inbody = 1;
	    # Have we found a responsible person?
	    unless( exists $opts{'resp'} ) {
		warn "No responsible person specified for edits!";
	    }
	    next;
	}
	
	if( /^(\w+):(.*)$/ ) {
	    # Make the header template substitution.
	    warn "Warning: header line $_ in body section" if $inbody;
	    my( $key, $val ) = ( $1, $2 );
	    if( $key eq 'MAIN' ) {
		warn "Illegal key $key; not substituting";
	    } else {
		$tmpl =~ s/__${key}__/$val/gi;
	    }
	    if( $key =~ /^transcriberid$/i ) {
		$opts{'resp'} = '#' . $val;
	    }
	}
	
	if( $inbody ) {
	    # Send it to the parser.
	    my $line;
	    ## TODO: Upgrade to perl 5.10 to get state variables.
	    ( $line, $in_div, $in_p ) = _process_line( $_, $in_div, $in_p, %opts );
	    $main_xml .= $line;
	}
    }
    close FILE;

    $tmpl =~ s/__MAIN__/$main_xml/;
    if( $opts{'wrap_words'} ) {
	$tmpl = word_tag_wrap( $tmpl, $opts{'format'} );
    } else {
	# Just make sure it parses, and format it if asked.
	my $parser = XML::LibXML->new();
	my $doc;
	my $ok = eval{ $doc = $parser->parse_string( $tmpl ); };
	unless( $ok ) {
	    warn "Parsing of new XML doc failed: $@";
	    return undef;
	}
	if( $doc->encoding =~ /utf-8/i ) {
	    $tmpl = decode_utf8( $doc->toString( $opts{'format'} ) );
	} else {
	    $tmpl = $doc->toString( $opts{'format'} );
	}
    }
    return $tmpl;
}

sub _process_line {
    my( $line, $in_div, $in_p, %opts ) = @_;
    chomp $line;
    
    # Look for paragraph and div markers.  
    my $sigils = $opts{'sigils'};
    my( $divsig, $pgsig ) = ( $sigils->{'div'}, $sigils->{'p'} );
    while( $line =~ /\Q$divsig\E(\d*)/g ) {   
	my $divno = $1;
	# Calculate the starting position.
	my $pos = pos( $line ) - 1;
	$pos -= length( $divno ) if $divno;
	
	if( $in_div ) {
	    warn "Nonsensical division number at end-division tag"
		if $divno;
	    substr( $line, $pos, 1, '</div>' );
	} else {
	    my $divstr = '<div' . ( $divno ? " n=\"$divno\"" : '' ) . ">";
	    substr( $line, $pos, pos( $line ) - $pos, $divstr );
	}
	$in_div = !$in_div;
    }
	    
    while( $line =~ /\Q$pgsig\E/g ) {
	my $p_str = '<' . ( $in_p ? '/' : '' ) . 'p>';
	substr( $line, pos( $line ) - 1, 1, $p_str );
	$in_p = !$in_p;
    }
    
    # Add and delete tags.  Do this first so that we do not stomp later
    # instances of the dash (e.g. in XML comments).
    while( $line =~ m|([-+])(\(([^\)]+)\))?(.*?)\1|g ) {
	my( $op, $where, $word ) = ( $1, $3, $4 );
	#  Calculate starting position.
	my $pos = pos( $line ) - ( length( $word ) + 2 );
	$pos -= ( length( $where ) + 2 ) if $where;
	my $interp_str = '<' . ( $op eq '+' ? 'add' : 'del' )
	    . ( $where ? " place=\"$where\"" : '' )
	    . ">$word</" . ( $op eq '+' ? 'add' : 'del' ) . '>';
	substr( $line, $pos, pos( $line ) - $pos, $interp_str );
    }
    
    
    # All the tags that are not very special cases.
    foreach my $tag ( qw( subst expan abbr hi ex num ) ) {
	my $tag_sig = $sigils->{$tag};
	my( $tag_open, $tag_close );
	if( ref( $tag_sig ) eq 'ARRAY' ) {
	    ( $tag_open, $tag_close ) = @$tag_sig;
	} else {
	    $tag_open = $tag_close = $tag_sig;
	}
	
	$line =~ s|\Q$tag_open\E(.*?)\Q$tag_close\E|_open_tag( $tag, $1, \%opts ) . "</$tag>"|ge;
    } 
    
    # Page breaks.  Defined by the delimiters, plus an optional
    # page/folio number & recto/verso indicator, on a line by itself.
    # Of course other languages may use other sigils to indicate recto
    # verso, so do not look for 'r' and 'v' specifically.
    my $pg_sig = $sigils->{'pb'};
    my ( $pg_open, $pg_close );
    if( ref( $pg_sig ) eq 'ARRAY' ) {
	( $pg_open, $pg_close ) = @$pg_sig;
    } else {
	$pg_open = $pg_sig;
	$pg_close = $pg_sig;
    }
    $line =~ s|^\Q$pg_open\E(\d+(.)?)\Q$pg_close\E\s*$|<pb n=\"$1\"/>|;

    
    # XML comments.  Convert ## text ## to <!-- text -->
    my $com_sig = $sigils->{'comment'};
    my ( $com_open, $com_close );
    if( ref( $com_sig ) eq 'ARRAY' ) {
	( $com_open, $com_close ) = @$com_sig;
    } else {
	$com_open = $com_close = $com_sig;
    }
    $line =~ s|\Q$com_open\E(.*?)\Q$com_close\E|<!--$1-->|g;
    

    # Finally, every line with text outside an XML tag must have a line
    # break.  Any lb tag should be inside a p or div tag.
    my $testline = $line;
    $testline =~ s/<[^>]*>//g;
    if( $testline =~ /\S/ ) {
	no warnings 'uninitialized';
	$line =~ s!(</p>|</div>)?$!<lb/>$1!;
    }	

    # Return the expanded line.
    return( "$line\n", $in_div, $in_p );
}

sub _open_tag {
    my( $tag, $arg, $opts ) = @_;

    my $opened_tag;
    if( $tag eq 'ex' ) {
	# It takes a resp agent.
	$opened_tag = '<ex resp="' . $opts->{'resp'} . "\">$arg";
    } elsif ( $tag eq 'num' ) {
	# Derive the number's value if requested.
	my $numconvert = $opts->{'number_conversion'};
	if( defined $numconvert ) {
	    my $nv = &$numconvert( $arg );
	    $opened_tag = "<num value=\"$nv\">$arg" if defined $nv;
	}
    } 

    # The default
    $opened_tag = "<$tag>$arg" unless $opened_tag;
    return $opened_tag;
}

=item B<word_tag_wrap>( $xml_string )

Takes a string containing a TEI XML document, and returns that
document with all its words wrapped in <w/> (or <seg/>) tags.  A
"word" is defined as a series of text characters separated by
whitespace.  A word can have a line break, or even a page break, in
the middle; if this is the case, there I<may not> be any whitespace
between the end of the first word segment and the <lb/> (or <pb/>)
tag.  Conversely, there I<must> be whitespace separating the <lb/> (or
<pb/>) from a complete word.

=cut

sub word_tag_wrap {
    my( $xml, $format ) = @_;
    $format = 0 unless defined $format;
    
    my $parser = XML::LibXML->new();
    my $doc = $parser->parse_string( $xml );

    # TODO: validate it.
    my $root = $doc->getDocumentElement();
    my @textnodes = $root->getElementsByTagName( 'text' );
    foreach my $t ( @textnodes ) {
	foreach my $p ( $t->getElementsByTagName( 'p' ) ) {
	    my $new_p = _wrap_children( $p );
	    $p->replaceNode( $new_p );
	}
    }
    
    # Annoyingly, we have to decode the encoding that takes place when
    # the string is returned.
    if( $doc->encoding() =~ /utf-8/i ) {
	return decode_utf8( $doc->serialize( $format ) );
    } else {
	return $doc->serialize( $format );
    }
}

sub _wrap_children {
    my $node = shift;
    my @children = $node->childNodes;

    my $new_node = XML::LibXML::Element->new( $node->nodeName );
    # Set the namespace
    $new_node->setNamespace( $node->namespaceURI );
    my $open_word_node = undef;
    foreach my $c ( @children ) {
	# Is it a text node?
	if( ref( $c ) eq 'XML::LibXML::Text' ) {
	    # Get the text.
	    my $str = $c->textContent;
	    # Strip out carriage returns and their surrounding spaces.
	    # Carriage returns should only occur after <lb/> elements,
	    # and the spaces around them should therefore be insignificant.
	    $str =~ s/^\s*\n\s*//gs;
	    # If there is nothing at all but a newline + initial spaces,
	    # pretend that the node isn't there at all.
	    next unless $str;

	    # Get the individual words.
	    my @words = split( /\s+/, $str );

	    # Finish out the last word if we need to.
	    if( $open_word_node ) {
		# If there are any words in this text string, the
		# first one should be used to close out the open node.
		# If the first word is empty, it's a space and the
		# word should just be closed.  If there are no words
		# at all, it was just a space.  If the first word was
		# all there is, we haven't encountered a space yet and
		# need to keep the word open.
		if( @words ) {
		    my $first = shift @words;
		    $open_word_node->appendText( $first ) if $first;
		} else {
		    $open_word_node = undef unless @words;
		}
	    }

	    foreach( @words ) {
		# Skip whitespace "words"
		next unless /\S/;

		# Make a new node for the word
		my $word_node = XML::LibXML::Element->new( 'w' );
		$word_node->appendText( $_ );
		$new_node->appendChild( $word_node );
		# ...and keep it open until we find a new word or a space
		$open_word_node = $word_node;
	    }
	    
	    # Close the last word node if our text node ends in a space.
	    if( $str =~ /\s+$/s ) {
		$open_word_node = undef;
	    }
	} else {
	    my $wrapped_child;
	    if ( ref( $c ) ne 'XML::LibXML::Comment' && $c->textContent ne ''
		 && $c->textContent =~ /\s+/ ) {
		# Recurse on any node that itself contains whitespace-separated text.
		my $new_c = _wrap_children( $c );
		$wrapped_child = ( $c->toString() ne $new_c->toString() );
		$c = $new_c;
	    } 
	    
	    # If there is an open word node, make it a seg and append
	    # our result there; if the child has text content but no
	    # word children, wrap it in a new seg; otherwise just pass
	    # it on through.
	    if( $open_word_node ) {
		$open_word_node->setNodeName( 'seg' );
		$open_word_node->setAttribute( 'type', 'word' );
		$open_word_node->appendChild( $c );
	    } elsif( ref( $c ) eq 'XML::LibXML::Comment' || $c->textContent eq '' 
		|| $wrapped_child ) {
		$new_node->appendChild( $c );
	    } else {
		my $segment_node = XML::LibXML::Element->new( 'seg' );
		$segment_node->setAttribute( 'type', 'word' );
		$segment_node->appendChild( $c );
		$new_node->appendChild( $segment_node );
		# Keep it open in case there is not a leading space on the next
		# text node.
		$open_word_node = $segment_node;
	    }
	}
    }

    return $new_node;    
}

=back

=head1 BUGS / TODO

The XML is not currently validated against a schema.  This is mostly
because I have been unable to get RelaxNG validation to work against
certain TEI schemas.

This module is currently in a state that I know to be useful to me.
If it looks like it might be useful to you, but something is bugging
you about it, report it!

=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews, L<aurum@cpan.org>


=cut

__DATA__
<?xml version="1.0" encoding="UTF-8"?>
<?oxygen RNGSchema="tools/tei_ms_crit.rng" type="xml"?>
<TEI
  xmlns:xi="http://www.w3.org/2001/XInclude"
  xmlns:svg="http://www.w3.org/2000/svg"
  xmlns:math="http://www.w3.org/1998/Math/MathML"
  xmlns="http://www.tei-c.org/ns/1.0">
    <teiHeader>
        <fileDesc>
            <titleStmt>
                <title>__TITLE__</title>
                <author>__AUTHOR__</author>
                <respStmt xml:id="__TRANSCRIBERID__">
                    <resp>Transcription by</resp>
                    <name>__TRANSCRIBER__</name>
                </respStmt>
            </titleStmt>
            <publicationStmt>
                <p>__PUBLICATIONSTMT__</p>
            </publicationStmt>
            <sourceDesc>
                <msDesc>
                    <msIdentifier>
                        <settlement>__SETTLEMENT__</settlement>
                        <repository>__REPOSITORY__</repository>
                        <idno>__IDNO__</idno>
                    </msIdentifier>
                    <p>__PAGES__</p>
                </msDesc>
            </sourceDesc>
        </fileDesc>
    </teiHeader>
    <text>
        <body>
__MAIN__
        </body>
    </text>
</TEI>
