Commit | Line | Data |
8d9a1cd8 |
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 | |
12523041 |
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 | $d->save_tradition( $tradition ); |
25 | my $stemma = Text::Tradition::Stemma->new( |
26 | 'dot' => $dotfile, 'collation' => $tradition->collation ); |
27 | $d->save_stemma( $stemma ); |
28 | |
29 | foreach my $id ( $d->traditions ) { |
30 | print $d->tradition( $id )->name; |
31 | print $d->stemma( $id )->as_svg; |
32 | } |
33 | |
34 | =head1 DESCRIPTION |
35 | |
36 | 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. |
37 | |
38 | =head1 METHODS |
39 | |
40 | =head2 new |
41 | |
42 | Returns a Directory object. Apart from those documented in L<KiokuX::Model>, |
43 | options include: |
44 | |
45 | =over |
46 | |
47 | =item * preload - Load all traditions and stemmata into memory upon instantiation. Defaults to true. (TODO manage on-demand loading) |
48 | |
49 | =back |
50 | |
51 | =head2 tradition_ids |
52 | |
53 | Returns the ID of all traditions in the database. |
54 | |
55 | =head2 tradition( $id ) |
56 | |
57 | Returns the Text::Tradition object of the given ID. |
58 | |
59 | =head2 stemma( $id ) |
60 | |
61 | Returns the Text::Tradition::Stemma object associated with the given tradition ID. |
62 | |
63 | =head2 save_tradition( $tradition ) |
64 | |
65 | Writes the given tradition to the database, returning its UUID. |
66 | |
67 | =head2 save_stemma( $stemma ) |
68 | |
69 | Writes the given stemma to the database, returning its UUID. |
70 | |
71 | =begin testing |
72 | |
73 | use File::Temp; |
74 | use Text::Tradition; |
75 | use Text::Tradition::Stemma; |
76 | use_ok 'Text::Tradition::Directory'; |
77 | |
78 | my $fh = File::Temp->new(); |
79 | my $file = $fh->filename; |
80 | $fh->close; |
81 | my $dsn = "dbi:SQLite:dbname=$file"; |
82 | |
83 | my $d = Text::Tradition::Directory->new( 'dsn' => $dsn, |
84 | 'extra_args' => { 'create' => 1 } ); |
85 | is( ref $d, 'Text::Tradition::Directory', "Got directory object" ); |
86 | |
87 | my $t = Text::Tradition->new( |
88 | 'name' => 'inline', |
89 | 'input' => 'Tabular', |
90 | 'file' => 't/data/simple.txt', |
91 | ); |
92 | my $uuid = $d->save_tradition( $t ); |
93 | ok( $uuid, "Saved test tradition" ); |
94 | |
95 | my $s = Text::Tradition::Stemma->new( |
96 | 'collation' => $t->collation, |
97 | 'dotfile' => 't/data/simple.dot' ); |
98 | my $sid = $d->save_stemma( $s ); |
99 | ok( $sid, "Saved test stemma" ); |
100 | |
101 | is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" ); |
102 | is( $d->stemma( $uuid ), $s, "Correct stemma returned for id" ); |
103 | is( scalar $d->tradition_ids, 1, "Only one tradition in DB" ); |
104 | |
105 | # Connect to a new instance |
106 | my $e = Text::Tradition::Directory->new( 'dsn' => $dsn ); |
107 | is( scalar $e->tradition_ids, 1, "One tradition preloaded from DB" ); |
108 | my $te = $e->tradition( $uuid ); |
109 | is( $te->name, $t->name, "New instance returns correct tradition" ); |
110 | my $se = $e->stemma( $uuid ); |
111 | is( $se->graph, $s->graph, "New instance returns correct stemma" ); |
112 | is( $e->tradition( 'NOT-A-UUID' ), undef, "Undef returned for non-tradition" ); |
113 | is( $e->stemma( 'NOT-A-UUID' ), undef, "Undef returned for non-stemma" ); |
114 | $te->name( "Changed name" ); |
115 | my $new_id = $e->save_tradition( $te ); |
116 | is( $new_id, $uuid, "Updated tradition ID did not change" ); |
117 | |
118 | my $f = Text::Tradition::Directory->new( 'dsn' => $dsn, 'preload' => 0 ); |
119 | is( scalar $f->tradition_ids, 0, "No traditions preloaded from DB" ); |
120 | ### TODO This doesn't work, as I cannot get an object scope in the |
121 | ### 'tradition' wrapper. |
122 | # my $tf = $f->tradition( $uuid ); |
123 | # is( $tf->name, $t->name, "Next instance returns correct tradition" ); |
124 | # is( $tf->name, "Changed name", "Change to tradition carried through" ); |
125 | |
126 | =end testing |
127 | |
128 | =cut |
129 | |
8d9a1cd8 |
130 | has data_hash => ( |
131 | traits => ['Hash'], |
132 | default => sub { {} }, |
133 | handles => { |
134 | tradition => 'get', |
135 | stemma => 'get', |
136 | add_tradition => 'set', |
137 | add_stemma => 'set', |
12523041 |
138 | tradition_ids => 'keys', |
8d9a1cd8 |
139 | }, |
140 | ); |
141 | |
12523041 |
142 | has +typemap => ( |
8d9a1cd8 |
143 | is => 'rw', |
144 | isa => 'KiokuDB::TypeMap', |
145 | default => sub { |
146 | KiokuDB::TypeMap->new( |
147 | isa_entries => { |
8d9a1cd8 |
148 | "Graph" => KiokuDB::TypeMap::Entry::Naive->new, |
149 | "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new, |
150 | } |
151 | ); |
152 | }, |
153 | ); |
154 | |
12523041 |
155 | has preload => ( |
156 | is => 'ro', |
157 | isa => 'Bool', |
158 | default => 1, |
159 | ); |
160 | |
8d9a1cd8 |
161 | around 'tradition' => sub { |
162 | my( $orig, $self, @arg ) = @_; |
163 | my $data = $self->$orig( @arg ); |
12523041 |
164 | unless( $data ) { |
165 | # Connect to the DB and fetch the thing. |
166 | $self->new_scope; |
167 | my $id = shift @arg; |
168 | my $trad = $self->lookup( $id ); |
169 | if( ref( $trad ) eq 'Text::Tradition' ) { |
170 | $self->add_tradition( $id => $trad ); |
171 | return $trad; |
172 | } |
173 | # If we got this far... |
174 | return undef; |
175 | } |
8d9a1cd8 |
176 | return $data->{'object'}; |
177 | }; |
178 | |
179 | around 'stemma' => sub { |
180 | my( $orig, $self, @arg ) = @_; |
181 | my $data = $self->$orig( @arg ); |
12523041 |
182 | unless( $data ) { |
183 | # Connect to the DB and fetch the thing. |
184 | $self->new_scope; |
185 | my $id = shift @arg; |
186 | my $trad = $self->lookup( $id ); |
187 | if( ref( $trad ) eq 'Text::Tradition' ) { |
188 | # Add it |
189 | $self->add_tradition( $id => $trad ); |
190 | # Find the stemma whose collation belongs to $trad |
191 | my $ret = $self->grep( sub { $_->collation eq $trad->collation } ); |
192 | my $stemma; |
193 | until ( $ret->is_done ) { |
194 | foreach my $st ( $ret->items ) { |
195 | warn "Found two saved stemmas for tradition $id" if $stemma; |
196 | $stemma = $st; |
197 | } |
198 | } |
199 | if( $stemma ) { |
200 | $self->add_stemma( $stemma ); |
201 | return $stemma; |
202 | } |
203 | } |
204 | # If we got this far... |
205 | return undef; |
206 | } |
8d9a1cd8 |
207 | return $data->{'stemma'}; |
208 | }; |
209 | |
210 | around 'add_tradition' => sub { |
211 | my( $orig, $self, $id, $obj ) = @_; |
212 | $self->$orig( $id => { 'object' => $obj } ); |
213 | }; |
214 | |
215 | around 'add_stemma' => sub { |
216 | my( $orig, $self, $id, $obj ) = @_; |
217 | $self->{data_hash}->{$id}->{'stemma'} = $obj; |
218 | }; |
219 | |
220 | # Load all the relevant data from the DSN we were passed. |
221 | |
222 | sub BUILD { |
223 | my $self = shift; |
224 | my $args = shift; |
225 | |
12523041 |
226 | $self->fetch_all if( $self->dsn && $self->preload ); |
227 | } |
228 | |
229 | # Connect to self, get the traditions and stemmas, and save them |
230 | # in the directory. |
231 | sub fetch_all { |
232 | my $self = shift; |
233 | my $scope = $self->new_scope; |
234 | my $stream = $self->root_set; |
235 | my %stemmata; |
236 | until( $stream->is_done ) { |
237 | foreach my $obj ( $stream->items ) { |
238 | my $uuid = $self->object_to_id( $obj ); |
239 | if( ref( $obj ) eq 'Text::Tradition' ) { |
240 | $self->add_tradition( $uuid => $obj ); |
241 | } elsif( ref( $obj ) eq 'Text::Tradition::Stemma' ) { |
242 | $stemmata{$obj->collation} = $obj; |
243 | } else { |
244 | warn "Found root object in DB that is neither tradition nor stemma: $obj"; |
8d9a1cd8 |
245 | } |
246 | } |
12523041 |
247 | } |
248 | # Now match the stemmata to their traditions. |
249 | foreach my $id ( $self->tradition_ids ) { |
250 | my $c = $self->tradition( $id )->collation; |
251 | if( exists $stemmata{$c} ) { |
252 | $self->add_stemma( $id => $stemmata{$c} ); |
8d9a1cd8 |
253 | } |
254 | } |
8d9a1cd8 |
255 | } |
12523041 |
256 | |
257 | |
258 | sub save_tradition { |
259 | my( $self, $tradition ) = @_; |
260 | # Write the thing to the db and return its ID. |
261 | unless( ref( $tradition ) eq 'Text::Tradition' ) { |
262 | warn "Object $tradition is not a Text::Tradition"; |
263 | return undef; |
264 | } |
265 | my $scope = $self->new_scope; |
266 | my $uuid = $self->store( $tradition ); |
267 | $self->add_tradition( $uuid => $tradition ); |
268 | return $uuid; |
269 | } |
270 | |
271 | sub save_stemma { |
272 | my( $self, $stemma ) = @_; |
273 | unless( ref( $stemma ) eq 'Text::Tradition::Stemma' ) { |
274 | warn "Object $stemma is not a Text::Tradition::Stemma"; |
275 | return undef; |
276 | } |
277 | my $scope = $self->new_scope; |
278 | # Get the tradition to which this stemma belongs. |
279 | my $tradition = $stemma->collation->tradition; |
280 | # Make sure the tradition is in the DB. |
281 | my $tid = $self->save_tradition( $tradition ); |
282 | unless( $tid ) { |
283 | warn "Could not access this stemma's tradition; aborting"; |
284 | return undef; |
285 | } |
286 | my $sid = $self->store( $stemma ); |
287 | $self->add_stemma( $tid => $stemma ); |
288 | return $tid; |
289 | } |
290 | |
8d9a1cd8 |
291 | |
292 | 1; |
12523041 |
293 | |
8d9a1cd8 |
294 | |