lib/Text/Tradition/Witness.pm

   1 package Text::Tradition::Witness;
   2
   3 use vars qw( %tags );
   4 use JSON;
   5 use Moose;
   6 use Moose::Util::TypeConstraints;
   7 use Text::TEI::Markup qw( word_tag_wrap );
   8 use TryCatch;
   9 use XML::Easy::Syntax qw( $xml10_name_rx );
  10
  11 =head1 NAME
  12
  13 Text::Tradition::Witness - a manuscript witness to a text tradition
  14
  15 =head1 SYNOPSIS
  16
  17   use Text::Tradition::Witness;
  18   my $w = Text::Tradition::Witness->new(
  19     'sigil' => 'A',
  20     'identifier' => 'Oxford MS Ex.1932',
  21     );
  22
  23 =head1 DESCRIPTION
  24
  25 Text::Tradition::Witness is an object representation of a manuscript
  26 witness to a text tradition.  A manuscript has a sigil (a short code that
  27 represents it in the wider tradition), an identifier (e.g. the library ID),
  28 and probably a text.
  29
  30 =head1 METHODS
  31
  32 =head2 new
  33
  34 Create a new witness.  Options include:
  35
  36 =over
  37
  38 =item * sigil - A short code to represent the manuscript.  Required.
  39
  40 =item * sourcetype - What sort of witness data this is. Options are
  41 'xmldesc', 'plaintext', 'json', or 'collation' (the last should only be
  42 used by Collation parsers.)
  43
  44 =item * file
  45 =item * string
  46 =item * object
  47
  48 The data source for the witness.  Use the appropriate option.
  49
  50 =item * use_text - An initialization option.  If the witness is read from a
  51 TEI document and more than one <text/> tag exists therein, the default
  52 behavior is to use the first defined text.  If this is not desired,
  53 use_text should be set to an XPath expression that will select the correct
  54 text.
  55
  56 =item * language - The name of the applicable L<Text::Tradition::Lang>
  57 module for language handling. Usually inherited from the language set in
  58 the L<Text::Tradition> object, and defaults to Default.
  59
  60 =item * identifier - The recognized name of the manuscript, e.g. a library
  61 identifier. Taken from the msDesc element for a TEI file.
  62
  63 =item * other_info - A freeform string for any other description of the
  64 manuscript.
  65
  66 =back
  67
  68 =head2 sigil
  69
  70 The sigil by which to identify this manuscript, which must conform to the
  71 specification for XML attribute strings (broadly speaking, it must begin
  72 with a letter and can have only a few sorts of punctuation characters in
  73 it.)
  74
  75 =head2 identifier
  76
  77 A freeform name by which to identify the manuscript, which may be longer
  78 than the sigil.  Defaults to 'Unidentified ms', but will be taken from the
  79 TEI msName attribute, or constructed from the settlement and idno if
  80 supplied.
  81
  82 =head2 settlement
  83
  84 The city, town, etc. where the manuscript is held. Will be read from the
  85 TEI msDesc element if supplied.
  86
  87 =head2 repository
  88
  89 The institution that holds the manuscript. Will be read from the TEI msDesc
  90 element if supplied.
  91
  92 =head2 idno
  93
  94 The identification or call number of the manuscript.  Will be read from the
  95 TEI msDesc element if supplied.
  96
  97 =head2 text
  98
  99 An array of strings (words) that contains the text of the
 100 manuscript.  This should not change after the witness has been
 101 instantiated, and the path through the collation should always match it.
 102
 103 =head2 layertext
 104
 105 An array of strings (words) that contains the layered
 106 text, if any, of the manuscript.  This should not change after the witness
 107 has been instantiated, and the path through the collation should always
 108 match it.
 109
 110 =head2 language
 111
 112 Accessor method to get the witness language.
 113
 114 =head2 identifier
 115
 116 Accessor method for the witness identifier.
 117
 118 =head2 other_info
 119
 120 Accessor method for the general witness description.
 121
 122 =head2 is_layered
 123
 124 Boolean method to note whether the witness has layers (e.g. pre-correction
 125 readings) in the collation.
 126
 127 =begin testing
 128
 129 use Text::Tradition;
 130 my $trad = Text::Tradition->new( 'name' => 'test tradition' );
 131 my $c = $trad->collation;
 132
 133 # Test a plaintext witness via string
 134 my $str = 'This is a line of text';
 135 my $ptwit = $trad->add_witness(
 136     'sigil' => 'A',
 137     'sourcetype' => 'plaintext',
 138     'string' => $str
 139      );
 140 is( ref( $ptwit ), 'Text::Tradition::Witness', 'Created a witness' );
 141 if( $ptwit ) {
 142     is( $ptwit->sigil, 'A', "Witness has correct sigil" );
 143     is( $c->path_text( $ptwit->sigil ), $str, "Witness has correct text" );
 144 }
 145
 146 # # Test some JSON witnesses via object
 147 # open( JSIN, 't/data/witnesses/testwit.json' ) or die "Could not open JSON test input";
 148 # binmode( JSIN, ':encoding(UTF-8)' );
 149 # my @lines = <JSIN>;
 150 # close JSIN;
 151 # $trad->add_json_witnesses( join( '', @lines ) );
 152 # is( ref( $trad->witness( 'MsAJ' ) ), 'Text::Tradition::Witness',
 153 #       "Found first JSON witness" );
 154 # is( ref( $trad->witness( 'MsBJ' ) ), 'Text::Tradition::Witness',
 155 #       "Found second JSON witness" );
 156 #
 157 # # Test an XML witness via file
 158 # my $xmlwit = $trad->add_witness( 'sourcetype' => 'xmldesc',
 159 #       'file' => 't/data/witnesses/teiwit.xml' );
 160 # is( ref( $xmlwit ), 'Text::Tradition::Witness', "Created witness from XML file" );
 161 # if( $xmlwit ) {
 162 #       is( $xmlwit->sigil, 'V887', "XML witness has correct sigil" );
 163 #       ok( $xmlwit->is_layered, "Picked up correction layer" );
 164 #       is( @{$xmlwit->path}, 185, "Got correct text length" );
 165 #       is( @{$xmlwit->uncorrected_path}, 185, "Got correct a.c. text length" );
 166 # }
 167
 168 ## Test use_text
 169
 170 =end testing
 171
 172 =cut
 173
 174 subtype 'SourceType',
 175         as 'Str',
 176         where { $_ =~ /^(xmldesc|plaintext|json|collation)$/ },
 177         message { 'Source type must be one of xmldesc, plaintext, json, collation' };
 178
 179 subtype 'Sigil',
 180         as 'Str',
 181         where { $_ =~ /\A$xml10_name_rx\z/ },
 182         message { 'Sigil must be a valid XML attribute string' };
 183
 184 no Moose::Util::TypeConstraints;
 185
 186 has 'tradition' => (
 187         'is' => 'ro',
 188         'isa' => 'Text::Tradition',
 189         'required' => 1,
 190         );
 191
 192 # Sigil. Required identifier for a witness, but may be found inside
 193 # the XML file.
 194 has 'sigil' => (
 195         is => 'ro',
 196         isa => 'Sigil',
 197         predicate => 'has_sigil',
 198         writer => '_set_sigil',
 199         );
 200
 201 # Other identifying information
 202 has 'identifier' => (
 203         is => 'rw',
 204         isa => 'Str',
 205         );
 206
 207 has 'settlement' => (
 208         is => 'rw',
 209         isa => 'Str',
 210         );
 211
 212 has 'repository' => (
 213         is => 'rw',
 214         isa => 'Str',
 215         );
 216
 217 has 'idno' => (
 218         is => 'rw',
 219         isa => 'Str',
 220         );
 221
 222 has 'sourcetype' => (
 223         is => 'ro',
 224         isa => 'SourceType',
 225         required => 1,
 226 );
 227
 228 has 'language' => (
 229     is => 'ro',
 230     isa => 'Str',
 231     default => 'Default',
 232     );
 233
 234 # Source. Can be XML obj, JSON data struct, or string.
 235 # Not used if the witness is created by parsing a collation.
 236 has 'file' => (
 237         is => 'ro',
 238         isa => 'Str',
 239         predicate => 'has_file',
 240 );
 241
 242 has 'string' => (
 243         is => 'ro',
 244         isa => 'Str',
 245         predicate => 'has_string',
 246 );
 247
 248 has 'object' => ( # could be anything.
 249         is => 'ro',
 250         predicate => 'has_object',
 251         clearer => 'clear_object',
 252 );
 253
 254 # In the case of a TEI document with multiple texts, specify
 255 # which text is the root. Should be an XPath expression.
 256 has 'use_text' => (
 257         is => 'ro',
 258         isa => 'Str',
 259         );
 260
 261 has 'msdesc' => (  # if we started with a TEI doc
 262         is => 'ro',
 263         isa => 'XML::LibXML::Element',
 264         predicate => 'has_msdesc',
 265         writer => '_save_msdesc',
 266         );
 267
 268 # Text.  This is an array of strings (i.e. word tokens).
 269 # TODO Think about how to handle this for the case of pre-prepared
 270 # collations, where the tokens are in the graph already.
 271 has 'text' => (
 272         is => 'rw',
 273         isa => 'ArrayRef[Str]',
 274         predicate => 'has_text',
 275         );
 276
 277 has 'layertext' => (
 278         is => 'rw',
 279         isa => 'ArrayRef[Str]',
 280         predicate => 'has_layertext',
 281         );
 282
 283 # Path.  This is an array of Reading nodes that can be saved during
 284 # initialization, but should be cleared before saving in a DB.
 285 has 'path' => (
 286         is => 'rw',
 287         isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
 288         predicate => 'has_path',
 289         clearer => 'clear_path',
 290         );
 291
 292 has 'uncorrected_path' => (
 293         is => 'rw',
 294         isa => 'ArrayRef[Text::Tradition::Collation::Reading]',
 295         clearer => 'clear_uncorrected_path',
 296         );
 297
 298 has 'is_layered' => (
 299         is => 'rw',
 300         isa => 'Bool',
 301         );
 302
 303 # If we set an uncorrected path, ever, remember that we did so.
 304 around 'uncorrected_path' => sub {
 305         my $orig = shift;
 306         my $self = shift;
 307
 308         $self->is_layered( 1 );
 309         $self->$orig( @_ );
 310 };
 311
 312 sub BUILD {
 313         my $self = shift;
 314         if( $self->has_source ) {
 315                 my $init_sub = '_init_from_' . $self->sourcetype;
 316                 $self->$init_sub();
 317                 # Remove our XML / source objects; we no longer need them.
 318                 $self->clear_object if $self->has_object;
 319                 $self->tradition->collation->make_witness_path( $self );
 320         }
 321         return $self;
 322 }
 323
 324 sub has_source {
 325         my $self = shift;
 326         return $self->has_file || $self->has_string || $self->has_object;
 327 }
 328
 329 sub _init_from_xmldesc {
 330         my $self = shift;
 331         my $xmlobj;
 332         if( $self->has_object ) {
 333                 unless( ref( $self->object ) eq 'XML::LibXML::Element' ) {
 334                         throw( ident => "bad source",
 335                                    message => "Source object must be an XML::LibXML::Element (this is "
 336                                         . ref( $self->object ) . ");" );
 337                 }
 338                 $xmlobj = $self->object;
 339         } else {
 340                 my $parser = XML::LibXML->new();
 341                 my $parsersub = $self->has_file ? 'parse_file' : 'parse_string';
 342                 try {
 343                         $xmlobj = $parser->$parsersub( $self->file )->documentElement;
 344                 } catch( XML::LibXML::Error $e ) {
 345                         throw( ident => "bad source",
 346                                    message => "XML parsing error: " . $e->as_string );
 347                 }
 348         }
 349
 350         unless( $xmlobj->nodeName eq 'TEI' ) {
 351                 throw( ident => "bad source",
 352                        message => "Source XML must be TEI (this is " . $xmlobj->nodeName . ")" );
 353         }
 354
 355         # Set up the tags we need, with or without namespaces.
 356         map { $tags{$_} = "//$_" }
 357                 qw/ msDesc msName settlement repository idno p lg w seg add del /;
 358         # Set up our XPath object
 359         my $xpc = _xpc_for_el( $xmlobj );
 360         # Use namespace-aware tags if we have to
 361         if( $xmlobj->namespaceURI ) {
 362             map { $tags{$_} = "//tei:$_" } keys %tags;
 363         }
 364
 365         # Get the identifier
 366         if( my $desc = $xpc->find( $tags{msDesc} ) ) {
 367                 my $descnode = $desc->get_node(1);
 368                 $self->_save_msdesc( $descnode );
 369                 # First try to use settlement/repository/idno.
 370                 my( $setNode, $reposNode, $idNode ) =
 371                         ( $xpc->find( $tags{settlement}, $descnode )->get_node(1),
 372                           $xpc->find( $tags{repository}, $descnode )->get_node(1),
 373                           $xpc->find( $tags{idno}, $descnode )->get_node(1) );
 374                 $self->settlement( $setNode ? $setNode->textContent : '' );
 375                 $self->repository( $reposNode ? $reposNode->textContent : '' );
 376                 $self->idno( $idNode ? $idNode->textContent : '' );
 377                 if( $self->settlement && $self->idno ) {
 378                 $self->identifier( join( ' ', $self->{'settlement'}, $self->{'idno'} ) );
 379                 } else {
 380                     # Look for an msName.
 381                     my $msNameNode = $xpc->find( $tags{msName}, $descnode )->get_node(1);
 382                     if( $msNameNode ) {
 383                 $self->identifier( $msNameNode->textContent );
 384             } else {
 385                 # We have an msDesc but who knows what is in it?
 386                 my $desc = $descnode->textContent;
 387                 $desc =~ s/\n/ /gs;
 388                 $desc =~ s/\s+/ /g;
 389                 $self->identifier( $desc );
 390             }
 391         }
 392         if( $descnode->hasAttribute('xml:id') ) {
 393                         $self->_set_sigil( $descnode->getAttribute('xml:id') );
 394                 } elsif( !$self->has_sigil ) {
 395                         throw( 'Could not find xml:id witness sigil' );
 396                 }
 397         } else {
 398             throw( ident => "bad source",
 399                    message => "Could not find manuscript description element in TEI header" );
 400         }
 401
 402         # Now get the words out.
 403         my @words;
 404         my @layerwords;  # if the witness has layers
 405         # First, make sure all the words are wrapped in tags.
 406         # TODO Make this not necessarily dependent upon whitespace...
 407         word_tag_wrap( $xmlobj );
 408         # Now go text hunting.
 409         my @textnodes;
 410         if( $self->use_text ) {
 411                 @textnodes = $xpc->findnodes( $self->use_text );
 412         } else {
 413                 # Use the first 'text' node in the document.
 414                 @textnodes = $xmlobj->getElementsByTagName( 'text' );
 415         }
 416         my $teitext = $textnodes[0];
 417         if( $teitext ) {
 418                 _tokenize_text( $self, $teitext, \@words, \@layerwords );
 419         } else {
 420             throw( ident => "bad source",
 421                    message => "No text element in document '" . $self->{'identifier'} . "!" );
 422         }
 423
 424         $self->path( \@words );
 425         my $a = join( ' ', map { $_->text } @words );
 426         my $b = join( ' ', map { $_->text } @layerwords );
 427         if( $a ne $b ) {
 428                 $self->uncorrected_path( \@layerwords );
 429         }
 430         # TODO set self->text
 431 }
 432
 433 sub _tokenize_text {
 434         my( $self, $teitext, $wordlist, $uncorrlist ) = @_;
 435         # Strip out the words.
 436         my $xpc = _xpc_for_el( $teitext );
 437         my @divs = $xpc->findnodes( '//*[starts-with(name(.), "div")]' );
 438         foreach( @divs ) {
 439                 my $place_str;
 440                 if( my $n = $_->getAttribute( 'n' ) ) {
 441                         $place_str = '#DIV_' . $n . '#';
 442                 } else {
 443                         $place_str = '#DIV#';
 444                 }
 445                 $self->_objectify_words( $teitext, $wordlist, $uncorrlist, $place_str );
 446         }  # foreach <div/>
 447
 448         # But maybe we don't have any divs.  Just paragraphs.
 449         unless( @divs ) {
 450                 $self->_objectify_words( $teitext, $wordlist, $uncorrlist );
 451         }
 452 }
 453
 454 sub _objectify_words {
 455         my( $self, $element, $wordlist, $uncorrlist, $divmarker ) = @_;
 456
 457         my $xpc = _xpc_for_el( $element );
 458         my $xpexpr = '.' . $tags{p} . '|.' . $tags{lg};
 459         my @pgraphs = $xpc->findnodes( $xpexpr );
 460     return () unless @pgraphs;
 461     # Set up an expression to look for words and segs
 462     $xpexpr = '.' . $tags{w} . '|.' . $tags{seg};
 463         foreach my $pg ( @pgraphs ) {
 464                 # If this paragraph is the descendant of a note element,
 465                 # skip it.
 466                 my @noop_container = $xpc->findnodes( 'ancestor::note', $pg );
 467                 next if scalar @noop_container;
 468                 # Get the text of each node
 469                 my $first_word = 1;
 470                 # Hunt down each wrapped word/seg, and make an object (or two objects)
 471                 # of it, if necessary.
 472                 foreach my $c ( $xpc->findnodes( $xpexpr, $pg ) ) {
 473                         my( $text, $uncorr ) = _get_word_object( $c );
 474 #                       try {
 475 #                               ( $text, $uncorr ) = _get_word_object( $c );
 476 #                       } catch( Text::Tradition::Error $e
 477 #                                               where { $_->has_tag( 'lb' ) } ) {
 478 #                               next;
 479 #                       }
 480                         unless( defined $text || defined $uncorr ) {
 481                                 print STDERR "WARNING: no text in node " . $c->nodeName
 482                                         . "\n" unless $c->nodeName eq 'lb';
 483                                 next;
 484                         }
 485                         print STDERR "DEBUG: space found in element node "
 486                                 . $c->nodeName . "\n" if $text =~ /\s/ || $uncorr =~ /\s/;
 487
 488                         my $ctr = @$wordlist > @$uncorrlist ? @$wordlist : @$uncorrlist;
 489                         while( $self->tradition->collation->reading( $self->sigil.'r'.$ctr ) ) {
 490                                 $ctr++;
 491                         }
 492                         my $id = $self->sigil . 'r' . $ctr;
 493                         my( $word, $acword );
 494                         if( $text ) {
 495                                 $word = $self->tradition->collation->add_reading(
 496                                         { 'id' => $id, 'text' => $text });
 497                         }
 498                         if( $uncorr && $uncorr ne $text ) {
 499                                 $id .= '_ac';
 500                                 $acword = $self->tradition->collation->add_reading(
 501                                         { 'id' => $id, 'text' => $uncorr });
 502                         } elsif( $uncorr ) {
 503                                 $acword = $word;
 504                         }
 505
 506 #                       if( $first_word ) {
 507 #                               $first_word = 0;
 508 #                               # Set the relevant sectioning markers
 509 #                               if( $divmarker ) {
 510 #                                       $w->add_placeholder( $divmarker );
 511 #                                       $divmarker = undef;
 512 #                               }
 513 #                               $w->add_placeholder( '#PG#' );
 514 #                       }
 515                         push( @$wordlist, $word ) if $word;
 516                         push( @$uncorrlist, $acword ) if $acword;
 517                 }
 518     }
 519 }
 520
 521 # Given a word or segment node, make a Reading object for the word
 522 # therein. Make two Reading objects if there is an 'uncorrected' vs.
 523 # 'corrected' state.
 524
 525 sub _get_word_strings {
 526         my( $node ) = @_;
 527         my( $text, $uncorrtext );
 528         # We can have an lb or pb in the middle of a word; if we do, the
 529         # whitespace (including \n) after the break becomes insignificant
 530         # and we want to nuke it.
 531         my $strip_leading_space = 0;
 532         my $word_excluded = 0;
 533         my $xpc = _xpc_for_el( $node );
 534         # TODO This does not cope with nested add/dels.
 535         my @addition = $xpc->findnodes( 'ancestor::' . $tags{add} );
 536         my @deletion = $xpc->findnodes( 'ancestor::' . $tags{del} );
 537         foreach my $c ($node->childNodes() ) {
 538                 if( $c->nodeName eq 'num'
 539                         && defined $c->getAttribute( 'value' ) ) {
 540                         # Push the number.
 541                         $text .= $c->getAttribute( 'value' ) unless @deletion;
 542                         $uncorrtext .= $c->getAttribute( 'value' ) unless @addition;
 543                         # If this is just after a line/page break, return to normal behavior.
 544                         $strip_leading_space = 0;
 545                 } elsif ( $c->nodeName =~ /^[lp]b$/ ) {
 546                         # Set a flag that strips leading whitespace until we
 547                         # get to the next bit of non-whitespace.
 548                         $strip_leading_space = 1;
 549                 } elsif ( $c->nodeName eq 'fw'   # for catchwords
 550                                   || $c->nodeName eq 'sic'
 551                                   || $c->nodeName eq 'note'      #TODO: decide how to deal with notes
 552                                   || $c->textContent eq ''
 553                                   || ref( $c ) eq 'XML::LibXML::Comment' ) {
 554                         $word_excluded = 1 if $c->nodeName =~ /^(fw|sic)$/;
 555                         next;
 556                 } elsif( $c->nodeName eq 'add' ) {
 557                         my( $use, $discard ) = _get_text_from_node( $c );
 558                         $text .= $use;
 559                 } elsif( $c->nodeName eq 'del' ) {
 560                         my( $discard, $use ) = _get_text_from_node( $c );
 561                         $uncorrtext .= $use;
 562                 } else {
 563                         my $tagtxt;
 564                         if( ref( $c ) eq 'XML::LibXML::Text' ) {
 565                                 # A text node.
 566                                 $tagtxt = $c->textContent;
 567                         } else {
 568                                 $tagtxt = _get_text_from_node( $c );
 569                         }
 570                         if( $strip_leading_space ) {
 571                                 $tagtxt =~ s/^[\s\n]+//s;
 572                                 # Unset the flag as soon as we see non-whitespace.
 573                                 $strip_leading_space = 0 if $tagtxt;
 574                         }
 575                         $text .= $tagtxt;
 576                         $uncorrtext .= $tagtxt;
 577                 }
 578         }
 579         throw( ident => "text not found",
 580                tags => [ $node->nodeName ],
 581                message => "No text found in node " . $node->toString(0) )
 582             unless $text || $uncorrtext || $word_excluded || $node->toString(0) =~/gap/;
 583         return( $text, $uncorrtext );
 584 }
 585
 586 sub _split_words {
 587         my( $self, $string, $c ) = @_;
 588         my @raw_words = split( /\s+/, $string );
 589         my @words;
 590         foreach my $w ( @raw_words ) {
 591                 my $id = $self->sigil . 'r'. $c++;
 592                 my %opts = ( 'text' => $w, 'id' => $id, 'language' => $self->language );
 593                 my $w_obj = $self->tradition->collation->add_reading( \%opts );
 594                 # Skip any words that have been canonized out of existence.
 595                 next if( length( $w_obj->text ) == 0 );
 596                 push( @words, $w_obj );
 597         }
 598         return @words;
 599 }
 600
 601 sub _init_from_json {
 602         my( $self ) = shift;
 603         my $wit;
 604         if( $self->has_object ) {
 605                 $wit = $self->object;
 606         } else {
 607
 608         }
 609
 610         $self->sigil( $wit->{'id'} );
 611         $self->identifier( $wit->{'name'} );
 612         my @words;
 613         my @layerwords;
 614         if( exists $wit->{'content'} ) {
 615                 # We need to tokenize the text ourselves.
 616                 @words = _split_words( $self, $wit->{'content'} );
 617         } elsif( exists $wit->{'tokens'} ) {
 618                 # We have a bunch of pretokenized words.
 619                 my $ctr = 0;
 620                 foreach my $token ( @{$wit->{'tokens'}} ) {
 621                         my $w_obj = $self->tradition->collation->add_reading({
 622                                 'text' => $token, 'id' => $self->sigil . 'r' . $ctr++ });
 623                         push( @words, $w_obj );
 624                 }
 625                 ## TODO rethink this JSOn mechanism
 626                 if( exists $wit->{'layertokens'} ) {
 627                         foreach my $token ( @{$wit->{'layertokens'}} ) {
 628                                 my $w_obj = $self->tradition->collation->add_reading({
 629                                         'text' => $token, 'id' => $self->sigil . 'r' . $ctr++ });
 630                                 push( @layerwords, $w_obj );
 631                         }
 632                 }
 633         }
 634         # TODO set self->text
 635         $self->path( \@words );
 636         $self->uncorrected_path( \@layerwords ) if @layerwords;
 637 }
 638
 639 sub _init_from_plaintext {
 640     my( $self ) = @_;
 641     my $str;
 642     if( $self->has_file ) {
 643         my $ok = open( INPUT, $self->file );
 644         unless( $ok ) {
 645                         throw( ident => "bad source",
 646                                    message => 'Could not open ' . $self->file . ' for reading' );
 647         }
 648         binmode( INPUT, ':encoding(UTF-8)' );
 649         my @lines = <INPUT>;
 650         close INPUT;
 651         $str = join( '', @lines );
 652     } elsif( $self->has_object ) { # ...seriously?
 653         $str = ${$self->object};
 654     } else {
 655         $str = $self->string;
 656     }
 657
 658     # TODO allow a different word separation expression
 659     my @text = split( /\s+/, $str );
 660     $self->text( \@text );
 661     my @words = _split_words( $self, $str );
 662         $self->path( \@words );
 663 }
 664
 665 sub throw {
 666         Text::Tradition::Error->throw(
 667                 'ident' => 'Witness parsing error',
 668                 'message' => $_[0],
 669                 );
 670 }
 671
 672 sub _xpc_for_el {
 673         my $el = shift;
 674         my $xpc = XML::LibXML::XPathContext->new( $el );
 675                 if( $el->namespaceURI ) {
 676                         $xpc->registerNs( 'tei', $el->namespaceURI );
 677                 }
 678         return $xpc;
 679 }
 680
 681 =head2 export_as_json
 682
 683 Exports the witness as a JSON structure, with the following keys:
 684
 685 =over 4
 686
 687 =item * id - The witness sigil
 688
 689 =item * name - The witness identifier
 690
 691 =item * tokens - An array of hashes of the form { "t":"WORD" }
 692
 693 =back
 694
 695 =begin testing
 696
 697 use Text::Tradition;
 698 my $trad = Text::Tradition->new();
 699
 700 my @text = qw/ Thhis is a line of text /;
 701 my $wit = $trad->add_witness(
 702     'sigil' => 'A',
 703     'string' => join( ' ', @text ),
 704     'sourcetype' => 'plaintext',
 705     'identifier' => 'test witness',
 706      );
 707 my $jsonstruct = $wit->export_as_json;
 708 is( $jsonstruct->{'id'}, 'A', "got the right witness sigil" );
 709 is( $jsonstruct->{'name'}, 'test witness', "got the right identifier" );
 710 is( scalar @{$jsonstruct->{'tokens'}}, 6, "got six text tokens" );
 711 foreach my $idx ( 0 .. $#text ) {
 712         is( $jsonstruct->{'tokens'}->[$idx]->{'t'}, $text[$idx], "tokens look OK" );
 713 }
 714
 715 my @ctext = qw( when april with his showers sweet with fruit the drought of march
 716                                 has pierced unto the root );
 717 $trad = Text::Tradition->new(
 718         'input' => 'CollateX',
 719         'file' => 't/data/Collatex-16.xml' );
 720
 721 $jsonstruct = $trad->witness('A')->export_as_json;
 722 is( $jsonstruct->{'id'}, 'A', "got the right witness sigil" );
 723 is( $jsonstruct->{'name'}, undef, "got undef for missing identifier" );
 724 is( scalar @{$jsonstruct->{'tokens'}}, 17, "got all text tokens" );
 725 foreach my $idx ( 0 .. $#ctext ) {
 726         is( $jsonstruct->{'tokens'}->[$idx]->{'t'}, $ctext[$idx], "tokens look OK" );
 727 }
 728
 729 ## TODO test layertext export
 730
 731 =end testing
 732
 733 =cut
 734
 735 sub export_as_json {
 736         my $self = shift;
 737         my @wordlist = map { { 't' => $_ || '' } } @{$self->text};
 738         my $obj =  {
 739                 'id' => $self->sigil,
 740                 'tokens' => \@wordlist,
 741                 'name' => $self->identifier,
 742         };
 743         if( $self->is_layered ) {
 744                 my @lwlist = map { { 't' => $_ || '' } } @{$self->uncorrected};
 745                 $obj->{'layertokens'} = \@lwlist;
 746         }
 747         return $obj;
 748 }
 749
 750 no Moose;
 751 __PACKAGE__->meta->make_immutable;
 752
 753 =head1 BUGS / TODO
 754
 755 =over
 756
 757 =item * Support encodings other than UTF-8
 758
 759 =back
 760
 761 =head1 LICENSE
 762
 763 This package is free software and is provided "as is" without express
 764 or implied warranty.  You can redistribute it and/or modify it under
 765 the same terms as Perl itself.
 766
 767 =head1 AUTHOR
 768
 769 Tara L Andrews E<lt>aurum@cpan.orgE<gt>