File Coverage

blib/lib/InterMine/Item.pm
Criterion Covered Total %
statement 9 179 5.0
branch 0 76 0.0
condition 0 41 0.0
subroutine 3 20 15.0
pod 13 13 100.0
total 25 329 7.6


line stmt bran cond sub pod time code
1             package InterMine::Item;
2              
3             our $VERSION = 0.991;
4              
5             =head1 NAME
6              
7             InterMine::Item - Representation of InterMine items
8              
9             =head1 SYNOPSIS
10              
11             my $factory = new InterMine::ItemFactory(model => $model);
12              
13             my $gene = $factory->make_item("Gene");
14             $gene->set("identifier", "CG10811");
15              
16             (See InterMine::ItemFactory for a longer Synopsis)
17              
18             =head1 AUTHOR
19              
20             FlyMine C<< <support@flymine.org> >>
21              
22             =head1 BUGS
23              
24             Please report any bugs or feature requests to C<support@flymine.org>.
25              
26             =head1 SUPPORT
27              
28             You can find documentation for this module with the perldoc command.
29              
30             perldoc InterMine::Item
31              
32             You can also look for information at:
33              
34             =over 4
35              
36             =item * FlyMine
37              
38             L<http://www.flymine.org>
39              
40             =item * Documentation
41              
42             L<http://www.intermine.org/wiki/ItemsAPIPerl>
43              
44             =back
45              
46             =head1 COPYRIGHT & LICENSE
47              
48             Copyright 2006,2007,2008 FlyMine, all rights reserved.
49              
50             This program is free software; you can redistribute it and/or modify it
51             under the same terms as Perl itself.
52              
53             =head1 FUNCTIONS
54              
55             =cut
56              
57 1     1   18316 use strict;
  1         1  
  1         35  
58 1     1   4 use Carp qw(confess);
  1         1  
  1         55  
59              
60 1     1   527 use XML::Writer;
  1         11797  
  1         1482  
