lib/Text/Tradition/Directory.pm

   1 package Text::Tradition::Directory;
   2
   3 use strict;
   4 use warnings;
   5 use Moose;
   6 use KiokuDB::TypeMap;
   7 use KiokuDB::TypeMap::Entry::Naive;
   8
   9 extends 'KiokuX::Model';
  10
  11 =head1 NAME
  12
  13 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
  14
  15 =head1 SYNOPSIS
  16
  17   use Text::Tradition::Directory;
  18   my $d = Text::Tradition::Directory->new(
  19     'dsn' => 'dbi:SQLite:mytraditions.db',
  20     'extra_args' => { 'create' => 1 },
  21   );
  22
  23   my $tradition = Text::Tradition->new( @args );
  24   my $stemma = $tradition->add_stemma( $dotfile );
  25   $d->save_tradition( $tradition );
  26
  27   foreach my $id ( $d->traditions ) {
  28         print $d->tradition( $id )->name;
  29   }
  30
  31 =head1 DESCRIPTION
  32
  33 Text::Tradition::Directory is an interface for storing and retrieving text traditions and all their data, including an associated stemma hypothesis.  It is an instantiation of a KiokuDB::Model, storing traditions and associated stemmas by UUID.
  34
  35 =head1 METHODS
  36
  37 =head2 new
  38
  39 Returns a Directory object.
  40
  41 =head2 tradition_ids
  42
  43 Returns the ID of all traditions in the database.
  44
  45 =head2 tradition( $id )
  46
  47 Returns the Text::Tradition object of the given ID.
  48
  49 =head2 save( $tradition )
  50
  51 Writes the given tradition to the database, returning its ID.
  52
  53 =begin testing
  54
  55 use Test::Warn;
  56 use File::Temp;
  57 use Text::Tradition;
  58 use_ok 'Text::Tradition::Directory';
  59
  60 my $fh = File::Temp->new();
  61 my $file = $fh->filename;
  62 $fh->close;
  63 my $dsn = "dbi:SQLite:dbname=$file";
  64
  65 my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
  66         'extra_args' => { 'create' => 1 } );
  67 is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
  68
  69 my $scope = $d->new_scope;
  70 my $t = Text::Tradition->new(
  71         'name'  => 'inline',
  72         'input' => 'Tabular',
  73         'file'  => 't/data/simple.txt',
  74         );
  75 my $uuid = $d->save( $t );
  76 ok( $uuid, "Saved test tradition" );
  77
  78 my $s = $t->add_stemma( 't/data/simple.dot' );
  79 ok( $d->save( $t ), "Updated tradition with stemma" );
  80 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
  81 is( $d->tradition( $uuid )->stemma, $s, "...and it has the correct stemma" );
  82 warning_like { $d->save( $s ) } qr/not a Text::Tradition/, "Correctly failed to save stemma directly";
  83
  84 my $e = Text::Tradition::Directory->new( 'dsn' => $dsn );
  85 $scope = $e->new_scope;
  86 is( scalar $e->tradition_ids, 1, "Directory index has our tradition" );
  87 my $te = $e->tradition( $uuid );
  88 is( $te->name, $t->name, "Retrieved the tradition from a new directory" );
  89 my $sid = $e->object_to_id( $te->stemma );
  90 warning_like { $e->tradition( $sid ) } qr/not a Text::Tradition/, "Did not retrieve stemma via tradition call";
  91 warning_like { $e->delete( $sid ) } qr/Cannot directly delete non-Tradition object/, "Stemma object not deleted from DB";
  92 $e->delete( $uuid );
  93 ok( !$e->exists( $uuid ), "Object is deleted from DB" );
  94 is( scalar $e->tradition_ids, 0, "Object is deleted from index" );
  95
  96
  97 =end testing
  98
  99 =cut
 100
 101 has +typemap => (
 102         is => 'rw',
 103         isa => 'KiokuDB::TypeMap',
 104         default => sub {
 105                 KiokuDB::TypeMap->new(
 106                         isa_entries => {
 107                                 "Graph" => KiokuDB::TypeMap::Entry::Naive->new,
 108                                 "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
 109                         }
 110                 );
 111         },
 112 );
 113
 114 has tradition_index => (
 115     traits => ['Hash'],
 116     isa => 'HashRef[Str]',
 117     handles => {
 118         add_index               => 'set',
 119         del_index               => 'delete',
 120         name                    => 'get',
 121         tradition_ids   => 'keys',
 122     },
 123     default => sub { {} },
 124     );
 125
 126 # Populate the tradition index.
 127 sub BUILD {
 128         my $self = shift;
 129         my $stream = $self->root_set;
 130         until( $stream->is_done ) {
 131                 foreach my $obj ( $stream->items ) {
 132                         my $uuid = $self->object_to_id( $obj );
 133                         if( ref( $obj ) eq 'Text::Tradition' ) {
 134                                  $self->add_index( $uuid => $obj->name );
 135                         } else {
 136                                 warn "Found root object in DB that is not a Text::Tradition";
 137                         }
 138                 }
 139         }
 140         return $self;
 141 }
 142
 143 # If a tradition is deleted, remove it from the index.
 144 around delete => sub {
 145         my $orig = shift;
 146         my $self = shift;
 147         warn "Only the first object will be deleted" if @_ > 1;
 148         my $arg = shift;
 149         my $obj = ref( $arg ) ? $arg : $self->lookup( $arg );
 150         my $id = ref( $arg ) ? $self->object_to_id( $arg ) : $arg;
 151         unless( ref $obj eq 'Text::Tradition' ) {
 152                 warn "Cannot directly delete non-Tradition object $obj";
 153                 return;
 154         }
 155         $self->$orig( $arg );
 156         $self->del_index( $id );
 157 };
 158
 159 sub save {
 160         my( $self, $obj ) = @_;
 161         unless( ref( $obj ) eq 'Text::Tradition' ) {
 162                 warn "Object $obj is not a Text::Tradition";
 163                 return;
 164         }
 165         my $uuid = $self->store( $obj );
 166         $self->add_index( $uuid => $obj->name ) if $uuid;
 167         return $uuid;
 168 }
 169
 170
 171 sub tradition {
 172         my( $self, $id ) = @_;
 173         my $obj = $self->lookup( $id );
 174         unless( ref( $obj ) eq 'Text::Tradition' ) {
 175                 warn "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition";
 176                 return;
 177         }
 178         return $obj;
 179 }
 180
 181 1;
 182
 183