base/lib/Text/Tradition.pm

   1 package Text::Tradition;
   2
   3 use JSON qw / from_json /;
   4 use Module::Load;
   5 use Moose;
   6 use Moose::Util qw/ does_role apply_all_roles /;
   7 use Text::Tradition::Collation;
   8 use Text::Tradition::Error;
   9 use Text::Tradition::Witness;
  10 use Text::Tradition::User;
  11 use TryCatch;
  12
  13 use vars qw( $VERSION );
  14 $VERSION = "0.5";
  15
  16 has 'collation' => (
  17     is => 'ro',
  18     isa => 'Text::Tradition::Collation',
  19     writer => '_save_collation',
  20     );
  21
  22 has 'witness_hash' => (
  23     traits => ['Hash'],
  24     isa => 'HashRef[Text::Tradition::Witness]',
  25     handles => {
  26         witness     => 'get',
  27         add_witness => 'set',
  28         del_witness => 'delete',
  29         has_witness => 'exists',
  30         witnesses   => 'values',
  31     },
  32     default => sub { {} },
  33     );
  34
  35 has 'name' => (
  36     is => 'rw',
  37     isa => 'Str',
  38     default => 'Tradition',
  39     );
  40
  41 has 'language' => (
  42         is => 'rw',
  43         isa => 'Str',
  44         predicate => 'has_language',
  45         );
  46
  47 has '_initialized' => (
  48         is => 'ro',
  49         isa => 'Bool',
  50         default => undef,
  51         writer => '_init_done',
  52         );
  53
  54 has 'user' => (
  55     is => 'rw',
  56     isa => 'Text::Tradition::User',
  57     required => 0,
  58     predicate => 'has_user',
  59     clearer => 'clear_user',
  60     weak_ref => 1
  61     );
  62
  63 has 'public' => (
  64     is => 'rw',
  65     isa => 'Bool',
  66     required => 0,
  67     default => sub { 0; },
  68     );
  69
  70 # Create the witness before trying to add it
  71 around 'add_witness' => sub {
  72     my $orig = shift;
  73     my $self = shift;
  74     # TODO allow add of a Witness object?
  75     my %args = @_ == 1 ? %{$_[0]} : @_;
  76     $args{'tradition'} = $self;
  77     $args{'language'} = $self->language
  78         if( $self->language && !exists $args{'language'} );
  79     my $new_wit = Text::Tradition::Witness->new( %args );
  80     $self->$orig( $new_wit->sigil => $new_wit );
  81     return $new_wit;
  82 };
  83
  84 # Allow deletion of witness by object as well as by sigil
  85 around 'del_witness' => sub {
  86     my $orig = shift;
  87     my $self = shift;
  88     my @key_args;
  89     foreach my $arg ( @_ ) {
  90         push( @key_args,
  91               ref( $arg ) eq 'Text::Tradition::Witness' ? $arg->sigil : $arg );
  92     }
  93     return $self->$orig( @key_args );
  94 };
  95
  96 # Don't allow an empty hash value
  97 around 'witness' => sub {
  98     my( $orig, $self, $arg ) = @_;
  99     return unless $self->has_witness( $arg );
 100     return $self->$orig( $arg );
 101 };
 102
 103 =head1 NAME
 104
 105 Text::Tradition - a software model for a set of collated texts
 106
 107 =head1 SYNOPSIS
 108
 109   use Text::Tradition;
 110   my $t = Text::Tradition->new(
 111     'name' => 'this is a text',
 112     'input' => 'TEI',
 113     'file' => '/path/to/tei_parallel_seg_file.xml' );
 114
 115   my @text_wits = $t->witnesses();
 116   my $manuscript_a = $t->witness( 'A' );
 117
 118   $t = Text::Tradition->new();
 119   $t->add_witness( 'sourcetype' => 'xmldesc',
 120     'file' => '/path/to/teitranscription.xml' );
 121   $t->add_witness( 'sourcetype => 'plaintext', 'sigil' => 'Q',
 122     'string' => 'The quick brown fox jumped over the lazy dogs' );
 123   ## TODO
 124   $t->collate_texts;
 125
 126   my $text_path_svg = $t->collation->as_svg();
 127   ## See Text::Tradition::Collation for more on text collation itself
 128
 129 =head1 DESCRIPTION
 130
 131 Text::Tradition is a library for representation and analysis of collated
 132 texts, particularly medieval ones.  A 'tradition' refers to the aggregation
 133 of surviving versions of a text, generally preserved in multiple
 134 manuscripts (or 'witnesses').  A Tradition object thus has one more more
 135 Witnesses, as well as a Collation that represents the unity of all versions
 136 of the text.
 137
 138 =head1 METHODS
 139
 140 =head2 new
 141
 142 Creates and returns a new text tradition object.  The following options are
 143 accepted.
 144
 145 General options:
 146
 147 =over 4
 148
 149 =item B<name> - The name of the text.
 150
 151 =back
 152
 153 Initialization based on a collation file:
 154
 155 =over 4
 156
 157 =item B<input> - The input format of the collation file.  Can be one of the
 158 following:
 159
 160 =over 4
 161
 162 =item * Self - a GraphML format produced by this module
 163
 164 =item * CollateX - a GraphML format produced by CollateX
 165
 166 =item * CTE - a TEI XML format produced by Classical Text Editor
 167
 168 =item * JSON - an alignment table in JSON format, as produced by CollateX and other tools
 169
 170 =item * KUL - a specific CSV format for variants, not documented here
 171
 172 =item * TEI - a TEI parallel segmentation format file
 173
 174 =item * Tabular - a comma- or tab-separated collation.  Takes an additional
 175 option, 'sep_char', which defaults to the tab character.
 176
 177 =back
 178
 179 =item B<file> - The name of the file that contains the data.  One of 'file'
 180 or 'string' should be specified.
 181
 182 =item B<string> - A text string that contains the data.  One of 'file' or
 183 'string' should be specified.
 184
 185 =item B<base> - The name of a text file that contains the base text, to be
 186 used with input formats that require it (currently only KUL).
 187
 188 =back
 189
 190 Initialization based on a list of witnesses [NOT YET IMPLEMENTED]:
 191
 192 =over 4
 193
 194 =item B<witnesses> - A reference to an array of Text::Tradition::Witness
 195 objects that carry the text to be collated.
 196
 197 =item B<collator> - A reference to a collation program that will accept
 198 Witness objects.
 199
 200 =back
 201
 202 =head2 B<witnesses>
 203
 204 Return the Text::Tradition::Witness objects associated with this tradition,
 205 as an array.
 206
 207 =head2 B<witness>( $sigil )
 208
 209 Returns the Text::Tradition::Witness object whose sigil is $sigil, or undef
 210 if there is no such object within the tradition.
 211
 212 =head2 B<add_witness>( %opts )
 213
 214 Instantiate a new witness with the given options (see documentation for
 215 Text::Tradition::Witness) and add it to the tradition.
 216
 217 =head2 B<del_witness>( $sigil )
 218
 219 Delete the witness with the given sigil from the tradition.  Returns the
 220 witness object for the deleted witness.
 221
 222 =begin testing
 223
 224 use_ok( 'Text::Tradition', "can use module" );
 225
 226 my $t = Text::Tradition->new( 'name' => 'empty' );
 227 is( ref( $t ), 'Text::Tradition', "initialized an empty Tradition object" );
 228 is( $t->name, 'empty', "object has the right name" );
 229 is( scalar $t->witnesses, 0, "object has no witnesses" );
 230
 231 my $simple = 't/data/simple.txt';
 232 my $s = Text::Tradition->new(
 233     'name'  => 'inline',
 234     'input' => 'Tabular',
 235     'file'  => $simple,
 236     );
 237 is( ref( $s ), 'Text::Tradition', "initialized a Tradition object" );
 238 is( $s->name, 'inline', "object has the right name" );
 239 is( scalar $s->witnesses, 3, "object has three witnesses" );
 240
 241 my $wit_a = $s->witness('A');
 242 is( ref( $wit_a ), 'Text::Tradition::Witness', "Found a witness A" );
 243 if( $wit_a ) {
 244     is( $wit_a->sigil, 'A', "Witness A has the right sigil" );
 245 }
 246 is( $s->witness('X'), undef, "There is no witness X" );
 247 ok( !exists $s->{'witnesses'}->{'X'}, "Witness key X not created" );
 248
 249 my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'collation' );
 250 is( ref( $wit_d ), 'Text::Tradition::Witness', "new witness created" );
 251 is( $wit_d->sigil, 'D', "witness has correct sigil" );
 252 is( scalar $s->witnesses, 4, "object now has four witnesses" );
 253
 254 my $del = $s->del_witness( 'D' );
 255 is( $del, $wit_d, "Deleted correct witness" );
 256 is( scalar $s->witnesses, 3, "object has three witnesses again" );
 257
 258 # TODO test initialization by witness list when we have it
 259
 260 =end testing
 261
 262 =cut
 263
 264
 265 sub BUILD {
 266     my( $self, $init_args ) = @_;
 267
 268     # First, make a collation object. This will use only those arguments in
 269     # init_args that apply to the collation.
 270         my $collation = Text::Tradition::Collation->new( %$init_args,
 271                                                                                                         'tradition' => $self );
 272         $self->_save_collation( $collation );
 273
 274     if( exists $init_args->{'input'} ) {
 275         # Call the appropriate parser on the given data
 276         my @format_standalone = qw/ Self CollateText CollateX CTE JSON TEI Tabular /;
 277         my @format_basetext = qw/ KUL /;
 278         my $use_base;
 279         my $format = $init_args->{'input'};
 280         if( $format && !( grep { $_ eq $format } @format_standalone )
 281             && !( grep { $_ eq $format } @format_basetext ) ) {
 282             warn "Unrecognized input format $format; not parsing";
 283             return;
 284         }
 285         if( $format && grep { $_ eq $format } @format_basetext ) {
 286             $use_base = 1;
 287             if( !exists $init_args->{'base'} ) {
 288                 warn "Cannot make a collation from $format without a base text";
 289                 return;
 290             }
 291         }
 292
 293         # Now do the parsing.
 294         if( $format ) {
 295             if( $use_base ) {
 296                 $format = 'BaseText';   # Use the BaseText module for parsing,
 297                                         # but retain the original input arg.
 298             }
 299             my $mod = "Text::Tradition::Parser::$format";
 300             load( $mod );
 301             $mod->can('parse')->( $self, $init_args );
 302         }
 303     }
 304     $self->_init_done( 1 );
 305     return $self;
 306 }
 307
 308 =head2 add_json_witnesses( $jsonstring, $options )
 309
 310 Adds a set of witnesses from a JSON array specification. This is a wrapper
 311 to parse the JSON and call add_witness (with the specified $options) for
 312 each element therein.
 313
 314 =cut
 315
 316 sub add_json_witnesses {
 317         my( $self, $jsonstr, $extraopts ) = @_;
 318         my $witarray = from_json( $jsonstr );
 319         foreach my $witspec ( @{$witarray->{witnesses}} ) {
 320                 my $opts = $extraopts || {};
 321                 $opts->{'sourcetype'} = 'json';
 322                 $opts->{'object'} = $witspec;
 323                 $self->add_witness( $opts );
 324         }
 325 }
 326
 327 =head1 PLUGIN HOOKS
 328
 329 =head2 enable_stemmata();
 330
 331 If the tradition in question does not have the HasStemma role, make it so. Throws
 332 an error if the role (ergo, if the Analysis package) is not installed.
 333
 334 =cut
 335
 336 sub enable_stemmata {
 337         my $self = shift;
 338         my $rolename = 'Text::Tradition::HasStemma';
 339         return 1 if does_role( $self, $rolename );
 340         try {
 341                 apply_all_roles( $self, $rolename );
 342         } catch {
 343                 throw( "Cannot apply role to enable stemmata; is the Analysis extension installed?" );
 344         }
 345         return 1;
 346 }
 347
 348 sub lemmatize {
 349         my $self = shift;
 350         unless( $self->has_language ) {
 351                 warn "Please set a language to lemmatize a tradition";
 352                 return;
 353         }
 354         my $mod = "Text::Tradition::Language::" . $self->language;
 355         load( $mod );
 356         $mod->can( 'lemmatize' )->( $self );
 357 }
 358
 359 sub throw {
 360         Text::Tradition::Error->throw(
 361                 'ident' => 'Tradition error',
 362                 'message' => $_[0],
 363                 );
 364 }
 365
 366 no Moose;
 367 __PACKAGE__->meta->make_immutable;
 368
 369
 370 =head1 BUGS / TODO
 371
 372 =over
 373
 374 =item * Allow tradition to be initialized via passing to a collator.
 375
 376 =back
 377
 378 =head1 LICENSE
 379
 380 This package is free software and is provided "as is" without express
 381 or implied warranty.  You can redistribute it and/or modify it under
 382 the same terms as Perl itself.
 383
 384 =head1 AUTHOR
 385
 386 Tara L Andrews E<lt>aurum@cpan.orgE<gt>