morphology/lib/Text/Tradition/WitLanguage.pm

   1 package Text::Tradition::WitLanguage;
   2
   3 use strict;
   4 use warnings;
   5 use Module::Load;
   6 use Moose::Role;
   7 use TryCatch;
   8
   9 =head1 NAME
  10
  11 Text::Tradition::WitLanguage - add-on role to enable language awareness and
  12 morphology functions to a Text::Tradition::Witness object.  Please see
  13 L<Text::Tradition::Morphology> for more information on the morphology
  14 add-on distribution.
  15
  16 =head1 METHODS
  17
  18 =head2 language
  19
  20 Accessor for the primary language of the tradition. Must correspond to one
  21 of the Text::Tradition::Language::* modules in this package. Used for JSON
  22 export of a language-regularized witness text.
  23
  24 =begin testing
  25
  26 use Test::Warn;
  27 use TryCatch;
  28 use_ok( 'Text::Tradition' ); # with Language
  29 use_ok( 'Text::Tradition::Witness' ); # with WitLanguage
  30
  31 =end testing
  32
  33 =cut
  34
  35 has 'language' => (
  36         is => 'rw',
  37         isa => 'Str',
  38         predicate => 'has_language',
  39         );
  40
  41 around 'language' => sub {
  42         my $orig = shift;
  43         my $self = shift;
  44         if( @_ && $_[0] ne 'Default' ) {
  45                 # We are trying to set the language; check that the corresponding
  46                 # module exists.
  47                 try {
  48                         load( "Text::Tradition::Language::".$_[0] );
  49                 } catch ( $e ) {
  50                         warn( "Cannot load language module for @_: $e" );
  51                 }
  52         } elsif( !$self->has_language && $self->tradition->has_language ) {
  53                 return $self->tradition->language;
  54         }
  55         $self->$orig( @_ );
  56 };
  57
  58 around 'export_as_json' => sub {
  59         my $orig = shift;
  60         my $self = shift;
  61         my $answer = $self->$orig( @_ );
  62         if( $self->has_language || $self->tradition->has_language ) {
  63                 # If we do have a language, regularize the tokens in $answer.
  64                 my $mod = "Text::Tradition::Language::" . $self->language;
  65                 load( $mod );
  66                 my $rsub = $mod->can( 'regularize' );
  67                 map { $_->{'n'} = $rsub->( $_->{'t'} ) } @{$answer->{tokens}};
  68                 if( exists $answer->{layertokens} ) {
  69                         map { $_->{'n'} = $rsub->( $_->{'t'} ) } @{$answer->{layertokens}};
  70                 }
  71         } else {
  72                 warn "Please set a language to regularize a tradition";
  73         }
  74         return $answer;
  75 };
  76
  77 1;
  78