1 package Text::Tradition::Parser::CTE;
5 use Text::Tradition::Parser::Util qw/ collate_variants /;
7 use XML::LibXML::XPathContext;
11 Text::Tradition::Parser::CTE
15 Parser module for Text::Tradition, given a TEI file exported from
16 Classical Text Editor.
24 my @apparatus = read( $xml_file );
26 Takes a Tradition object and a TEI file exported from Classical Text
27 Editor using double-endpoint-attachment critical apparatus encoding;
28 initializes the Tradition from the file.
32 my %sigil_for; # Save the XML IDs for witnesses.
33 my %apps; # Save the apparatus XML for a given ID.
36 my( $tradition, $xml_str ) = @_;
37 my $c = $tradition->collation; # Some shorthand
39 # First, parse the XML.
40 my $parser = XML::LibXML->new();
41 my $doc = $parser->parse_string( $xml_str );
42 my $tei = $doc->documentElement();
43 my $xpc = XML::LibXML::XPathContext->new( $tei );
45 # CTE uses a DTD rather than any xmlns-based parsing. Thus we
46 # need no namespace handling.
48 # Get the witnesses and create the witness objects.
49 foreach my $wit_el ( $xpc->findnodes( '//sourceDesc/listWit/witness' ) ) {
50 # The witness xml:id is used internally, and is *not* the sigil name.
51 my $id= $wit_el->getAttribute( 'xml:id' );
52 my @sig_parts = $xpc->findnodes( './abbr/descendant::text()', $wit_el );
53 my $sig = _stringify_sigil( @sig_parts );
54 $tradition->add_witness( sigil => $sig, source => $wit_el->toString() );
55 $sigil_for{'#'.$id} = $sig; # Make life easy by keying on the ID ref syntax
58 # Now go through the text and find the base tokens, apparatus tags, and
59 # anchors. Make a giant array of all of these things in sequence.
60 # TODO consider combining this with creation of graph below
62 foreach my $pg_el ( $xpc->findnodes( '/TEI/text/body/p' ) ) {
63 foreach my $xn ( $pg_el->childNodes ) {
64 push( @base_text, _get_base( $xn ) );
68 # We now have to work through this array applying the alternate
69 # apparatus readings to the base text. Essentially we will put
70 # everything on the graph, from which we will delete the apps and
71 # anchors when we are done.
74 foreach my $item ( @base_text ) {
76 if( $item->{'type'} eq 'token' ) {
77 $r = $c->add_reading( 'n'.$counter++ );
78 $r->text( $item->{'content'} );
79 } elsif ( $item->{'type'} eq 'anchor' ) {
80 $r = $c->add_reading( '#ANCHOR_' . $item->{'content'} . '#' );
81 } elsif ( $item->{'type'} eq 'app' ) {
82 my $tag = '#APP_' . $counter++ . '#';
83 $r = $c->add_reading( $tag );
84 $apps{$tag} = $item->{'content'};
86 $c->add_path( $last, $r, 'BASE' );
89 $c->add_path( $last, $c->end, 'BASE' );
91 # Now we can parse the apparatus entries, and add the variant readings
94 foreach my $app_id ( keys %apps ) {
95 _add_readings( $c, $app_id );
98 # With the variant readings added, we now have to walk the graph for
99 # each witness and add an explicit path wherever there is not a divergence
100 # from BASE. Thus we will also construct $wit->path.
102 foreach my $wit ( $tradition->witnesses ) {
103 my $sig = $wit->sigil;
104 my @wit_path = $c->reading_sequence( $c->start, $c->end, $sig, 'BASE' );
106 foreach my $n ( @wit_path ) {
107 next if $cur eq $c->start;
108 my @paths = $cur->edges_to( $n );
109 unless( grep { $_->name eq $sig } @paths ) {
110 $c->add_path( $cur, $n, $sig );
113 $wit->path( \@wit_path );
116 # Collated readings are now on the graph, so now we get to remove
117 # all BASE edges and all app/anchor nodes.
118 foreach my $p ( $c->paths ) {
119 $c->del_path( $p ) if $p->name eq 'BASE';
121 foreach my $n ( $c->readings ) {
122 if( $n->name =~ /^\#A(PP|NCHOR)/ ) {
123 # Pair up incoming / outgoing edges with the same label
124 my( %incoming, %outgoing );
125 foreach my $e ( $n->incoming ) {
126 $incoming{$e->name} = $e->from;
129 foreach my $e ( $n->outgoing ) {
130 $outgoing{$e->name} = $e->to;
133 foreach my $w ( keys %incoming ) {
134 my $from = $incoming{$w};
135 my $to = delete $outgoing{$w};
136 warn "No outgoing edge on ".$n->name." for wit $w" unless $to;
137 $c->add_path( $from, $to, $w );
139 foreach my $w ( keys %outgoing ) {
140 warn "Found no incoming edge on ".$n->name." for wit $w";
142 $c->del_reading( $n );
147 sub _stringify_sigil {
149 my @parts = grep { /\w/ } map { $_->data } @nodes;
150 return join( '', @parts );
153 ## Recursive little helper function to help us navigate through nested
154 ## XML, picking out the words, the apparatus, and the anchors.
159 if( $xn->nodeType == XML_TEXT_NODE ) {
160 # Base text, just split the words on whitespace and add them
164 foreach my $w ( split( /\s+/, $str ) ) {
165 push( @readings, { 'type' => 'token', 'content' => $w } );
167 } elsif( $xn->nodeName eq 'hi' ) {
168 # Recurse as if the hi weren't there.
169 foreach( $xn->childNodes ) {
170 push( @readings, _get_base( $_ ) );
172 } elsif( $xn->nodeName eq 'app' ) {
173 # Apparatus, just save the entire XML node.
174 push( @readings, { 'type' => 'app', 'content' => $xn } );
175 } elsif( $xn->nodeName eq 'anchor' ) {
176 # Anchor to mark the end of some apparatus; save its ID.
177 push( @readings, { 'type' => 'anchor',
178 'content' => $xn->getAttribute( 'xml:id' ) } );
179 } elsif ( $xn->nodeName ne 'note' ) { # Any tag we don't know to disregard
180 print STDERR "Unrecognized tag " . $xn->nodeName . "\n";
186 my( $c, $app_id ) = @_;
187 my $xn = $apps{$app_id};
188 my $anchor = _anchor_name( $xn->getAttribute( 'to' ) );
189 # Get the lemma, which is all the readings between app and anchor,
190 # excluding other apps or anchors.
191 my @lemma = _return_lemma( $c, $app_id, $anchor );
192 my $lemma_str = join( ' ', grep { $_ !~ /^\#/ } map { $_->text } @lemma );
194 # For each reading, send its text to 'interpret' along with the lemma,
195 # and then save the list of witnesses that these tokens belong to.
199 $tag =~ s/^\#APP_(.*)\#$/$1/;
200 foreach my $rdg ( $xn->getChildrenByTagName( 'rdg' ) ) {
202 my $wits = $rdg->getAttribute( 'wit' );
203 foreach ( $rdg->childNodes ) {
204 push( @text, _get_base( $_ ) );
206 my $interpreted = @text
207 ? interpret( join( ' ', map { $_->{'content'} } @text ), $lemma_str )
210 foreach my $w ( split( /\s+/, $interpreted ) ) {
211 my $r = $c->add_reading( $tag . "/" . $ctr++ );
213 push( @rdg_nodes, $r );
215 $wit_rdgs{$wits} = \@rdg_nodes;
218 # Now collate the variant readings, since it is not done for us.
219 collate_variants( $c, \@lemma, values %wit_rdgs );
221 # Now add the witness paths for each reading.
222 foreach my $wit_str ( keys %wit_rdgs ) {
223 my @wits = get_sigla( $wit_str );
224 my $rdg_list = $wit_rdgs{$wit_str};
225 _add_wit_path( $c, $rdg_list, $app_id, $anchor, @wits );
232 return sprintf( "#ANCHOR_%s#", $xmlid );
236 my( $c, $app, $anchor ) = @_;
237 my $app_node = $c->graph->node( $app );
238 my $anchor_node = $c->graph->node( $anchor );
239 my @nodes = grep { $_->name !~ /^\#A(PP|NCHOR)$/ }
240 $c->reading_sequence( $app_node, $anchor_node, 'BASE' );
245 # A utility function to change apparatus-ese into a full variant.
246 my( $reading, $lemma ) = @_;
247 return $reading if $reading eq $lemma;
248 my $oldreading = $reading;
249 # $lemma =~ s/\s+[[:punct:]]+$//;
250 # $reading =~ s/\s*\(?sic([\s\w.]+)?\)?$//;
251 my @words = split( /\s+/, $lemma );
252 if( $reading =~ /^(.*) praem.$/ ) {
253 $reading = "$1 $lemma";
254 } elsif( $reading =~ /^(.*) add.$/ ) {
255 $reading = "$lemma $1";
256 } elsif( $reading eq 'om.' ) {
258 } elsif( $reading eq 'inv.' ) {
259 # Hope it is two words.
260 print STDERR "WARNING: want to invert a lemma that is not two words\n"
261 unless scalar( @words ) == 2;
262 $reading = join( ' ', reverse( @words ) );
263 } elsif( $reading eq 'iter.' ) {
265 $reading = "$lemma $lemma";
266 } elsif( $reading =~ /^(.*) \.\.\. (.*)$/ ) {
267 # The first and last N words captured should replace the first and
268 # last N words of the lemma.
269 my @begin = split( /\s+/, $1 );
270 my @end = split( /\s+/, $2 );
271 if( scalar( @begin ) + scalar ( @end ) > scalar( @words ) ) {
272 # Something is wrong and we can't do the splice.
273 print STDERR "ERROR: $lemma is too short to accommodate $oldreading\n";
275 splice( @words, 0, scalar @begin, @begin );
276 splice( @words, -(scalar @end), scalar @end, @end );
277 $reading = join( ' ', @words );
280 print STDERR "Interpreted $oldreading as $reading given $lemma\n";
286 my @xml_ids = split( /\s+/, $witstr );
287 my @sigs = map { $sigil_for{$_} } @xml_ids;
292 my( $c, $rdg, $app, $anchor, @wits ) = @_;
294 push( @nodes, $c->graph->node( $anchor ) );
296 my $cur = $c->graph->node( $app );
297 foreach my $n ( @nodes ) {
298 foreach my $w ( @wits ) {
299 $c->add_path( $cur, $n, $w );
309 This package is free software and is provided "as is" without express
310 or implied warranty. You can redistribute it and/or modify it under
311 the same terms as Perl itself.
315 Tara L Andrews, aurum@cpan.org