61              
62             my $ID_PREFIX = '0_';
63              
64             =head2 new
65              
66             Title : new
67             Usage : $item = $factory->make_item("Gene"); # calls Item->new() implicitly
68             Function: create a new Item
69             Args : model - the InterMine::Model object to use to check field validity
70             Note : use this method indirectly using an ItemFactory
71              
72             =cut
73             sub new {
74 0     0 1   my $class = shift;
75 0           my %opts = @_;
76              
77 0 0         if (!defined $opts{id}) {
78 0           confess "no id argument in $class constructor\n";
79             }
80 0 0         if (!defined $opts{model}) {
81 0           confess "no model argument in $class constructor\n";
82             }
83 0           for my $key (keys %opts) {
84 0 0 0       if ($key ne "model" && $key ne "id" && $key ne "classname" && $key ne "implements" && $key ne "ignore_null") {
      0        
      0        
      0        
85 0           confess "unknown argument to $class->new(): $key\n";
86             }
87             }
88              
89 0   0       my $classname = $opts{classname} || "";
90 0   0       my $implements_arg = $opts{implements} || "";
91              
92 0           my @implements = ();
93              
94 0 0         if (ref $implements_arg eq 'ARRAY') {
95 0           @implements = @$implements_arg;
96             } else {
97 0 0         if ($implements_arg ne '') {
98 0           @implements = split /\s+/, $implements_arg;
99             }
100             }
101              
102 0           my $self = {
103             id => $opts{id}, ':model' => $opts{model}, ':classname' => $classname,
104             ':implements' => $implements_arg, ':ignore_null' => $opts{ignore_null},
105             };
106              
107 0 0         if ($classname ne '') {
108 0           my $classdesc = $self->{':model'}->get_classdescriptor_by_name($classname);
109 0           $self->{':classdesc'} = $classdesc;
110             }
111              
112 0           my @implements_classdescs = map {
113 0           my $imp_classdesc = $self->{':model'}->get_classdescriptor_by_name($_);
114 0 0         if (!defined $imp_classdesc) {
115 0           confess "interface '$_' is not in the model\n";
116             }
117 0           $imp_classdesc;
118             } @implements;
119              
120 0 0 0       if ($classname eq '' and scalar(@implements_classdescs) == 0) {
121 0           confess "no '$classname' and no implementations for object\n";
122             }
123              
124 0           $self->{':implements'} = $implements_arg;
125 0           $self->{':implements_classdescs'} = [@implements_classdescs];
126 0           $self->{':classname'} = $classname;
127              
128 0           bless $self, $class;
129              
130 0           return $self;
131             }
132              
133             sub _get_object_field_by_name
134             {
135 0     0     my $self = shift;
136 0           my $name = shift;
137              
138 0           my @class_descs = $self->all_class_descriptors();
139              
140 0           for my $class_desc (@class_descs) {
141 0 0         if (defined $class_desc->get_field_by_name($name)) {
142 0           return $class_desc->get_field_by_name($name);
143             }
144             }
145 0           return undef;
146             }
147              
148             =head2 set
149              
150             Title : set
151             Usage : $gene_item->set("name", "wtf7");
152             or: $gene_item->set("organism", $organism_item);
153             Function: set a field in the Item, checking that this object can have a field
154             with that name
155             Args : $name - the name of the field to set
156             $value - the new value (must not be undefined)
157              
158             =cut
159             sub set {
160 0     0 1   my $self = shift;
161 0           my $name = shift;
162 0           my $value = shift;
163              
164 0 0 0       if (!defined $value && !$self->{':ignore_null'}) {
165 0           confess "value undefined while setting $name\n";
166             }
167              
168 0           my $field = $self->_get_object_field_by_name($name);
169              
170 0 0         if (!defined $field) {
171 0           confess "object ", $self->to_string(), " does not have a field called: $name\n";
172             }
173              
174 0 0         if (ref $value) {
175 0 0         if (ref $value eq 'ARRAY') {
176 0 0         if ( not $field->isa('InterMine::Model::Collection') ) {
177 0           confess "tried to set field '$name' in class '",
178             $self->to_string(),
179             "' to something other than type: ",
180             ref $field, "\n";
181             }
182              
183 0           my @items = grep {defined} @$value;
  0            
184 0 0         unless (@items == @$value) {
185 0           warn "Undefined items passed as value";
186             }
187              
188 0           push @{$self->{$name}}, $_ for @items;
  0            
189              
190 0           my $collection_hash_name = _get_collection_hash_name($name);
191 0           my %collection_hash = map {$_ => $_} @items;
  0            
192              
193 0           $self->{$collection_hash_name} = \%collection_hash;
194              
195             # check the types of the elements in the collection and set the reverse
196             # references if necessary
197              
198 0           for my $other_item (@items) {
199 0 0         if ($other_item->instance_of($field->referenced_classdescriptor())) {
200 0 0         if ($field->is_one_to_many()) {
201 0           my $current_rev_ref = $other_item->get($field->reverse_reference_name());
202 0 0 0       if (!defined $current_rev_ref || $current_rev_ref != $self) {
203 0           $other_item->set($field->reverse_reference_name(), $self);
204             }
205             }
206             } else {
207 0           confess "collection '$name' in class '", $self->to_string(),
208             "' must contain items of type: ", $field->referenced_type_name(),
209             " not: ", $self->to_string();
210             }
211             }
212              
213             } else {
214 0 0         if (ref $field ne 'InterMine::Model::Reference') {
215 0           confess "tried to set field '$name' in class '", $self->to_string(),
216             "' to something other than type: ", $field->attribute_type(), "\n";
217             }
218              
219 0 0 0       if (!defined $self->{$name} || $self->{$name} != $value) {
220 0           $self->{$name} = $value;
221             }
222             }
223             } else {
224 0 0         if (ref $field ne 'InterMine::Model::Attribute') {
225 0           confess "tried to set field '$name' in class '", $self->to_string(),
226             "' to something other than type: ", $field->referenced_type_name(), "\n";
227             }
228              
229 0           $self->{$name} = $value;
230             }
231             }
232              
233             =head2 get
234              
235             Title : get
236             Usage : $gene_name = $gene_item->get("name");
237             or: $organism_item = $gene_item->get("organism");
238             Function: get the value of a field from an Item
239             Args : $name - the name of the field to get
240             Return : the value
241              
242             =cut
243             sub get {
244 0     0 1   my $self = shift;
245 0           my $fieldname = shift;
246 0           my $field = $self->_get_object_field_by_name($fieldname);
247              
248 0 0         if (!defined $field) {
249 0           confess qq(object ") .
250             $self->to_string() .
251             qq(" doesn't have a field named: $fieldname\n);
252             }
253              
254 0           my $retval = $self->{$fieldname};
255 0 0         if (defined $retval) {
256 0           return $retval;
257             } else {
258 0 0         if ($field->isa('InterMine::Model::Collection')) {
259 0           return [];
260             } else {
261 0           return undef;
262             }
263             }
264             }
265              
266             sub _get_collection_hash_name
267             {
268 0     0     my $name = shift;
269 0           return ":${name}:hash";
270             }
271              
272             sub _add_to_collection
273             {
274 0     0     my $self = shift;
275 0           my $name = shift;
276 0           my $value = shift;
277              
278 0           my $field = $self->_get_object_field_by_name($name);
279              
280 0 0         if (ref $field ne 'InterMine::Model::Collection') {
281 0           confess "can't add $value to a field ($name in " . $self->to_string() .
282             ") that isn't a collection\n";
283             }
284              
285 0 0         if (ref $value ne 'InterMine::Item') {
286 0           confess qq(can't add value "$value" to a collection $name in ) . $self->to_string() .
287             qq(as it isn't an Item\n);
288             }
289              
290 0           my $collection_hash_name = _get_collection_hash_name($name);
291              
292 0           my %collection_hash;
293 0 0         if (defined $self->{$collection_hash_name}) {
294 0           %collection_hash = %{$self->{$collection_hash_name}}
  0            
295             } else {
296 0           %collection_hash = ();
297             }
298              
299 0 0         if (exists $collection_hash{$value}) {
300 0           return;
301             }
302              
303 0           push @{$self->{$name}}, $value;
  0            
304             }
305              
306             =head2 model
307              
308             Title : model
309             Usage : $model = $item->model();
310             Function: return the model that this Item obeys
311              
312             =cut
313             sub model
314             {
315 0     0 1   my $self = shift;
316 0           return $self->{':model'};
317             }
318              
319             =head2 classname
320              
321             Title : classname
322             Usage : $classname = $item->classname();
323             Function: return the class name of this Item - ie the class name that will be
324             used when creating the object in InterMine
325              
326             =cut
327             sub classname
328             {
329 0     0 1   my $self = shift;
330 0           return $self->{':classname'};
331             }
332              
333             =head2 classdescriptor
334              
335             Title : classdescriptor
336             Usage : $cd = $item->classdescriptor();
337             Function: return the ClassDescriptor object from the model for this Item
338              
339             =cut
340             sub classdescriptor
341             {
342 0     0 1   my $self = shift;
343 0           return $self->{':classdesc'};
344             }
345              
346             sub _implements_classdescriptors
347             {
348 0     0     my $self = shift;
349 0           return @{$self->{':implements_classdescs'}};
  0            
350             }
351              
352             =head2 all_class_descriptors
353              
354             Title : all_class_descriptors
355             Usage : @cds = $item->all_class_descriptors();
356             Function: return a list of ClassDescriptor objects from the model for this
357             Item, including the classdescriptors of all parent objects
358              
359             =cut
360             sub all_class_descriptors
361             {
362 0     0 1   my $self = shift;
363              
364 0           my @class_descs = $self->_implements_classdescriptors();
365 0 0         if (defined $self->classdescriptor()) {
366 0           push @class_descs, $self->classdescriptor();
367             }
368 0           return @class_descs;
369             }
370              
371             =head2 valid_field
372              
373             Title : valid_field
374             Usage : if ($item->valid_field('someFieldName')) { ... };
375             Function: return true if and only if the given field name is valid for this
376             object according to the model
377              
378             =cut
379              
380             sub valid_field { # deprecated name
381 0     0 1   my $self = shift;
382 0           return $self->has_field_called(@_);
383             }
384              
385             =head2 has_field_called
386              
387             Title : has_field_called
388             Usage : if ($item->has_field_called('someFieldName')) { ... };
389             Function: return true if the item has a field slot of the given name.
390             This is the new and recommended name for "valid_field".
391              
392             =cut
393              
394             sub has_field_called {
395 0     0 1   my $self = shift;
396 0           my $field = shift;
397              
398 0           my @class_descs = $self->all_class_descriptors();
399              
400 0           for my $class_desc (@class_descs) {
401 0 0         if ($class_desc->valid_field($field)) {
402 0           return 1;
403             }
404             }
405              
406 0           return 0;
407             }
408              
409             =head2 instance_of
410              
411             Title : instance_of
412             Usage : my $gene_cd = $model->get_classdescriptor_by_name("Gene");
413             if ($some_item->instance_of($gene_cd)) { ... }
414             Function: Return true if and only if this Item represents an object that has
415             the given class, or is a sub-class.
416              
417             =cut
418             sub instance_of
419             {
420 0     0 1   my $self = shift;
421 0           my $other_class_desc = shift;
422              
423 0           for my $class_desc ($self->all_class_descriptors()) {
424 0 0         if ($class_desc->sub_class_of($other_class_desc)) {
425 0           return 1;
426             }
427             }
428 0           return 0;
429             }
430              
431             =head2 to_string
432              
433             Title : to_string
434             Usage : warn('item: ', $item->to_string());
435             Function: return a text representation of this Item
436              
437             =cut
438             sub to_string
439             {
440 0     0 1   my $self = shift;
441 0           my $implements = join (' ', $self->{':implements'});
442 0           my $classname = $self->classname();
443 0 0 0       if (defined $classname and length $classname > 0) {
444 0           return "[classname: " . $classname . " implements: $implements]";
445             } else {
446 0           return "[implements: $implements]";
447             }
448             }
449              
450             =head2 as_xml
451              
452             Title : as_xml
453             Usage : $xml = $item->as_xml();
454             Function: return an XML representation of this Item
455              
456             =cut
457             sub as_xml
458             {
459 0     0 1   my $self = shift;
460 0           my $writer = shift;
461 0           my $ignore_null = shift;
462 0           my $id = $self->{id};
463 0   0       my $classname = $self->{':classname'} || "";
464 0   0       my $implements = $self->{':implements'} || "";
465              
466 0           $writer->startTag("item", id => $ID_PREFIX . $id,
467             class => $classname, implements => $implements);
468              
469 0           for my $key (sort keys %$self) {
470 0 0         next if $key =~ /^:/;
471 0 0 0       if ($key ne 'id' && $key ne 'class') {
472 0           my $val = $self->{$key};
473              
474 0 0 0       if (not defined $val and $ignore_null) {
475 0           next;
476             }
477              
478 0 0         confess "Item is invalid - it has an undefined field value"
479             unless defined $val; #causes script to die if $val == undef
480              
481 0 0         if (ref $val) {
482 0 0         if (ref $val eq 'ARRAY') {
483 0           $writer->startTag("collection", name => $key);
484 0           my @refs = @$val;
485 0           for my $r (@refs) {
486 0           $writer->emptyTag("reference", ref_id => $ID_PREFIX . $r->{id});
487             }
488 0           $writer->endTag();
489             } else {
490 0           $writer->emptyTag("reference", name => $key, ref_id => $ID_PREFIX . $val->{id});
491             }
492             } else {
493 0           $writer->emptyTag("attribute", name => $key, value => $val);
494             }
495             }
496             }
497              
498 0           $writer->endTag();
499             }
500              
501             =head2 destroy
502              
503             Title : destroy
504             Usage : $item = $item->destroy;
505             Function: deletes the item object and its contents
506              
507             =cut
508             sub destroy
509             {
510 0     0 1   my $self = shift;
511 0           my @keys = keys(%$self);
512 0           foreach my $key (@keys) { delete $self->{$key} }
  0            
513 0           return undef;
514             }
515              
516             1;