File Coverage

Bio/Factory/ObjectFactory.pm
Criterion Covered Total %
statement 36 39 92.3
branch 11 14 78.5
condition 4 5 80.0
subroutine 7 7 100.0
pod 4 4 100.0
total 62 69 89.8


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::Factory::ObjectFactory
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Hilmar Lapp
7             #
8             # Copyright Hilmar Lapp
9             #
10             # You may distribute this module under the same terms as perl itself
11              
12             #
13             # (c) Hilmar Lapp, hlapp at gmx.net, 2003.
14             # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003.
15             #
16             # You may distribute this module under the same terms as perl itself.
17             # Refer to the Perl Artistic License (see the license accompanying this
18             # software package, or see http://www.perl.com/language/misc/Artistic.html)
19             # for the terms under which you may use, modify, and redistribute this module.
20             #
21             # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
22             # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
23             # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
24             #
25              
26             # POD documentation - main docs before the code
27              
28             =head1 NAME
29              
30             Bio::Factory::ObjectFactory - Instantiates a new Bio::Root::RootI (or derived class) through a factory
31              
32             =head1 SYNOPSIS
33              
34             use Bio::Factory::ObjectFactory;
35              
36             my $factory = Bio::Factory::ObjectFactory->new(-type => 'Bio::Ontology::GOterm');
37             my $term = $factory->create_object(-name => 'peroxisome',
38             -ontology => 'Gene Factory',
39             -identifier => 'GO:0005777');
40              
41              
42             =head1 DESCRIPTION
43              
44             This object will build L objects generically.
45              
46             =head1 FEEDBACK
47              
48             =head2 Mailing Lists
49              
50             User feedback is an integral part of the evolution of this and other
51             Bioperl modules. Send your comments and suggestions preferably to
52             the Bioperl mailing list. Your participation is much appreciated.
53              
54             bioperl-l@bioperl.org - General discussion
55             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
56              
57             =head2 Support
58              
59             Please direct usage questions or support issues to the mailing list:
60              
61             I
62              
63             rather than to the module maintainer directly. Many experienced and
64             reponsive experts will be able look at the problem and quickly
65             address it. Please include a thorough description of the problem
66             with code and data examples if at all possible.
67              
68             =head2 Reporting Bugs
69              
70             Report bugs to the Bioperl bug tracking system to help us keep track
71             of the bugs and their resolution. Bug reports can be submitted via the
72             web:
73              
74             https://github.com/bioperl/bioperl-live/issues
75              
76             =head1 AUTHOR - Hilmar Lapp
77              
78             Email hlapp at gmx.net
79              
80              
81             =head1 CONTRIBUTORS
82              
83             This is mostly copy-and-paste with subsequent adaptation from
84             Bio::Seq::SeqFactory by Jason Stajich. Most credits should in fact go
85             to him.
86              
87             =head1 APPENDIX
88              
89             The rest of the documentation details each of the object methods.
90             Internal methods are usually preceded with a _
91              
92             =cut
93              
94              
95             # Let the code begin...
96              
97              
98             package Bio::Factory::ObjectFactory;
99 52     52   175 use strict;
  52         51  
  52         1310  
100              
101              
102 52     52   162 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
  52         51  
  52         16175  
