Bio/Factory/ObjectFactory.pm

   1 #
   2 # BioPerl module for Bio::Factory::ObjectFactory
   3 #
   4 # Please direct questions and support issues to <bioperl-l@bioperl.org>
   5 #
   6 # Cared for by Hilmar Lapp <hlapp at gmx.net>
   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<Bio::Root::RootI> 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<bioperl-l@bioperl.org>
  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 use strict;
 100
 101
 102 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
 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<Bio::Root::RootI> 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     my($class,@args) = @_;
 120
 121     my $self = $class->SUPER::new(@args);
 122
 123     my ($type,$interface) = $self->_rearrange([qw(TYPE INTERFACE)], @args);
 124
 125     $self->{'_loaded_types'} = {};
 126     $self->interface($interface || "Bio::Root::RootI");
 127     $self->type($type) if $type;
 128
 129     return $self;
 130 }
 131
 132
 133 =head2 create_object
 134
 135  Title   : create_object
 136  Usage   : my $seq = $factory->create_object(<named parameters>);
 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    my ($self,@args) = @_;
 156
 157    my $type = $self->type(); # type has already been loaded upon set
 158    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     my $self = shift;
 178
 179     if(@_) {
 180         my $type = shift;
 181         if($type && (! $self->{'_loaded_types'}->{$type})) {
 182             eval {
 183                 $self->_load_module($type);
 184             };
 185             if( $@ ) {
 186                 $self->throw("module for '$type' failed to load: ".
 187                              $@);
 188             }
 189             my $o = bless {},$type;
 190             if(!$self->_validate_type($o)) { # this may throw an exception
 191                 $self->throw("'$type' is not valid for factory ".ref($self));
 192             }
 193             $self->{'_loaded_types'}->{$type} = 1;
 194         }
 195         return $self->{'type'} = $type;
 196     }
 197     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     my $self = shift;
 215     my $interface = shift;
 216
 217     if($interface) {
 218         return $self->{'interface'} = $interface;
 219     }
 220     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     my ($self,$obj) = @_;
 251
 252     if(! $obj->isa($self->interface())) {
 253         $self->throw("invalid type: '".ref($obj).
 254                      "' does not implement '".$self->interface()."'");
 255     }
 256     return 1;
 257 }
 258
 259 #####################################################################
 260 # aliases for naming consistency or other reasons                   #
 261 #####################################################################
 262
 263 *create = \&create_object;
 264
 265 1;