lib/Text/Tradition/Directory.pm

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