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 = "1.0";
  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
 169 other tools
 170
 171 =item * TEI - a TEI parallel segmentation format file
 172
 173 =item * Tabular - a spreadsheet collation.  See the documentation for
 174 L<Text::Tradition::Parser::Tabular> for an explanation of additional options.
 175
 176 =back
 177
 178 =item B<file> - The name of the file that contains the data.  One of 'file'
 179 or 'string' should be specified.
 180
 181 =item B<string> - A text string that contains the data.  One of 'file' or
 182 'string' should be specified.
 183
 184 =back
 185
 186 Initialization based on a list of witnesses [NOT YET IMPLEMENTED]:
 187
 188 =over 4
 189
 190 =item B<witnesses> - A reference to an array of Text::Tradition::Witness
 191 objects that carry the text to be collated.
 192
 193 =item B<collator> - A reference to a collation program that will accept
 194 Witness objects.
 195
 196 =back
 197
 198 =head2 B<witnesses>
 199
 200 Return the Text::Tradition::Witness objects associated with this tradition,
 201 as an array.
 202
 203 =head2 B<witness>( $sigil )
 204
 205 Returns the Text::Tradition::Witness object whose sigil is $sigil, or undef
 206 if there is no such object within the tradition.
 207
 208 =head2 B<add_witness>( %opts )
 209
 210 Instantiate a new witness with the given options (see documentation for
 211 Text::Tradition::Witness) and add it to the tradition.
 212
 213 =head2 B<del_witness>( $sigil )
 214
 215 Delete the witness with the given sigil from the tradition.  Returns the
 216 witness object for the deleted witness.
 217
 218 =begin testing
 219
 220 use_ok( 'Text::Tradition', "can use module" );
 221
 222 my $t = Text::Tradition->new( 'name' => 'empty' );
 223 is( ref( $t ), 'Text::Tradition', "initialized an empty Tradition object" );
 224 is( $t->name, 'empty', "object has the right name" );
 225 is( scalar $t->witnesses, 0, "object has no witnesses" );
 226
 227 my $simple = 't/data/simple.txt';
 228 my $s = Text::Tradition->new(
 229     'name'  => 'inline',
 230     'input' => 'Tabular',
 231     'file'  => $simple,
 232     );
 233 is( ref( $s ), 'Text::Tradition', "initialized a Tradition object" );
 234 is( $s->name, 'inline', "object has the right name" );
 235 is( scalar $s->witnesses, 3, "object has three witnesses" );
 236
 237 my $wit_a = $s->witness('A');
 238 is( ref( $wit_a ), 'Text::Tradition::Witness', "Found a witness A" );
 239 if( $wit_a ) {
 240     is( $wit_a->sigil, 'A', "Witness A has the right sigil" );
 241 }
 242 is( $s->witness('X'), undef, "There is no witness X" );
 243 ok( !exists $s->{'witnesses'}->{'X'}, "Witness key X not created" );
 244
 245 my $wit_d = $s->add_witness( 'sigil' => 'D', 'sourcetype' => 'collation' );
 246 is( ref( $wit_d ), 'Text::Tradition::Witness', "new witness created" );
 247 is( $wit_d->sigil, 'D', "witness has correct sigil" );
 248 is( scalar $s->witnesses, 4, "object now has four witnesses" );
 249
 250 my $del = $s->del_witness( 'D' );
 251 is( $del, $wit_d, "Deleted correct witness" );
 252 is( scalar $s->witnesses, 3, "object has three witnesses again" );
 253
 254 # TODO test initialization by witness list when we have it
 255
 256 =end testing
 257
 258 =cut
 259
 260
 261 sub BUILD {
 262     my( $self, $init_args ) = @_;
 263
 264     # First, make a collation object. This will use only those arguments in
 265     # init_args that apply to the collation.
 266         my $collation = Text::Tradition::Collation->new( %$init_args,
 267                                                                                                         'tradition' => $self );
 268         $self->_save_collation( $collation );
 269
 270     if( exists $init_args->{'input'} ) {
 271         # Call the appropriate parser on the given data
 272         my @format_standalone = qw/ Self CollateText CollateX CTE JSON TEI Tabular /;
 273         my @format_basetext = qw/ KUL /;
 274         my $use_base;
 275         my $format = $init_args->{'input'};
 276         if( $format && !( grep { $_ eq $format } @format_standalone )
 277             && !( grep { $_ eq $format } @format_basetext ) ) {
 278             warn "Unrecognized input format $format; not parsing";
 279             return;
 280         }
 281         if( $format && grep { $_ eq $format } @format_basetext ) {
 282             $use_base = 1;
 283             if( !exists $init_args->{'base'} ) {
 284                 warn "Cannot make a collation from $format without a base text";
 285                 return;
 286             }
 287         }
 288
 289         # Now do the parsing.
 290         if( $format ) {
 291             if( $use_base ) {
 292                 $format = 'BaseText';   # Use the BaseText module for parsing,
 293                                         # but retain the original input arg.
 294             }
 295             my $mod = "Text::Tradition::Parser::$format";
 296             load( $mod );
 297             $mod->can('parse')->( $self, $init_args );
 298         }
 299     }
 300     $self->_init_done( 1 );
 301     return $self;
 302 }
 303
 304 =head2 add_json_witnesses( $jsonstring, $options )
 305
 306 Adds a set of witnesses from a JSON array specification. This is a wrapper
 307 to parse the JSON and call add_witness (with the specified $options) for
 308 each element therein.
 309
 310 =cut
 311
 312 sub add_json_witnesses {
 313         my( $self, $jsonstr, $extraopts ) = @_;
 314         my $witarray = from_json( $jsonstr );
 315         foreach my $witspec ( @{$witarray->{witnesses}} ) {
 316                 my $opts = $extraopts || {};
 317                 $opts->{'sourcetype'} = 'json';
 318                 $opts->{'object'} = $witspec;
 319                 $self->add_witness( $opts );
 320         }
 321 }
 322
 323 =head1 PLUGIN HOOKS
 324
 325 =head2 enable_stemmata
 326
 327 If the tradition in question does not have the HasStemma role, make it so. Throws
 328 an error if the role (ergo, if the Analysis package) is not installed.
 329
 330 =cut
 331
 332 sub enable_stemmata {
 333         my $self = shift;
 334         my $rolename = 'Text::Tradition::HasStemma';
 335         return 1 if does_role( $self, $rolename );
 336         try {
 337                 apply_all_roles( $self, $rolename );
 338         } catch {
 339                 throw( "Cannot apply role to enable stemmata; is the Analysis extension installed?" );
 340         }
 341         return 1;
 342 }
 343
 344 =head2 enable_morphology
 345
 346 If the tradition in question has readings that do not include the Morphology
 347 role, apply the role to them. Throws an error if the role (ergo, if the
 348 Morphology package) is not installed.
 349
 350 =cut
 351
 352 sub enable_morphology {
 353         my $self = shift;
 354         my $rolename = 'Text::Tradition::Morphology';
 355         try {
 356                 load( $rolename );
 357         } catch {
 358                 throw( "Cannot apply role to enable morphology; is the extension installed?" );
 359         }
 360         foreach my $r ( $self->collation->readings ) {
 361                 apply_all_roles( $r, $rolename )
 362                         unless does_role( $r, $rolename );
 363         }
 364         return 1;
 365 }
 366
 367 =head2 lemmatize
 368
 369 Calls the appropriate lemmatization function for the language of the
 370 tradition. Implicitly applies the Morphology role where appropriate (and
 371 throws an error if the package is not installed.)
 372
 373 =cut
 374
 375 # TODO find a better way to hook this
 376 sub lemmatize {
 377         my $self = shift;
 378         unless( $self->has_language ) {
 379                 warn "Please set a language to lemmatize a tradition";
 380                 return;
 381         }
 382         $self->enable_morphology;
 383         my $mod = "Text::Tradition::Language::" . $self->language;
 384         load( $mod );
 385         $mod->can( 'lemmatize' )->( $self );
 386 }
 387
 388 sub throw {
 389         Text::Tradition::Error->throw(
 390                 'ident' => 'Tradition error',
 391                 'message' => $_[0],
 392                 );
 393 }
 394
 395 no Moose;
 396 __PACKAGE__->meta->make_immutable;
 397
 398
 399 =head1 BUGS / TODO
 400
 401 =over
 402
 403 =item * Allow tradition to be initialized via passing to a collator.
 404
 405 =back
 406
 407 =head1 LICENSE
 408
 409 This package is free software and is provided "as is" without express
 410 or implied warranty.  You can redistribute it and/or modify it under
 411 the same terms as Perl itself.
 412
 413 =head1 AUTHOR
 414
 415 Tara L Andrews E<lt>aurum@cpan.orgE<gt>