lib/Text/Tradition/Parser/Self.pm

   1 package Text::Tradition::Parser::Self;
   2
   3 use strict;
   4 use warnings;
   5 use Text::Tradition::Parser::GraphML qw/ graphml_parse /;
   6 use Text::Tradition::UserStore;
   7 use TryCatch;
   8
   9 =head1 NAME
  10
  11 Text::Tradition::Parser::GraphML
  12
  13 =head1 SYNOPSIS
  14
  15   use Text::Tradition;
  16
  17   my $t_from_file = Text::Tradition->new(
  18     'name' => 'my text',
  19     'input' => 'Self',
  20     'file' => '/path/to/tradition.xml'
  21     );
  22
  23   my $t_from_string = Text::Tradition->new(
  24     'name' => 'my text',
  25     'input' => 'Self',
  26     'string' => $tradition_xml,
  27     );
  28
  29 =head1 DESCRIPTION
  30
  31 Parser module for Text::Tradition to read in its own GraphML output format.
  32 GraphML is a relatively simple graph description language; a 'graph' element
  33 can have 'node' and 'edge' elements, and each of these can have simple 'data'
  34 elements for attributes to be saved.
  35
  36 The graph itself has attributes as in the Collation object:
  37
  38 =over
  39
  40 =item * linear
  41
  42 =item * ac_label
  43
  44 =item * baselabel
  45
  46 =item * wit_list_separator
  47
  48 =back
  49
  50 The node objects have the following attributes:
  51
  52 =over
  53
  54 =item * name
  55
  56 =item * reading
  57
  58 =item * identical
  59
  60 =item * rank
  61
  62 =item * class
  63
  64 =back
  65
  66 The edge objects have the following attributes:
  67
  68 =over
  69
  70 =item * class
  71
  72 =item * witness (for 'path' class edges)
  73
  74 =item * extra   (for 'path' class edges)
  75
  76 =item * relationship    (for 'relationship' class edges)
  77
  78 =item * equal_rank      (for 'relationship' class edges)
  79
  80 =item * non_correctable (for 'relationship' class edges)
  81
  82 =item * non_independent (for 'relationship' class edges)
  83
  84 =back
  85
  86 =head1 METHODS
  87
  88 =head2 B<parse>
  89
  90 parse( $graph, $opts );
  91
  92 Takes an initialized Text::Tradition object and a set of options; creates
  93 the appropriate nodes and edges on the graph.  The options hash should
  94 include either a 'file' argument or a 'string' argument, depending on the
  95 source of the XML to be parsed.
  96
  97 =begin testing
  98
  99 use File::Temp;
 100 use Test::Warn;
 101 use Text::Tradition;
 102 binmode STDOUT, ":utf8";
 103 binmode STDERR, ":utf8";
 104 eval { no warnings; binmode $DB::OUT, ":utf8"; };
 105
 106 my $tradition = 't/data/florilegium_graphml.xml';
 107 my $t = Text::Tradition->new(
 108     'name'  => 'inline',
 109     'input' => 'Self',
 110     'file'  => $tradition,
 111     );
 112
 113 is( ref( $t ), 'Text::Tradition', "Parsed GraphML version 2" );
 114 if( $t ) {
 115     is( scalar $t->collation->readings, 319, "Collation has all readings" );
 116     is( scalar $t->collation->paths, 376, "Collation has all paths" );
 117     is( scalar $t->witnesses, 13, "Collation has all witnesses" );
 118 }
 119
 120 # TODO add a relationship, add a stemma, write graphml, reparse it, check that
 121 # the new data is there
 122 $t->language('Greek');
 123 $t->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
 124 $t->collation->add_relationship( 'w12', 'w13',
 125         { 'type' => 'grammatical', 'scope' => 'global',
 126           'annotation' => 'This is some note' } );
 127 ok( $t->collation->get_relationship( 'w12', 'w13' ), "Relationship set" );
 128 my $graphml_str = $t->collation->as_graphml;
 129
 130 my $newt = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str );
 131 is( ref( $newt ), 'Text::Tradition', "Parsed current GraphML version" );
 132 if( $newt ) {
 133     is( scalar $newt->collation->readings, 319, "Collation has all readings" );
 134     is( scalar $newt->collation->paths, 376, "Collation has all paths" );
 135     is( scalar $newt->witnesses, 13, "Collation has all witnesses" );
 136     is( scalar $newt->collation->relationships, 1, "Collation has added relationship" );
 137     is( $newt->language, 'Greek', "Tradition has correct language setting" );
 138     my $rel = $newt->collation->get_relationship( 'w12', 'w13' );
 139     ok( $rel, "Found set relationship" );
 140     is( $rel->annotation, 'This is some note', "Relationship has its properties" );
 141     is( scalar $newt->stemmata, 1, "Tradition has its stemma" );
 142     is( $newt->stemma(0)->witnesses, $t->stemma(0)->witnesses, "Stemma has correct length witness list" );
 143 }
 144
 145 # Test user save / restore
 146 my $fh = File::Temp->new();
 147 my $file = $fh->filename;
 148 $fh->close;
 149 my $dsn = "dbi:SQLite:dbname=$file";
 150 my $userstore = Text::Tradition::Directory->new( { dsn => $dsn,
 151         extra_args => { create => 1 } } );
 152 my $scope = $userstore->new_scope();
 153 my $testuser = $userstore->create_user( { url => 'http://example.com' } );
 154 is( ref( $testuser ), 'Text::Tradition::User', "Created test user via userstore" );
 155 $testuser->add_tradition( $newt );
 156 is( $newt->user->id, $testuser->id, "Assigned tradition to test user" );
 157 $graphml_str = $newt->collation->as_graphml;
 158 my $usert;
 159 warning_is {
 160         $usert = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str );
 161 } 'DROPPING user assignment without a specified userstore',
 162         "Got expected user drop warning on parse";
 163 $usert = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml_str,
 164         'userstore' => $userstore );
 165 is( $usert->user->id, $testuser->id, "Parsed tradition with userstore points to correct user" );
 166
 167
 168 =end testing
 169
 170 =cut
 171 use Data::Dump;
 172 sub parse {
 173     my( $tradition, $opts ) = @_;
 174
 175     # Collation data is in the first graph; relationship-specific stuff
 176     # is in the second.
 177     my( $graph_data, $rel_data ) = graphml_parse( $opts );
 178
 179     my $collation = $tradition->collation;
 180     my %witnesses;
 181
 182     # print STDERR "Setting graph globals\n";
 183     $tradition->name( $graph_data->{'name'} );
 184
 185     my $use_version;
 186     my $tmeta = $tradition->meta;
 187     my $cmeta = $collation->meta;
 188     foreach my $gkey ( keys %{$graph_data->{'global'}} ) {
 189                 my $val = $graph_data->{'global'}->{$gkey};
 190                 if( $gkey eq 'version' ) {
 191                         $use_version = $val;
 192                 } elsif( $gkey eq 'stemmata' ) {
 193                         # Parse the stemmata into objects
 194                         foreach my $dotstr ( split( /\n/, $val ) ) {
 195                                 $tradition->add_stemma( 'dot' => $dotstr );
 196                         }
 197                 } elsif( $gkey eq 'user' ) {
 198                         # Assign the tradition to the user if we can
 199                         if( exists $opts->{'userstore'} ) {
 200                                 my $userdir = delete $opts->{'userstore'};
 201                                 my $user = $userdir->find_user( { username => $val } );
 202                                 if( $user ) {
 203                                         $user->add_tradition( $tradition );
 204                                 } else {
 205                                         warn( "Found no user with ID $val; DROPPING user assignment" );
 206                                 }
 207                         } else {
 208                                 warn( "DROPPING user assignment without a specified userstore" );
 209                         }
 210                 } elsif( $tmeta->has_attribute( $gkey ) ) {
 211                         $tradition->$gkey( $val );
 212                 } else {
 213                         $collation->$gkey( $val );
 214                 }
 215         }
 216
 217     # Add the nodes to the graph.
 218     # Note any reading IDs that were changed in order to comply with XML
 219     # name restrictions; we have to hardcode start & end.
 220     my %namechange = ( '#START#' => '__START__', '#END#' => '__END__' );
 221
 222     # print STDERR "Adding collation readings\n";
 223     foreach my $n ( @{$graph_data->{'nodes'}} ) {
 224         # If it is the start or end node, we already have one, so
 225         # grab the rank and go.
 226         if( defined $n->{'is_start'} ) {
 227 #         warn Data::Dump::dump($n);
 228 #         warn $collation->start->id;
 229           $collation->start->rank($n->{'rank'});
 230           next;
 231         }
 232         if( defined $n->{'is_end'} ) {
 233 #         warn Data::Dump::dump($n);
 234                 $collation->end->rank( $n->{'rank'} );
 235                 next;
 236         }
 237                 my $gnode = $collation->add_reading( $n );
 238                 if( $gnode->id ne $n->{'id'} ) {
 239                         $namechange{$n->{'id'}} = $gnode->id;
 240                 }
 241     }
 242
 243     # Now add the edges.
 244     # print STDERR "Adding collation path edges\n";
 245     foreach my $e ( @{$graph_data->{'edges'}} ) {
 246         my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
 247                 ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
 248         my $targetid = exists $namechange{$e->{'target'}->{'id'}}
 249                 ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
 250         my $from = $collation->reading( $sourceid );
 251         my $to = $collation->reading( $targetid );
 252
 253                 warn "No witness label on path edge!" unless $e->{'witness'};
 254                 my $label = $e->{'witness'} . ( $e->{'extra'} ? $collation->ac_label : '' );
 255                 $collation->add_path( $from, $to, $label );
 256
 257                 # Add the witness if we don't have it already.
 258                 unless( $witnesses{$e->{'witness'}} ) {
 259                         $tradition->add_witness(
 260                                 sigil => $e->{'witness'}, 'sourcetype' => 'collation' );
 261                         $witnesses{$e->{'witness'}} = 1;
 262                 }
 263                 $tradition->witness( $e->{'witness'} )->is_layered( 1 ) if $e->{'extra'};
 264     }
 265
 266     ## Done with the main graph, now look at the relationships.
 267         # Nodes are added via the call to add_reading above.  We only need
 268         # add the relationships themselves.
 269         # TODO check that scoping does trt
 270         $rel_data->{'edges'} ||= []; # so that the next line doesn't break on no rels
 271         foreach my $e ( sort { _layersort_rel( $a, $b ) } @{$rel_data->{'edges'}} ) {
 272         my $sourceid = exists $namechange{$e->{'source'}->{'id'}}
 273                 ? $namechange{$e->{'source'}->{'id'}} : $e->{'source'}->{'id'};
 274         my $targetid = exists $namechange{$e->{'target'}->{'id'}}
 275                 ? $namechange{$e->{'target'}->{'id'}} : $e->{'target'}->{'id'};
 276         my $from = $collation->reading( $sourceid );
 277         my $to = $collation->reading( $targetid );
 278                 delete $e->{'source'};
 279                 delete $e->{'target'};
 280                 # The remaining keys are relationship attributes.
 281                 # Backward compatibility...
 282                 if( $use_version eq '2.0' || $use_version eq '3.0' ) {
 283                         delete $e->{'class'};
 284                         $e->{'type'} = delete $e->{'relationship'} if exists $e->{'relationship'};
 285                 }
 286                 # Add the specified relationship unless we already have done.
 287                 my $rel_exists;
 288                 if( $e->{'scope'} ne 'local' ) {
 289                         my $relobj = $collation->get_relationship( $from, $to );
 290                         if( $relobj && $relobj->scope eq $e->{'scope'}
 291                                 && $relobj->type eq $e->{'type'} ) {
 292                                 $rel_exists = 1;
 293                         }
 294                 }
 295                 try {
 296                         $collation->add_relationship( $from, $to, $e ) unless $rel_exists;
 297                 } catch( Text::Tradition::Error $e ) {
 298                         warn "DROPPING $from -> $to: " . $e->message;
 299                 }
 300         }
 301
 302     # Save the text for each witness so that we can ensure consistency
 303     # later on
 304         $collation->text_from_paths();
 305 }
 306
 307 ## Return the relationship that comes first in priority.
 308 my %LAYERS = (
 309         'collated' => 1,
 310         'orthographic' => 2,
 311         'spelling' => 3,
 312         );
 313
 314 sub _layersort_rel {
 315         my( $a, $b ) = @_;
 316         my $key = exists $a->{'type'} ? 'type' : 'relationship';
 317         my $at = $LAYERS{$a->{$key}} || 99;
 318         my $bt = $LAYERS{$b->{$key}} || 99;
 319         return $at <=> $bt;
 320 }
 321
 322 1;
 323
 324 =head1 BUGS / TODO
 325
 326 =over
 327
 328 =item * Make this into a stream parser with GraphML
 329
 330 =item * Simply field -> attribute correspondence for nodes and edges
 331
 332 =item * Share key name constants with Collation.pm
 333
 334 =back
 335
 336 =head1 LICENSE
 337
 338 This package is free software and is provided "as is" without express
 339 or implied warranty.  You can redistribute it and/or modify it under
 340 the same terms as Perl itself.
 341
 342 =head1 AUTHOR
 343
 344 Tara L Andrews E<lt>aurum@cpan.orgE<gt>