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