X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FDirectory.pm;h=f10fda6023b920ebcdef2378357e0a4ef78602ed;hb=566f45958928958a29cec59caf402715a1d4b7cb;hp=9db309eef3e64df6da678efca7e9da4c34ac9417;hpb=3837c155d39333869a93adf1e8375960ffbf3a92;p=scpubgit%2Fstemmatology.git diff --git a/lib/Text/Tradition/Directory.pm b/lib/Text/Tradition/Directory.pm index 9db309e..f10fda6 100644 --- a/lib/Text/Tradition/Directory.pm +++ b/lib/Text/Tradition/Directory.pm @@ -3,30 +3,109 @@ package Text::Tradition::Directory; use strict; use warnings; use Moose; +use KiokuDB::GC::Naive; use KiokuDB::TypeMap; use KiokuDB::TypeMap::Entry::Naive; extends 'KiokuX::Model'; -has data_hash => ( - traits => ['Hash'], - default => sub { {} }, - handles => { - tradition => 'get', - stemma => 'get', - add_tradition => 'set', - add_stemma => 'set', - traditions => 'keys', - }, -); - -has typemap => ( +=head1 NAME + +Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions + +=head1 SYNOPSIS + + use Text::Tradition::Directory; + my $d = Text::Tradition::Directory->new( + 'dsn' => 'dbi:SQLite:mytraditions.db', + 'extra_args' => { 'create' => 1 }, + ); + + my $tradition = Text::Tradition->new( @args ); + my $stemma = $tradition->add_stemma( $dotfile ); + $d->save_tradition( $tradition ); + + foreach my $id ( $d->traditions ) { + print $d->tradition( $id )->name; + } + +=head1 DESCRIPTION + +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. + +=head1 METHODS + +=head2 new + +Returns a Directory object. + +=head2 tradition_ids + +Returns the ID of all traditions in the database. + +=head2 tradition( $id ) + +Returns the Text::Tradition object of the given ID. + +=head2 save( $tradition ) + +Writes the given tradition to the database, returning its ID. + +=begin testing + +use Test::Warn; +use File::Temp; +use Text::Tradition; +use_ok 'Text::Tradition::Directory'; + +my $fh = File::Temp->new(); +my $file = $fh->filename; +$fh->close; +my $dsn = "dbi:SQLite:dbname=$file"; + +my $d = Text::Tradition::Directory->new( 'dsn' => $dsn, + 'extra_args' => { 'create' => 1 } ); +is( ref $d, 'Text::Tradition::Directory', "Got directory object" ); + +my $scope = $d->new_scope; +my $t = Text::Tradition->new( + 'name' => 'inline', + 'input' => 'Tabular', + 'file' => 't/data/simple.txt', + ); +my $uuid = $d->save( $t ); +ok( $uuid, "Saved test tradition" ); + +my $s = $t->add_stemma( 't/data/simple.dot' ); +ok( $d->save( $t ), "Updated tradition with stemma" ); +is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" ); +is( $d->tradition( $uuid )->stemma, $s, "...and it has the correct stemma" ); +warning_like { $d->save( $s ) } qr/not a Text::Tradition/, "Correctly failed to save stemma directly"; + +my $e = Text::Tradition::Directory->new( 'dsn' => $dsn ); +$scope = $e->new_scope; +is( scalar $e->tradition_ids, 1, "Directory index has our tradition" ); +my $te = $e->tradition( $uuid ); +is( $te->name, $t->name, "Retrieved the tradition from a new directory" ); +my $sid = $e->object_to_id( $te->stemma ); +warning_like { $e->tradition( $sid ) } qr/not a Text::Tradition/, "Did not retrieve stemma via tradition call"; +warning_like { $e->delete( $sid ) } qr/Cannot directly delete non-Tradition object/, "Stemma object not deleted from DB"; +$e->delete( $uuid ); +ok( !$e->exists( $uuid ), "Object is deleted from DB" ); +ok( !$e->exists( $sid ), "Object stemma also deleted from DB" ); +is( scalar $e->tradition_ids, 0, "Object is deleted from index" ); + + +=end testing + +=cut + +has +typemap => ( is => 'rw', isa => 'KiokuDB::TypeMap', default => sub { KiokuDB::TypeMap->new( isa_entries => { - "Graph::Easy::Base" => KiokuDB::TypeMap::Entry::Naive->new, "Graph" => KiokuDB::TypeMap::Entry::Naive->new, "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new, } @@ -34,62 +113,75 @@ has typemap => ( }, ); -around 'tradition' => sub { - my( $orig, $self, @arg ) = @_; - my $data = $self->$orig( @arg ); - return $data->{'object'}; -}; +has tradition_index => ( + traits => ['Hash'], + isa => 'HashRef[Str]', + handles => { + add_index => 'set', + del_index => 'delete', + name => 'get', + tradition_ids => 'keys', + }, + default => sub { {} }, + ); -around 'stemma' => sub { - my( $orig, $self, @arg ) = @_; - my $data = $self->$orig( @arg ); - return $data->{'stemma'}; -}; +# Populate the tradition index. +sub BUILD { + my $self = shift; + my $stream = $self->root_set; + until( $stream->is_done ) { + foreach my $obj ( $stream->items ) { + my $uuid = $self->object_to_id( $obj ); + if( ref( $obj ) eq 'Text::Tradition' ) { + $self->add_index( $uuid => $obj->name ); + } else { + warn "Found root object in DB that is not a Text::Tradition"; + } + } + } + return $self; +} -around 'add_tradition' => sub { - my( $orig, $self, $id, $obj ) = @_; - $self->$orig( $id => { 'object' => $obj } ); +# If a tradition is deleted, remove it from the index. +around delete => sub { + my $orig = shift; + my $self = shift; + warn "Will only delete one tradition at a time" if @_ > 1; + my $arg = shift; + my $obj = ref( $arg ) ? $arg : $self->lookup( $arg ); + my $id = ref( $arg ) ? $self->object_to_id( $arg ) : $arg; + unless( ref $obj eq 'Text::Tradition' ) { + warn "Cannot directly delete non-Tradition object $obj"; + return; + } + $self->$orig( $arg ); + my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend ); + $self->$orig( $gc->garbage->members ); + $self->del_index( $id ); }; -around 'add_stemma' => sub { - my( $orig, $self, $id, $obj ) = @_; - $self->{data_hash}->{$id}->{'stemma'} = $obj; -}; +sub save { + my( $self, $obj ) = @_; + unless( ref( $obj ) eq 'Text::Tradition' ) { + warn "Object $obj is not a Text::Tradition"; + return; + } + my $uuid = $self->store( $obj ); + $self->add_index( $uuid => $obj->name ) if $uuid; + return $uuid; +} -# Load all the relevant data from the DSN we were passed. -sub BUILD { - my $self = shift; - my $args = shift; - - if( exists $args->{'dsn'} ) { - # Connect to self, get the traditions and stemmas, and save them - # in the directory. - my $scope = $self->new_scope; - my $stream = $self->root_set; - my %stemmata; - until( $stream->is_done ) { - foreach my $obj ( $stream->items ) { - my $uuid = $self->object_to_id( $obj ); - if( ref( $obj ) eq 'Text::Tradition' ) { - $self->add_tradition( $uuid => $obj ); - } elsif( ref( $obj ) eq 'Text::Tradition::Stemma' ) { - $stemmata{$obj->collation} = $obj; - } else { - warn "Found root object in DB that is neither tradition nor stemma: $obj"; - } - } - } - # Now match the stemmata to their traditions. - foreach my $id ( $self->traditions ) { - my $c = $self->tradition( $id )->collation; - if( exists $stemmata{$c} ) { - $self->add_stemma( $id => $stemmata{$c} ); - } - } +sub tradition { + my( $self, $id ) = @_; + my $obj = $self->lookup( $id ); + unless( ref( $obj ) eq 'Text::Tradition' ) { + warn "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition"; + return; } + return $obj; } 1; - + \ No newline at end of file