Commit | Line | Data |
8d9a1cd8 |
1 | package Text::Tradition::Directory; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use Moose; |
ad1291ee |
6 | use KiokuDB::GC::Naive; |
8d9a1cd8 |
7 | use KiokuDB::TypeMap; |
8 | use KiokuDB::TypeMap::Entry::Naive; |
9 | |
10 | extends 'KiokuX::Model'; |
11 | |
12523041 |
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 ); |
56cf65bd |
25 | my $stemma = $tradition->add_stemma( $dotfile ); |
12523041 |
26 | $d->save_tradition( $tradition ); |
12523041 |
27 | |
28 | foreach my $id ( $d->traditions ) { |
29 | print $d->tradition( $id )->name; |
12523041 |
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 | |
56cf65bd |
40 | Returns a Directory object. |
12523041 |
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 | |
56cf65bd |
50 | =head2 save( $tradition ) |
12523041 |
51 | |
56cf65bd |
52 | Writes the given tradition to the database, returning its ID. |
12523041 |
53 | |
54 | =begin testing |
55 | |
56cf65bd |
56 | use Test::Warn; |
12523041 |
57 | use File::Temp; |
58 | use Text::Tradition; |
12523041 |
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, |
56cf65bd |
67 | 'extra_args' => { 'create' => 1 } ); |
12523041 |
68 | is( ref $d, 'Text::Tradition::Directory', "Got directory object" ); |
69 | |
56cf65bd |
70 | my $scope = $d->new_scope; |
12523041 |
71 | my $t = Text::Tradition->new( |
56cf65bd |
72 | 'name' => 'inline', |
73 | 'input' => 'Tabular', |
74 | 'file' => 't/data/simple.txt', |
75 | ); |
76 | my $uuid = $d->save( $t ); |
12523041 |
77 | ok( $uuid, "Saved test tradition" ); |
78 | |
56cf65bd |
79 | my $s = $t->add_stemma( 't/data/simple.dot' ); |
80 | ok( $d->save( $t ), "Updated tradition with stemma" ); |
12523041 |
81 | is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" ); |
56cf65bd |
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"; |
12523041 |
84 | |
12523041 |
85 | my $e = Text::Tradition::Directory->new( 'dsn' => $dsn ); |
56cf65bd |
86 | $scope = $e->new_scope; |
87 | is( scalar $e->tradition_ids, 1, "Directory index has our tradition" ); |
12523041 |
88 | my $te = $e->tradition( $uuid ); |
56cf65bd |
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" ); |
ad1291ee |
95 | ok( !$e->exists( $sid ), "Object stemma also deleted from DB" ); |
56cf65bd |
96 | is( scalar $e->tradition_ids, 0, "Object is deleted from index" ); |
97 | |
12523041 |
98 | |
99 | =end testing |
100 | |
101 | =cut |
102 | |
12523041 |
103 | has +typemap => ( |
8d9a1cd8 |
104 | is => 'rw', |
105 | isa => 'KiokuDB::TypeMap', |
106 | default => sub { |
107 | KiokuDB::TypeMap->new( |
108 | isa_entries => { |
8d9a1cd8 |
109 | "Graph" => KiokuDB::TypeMap::Entry::Naive->new, |
110 | "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new, |
111 | } |
112 | ); |
113 | }, |
114 | ); |
115 | |
56cf65bd |
116 | has tradition_index => ( |
117 | traits => ['Hash'], |
118 | isa => 'HashRef[Str]', |
119 | handles => { |
120 | add_index => 'set', |
121 | del_index => 'delete', |
122 | name => 'get', |
123 | tradition_ids => 'keys', |
124 | }, |
125 | default => sub { {} }, |
126 | ); |
8d9a1cd8 |
127 | |
56cf65bd |
128 | # Populate the tradition index. |
8d9a1cd8 |
129 | sub BUILD { |
130 | my $self = shift; |
12523041 |
131 | my $stream = $self->root_set; |
12523041 |
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' ) { |
56cf65bd |
136 | $self->add_index( $uuid => $obj->name ); |
12523041 |
137 | } else { |
56cf65bd |
138 | warn "Found root object in DB that is not a Text::Tradition"; |
8d9a1cd8 |
139 | } |
140 | } |
12523041 |
141 | } |
56cf65bd |
142 | return $self; |
8d9a1cd8 |
143 | } |
12523041 |
144 | |
56cf65bd |
145 | # If a tradition is deleted, remove it from the index. |
146 | around delete => sub { |
147 | my $orig = shift; |
148 | my $self = shift; |
ad1291ee |
149 | warn "Will only delete one tradition at a time" if @_ > 1; |
56cf65bd |
150 | my $arg = shift; |
151 | my $obj = ref( $arg ) ? $arg : $self->lookup( $arg ); |
152 | my $id = ref( $arg ) ? $self->object_to_id( $arg ) : $arg; |
153 | unless( ref $obj eq 'Text::Tradition' ) { |
154 | warn "Cannot directly delete non-Tradition object $obj"; |
155 | return; |
156 | } |
157 | $self->$orig( $arg ); |
ad1291ee |
158 | my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend ); |
159 | $self->$orig( $gc->garbage->members ); |
56cf65bd |
160 | $self->del_index( $id ); |
161 | }; |
162 | |
163 | sub save { |
164 | my( $self, $obj ) = @_; |
165 | unless( ref( $obj ) eq 'Text::Tradition' ) { |
166 | warn "Object $obj is not a Text::Tradition"; |
167 | return; |
12523041 |
168 | } |
56cf65bd |
169 | my $uuid = $self->store( $obj ); |
170 | $self->add_index( $uuid => $obj->name ) if $uuid; |
12523041 |
171 | return $uuid; |
172 | } |
173 | |
56cf65bd |
174 | |
175 | sub tradition { |
176 | my( $self, $id ) = @_; |
177 | my $obj = $self->lookup( $id ); |
178 | unless( ref( $obj ) eq 'Text::Tradition' ) { |
179 | warn "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition"; |
180 | return; |
12523041 |
181 | } |
56cf65bd |
182 | return $obj; |
12523041 |
183 | } |
8d9a1cd8 |
184 | |
185 | 1; |
12523041 |
186 | |
8d9a1cd8 |
187 | |