continued doc and testing drive; rationalize GraphML a little
[scpubgit/stemmatology.git] / lib / Text / Tradition / Parser / TEI.pm
CommitLineData
f6066bac 1package Text::Tradition::Parser::TEI;
2
3use strict;
4use warnings;
910a0a6d 5use Text::Tradition::Parser::Util qw( collate_variants );
f6066bac 6use XML::LibXML;
7use XML::LibXML::XPathContext;
8
9=head1 NAME
10
11Text::Tradition::Parser::TEI
12
3b853983 13=head1 SYNOPSIS
14
15 use Text::Tradition;
16
17 my $t_from_file = Text::Tradition->new(
18 'name' => 'my text',
19 'input' => 'TEI',
20 'file' => '/path/to/parallel_seg_file.xml'
21 );
22
23 my $t_from_string = Text::Tradition->new(
24 'name' => 'my text',
25 'input' => 'TEI',
26 'string' => $parallel_seg_xml,
27 );
28
29
f6066bac 30=head1 DESCRIPTION
31
3b853983 32Parser module for Text::Tradition, given a TEI parallel-segmentation file
33that describes a text and its variants. Normally called upon
34initialization of Text::Tradition.
35
36The witnesses for the tradition are taken from the <listWit/> element
37within the TEI header; the readings are taken from any <p/> element that
38appears in the text body (including <head/> elements therein.)
f6066bac 39
40=head1 METHODS
41
e867486f 42=head2 B<parse>( $tradition, $option_hash )
3b853983 43
44Takes an initialized tradition and a set of options; creates the
45appropriate nodes and edges on the graph, as well as the appropriate
46witness objects. The $option_hash must contain either a 'file' or a
47'string' argument with the XML to be parsed.
48
49=begin testing
50
51use Text::Tradition;
52binmode STDOUT, ":utf8";
53binmode STDERR, ":utf8";
54eval { no warnings; binmode $DB::OUT, ":utf8"; };
55
56my $par_seg = 't/data/florilegium_tei_ps.xml';
57my $t = Text::Tradition->new(
58 'name' => 'inline',
59 'input' => 'TEI',
60 'file' => $par_seg,
61 );
f6066bac 62
3b853983 63is( ref( $t ), 'Text::Tradition', "Parsed parallel-segmentation TEI" );
64if( $t ) {
65 is( scalar $t->collation->readings, 319, "Collation has all readings" );
66 is( scalar $t->collation->paths, 2854, "Collation has all paths" );
67}
f6066bac 68
3b853983 69=end testing
f6066bac 70
71=cut
72
910a0a6d 73my $text = {}; # Hash of arrays, one per eventual witness we find.
910a0a6d 74my $substitutions = {}; # Keep track of merged readings
75my $app_anchors = {}; # Track apparatus references
76my $app_ac = {}; # Save a.c. readings
eca16057 77my $app_count; # Keep track of how many apps we have
910a0a6d 78
79# Create the package variables for tag names.
80
81# Would really like to do this with varname variables, but apparently this
82# is considered a bad idea. The long way round then.
83my( $LISTWIT, $WITNESS, $TEXT, $W, $SEG, $APP, $RDG, $LEM )
84 = ( 'listWit', 'witness', 'text', 'w', 'seg', 'app', 'rdg', 'lem' );
3b853983 85sub _make_tagnames {
910a0a6d 86 my( $ns ) = @_;
87 if( $ns ) {
88 $LISTWIT = "$ns:$LISTWIT";
89 $WITNESS = "$ns:$WITNESS";
90 $TEXT = "$ns:$TEXT";
91 $W = "$ns:$W";
92 $SEG = "$ns:$SEG";
93 $APP = "$ns:$APP";
94 $RDG = "$ns:$RDG";
95 $LEM = "$ns:$LEM";
96 }
97}
98
99# Parse the TEI file.
f6066bac 100sub parse {
dfc37e38 101 my( $tradition, $opts ) = @_;
f6066bac 102
103 # First, parse the XML.
104 my $parser = XML::LibXML->new();
dfc37e38 105 my $doc;
106 if( exists $opts->{'string'} ) {
107 $doc = $parser->parse_string( $opts->{'string'} );
108 } elsif ( exists $opts->{'file'} ) {
109 $doc = $parser->parse_file( $opts->{'file'} );
110 } else {
111 warn "Could not find string or file option to parse";
112 return;
113 }
f6066bac 114 my $tei = $doc->documentElement();
f2b9605f 115 my $xpc = XML::LibXML::XPathContext->new( $tei );
910a0a6d 116 my $ns;
117 if( $tei->namespaceURI ) {
118 $ns = 'tei';
119 $xpc->registerNs( $ns, $tei->namespaceURI );
120 }
3b853983 121 _make_tagnames( $ns );
910a0a6d 122
f6066bac 123 # Then get the witnesses and create the witness objects.
910a0a6d 124 foreach my $wit_el ( $xpc->findnodes( "//$LISTWIT/$WITNESS" ) ) {
125 my $sig = $wit_el->getAttribute( 'xml:id' );
126 my $source = $wit_el->toString();
127 $tradition->add_witness( sigil => $sig, source => $source );
f6066bac 128 }
910a0a6d 129 map { $text->{$_->sigil} = [] } $tradition->witnesses;
eca16057 130
910a0a6d 131 # Look for all word/seg node IDs and note their pre-existence.
132 my @attrs = $xpc->findnodes( "//$W|$SEG/attribute::xml:id" );
3b853983 133 _save_preexisting_nodeids( @attrs );
910a0a6d 134
eca16057 135 # Count up how many apps we have.
136 my @apps = $xpc->findnodes( "//$APP" );
137 $app_count = scalar( @apps );
138
910a0a6d 139 # Now go through the children of the text element and pull out the
140 # actual text.
141 foreach my $xml_el ( $xpc->findnodes( "//$TEXT" ) ) {
142 foreach my $xn ( $xml_el->childNodes ) {
143 _get_readings( $tradition, $xn );
144 }
145 }
146 # Our $text global now has lists of readings, one per witness.
147 # Join them up.
148 my $c = $tradition->collation;
149 foreach my $sig ( keys %$text ) {
150 next if $sig eq 'base'; # Skip base text readings with no witnesses.
151 # Determine the list of readings for
152 my $sequence = $text->{$sig};
153 my @real_sequence = ( $c->start );
154 push( @$sequence, $c->end );
155 my $source = $c->start;
156 foreach( _clean_sequence( $sig, $sequence ) ) {
157 my $rdg = _return_rdg( $_ );
158 push( @real_sequence, $rdg );
159 $c->add_path( $source, $rdg, $sig );
160 $source = $rdg;
161 }
162 $tradition->witness( $sig )->path( \@real_sequence );
163 # See if we need to make an a.c. version of the witness.
164 if( exists $app_ac->{$sig} ) {
165 my @uncorrected;
166 push( @uncorrected, @real_sequence );
167 foreach my $app ( keys %{$app_ac->{$sig}} ) {
168 my $start = _return_rdg( $app_anchors->{$app}->{$sig}->{'start'} );
169 my $end = _return_rdg( $app_anchors->{$app}->{$sig}->{'end'} );
170 my @new = map { _return_rdg( $_ ) } @{$app_ac->{$sig}->{$app}};
171 _replace_sequence( \@uncorrected, $start, $end, @new );
172 }
173 my $source = $c->start;
174 foreach my $rdg ( @uncorrected ) {
175 my $has_base = grep { $_->label eq $sig } $source->edges_to( $rdg );
176 if( $rdg ne $c->start && !$has_base ) {
177 print STDERR sprintf( "Adding path %s from %s -> %s\n",
178 $sig.$c->ac_label, $source->name, $rdg->name );
179 $c->add_path( $source, $rdg, $sig.$c->ac_label );
180 }
181 $source = $rdg;
182 }
78fab1cf 183 print STDERR "Adding a.c. version for witness $sig\n";
910a0a6d 184 $tradition->witness( $sig )->uncorrected_path( \@uncorrected );
185 }
186 }
3b853983 187
188 # Calculate the ranks for the nodes.
c9bf3dbf 189 $tradition->collation->calculate_ranks();
3bc0cd18 190
191 # Now that we have ranks, see if we have distinct nodes with identical
192 # text and identical rank that can be merged.
0e476982 193 $tradition->collation->flatten_ranks();
910a0a6d 194}
195
196sub _clean_sequence {
197 my( $wit, $sequence ) = @_;
198 my @clean_sequence;
199 foreach my $rdg ( @$sequence ) {
200 if( $rdg =~ /^PH-(.*)$/ ) {
201 # It is a placeholder. Keep it only if we need it.
202 my $app_id = $1;
78fab1cf 203 if( exists $app_ac->{$wit} &&
204 exists $app_ac->{$wit}->{$app_id} ) {
910a0a6d 205 print STDERR "Retaining empty placeholder for $app_id\n";
206 push( @clean_sequence, $rdg );
207 }
208 } else {
209 push( @clean_sequence, $rdg );
210 }
f6066bac 211 }
910a0a6d 212 return @clean_sequence;
213}
f6066bac 214
910a0a6d 215sub _replace_sequence {
216 my( $arr, $start, $end, @new ) = @_;
217 my( $start_idx, $end_idx );
218 foreach my $i ( 0 .. $#{$arr} ) {
219 $start_idx = $i if( $arr->[$i]->name eq $start );
220 if( $arr->[$i]->name eq $end ) {
221 $end_idx = $i;
222 last;
223 }
224 }
225 unless( $start_idx && $end_idx ) {
226 warn "Could not find start and end";
227 return;
f2b9605f 228 }
910a0a6d 229 my $length = $end_idx - $start_idx + 1;
230 splice( @$arr, $start_idx, $length, @new );
231}
f6066bac 232
910a0a6d 233sub _return_rdg {
234 my( $rdg ) = @_;
235 # If we were passed a reading name, return the name. If we were
236 # passed a reading object, return the object.
237 my $wantobj = ref( $rdg ) eq 'Text::Tradition::Collation::Reading';
238 my $real = $rdg;
239 if( exists $substitutions->{ $wantobj ? $rdg->name : $rdg } ) {
240 $real = $substitutions->{ $wantobj ? $rdg->name : $rdg };
241 $real = $real->name unless $wantobj;
242 }
243 return $real;
f6066bac 244}
245
3b853983 246## TODO test specific sorts of nodes of the parallel-seg XML.
247
910a0a6d 248## Recursive helper function to help us navigate through nested XML,
249## picking out the text. $tradition is the tradition, needed for
250## making readings; $xn is the XML node currently being looked at,
251## $in_var is a flag to say that we are inside a variant, $ac is a
252## flag to say that we are inside an ante-correctionem reading, and
253## @cur_wits is the list of witnesses to which this XML node applies.
254## Returns the list of readings, if any, created on the run.
255
256{
3bc0cd18 257 my %active_wits;
910a0a6d 258 my $current_app;
eca16057 259 my $seen_apps;
910a0a6d 260
261 sub _get_readings {
262 my( $tradition, $xn, $in_var, $ac, @cur_wits ) = @_;
3bc0cd18 263 @cur_wits = grep { $active_wits{$_} } keys %active_wits unless $in_var;
910a0a6d 264
265 my @new_readings;
266 if( $xn->nodeType == XML_TEXT_NODE ) {
267 # Some words, thus make some readings.
268 my $str = $xn->data;
269 return unless $str =~ /\S/; # skip whitespace-only text nodes
270 #print STDERR "Handling text node " . $str . "\n";
271 # Check that all the witnesses we have are active.
272 foreach my $c ( @cur_wits ) {
3bc0cd18 273 warn "$c is not among active wits" unless $active_wits{$c};
910a0a6d 274 }
275 $str =~ s/^\s+//;
276 my $final = $str =~ s/\s+$//;
277 foreach my $w ( split( /\s+/, $str ) ) {
278 # For now, skip punctuation.
279 next if $w !~ /[[:alnum:]]/;
3b853983 280 my $rdg = _make_reading( $tradition->collation, $w );
910a0a6d 281 push( @new_readings, $rdg );
282 unless( $in_var ) {
910a0a6d 283 $rdg->make_common;
284 }
285 foreach ( @cur_wits ) {
286 warn "Empty wit!" unless $_;
287 warn "Empty reading!" unless $rdg;
288 push( @{$text->{$_}}, $rdg ) unless $ac;
289 }
290 }
291 } elsif( $xn->nodeName eq 'w' ) {
292 # Everything in this tag is one word. Also save any original XML ID.
293 #print STDERR "Handling word " . $xn->toString . "\n";
294 # Check that all the witnesses we have are active.
295 foreach my $c ( @cur_wits ) {
3bc0cd18 296 warn "$c is not among active wits" unless $active_wits{$c};
910a0a6d 297 }
298 my $xml_id = $xn->getAttribute( 'xml:id' );
3b853983 299 my $rdg = _make_reading( $tradition->collation, $xn->textContent, $xml_id );
910a0a6d 300 push( @new_readings, $rdg );
301 unless( $in_var ) {
910a0a6d 302 $rdg->make_common;
303 }
304 foreach( @cur_wits ) {
305 warn "Empty wit!" unless $_;
306 warn "Empty reading!" unless $rdg;
307 push( @{$text->{$_}}, $rdg ) unless $ac;
308 }
309 } elsif ( $xn->nodeName eq 'app' ) {
eca16057 310 $seen_apps++;
910a0a6d 311 $current_app = $xn->getAttribute( 'xml:id' );
312 # print STDERR "Handling app $current_app\n";
313 # Keep the reading sets in this app.
314 my @sets;
315 # Recurse through all children (i.e. rdgs) for sets of words.
316 foreach ( $xn->childNodes ) {
317 my @rdg_set = _get_readings( $tradition, $_, $in_var, $ac, @cur_wits );
318 push( @sets, \@rdg_set ) if @rdg_set;
319 }
320 # Now collate these sets if we have more than one.
321 my $subs = collate_variants( $tradition->collation, @sets ) if @sets > 1;
322 map { $substitutions->{$_} = $subs->{$_} } keys %$subs;
323 # TODO Look through substitutions to see if we can make anything common now.
324 # Return the entire set of unique readings.
325 my %unique;
326 foreach my $s ( @sets ) {
327 map { $unique{$_->name} = $_ } @$s;
328 }
329 push( @new_readings, values( %unique ) );
330 # Exit the current app.
331 $current_app = '';
332 } elsif ( $xn->nodeName eq 'lem' || $xn->nodeName eq 'rdg' ) {
333 # Alter the current witnesses and recurse.
334 #print STDERR "Handling reading for " . $xn->getAttribute( 'wit' ) . "\n";
3bc0cd18 335 # TODO handle p.c. and s.l. designations too
910a0a6d 336 $ac = $xn->getAttribute( 'type' ) && $xn->getAttribute( 'type' ) eq 'a.c.';
3b853983 337 my @rdg_wits = _get_sigla( $xn );
910a0a6d 338 @rdg_wits = ( 'base' ) unless @rdg_wits; # Allow for editorially-supplied readings
339 my @words;
340 foreach ( $xn->childNodes ) {
341 my @rdg_set = _get_readings( $tradition, $_, 1, $ac, @rdg_wits );
342 push( @words, @rdg_set ) if @rdg_set;
343 }
344 # If we have more than one word in a reading, it should become a segment.
345 # $tradition->collation->add_segment( @words ) if @words > 1;
346
347 if( $ac ) {
348 # Add the reading set to the a.c. readings.
349 foreach ( @rdg_wits ) {
350 $app_ac->{$_}->{$current_app} = \@words;
351 }
352 } else {
353 # Add the reading set to the app anchors for each witness
354 # or put in placeholders for empty p.c. readings
355 foreach ( @rdg_wits ) {
356 my $start = @words ? $words[0]->name : "PH-$current_app";
357 my $end = @words ? $words[-1]->name : "PH-$current_app";
358 $app_anchors->{$current_app}->{$_}->{'start'} = $start;
359 $app_anchors->{$current_app}->{$_}->{'end'} = $end;
360 push( @{$text->{$_}}, $start ) unless @words;
361 }
362 }
363 push( @new_readings, @words );
364 } elsif( $xn->nodeName eq 'witStart' ) {
365 # Add the relevant wit(s) to the active list.
366 #print STDERR "Handling witStart\n";
3bc0cd18 367 map { $active_wits{$_} = 1 } @cur_wits;
368 # Record a lacuna in all non-active witnesses if this is
369 # the first app. Get the full list from $text.
370 if( $seen_apps == 1 ) {
371 my $i = 0;
372 foreach my $sig ( keys %$text ) {
373 next if $active_wits{$sig};
374 my $l = $tradition->collation->add_lacuna( $current_app . "_$i" );
375 $i++;
376 push( @{$text->{$sig}}, $l );
377 }
378 }
910a0a6d 379 } elsif( $xn->nodeName eq 'witEnd' ) {
380 # Take the relevant wit(s) out of the list.
381 #print STDERR "Handling witEnd\n";
3bc0cd18 382 map { $active_wits{$_} = undef } @cur_wits;
eca16057 383 # Record a lacuna, unless this is the last app.
384 unless( $seen_apps == $app_count ) {
385 foreach my $i ( 0 .. $#cur_wits ) {
386 my $w = $cur_wits[$i];
387 my $l = $tradition->collation->add_lacuna( $current_app . "_$i" );
388 push( @{$text->{$w}}, $l );
389 }
390 }
910a0a6d 391 } elsif( $xn->nodeName eq 'witDetail' ) {
392 # Ignore these for now.
393 return;
394 } else {
395 # Recurse as if this tag weren't there.
396 #print STDERR "Recursing on tag " . $xn->nodeName . "\n";
397 foreach( $xn->childNodes ) {
398 push( @new_readings, _get_readings( $tradition, $_, $in_var, $ac, @cur_wits ) );
399 }
400 }
401 return @new_readings;
402 }
403
404}
405
3b853983 406=begin testing
407
408use XML::LibXML;
409use XML::LibXML::XPathContext;
410use Text::Tradition::Parser::TEI;
411
412my $xml_str = '<tei><rdg wit="#A #B #C #D">some text</rdg></tei>';
413my $el = XML::LibXML->new()->parse_string( $xml_str )->documentElement;
414my $xpc = XML::LibXML::XPathContext->new( $el );
415my $obj = $xpc->find( '//rdg' );
416
417my @wits = Text::Tradition::Parser::TEI::_get_sigla( $obj );
418is( join( ' ', @wits) , "A B C D", "correctly parsed reading wit string" );
419
420=end testing
421
422=cut
423
910a0a6d 424# Helper to extract a list of witness sigla from a reading element.
3b853983 425sub _get_sigla {
f6066bac 426 my( $rdg ) = @_;
427 # Cope if we have been handed a NodeList. There is only
428 # one reading here.
429 if( ref( $rdg ) eq 'XML::LibXML::NodeList' ) {
910a0a6d 430 $rdg = $rdg->shift;
f6066bac 431 }
432
433 my @wits;
434 if( ref( $rdg ) eq 'XML::LibXML::Element' ) {
910a0a6d 435 my $witstr = $rdg->getAttribute( 'wit' );
436 $witstr =~ s/^\s+//;
437 $witstr =~ s/\s+$//;
438 @wits = split( /\s+/, $witstr );
439 map { $_ =~ s/^\#// } @wits;
f6066bac 440 }
441 return @wits;
442}
443
910a0a6d 444# Helper with its counters to actually make the readings.
f2b9605f 445{
446 my $word_ctr = 0;
447 my %used_nodeids;
448
3b853983 449 sub _save_preexisting_nodeids {
910a0a6d 450 foreach( @_ ) {
451 $used_nodeids{$_->getValue()} = 1;
452 }
453 }
454
3b853983 455 sub _make_reading {
910a0a6d 456 my( $graph, $word, $xml_id ) = @_;
457 if( $xml_id ) {
458 if( exists $used_nodeids{$xml_id} ) {
459 if( $used_nodeids{$xml_id} != 1 ) {
460 warn "Already used assigned XML ID somewhere else!";
461 $xml_id = undef;
462 }
463 } else {
464 warn "Undetected pre-existing XML ID";
465 }
466 }
467 if( !$xml_id ) {
468 until( $xml_id ) {
469 my $try_id = 'w'.$word_ctr++;
470 next if exists $used_nodeids{$try_id};
471 $xml_id = $try_id;
472 }
473 }
474 my $rdg = $graph->add_reading( $xml_id );
475 $rdg->text( $word );
476 $used_nodeids{$xml_id} = $rdg;
477 return $rdg;
f2b9605f 478 }
479}
480
f6066bac 4811;
3b853983 482
483=head1 BUGS / TODO
484
485=over
486
487=item * More unit testing
488
e867486f 489=item * Handle special designations apart from a.c.
490
491=item * Mark common nodes within collated variants
492
3b853983 493=back
494
495=head1 LICENSE
496
497This package is free software and is provided "as is" without express
498or implied warranty. You can redistribute it and/or modify it under
499the same terms as Perl itself.
500
501=head1 AUTHOR
502
503Tara L Andrews E<lt>aurum@cpan.orgE<gt>