Bio/Factory/ObjectFactory.pm

   1 # $Id$
   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 = Bio::Factory::ObjectFactory->new(-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/wiki/Mailing_lists  - 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 the
  60 web:
  61
  62   http://bugzilla.open-bio.org/
  63
  64 =head1 AUTHOR - Hilmar Lapp
  65
  66 Email hlapp at gmx.net
  67
  68
  69 =head1 CONTRIBUTORS
  70
  71 This is mostly copy-and-paste with subsequent adaptation from
  72 Bio::Seq::SeqFactory by Jason Stajich. Most credits should in fact go
  73 to him.
  74
  75 =head1 APPENDIX
  76
  77 The rest of the documentation details each of the object methods.
  78 Internal methods are usually preceded with a _
  79
  80 =cut
  81
  82
  83 # Let the code begin...
  84
  85
  86 package Bio::Factory::ObjectFactory;
  87 use strict;
  88
  89
  90 use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI);
  91
  92 =head2 new
  93
  94  Title   : new
  95  Usage   : my $obj = Bio::Factory::ObjectFactory->new();
  96  Function: Builds a new Bio::Factory::ObjectFactory object
  97  Returns : Bio::Factory::ObjectFactory
  98  Args    : -type      => string, name of a L<Bio::Root::RootI> derived class.
  99                          There is no default.
 100            -interface => string, name of the interface or class any type
 101                          specified needs to at least implement.
 102                          The default is Bio::Root::RootI.
 103
 104 =cut
 105
 106 sub new {
 107     my($class,@args) = @_;
 108
 109     my $self = $class->SUPER::new(@args);
 110
 111     my ($type,$interface) = $self->_rearrange([qw(TYPE INTERFACE)], @args);
 112
 113     $self->{'_loaded_types'} = {};
 114     $self->interface($interface || "Bio::Root::RootI");
 115     $self->type($type) if $type;
 116
 117     return $self;
 118 }
 119
 120
 121 =head2 create_object
 122
 123  Title   : create_object
 124  Usage   : my $seq = $factory->create_object(<named parameters>);
 125  Function: Instantiates a new object of the previously set type.
 126
 127            This object allows us to genericize the instantiation of
 128            objects.
 129
 130            You must have provided -type at instantiation, or have
 131            called type($mytype) before you can call this method.
 132
 133  Returns : an object of the type returned by type()
 134
 135            The return type is configurable using new(-type =>"..."),
 136            or by calling $self->type("My::Fancy::Class").
 137  Args    : Initialization parameters specific to the type of
 138            object we want. Check the POD of the class you set as type.
 139
 140 =cut
 141
 142 sub create_object {
 143    my ($self,@args) = @_;
 144
 145    my $type = $self->type(); # type has already been loaded upon set
 146    return $type->new(-verbose => $self->verbose, @args);
 147 }
 148
 149 =head2 type
 150
 151  Title   : type
 152  Usage   : $obj->type($newval)
 153  Function: Get/set the type of object to be created.
 154
 155            This may be changed at any time during the lifetime of this
 156            factory.
 157
 158  Returns : value of type (a string)
 159  Args    : newvalue (optional, a string)
 160
 161
 162 =cut
 163
 164 sub type{
 165     my $self = shift;
 166
 167     if(@_) {
 168         my $type = shift;
 169         if($type && (! $self->{'_loaded_types'}->{$type})) {
 170             eval {
 171                 $self->_load_module($type);
 172             };
 173             if( $@ ) {
 174                 $self->throw("module for '$type' failed to load: ".
 175                              $@);
 176             }
 177             my $o = bless {},$type;
 178             if(!$self->_validate_type($o)) { # this may throw an exception
 179                 $self->throw("'$type' is not valid for factory ".ref($self));
 180             }
 181             $self->{'_loaded_types'}->{$type} = 1;
 182         }
 183         return $self->{'type'} = $type;
 184     }
 185     return $self->{'type'};
 186 }
 187
 188 =head2 interface
 189
 190  Title   : interface
 191  Usage   : $obj->interface($newval)
 192  Function: Get/set the interface or base class that supplied types
 193            must at least implement (inherit from).
 194  Example :
 195  Returns : value of interface (a scalar)
 196  Args    : on set, new value (a scalar or undef, optional)
 197
 198
 199 =cut
 200
 201 sub interface{
 202     my $self = shift;
 203     my $interface = shift;
 204
 205     if($interface) {
 206         return $self->{'interface'} = $interface;
 207     }
 208     return $self->{'interface'};
 209 }
 210
 211 =head2 _validate_type
 212
 213  Title   : _validate_type
 214  Usage   : $factory->_validate_type($object)
 215  Function: Called to let derived factories validate the type set
 216            via type().
 217
 218            The default implementation here checks whether the supplied
 219            object skeleton implements the interface set via -interface
 220            upon factory instantiation.
 221
 222  Example :
 223  Returns : TRUE if the type is to be considered valid, and FALSE otherwise.
 224            Instead of returning FALSE this method may also just throw
 225            an informative exception.
 226
 227            The default implementation here will throw an exception
 228            if the supplied object does not inherit from the interface
 229            provided by the interface() method.
 230
 231  Args    : A hash reference blessed into the specified type, allowing
 232            queries like isa().
 233
 234
 235 =cut
 236
 237 sub _validate_type{
 238     my ($self,$obj) = @_;
 239
 240     if(! $obj->isa($self->interface())) {
 241         $self->throw("invalid type: '".ref($obj).
 242                      "' does not implement '".$self->interface()."'");
 243     }
 244     return 1;
 245 }
 246
 247 #####################################################################
 248 # aliases for naming consistency or other reasons                   #
 249 #####################################################################
 250
 251 *create = \&create_object;
 252
 253 1;