File Coverage

blib/lib/Catmandu/Store/FedoraCommons.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package Catmandu::Store::FedoraCommons;
2              
3 1     1   35740 use Catmandu::Sane;
  1         266527  
  1         7  
4 1     1   1127 use Catmandu::FedoraCommons;
  0            
  0            
5             use Moo;
6              
7             with 'Catmandu::Store';
8              
9             has baseurl => (is => 'ro' , required => 1);
10             has username => (is => 'ro' , default => sub { '' } );
11             has password => (is => 'ro' , default => sub { '' } );
12             has model => (is => 'ro' , default => sub { 'Catmandu::Store::FedoraCommons::DC' } );
13              
14             has fedora => (
15             is => 'ro',
16             init_arg => undef,
17             lazy => 1,
18             builder => '_build_fedora',
19             );
20             has _repository_description => (
21             is => 'ro',
22             init_arg => undef,
23             lazy => 1,
24             builder => '_build_repository_description'
25             );
26             has _default_namespace => (
27             is => 'ro',
28             init_arg => undef,
29             lazy => 1,
30             builder => '_build_default_namespace'
31             );
32             has _pid_delimiter => (
33             is => 'ro',
34             init_arg => undef,
35             lazy => 1,
36             builder => '_build_pid_delimiter'
37             );
38              
39             sub _build_fedora {
40             my $self = $_[0];
41            
42             Catmandu::FedoraCommons->new($self->baseurl, $self->username, $self->password);
43             }
44             #namespace corresponds to name of bag
45             #don't use "data", but use the internal default namespace of fedora
46             around default_bag => sub {
47             my($orig,$self) = @_;
48             $self->_default_namespace();
49             };
50              
51             sub _build_repository_description {
52             $_[0]->fedora->describeRepository()->parse_content();
53             }
54             sub _build_default_namespace {
55             my $self = $_[0];
56             my $desc = $self->_repository_description();
57             $desc->{repositoryPID}->{'PID-namespaceIdentifier'};
58             }
59             sub _build_pid_delimiter {
60             my $self = $_[0];
61             my $desc = $self->_repository_description();
62             $desc->{repositoryPID}->{'PID-delimiter'};
63             }
64              
65             package Catmandu::Store::FedoraCommons::Bag;
66              
67             use Catmandu::Sane;
68             use Catmandu::Store::FedoraCommons::FOXML;
69             use Moo;
70             use Catmandu::Util qw(:is);
71              
72              
73             has _namespace_prefix => (
74             is => 'ro',
75             init_arg => undef,
76             lazy => 1,
77             builder => '_build_namespace_prefix'
78             );
79             has _namespace_prefix_re => (
80             is => 'ro',
81             init_arg => undef,
82             lazy => 1,
83             builder => '_build_namespace_prefix_re'
84             );
85             sub _build_namespace_prefix {
86             my $self = $_[0];
87             my $name = $self->name();
88             my $pid_delimiter = $self->store->_pid_delimiter();
89             "${name}${pid_delimiter}";
90             }
91             sub _build_namespace_prefix_re {
92             my $self = $_[0];
93             my $p = $self->_namespace_prefix();
94             qr/$p/;
95             }
96             sub _id_valid {
97             my ($self,$id) = @_;
98             return ( index( $id, $self->_namespace_prefix() ) == 0 ) ? 1 : 0;
99             }
100              
101             #add namespace to generated ID if it does not start with the namespace prefix
102             before add => sub {
103             my ($self, $data) = @_;
104             unless( $self->_id_valid( $data->{_id} ) ) {
105             $data->{_id} = $self->_namespace_prefix().$data->{_id};
106             }
107             };
108             #make it impossible to find 'islandora:1' in bag 'archive.ugent.be'
109             around 'get' => sub {
110             my($orig,$self,$id) = @_;
111              
112             return undef unless $self->_id_valid( $id );
113              
114             $orig->($self,$id);
115             };
116             #make it impossible to delete 'islandora:1' when using bag 'archive.ugent.be'
117             around 'delete' => sub {
118             my($orig,$self,$id) = @_;
119              
120             return undef unless $self->_id_valid( $id );
121              
122             $orig->($self,$id);
123             };
124              
125             sub _get_model {
126             my ($self, $obj) = @_;
127             my $pid = $obj->{pid};
128             my $fedora = $self->store->fedora;
129             my $model = $self->store->model;
130            
131             eval "use $model";
132             my $x = $model->new(fedora => $fedora);
133             my $res = $x->get($pid);
134            
135             return $res;
136             }
137              
138             sub _update_model {
139             my ($self, $obj) = @_;
140             my $fedora = $self->store->fedora;
141             my $model = $self->store->model;
142              
143             eval "use $model";
144             my $x = $model->new(fedora => $fedora);
145             my $res = $x->update($obj);
146              
147             return $res;
148             }
149              
150             sub _ingest_model {
151             my ($self, $data) = @_;
152            
153             my $serializer = Catmandu::Store::FedoraCommons::FOXML->new;
154            
155             my ($valid,$reason) = $serializer->valid($data);
156            
157             unless ($valid) {
158             warn "data is not valid";
159             return undef;
160             }
161            
162             my $xml = $serializer->serialize($data);
163            
164             my %args = (
165             pid => $data->{_id} ,
166             xml => $xml ,
167             format => 'info:fedora/fedora-system:FOXML-1.1'
168             );
169            
170             my $result = $self->store->fedora->ingest(%args);
171            
172             return undef unless $result->is_ok;
173            
174             $data->{_id} = $result->parse_content->{pid};
175            
176             return $self->_update_model($data);
177             }
178              
179             sub generator {
180             my ($self) = @_;
181             my $fedora = $self->store->fedora;
182            
183             sub {
184             state $hits;
185             state $row;
186             state $ns_prefix = $self->_namespace_prefix;
187            
188             if( ! defined $hits) {
189             my $res = $fedora->findObjects( query => "pid~${ns_prefix}*" );
190             unless ($res->is_ok) {
191             warn $res->error;
192             return undef;
193             }
194             $row = 0;
195             $hits = $res->parse_content;
196             }
197             if ($row + 1 == @{ $hits->{results} } && defined $hits->{token}) {
198             my $result = $hits->{results}->[ $row ];
199            
200             my $res = $fedora->findObjects(sessionToken => $hits->{token});
201            
202             unless ($res->is_ok) {
203             warn $res->error;
204             return undef;
205             }
206            
207             $row = 0;
208             $hits = $res->parse_content;
209            
210             return $self->_get_model($result);
211             }
212             else {
213             my $result = $hits->{results}->[ $row++ ];
214             return $self->_get_model($result);
215             }
216             };
217             }
218              
219             sub add {
220             my ($self,$data) = @_;
221            
222             if ( defined $self->get($data->{_id}) ) {
223             my $ok = $self->_update_model($data);
224              
225             die "failed to update" unless $ok;
226             }
227             else {
228             my $ok = $self->_ingest_model($data);
229            
230             die "failed to ingest" unless $ok;
231             }
232            
233             return $data;
234             }
235              
236             sub get {
237             my ($self, $id) = @_;
238             return $self->_get_model({ pid => $id });
239             }
240              
241             sub delete {
242             my ($self, $id) = @_;
243            
244             return undef unless defined $id;
245            
246             my $fedora = $self->store->fedora;
247            
248             $fedora->purgeObject(pid => $id)->is_ok;
249             }
250              
251             sub delete_all {
252             my ($self) = @_;
253            
254             my $count = 0;
255             $self->each(sub {
256             my $obj = $_[0];
257             my $pid = $obj->{_id};
258            
259             my $ret = $self->delete($pid);
260            
261             $count += 1 if $ret;
262             });
263            
264             $count;
265             }
266              
267             with 'Catmandu::Bag';
268              
269             1;
270              
271             =head1 NAME
272              
273             Catmandu::Store::FedoraCommons - A Catmandu::Store plugin for the Fedora Commons repository
274              
275             =head1 SYNOPSIS
276              
277             use Catmandu::Store::FedoraCommons;
278              
279             my $store = Catmandu::Store::FedoraCommons->new(
280             baseurl => 'http://localhost:8080/fedora',
281             username => 'fedoraAdmin',
282             password => 'fedoraAdmin',
283             model => 'Catmandu::Store::FedoraCommons::DC' # default
284             );
285              
286             # We use the DC model, lets store some DC
287             my $obj1 = $store->bag->add({
288             title => ['The Master and Margarita'] ,
289             creator => ['Bulgakov, Mikhail'] }
290             );
291              
292             printf "obj1 stored as %s\n" , $obj1->{_id};
293              
294             # Force an id in the store
295             my $obj2 = $store->bag->add({ _id => 'demo:120812' , title => ['The Master and Margarita'] });
296              
297             my $obj3 = $store->bag->get('demo:120812');
298              
299             $store->bag->delete('demo:120812');
300              
301             $store->bag->delete_all;
302              
303             # All bags are iterators
304             $store->bag->each(sub {
305             my $obj = $_[0];
306             my $pid = $obj->{_id};
307             my $ds = $store->fedora->listDatastreams(pid => $pid)->parse_content;
308             });
309            
310             $store->bag->take(10)->each(sub { ... });
311            
312             =head1 DESCRIPTION
313              
314             A Catmandu::Store::FedoraCommons is a Perl package that can store data into
315             FedoraCommons backed databases. The database as a whole is called a 'store'.
316             Databases also have compartments (e.g. tables) called Catmandu::Bag-s.
317             In Fedora we have namespaces. A bag corresponds to a namespace.
318             The default bag corresponds to the default namespace in Fedora.
319              
320             By default Catmandu::Store::FedoraCommons works with a Dublin Core data model.
321             You can use the add,get and delete methods of the store to retrieve and insert Perl HASH-es that
322             mimic Dublin Core records. Optionally other models can be provided by creating
323             a model package that implements a 'get' and 'update' method.
324              
325             =head1 METHODS
326              
327             =head2 new(baseurl => $fedora_baseurl , username => $username , password => $password , model => $model )
328              
329             Create a new Catmandu::Store::FedoraCommons store at $fedora_baseurl. Optionally provide a name of
330             a $model to serialize your Perl hashes into a Fedora Commons model.
331              
332             =head2 bag('$namespace')
333              
334             Create or retrieve a bag. Returns a Catmandu::Bag.
335             Use this for storing or retrieving records from a
336             fedora namespace.
337              
338             =head2 fedora
339              
340             Returns a low level Catmandu::FedoraCommons reference.
341              
342             =head1 SEE ALSO
343              
344             L<Catmandu::Bag>, L<Catmandu::Searchable>, L<Catmandu::FedoraCommons>
345              
346             =head1 AUTHOR
347              
348             =over
349              
350             =item * Patrick Hochstenbach, C<< <patrick.hochstenbach at ugent.be> >>
351              
352             =back
353              
354             =cut