lib/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
 100 use strict;
 101
 102
 103 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
 104
 105 =head2 new
 106
 107  Title   : new
 108  Usage   : my $obj = Bio::Factory::ObjectFactory->new();
 109  Function: Builds a new Bio::Factory::ObjectFactory object
 110  Returns : Bio::Factory::ObjectFactory
 111  Args    : -type      => string, name of a L<Bio::Root::RootI> derived class.
 112                          There is no default.
 113            -interface => string, name of the interface or class any type
 114                          specified needs to at least implement.
 115                          The default is Bio::Root::RootI.
 116
 117 =cut
 118
 119 sub new {
 120     my($class,@args) = @_;
 121
 122     my $self = $class->SUPER::new(@args);
 123
 124     my ($type,$interface) = $self->_rearrange([qw(TYPE INTERFACE)], @args);
 125
 126     $self->{'_loaded_types'} = {};
 127     $self->interface($interface || "Bio::Root::RootI");
 128     $self->type($type) if $type;
 129
 130     return $self;
 131 }
 132
 133
 134 =head2 create_object
 135
 136  Title   : create_object
 137  Usage   : my $seq = $factory->create_object(<named parameters>);
 138  Function: Instantiates a new object of the previously set type.
 139
 140            This object allows us to genericize the instantiation of
 141            objects.
 142
 143            You must have provided -type at instantiation, or have
 144            called type($mytype) before you can call this method.
 145
 146  Returns : an object of the type returned by type()
 147
 148            The return type is configurable using new(-type =>"..."),
 149            or by calling $self->type("My::Fancy::Class").
 150  Args    : Initialization parameters specific to the type of
 151            object we want. Check the POD of the class you set as type.
 152
 153 =cut
 154
 155 sub create_object {
 156    my ($self,@args) = @_;
 157
 158    my $type = $self->type(); # type has already been loaded upon set
 159    return $type->new(-verbose => $self->verbose, @args);
 160 }
 161
 162 =head2 type
 163
 164  Title   : type
 165  Usage   : $obj->type($newval)
 166  Function: Get/set the type of object to be created.
 167
 168            This may be changed at any time during the lifetime of this
 169            factory.
 170
 171  Returns : value of type (a string)
 172  Args    : newvalue (optional, a string)
 173
 174
 175 =cut
 176
 177 sub type{
 178     my $self = shift;
 179
 180     if(@_) {
 181         my $type = shift;
 182         if($type && (! $self->{'_loaded_types'}->{$type})) {
 183             eval {
 184                 $self->_load_module($type);
 185             };
 186             if( $@ ) {
 187                 $self->throw("module for '$type' failed to load: ".
 188                              $@);
 189             }
 190             my $o = bless {},$type;
 191             if(!$self->_validate_type($o)) { # this may throw an exception
 192                 $self->throw("'$type' is not valid for factory ".ref($self));
 193             }
 194             $self->{'_loaded_types'}->{$type} = 1;
 195         }
 196         return $self->{'type'} = $type;
 197     }
 198     return $self->{'type'};
 199 }
 200
 201 =head2 interface
 202
 203  Title   : interface
 204  Usage   : $obj->interface($newval)
 205  Function: Get/set the interface or base class that supplied types
 206            must at least implement (inherit from).
 207  Example :
 208  Returns : value of interface (a scalar)
 209  Args    : on set, new value (a scalar or undef, optional)
 210
 211
 212 =cut
 213
 214 sub interface{
 215     my $self = shift;
 216     my $interface = shift;
 217
 218     if($interface) {
 219         return $self->{'interface'} = $interface;
 220     }
 221     return $self->{'interface'};
 222 }
 223
 224 =head2 _validate_type
 225
 226  Title   : _validate_type
 227  Usage   : $factory->_validate_type($object)
 228  Function: Called to let derived factories validate the type set
 229            via type().
 230
 231            The default implementation here checks whether the supplied
 232            object skeleton implements the interface set via -interface
 233            upon factory instantiation.
 234
 235  Example :
 236  Returns : TRUE if the type is to be considered valid, and FALSE otherwise.
 237            Instead of returning FALSE this method may also just throw
 238            an informative exception.
 239
 240            The default implementation here will throw an exception
 241            if the supplied object does not inherit from the interface
 242            provided by the interface() method.
 243
 244  Args    : A hash reference blessed into the specified type, allowing
 245            queries like isa().
 246
 247
 248 =cut
 249
 250 sub _validate_type{
 251     my ($self,$obj) = @_;
 252
 253     if(! $obj->isa($self->interface())) {
 254         $self->throw("invalid type: '".ref($obj).
 255                      "' does not implement '".$self->interface()."'");
 256     }
 257     return 1;
 258 }
 259
 260 #####################################################################
 261 # aliases for naming consistency or other reasons                   #
 262 #####################################################################
 263
 264 *create = \&create_object;
 265
 266 1;