1 package Text::Tradition::Parser::JSON;
5 use JSON qw/ from_json /;
9 Text::Tradition::Parser::JSON
15 my $tradition = Text::Tradition->new(
18 'string' => $json_encoded_utf8,
23 Parser module for Text::Tradition to read a JSON alignment table format such
24 as that produced by CollateX.
28 =head2 B<parse>( $tradition, $option_hash )
30 Takes an initialized tradition and a set of options; creates the
31 appropriate nodes and edges on the graph, as well as the appropriate
32 witness objects. The $option_hash must contain either a 'file' or a
33 'string' argument with the JSON structure to be parsed.
35 The structure of the JSON is thus:
37 { alignment => [ { witness => "SIGIL",
38 tokens => [ { t => "TEXT" }, ... ] },
40 tokens => [ { t => "TEXT" }, ... ] },
45 Longer lacunae in the text, to be disregarded in cladistic analysis, may be
46 represented with the meta-reading '#LACUNA#'. Multiple lacuna tags in sequence
47 are collapsed into a single multi-reading lacuna.
49 If a witness name ends in the collation's ac_label, it will be treated as
50 an extra layer of the 'main' witness whose sigil it shares.
55 binmode STDOUT, ":utf8";
56 binmode STDERR, ":utf8";
57 eval { no warnings; binmode $DB::OUT, ":utf8"; };
59 use_ok( 'Text::Tradition::Parser::JSON' );
61 open( JSFILE, 't/data/cx16.json' );
62 binmode JSFILE, ':utf8';
66 my $t = Text::Tradition->new(
69 'string' => join( '', @lines ),
72 is( ref( $t ), 'Text::Tradition', "Parsed a JSON alignment" );
74 is( scalar $t->collation->readings, 26, "Collation has all readings" );
75 is( scalar $t->collation->paths, 32, "Collation has all paths" );
76 is( scalar $t->witnesses, 3, "Collation has all witnesses" );
80 map { $seen_wits{$_} = 0 } qw/ A B C /;
81 # Check that we have the right witnesses
82 foreach my $wit ( $t->witnesses ) {
83 $seen_wits{$wit->sigil} = 1;
85 is( scalar keys %seen_wits, 3, "No extra witnesses were made" );
86 foreach my $k ( keys %seen_wits ) {
87 ok( $seen_wits{$k}, "Witness $k still exists" );
90 # Check that the witnesses have the right texts
91 foreach my $wit ( $t->witnesses ) {
92 my $origtext = join( ' ', @{$wit->text} );
93 my $graphtext = $t->collation->path_text( $wit->sigil );
94 is( $graphtext, $origtext, "Collation matches original for witness " . $wit->sigil );
102 my( $tradition, $opts ) = @_;
103 my $c = $tradition->collation;
105 my $table = from_json( $opts->{'string'} );
107 # Create the witnesses
108 my @witnesses; # Keep the ordered list of our witnesses
109 my %ac_wits; # Track these for later removal
110 foreach my $sigil ( map { $_->{'witness'} } @{$table->{'alignment'}} ) {
112 if( $tradition->has_witness( $sigil ) ) {
113 $wit = $tradition->witness( $sigil );
114 $wit->is_collated( 1 );
116 $wit = $tradition->add_witness(
117 'sigil' => $sigil, 'sourcetype' => 'collation' );
119 $wit->path( [ $c->start ] );
120 push( @witnesses, $wit );
121 my $aclabel = $c->ac_label;
122 if( $sigil =~ /^(.*)\Q$aclabel\E$/ ) {
123 $ac_wits{$sigil} = $1;
127 # Save the original witness text for consistency checking. We do this
128 # in a separate loop to make sure we have all base witnesses defined,
129 # and to make sure that our munging and comparing later doesn't affect
131 foreach my $intext ( @{$table->{'alignment'}} ) {
132 my $rs = $intext->{'witness'};
133 my $is_layer = exists $ac_wits{$rs};
134 my $wit = $tradition->witness( $is_layer ? $ac_wits{$rs} : $rs );
135 my @tokens = grep { $_ && $_->{'t'} !~ /^\#.*\#$/ } @{$intext->{'tokens'}};
136 my @words = map { _restore_punct( $_ ) } @tokens;
137 $is_layer ? $wit->layertext( \@words ) : $wit->text( \@words );
140 # Create the readings in each row
141 my $length = exists $table->{'length'}
143 : scalar @{$table->{'alignment'}->[0]->{'tokens'}};
145 foreach my $idx ( 0 .. $length - 1 ) {
146 my @tokens = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
147 my @readings = make_nodes( $c, $idx, @tokens );
148 foreach my $w ( 0 .. $#readings ) {
149 # push the appropriate node onto the appropriate witness path
150 my $rdg = $readings[$w];
152 my $wit = $witnesses[$w];
153 push( @{$wit->path}, $rdg );
154 } # else skip it for empty readings.
158 # Collapse our lacunae into a single node and
159 # push the end node onto all paths.
160 $c->end->rank( $length );
161 foreach my $wit ( @witnesses ) {
163 my $last_rdg = shift @$p;
164 my $new_p = [ $last_rdg ];
165 foreach my $rdg ( @$p ) {
166 # Omit the reading if we are in a lacuna already.
167 next if $rdg->is_lacuna && $last_rdg->is_lacuna;
168 # Save the reading otherwise.
169 push( @$new_p, $rdg );
172 push( @$new_p, $c->end );
173 $wit->path( $new_p );
176 # Fold any a.c. witnesses into their main witness objects, and
177 # delete the independent a.c. versions.
178 foreach my $a ( keys %ac_wits ) {
179 my $ac_wit = $tradition->witness( $a );
180 my $main_wit = $tradition->witness( $ac_wits{$a} );
181 next unless $main_wit;
182 $main_wit->uncorrected_path( $ac_wit->path );
183 $tradition->del_witness( $ac_wit );
187 $c->make_witness_paths;
188 # Delete our unused lacuna nodes.
189 foreach my $rdg ( grep { $_->is_lacuna } $c->readings ) {
190 $c->del_reading( $rdg ) unless $c->reading_witnesses( $rdg );
193 # Note that our ranks and common readings are set.
194 $c->_graphcalc_done(1);
197 =head2 make_nodes( $collation, $index, @tokenlist )
199 Create readings from the unique tokens in @tokenlist, and set their rank to
200 $index. Returns an array of readings of the same size as the original @tokenlist.
205 my( $c, $idx, @tokens ) = @_;
209 foreach my $j ( 0 .. $#tokens ) {
211 my $word = _restore_punct( $tokens[$j] );
213 if( exists( $unique{$word} ) ) {
214 $rdg = $unique{$word};
216 my %args = ( 'id' => 'r' . join( '.', $idx, $j+1 ),
220 if( $word eq '#LACUNA#' ) {
221 $args{'is_lacuna'} = 1
225 $rdg = Text::Tradition::Collation::Reading->new( %args );
226 $unique{$word} = $rdg;
228 push( @readings, $rdg );
231 push( @readings, undef );
234 if( $commonctr == 1 ) {
235 # Whichever reading isn't a lacuna is a common node.
236 foreach my $rdg ( values %unique ) {
237 next if $rdg->is_lacuna;
238 $rdg->is_common( 1 );
241 map { $c->add_reading( $_ ) } values( %unique );
245 # Utility function for parsing JSON from nCritic
248 my $word = $token->{'t'};
249 return $word unless exists $token->{'punctuation'};
250 foreach my $p ( sort { $a->{pos} <=> $b->{pos} } @{$token->{'punctuation'}} ) {
251 substr( $word, $p->{pos}, 0, $p->{char} );
260 This package is free software and is provided "as is" without express
261 or implied warranty. You can redistribute it and/or modify it under
262 the same terms as Perl itself.
266 Tara L Andrews E<lt>aurum@cpan.orgE<gt>