103              
104             =head2 new
105              
106             Title : new
107             Usage : my $obj = Bio::Factory::ObjectFactory->new();
108             Function: Builds a new Bio::Factory::ObjectFactory object
109             Returns : Bio::Factory::ObjectFactory
110             Args : -type => string, name of a L derived class.
111             There is no default.
112             -interface => string, name of the interface or class any type
113             specified needs to at least implement.
114             The default is Bio::Root::RootI.
115              
116             =cut
117              
118             sub new {
119 5586     5586 1 8335 my($class,@args) = @_;
120              
121 5586         10037 my $self = $class->SUPER::new(@args);
122            
123 5586         13303 my ($type,$interface) = $self->_rearrange([qw(TYPE INTERFACE)], @args);
124              
125 5586         9722 $self->{'_loaded_types'} = {};
126 5586   100     13409 $self->interface($interface || "Bio::Root::RootI");
127 5586 100       11614 $self->type($type) if $type;
128              
129 5586         15157 return $self;
130             }
131              
132              
133             =head2 create_object
134              
135             Title : create_object
136             Usage : my $seq = $factory->create_object();
137             Function: Instantiates a new object of the previously set type.
138              
139             This object allows us to genericize the instantiation of
140             objects.
141              
142             You must have provided -type at instantiation, or have
143             called type($mytype) before you can call this method.
144              
145             Returns : an object of the type returned by type()
146              
147             The return type is configurable using new(-type =>"..."),
148             or by calling $self->type("My::Fancy::Class").
149             Args : Initialization parameters specific to the type of
150             object we want. Check the POD of the class you set as type.
151              
152             =cut
153              
154             sub create_object {
155 8577     8577 1 23596 my ($self,@args) = @_;
156              
157 8577         11450 my $type = $self->type(); # type has already been loaded upon set
158 8577         19612 return $type->new(-verbose => $self->verbose, @args);
159             }
160              
161             =head2 type
162              
163             Title : type
164             Usage : $obj->type($newval)
165             Function: Get/set the type of object to be created.
166              
167             This may be changed at any time during the lifetime of this
168             factory.
169              
170             Returns : value of type (a string)
171             Args : newvalue (optional, a string)
172              
173              
174             =cut
175              
176             sub type{
177 14205     14205 1 11197 my $self = shift;
178              
179 14205 100       20529 if(@_) {
180 5604         4568 my $type = shift;
181 5604 100 66     18339 if($type && (! $self->{'_loaded_types'}->{$type})) {
182 5588         5810 eval {
183 5588         9726 $self->_load_module($type);
184             };
185 5588 50       8565 if( $@ ) {
186 0         0 $self->throw("module for '$type' failed to load: ".
187             $@);
188             }
189 5588         10810 my $o = bless {},$type;
190 5588 50       9110 if(!$self->_validate_type($o)) { # this may throw an exception
191 0         0 $self->throw("'$type' is not valid for factory ".ref($self));
192             }
193 5588         12932 $self->{'_loaded_types'}->{$type} = 1;
194             }
195 5604         8473 return $self->{'type'} = $type;
196             }
197 8601         10756 return $self->{'type'};
198             }
199              
200             =head2 interface
201              
202             Title : interface
203             Usage : $obj->interface($newval)
204             Function: Get/set the interface or base class that supplied types
205             must at least implement (inherit from).
206             Example :
207             Returns : value of interface (a scalar)
208             Args : on set, new value (a scalar or undef, optional)
209              
210              
211             =cut
212              
213             sub interface{
214 11192     11192 1 9496 my $self = shift;
215 11192         8128 my $interface = shift;
216              
217 11192 100       15052 if($interface) {
218 5604         8377 return $self->{'interface'} = $interface;
219             }
220 5588         18074 return $self->{'interface'};
221             }
222              
223             =head2 _validate_type
224              
225             Title : _validate_type
226             Usage : $factory->_validate_type($object)
227             Function: Called to let derived factories validate the type set
228             via type().
229              
230             The default implementation here checks whether the supplied
231             object skeleton implements the interface set via -interface
232             upon factory instantiation.
233              
234             Example :
235             Returns : TRUE if the type is to be considered valid, and FALSE otherwise.
236             Instead of returning FALSE this method may also just throw
237             an informative exception.
238              
239             The default implementation here will throw an exception
240             if the supplied object does not inherit from the interface
241             provided by the interface() method.
242              
243             Args : A hash reference blessed into the specified type, allowing
244             queries like isa().
245              
246              
247             =cut
248              
249             sub _validate_type{
250 5588     5588   5386 my ($self,$obj) = @_;
251              
252 5588 50       7671 if(! $obj->isa($self->interface())) {
253 0         0 $self->throw("invalid type: '".ref($obj).
254             "' does not implement '".$self->interface()."'");
255             }
256 5588         9001 return 1;
257             }
258              
259             #####################################################################
260             # aliases for naming consistency or other reasons #
261             #####################################################################
262              
263             *create = \&create_object;
264              
265             1;