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" );
+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,
}
},
);
-around 'tradition' => sub {
- my( $orig, $self, @arg ) = @_;
- my $data = $self->$orig( @arg );
- return $data->{'object'};
-};
-
-around 'stemma' => sub {
- my( $orig, $self, @arg ) = @_;
- my $data = $self->$orig( @arg );
- return $data->{'stemma'};
-};
-
-around 'add_tradition' => sub {
- my( $orig, $self, $id, $obj ) = @_;
- $self->$orig( $id => { 'object' => $obj } );
-};
-
-around 'add_stemma' => sub {
- my( $orig, $self, $id, $obj ) = @_;
- $self->{data_hash}->{$id}->{'stemma'} = $obj;
-};
-
-# Load all the relevant data from the DSN we were passed.
+has tradition_index => (
+ traits => ['Hash'],
+ isa => 'HashRef[Str]',
+ handles => {
+ add_index => 'set',
+ del_index => 'delete',
+ name => 'get',
+ tradition_ids => 'keys',
+ },
+ default => sub { {} },
+ );
+# Populate the tradition index.
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} );
+ 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;
}
+# If a tradition is deleted, remove it from the index.
+around delete => sub {
+ my $orig = shift;
+ my $self = shift;
+ warn "Only the first object will be deleted" 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 );
+ $self->del_index( $id );
+};
+
+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;
+}
+
+
+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
projects / scpubgit/stemmatology.git / blobdiff