Mercurial > repos > mahtabm > ensembl
diff variant_effect_predictor/Bio/Root/Object.pm @ 0:1f6dce3d34e0
Uploaded
| author | mahtabm |
|---|---|
| date | Thu, 11 Apr 2013 02:01:53 -0400 |
| parents | |
| children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/variant_effect_predictor/Bio/Root/Object.pm Thu Apr 11 02:01:53 2013 -0400 @@ -0,0 +1,2161 @@ +#----------------------------------------------------------------------------- +# PACKAGE : Bio::Root::Object.pm +# AUTHOR : Steve Chervitz (sac@bioperl.org) +# CREATED : 23 July 1996 +# REVISION: $Id: Object.pm,v 1.23 2002/10/22 07:38:37 lapp Exp $ +# STATUS : Alpha +# +# For documentation, run this module through pod2html +# (preferably from Perl v5.004 or better). +# +# MODIFICATION NOTES: See bottom of file. +# +# Copyright (c) 1996-2000 Steve Chervitz. All Rights Reserved. +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# Retain this notice and note any modifications made. +#----------------------------------------------------------------------------- + +package Bio::Root::Object; +use strict; + +require 5.002; +use Bio::Root::Global qw(:devel $AUTHORITY $CGI); +use Bio::Root::Root; + +use Exporter (); + +#use AutoLoader; +#*AUTOLOAD = \&AutoLoader::AUTOLOAD; + +use vars qw(@EXPORT_OK %EXPORT_TAGS); +@EXPORT_OK = qw($VERSION &find_object &stack_trace &containment &_rearrange); +%EXPORT_TAGS = ( std => [qw(&stack_trace &containment)] ); + +use vars qw($ID $VERSION %Objects_created $Revision @ISA); + +@ISA = qw(Bio::Root::Root); + + +# %Objects_created can be used for tracking all objects created. +# See _initialize() for details. + +$ID = 'Bio::Root::Object'; +$VERSION = 0.041; +$Revision = '$Id: Object.pm,v 1.23 2002/10/22 07:38:37 lapp Exp $'; #' + +### POD Documentation: + +=head1 NAME + +Bio::Root::Object - A core Perl 5 object. + +=head1 SYNOPSIS + +Use this module as the root of your inheritance tree. + +=head2 Object Creation + + require Bio::Root::Object; + + $dad = new Bio::Root::Object(); + $son = new Bio::Root::Object(-name => 'Junior', + -parent => $dad, + -make => 'full'); + + +See the L<new()|new> method for a complete description of parameters. +See also L<the USAGE section | USAGE>. + +=head1 DESCRIPTION + +B<Bio::Root::Object> attempts to encapsulate the "core" Perl5 +object: What are the key data and behaviors ALL (or at least most) Perl5 +objects should have? + +=head2 Rationale + +Use of B<Bio::Root::Object.pm> within the Bioperl framework facilitates +operational consistency across the different modules defined within +the B<Bio::> namespace. Not all objects need to derive from +B<Bio::Root::Object.pm>. However, when generating lots of different types +of potentially complex objects which should all conform to a set of +basic expectations, this module may be handy. + +At the very least, this module saves you from re-writing the L<new()|new> +method for each module you develop. It also permits consistent and +robust handling of C<-tag =E<gt> value> method arguments via the +L<Bio::Root::RootI::_rearrange()|Bio::Root::RootI> method and provides a +object-oriented way handle exceptions and warnings via the L<Bio::Root::Root::throw()|Bio::Root::Root> and L<Bio::Root::Root::warn()|Bio::Root::Root> methods. + +See L<the APPENDIX section | APPENDIX> for some other handy methods. + +=head2 Fault-Tolerant Objects + +A major motivation for this module was to promote the creation of robust, +fault-tolerant Perl5 objects. The L<Bio::Root::Root::throw()|Bio::Root::Root> method relies on Perl's built-in +C<eval{}/die> exception mechanism to generate fatal exceptions. +The data comprising an exception is managed by the B<Bio::Root::Err.pm> +module, which essentially allows the data thrown by a C<die()> event to be +wrapped into an object that can be easily examined and possibly re-thrown. + +The intent here is three-fold: + +=over 4 + +=item 1 Detailed error reporting. + +Allow objects to report detailed information about the error condition +(who, what, where, why, how). + +=item 2 Handle complex errors in objects. + +The goal is to make it relatively painless to detect and handle the wide +variety of errors possible with a complex Perl object. +Perl's error handling mechanism is a might clunky when it comes to +handling complex errors within complex objects, but it is improving. + +=item 3 Efficient & easy exception handling. + +To enable robust exception handling without incurring a significant +performance penalty in the resulting code. Ideally, exception handling +code should be transparent to the cpu until and unless an exception +arises. + +=back + +These goals may at times be at odds and we are not claiming +to have achieved the perfect balance. Ultimately, we want self- +sufficient object-oriented systems able to deal with their own errors. +This area should improve as the module, and Perl, evolve. +One possible modification might be to utilize Graham Barr's B<Error.pm> +module or Torsten Ekedahl's B<Experimental::Exception.pm> module +(see L<Other Exception Modules>). +Technologies such as these may eventually be +incorporated into future releases of Perl. The exception handling +used by B<Bio::Root::Object.pm> can be expected to change as Perl's +exception handling mechanism evolves. + +B<TERMINOLOGY NOTE:> In this discussion and elsewhere in this module, +the terms "Exception" and "Error" are used interchangeably to mean +"something unexpected occurred" either as a result of incorrect user +input or faulty internal processing. + +=head1 USAGE + +=head2 Basic Exception handling + +Object construction is a common place for exceptions to occur. By wrapping +the construction in an C<eval{ }> block, we can prevent the exception from +crashing the script and attempt to recover gracefully: + + # Package Foo.pm IS-A Bio::Root::Object.pm + + $obj = eval { new Foo(@data) }; # ending semicolon required. + if($@) { + print STDERR "\nTrouble creating Foo object: $@\n"; + recover_gracefully($@); + } + +A common strategy when generating lots of objects is to collect +data about which objects failed to build but still permit +the successfully created ones get processed: + + @errs = (); + foreach $thing ( @stuff ) { + my $obj = eval { new Foo($thing) }; + if($@) { + push @err, [$thing, $@]; + } + else { + process_obj($obj); + } + } + +Post-mortem reporting, logging, or analysis of the problems ensues: + + if(@errs) { + printf "\n%d things failed:\n", scalar(@errs); + foreach(@errs) { print "$err->[0], ";} + + print "\n\nTrapped exceptions:\n"; + foreach(@errs) { print "$err->[1]\n";} + } + +New with B<Perl 5.005> is the ability to C<die()> with an object +reference in C<$@> instead of just a string. This feature is not yet +exploited in Bio::Root::Object.pm but may be in future versions. +Bio::Root::Err.pm objects can be reconstructed from the contents of C<$@>: + + eval{ # exception-prone code here... }; + if($@) { + $err = new Bio::Root::Err($@); + printf "Trouble: %s\n". $err->msg; + printf "Stack trace: %s\n". $err->stack; + } + + +=head2 Demo Scripts + +Some demo script that illustrate working with Bio::Root::Objects +are included with the distribution in the examples/root_object directory. + + +=head1 STRICTNESS & VERBOSITY + +There are two global variables that can be used to control sensitivity to +exceptions/warnings and the amount of reporting for all objects within a process. +These are accessed via functions B<strictness()> and B<verbosity()> exported by +Bio::Root::Global (see L<Bio::Root::Global>). + + $STRICTNESS - Regulates the sensitivity of the object to exceptions and warnings. + + $VERBOSITY - Regulates the amount of reporting by an object. + + +The L<strict()|strict> and L<verbose()|verbose> methods of B<Bio::Root::Object> +originally operated at the the object level, to permit individual +strictness and verbosity levels for different objects. This level of +control is not usually required and can often be inconvenient; one +typically wants to set these properties globally for a given +script. While this sacrifices some flexibility, it saves time and +memory when working with lots of objects. For instance, child objects +don't have to worry about checking their parents to determine their +strictness/verbosity levels. Strictness and verbosity are +globally-defined values, but different classes of objects can be +differentially sensitive to these values depending on design criteria. + +Strictness and verbosity can be positive or negative. Negative +verbosity equals terseness; negative strictness equals permissiveness. +In B<Bio::Root::Object> only the Bio::Root::Root::throw() and +Bio::Root::Root::warn() methods (see L<Bio::Root::Root>) are sensitive to +these values as indicated in the tables below: + + +---------+ + | throw() | v e r b o s i t y + +---------+ ------------------------------------- + -1 0 1 + s ---------- ----------- ---------- + t + r -2 -- throw() converted into warn() + i + c -1 | Exception Exception Exception + t 0 |_ printed printed printed + n 1 | without with with stack + e 2 | stack trace stack trace trace and + s | sysbeep + s + + + +---------+ + | warn() | v e r b o s i t y + +---------+ -------------------------------------- + -1 0 1 + s ---------- ----------- ----------- + t + r -2 | Warning Warning Warning + i -1 |_ not printed printed + c 0 | printed without with stack + t 1 | but stack trace trace and + n | attached* sysbeep + e + s 2 -- warn() converted into throw() + s + + (*) Warnings will be attached to an object if the + -record_err =>1 flag is set when constructing the object + or if $object->record_err(1) is called subsequent to creation. + +See the methods L<verbose()|verbose>, L<strict()|strict>, L<record_err()|record_err>, +Bio::Root::Root::throw(), and Bio::Root::Root::warn() in +L<Bio::Root::Root> for more details. + + +=head1 DEPENDENCIES + +As the B<Bio::Root::Object> does not inherit from any modules +but wraps (i.e., provides an interface and delegates +functionality to) other modules in the Bio::Root:: hierarchy: + + Module Purpose + -------------------- ------------------------------------ + Bio::Root::Err.pm Exception handling + Bio::Root::IOManager.pm Input/output of object data or error data + Bio::Root::Xref.pm Arbitrary links between objects + +All of these modules are loaded only when necessary. +B<Bio::Root::Err> is an object representing an exception. +B<Bio::Root::IOManager> and B<Bio::Root::Xref> are more experimental. They are +utilized via delegation, which permits them to be developed and utilized +independently of B<Bio::Root::Object>. + +Since this module is at the root of potentially many different objects +in a particular application, efficiency is important. Bio::Root::Object.pm is +intended to be a lightweight, lean and mean module. + + +=head1 FEEDBACK + +=head2 Mailing Lists + +User feedback is an integral part of the evolution of this and other Bioperl modules. +Send your comments and suggestions preferably to one of the Bioperl mailing lists. +Your participation is much appreciated. + + bioperl-l@bioperl.org - General discussion + http://bioperl.org/MailList.shtml - About the mailing lists + +=head2 Reporting Bugs + +Report bugs to the Bioperl bug tracking system to help us keep track the bugs and +their resolution. Bug reports can be submitted via email or the web: + + bioperl-bugs@bio.perl.org + http://bugzilla.bioperl.org/ + +=head1 AUTHOR + +Steve Chervitz E<lt>sac@bioperl.orgE<gt> + +See L<the FEEDBACK section | FEEDBACK> for where to send bug reports and comments. + +=head1 VERSION + +Bio::Root::Object.pm, 0.041 + + +=head1 TODO + +=over 0 + +=item * Experiment with other Exception classes. + +Consider incorporating a more widely-used Error/Exception module +(see L<Other Exception Modules>). + +=item * Think about integration with Data::Dumper.pm for persisting objects. + +=back + +=head1 SEE ALSO + +L<Bio::Root::Err> - Error/Exception object +L<Bio::Root::IOManager> - Input/Output manager object +L<Bio::Root::Vector> - Manages dynamic lists of objects +L<Bio::Root::Xref> - Cross-reference object +L<Bio::Root::Global> - Manages global variables/constants + +http://bio.perl.org/Projects/modules.html - Online module documentation +http://bio.perl.org/ - Bioperl Project Homepage + +=head2 Other Exception Modules + +Experimental::Exception.pm - ftp://ftp.matematik.su.se/pub/teke/ +Error.pm - http://www.cpan.org/authors/id/GBARR/ +Throwable.pm - mailto:kstevens@globeandmail.ca + +http://genome-www.stanford.edu/perlOOP/exceptions.html + +=head1 ACKNOWLEDGEMENTS + +This module was developed under the auspices of the Saccharomyces Genome +Database: + +http://genome-www.stanford.edu/Saccharomyces + +Other Bioperl developers contributed ideas including Ewan Birney, Ian Korf, +Chris Dagdigian, Georg Fuellen, and Steven Brenner. + +=head1 COPYRIGHT + +Copyright (c) 1996-98 Steve Chervitz. All Rights Reserved. +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + + +# +## +### +#### END of main POD documentation. ' +### +## +# + + +=head1 APPENDIX + +Methods beginning with a leading underscore are considered private +and are intended for internal use by this module. They are +B<not> considered part of the public interface and are described here +for documentation purposes only. + +=cut + +# +# This object is deprecated as the root of the inheritance tree, but some +# modules depend on it as a legacy. We issue a deprecation warning for all +# other modules. +# +my @inheriting_modules = ('Bio::Tools::Blast', 'Bio::Root::Object', + 'Bio::Root::IOManager'); + + +####################################################### +# CONSTRUCTOR/DESTRUCTOR # +####################################################### + + +=head2 new + + Purpose : Creates a blessed object reference (hash) for the indicated class + : and calls _initialize() for the class passing it all parameters. + Usage : new CLASS_NAME [ %named_parameters]; + Example : $obj = new Bio::Root::Object 'george'; + : $obj = Bio::Root::Object->new(-name => 'L56163', + : -parent => $obj2 ); + : $obj = Bio::Root::Object->new(); + Returns : Blessed hash reference. + Argument : Named parameters: (PARAMETER TAGS CAN BE UPPER OR LOWERCASE). + : (all are optional) + : -NAME => arbitrary string to identify an object; + : should be unique within its class. + : -PARENT => blessed reference for an object that + : is responsible for the present object + : (e.g., a container). + : -MAKE => string to specify special constructor option. + : -OBJ => object reference for an object to be cloned. + : -RECORD_ERR => boolean (if true, attach all Err.pm objects generated by + : warn() or throw() calls to the present object; + : default = false). + : + : The use of STRICT and VERBOSE in constructors is no longer + : necessary since there is no object-specific strict or verbose setting. + : Use the strictness() and verbosity() functions exported by + : Bio::Root::Global.pm. These options are still provided + : in the constructor but the will affect *all* objects within a + : given process. + : + : -STRICT => integer (level of strictness: -2, -1, 0, 1, 2). + : -VERBOSE => integer (level of verbosity: -1, 0, 1) + : Verbosity can be used to control how much reporting + : an object should do generally. In this module, + : verbosity affects the behavior of throw() and warn() + : only. + : + : + Comments : This method creates blessed HASH references. + : An object is free to define its own strict, and verbose + : behavior as well as its own make (constructor) options. + +See Also : L<_initialize()|_initialize>, L<name()|name>, L<parent()|parent>, L<make()|make>, L<strict()|strict>, L<verbose()|verbose>, L<record_err()|record_err>, and Bio::Root::Root::throw() and Bio::Root::Root::warn() in L<Bio::Root::Root> + +=cut + +#---------- +sub new { +#---------- + my($class, @param) = @_; + my $self = {}; + bless $self, ref($class) || $class; + $DEBUG==2 && print STDERR "CREATING $self"; + $self->_initialize(@param); + $self; +} + + +=head2 _initialize + + Purpose : Initializes key Bio::Root::Object.pm data (name, parent, make, strict). + : Called by new(). + Usage : n/a; automatically called by Bio::Root::Object::new() + Returns : String containing the -MAKE constructor option or 'default' + : if none defined (if a -MAKE parameter is defined, the value + : returned will be that obtained from the make() method.) + : This return value saves any subclass from having to call + : $self->make() during construction. For example, within a + : subclass _initialize() method, invoke the Bio::Root::Object:: + : initialize() method as follows: + : my $make = $self->SUPER::_initialize(@param); + Argument : Named parameters passed from new() + : (PARAMETER TAGS CAN BE ALL UPPER OR ALL LOWER CASE). + Comments : This method calls name(), make(), parent(), strict(), index() + : and thus enables polymorphism on these methods. To save on method + : call overhead, these methods are called only if the data need + : to be set. + : + : The _set_clone() method is called if the -MAKE option includes + : the string 'clone' (e.g., -MAKE => 'clone'). + : + : The index() method is called if the -MAKE option includes + : the string 'index'. (This is an experimental feature) + : (Example: -MAKE => 'full_index'). + : + : NOTE ON USING _rearrange(): + : + : _rearrange() is a handy method for working with tagged (named) + : parameters and it permits case-insensitive in tag names + : as well as handling tagged or un-tagged parameters. + : _initialize() does not currently call _rearrange() since + : there is a concern about performance when setting many objects. + : One issue is that _rearrange() could be called with many elements + : yet the caller is interested in only a few. Also, derived objects + : typically invoke _rearrange() in their constructors as well. + : This could particularly degrade performance when creating lots + : of objects with extended inheritance hierarchies and lots of tagged + : parameters which are passes along the inheritance hierarchy. + : + : One thing that may help is if _rearrange() deleted all parameters + : it extracted. This would require passing a reference to the param list + : and may add excessive dereferencing overhead. + : It also would cause problems if the same parameters are used by + : different methods or objects. + +See Also : L<new()|new>, L<make()|make>, L<name()|name>, L<parent()|parent>, L<strict()|strict>, L<index()|index>, L<verbose()|verbose> + +=cut + +#---------------- +sub _initialize { +#---------------- + local($^W) = 0; + my($self, %param) = @_; + + if(! grep { ref($self) =~ /$_/; } @inheriting_modules) { + $self->warn("Class " . ref($self) . + " inherits from Bio::Root::Object, which is deprecated. ". + "Try changing your inheritance to Bio::Root::Root."); + } + my($name, $parent, $make, $strict, $verbose, $obj, $record_err) = ( + ($param{-NAME}||$param{'-name'}), ($param{-PARENT}||$param{'-parent'}), + ($param{-MAKE}||$param{'-make'}), ($param{-STRICT}||$param{'-strict'}), + ($param{-VERBOSE}||$param{'-verbose'}), + ($param{-OBJ}||$param{'-obj'}, $param{-RECORD_ERR}||$param{'-record_err'}) + ); + + ## See "Comments" above regarding use of _rearrange(). +# $self->_rearrange([qw(NAME PARENT MAKE STRICT VERBOSE OBJ)], %param); + + $DEBUG and do{ print STDERR ">>>> Initializing $ID (${\ref($self)}) ",$name||'anon';<STDIN>}; + + if(defined($make) and $make =~ /clone/i) { + $self->_set_clone($obj); + + } else { + $name ||= ($#_ == 1 ? $_[1] : ''); # If a single arg is given, use as name. + + ## Another performance issue: calling name(), parent(), strict(), make() + ## Any speed diff with conditionals to avoid method calls? + + $self->name($name) if $name; + $self->parent($parent) if $parent; + $self->{'_strict'} = $strict || undef; + $self->{'_verbose'} = $verbose || undef; + $self->{'_record_err'} = $record_err || undef; + + if($make) { + $make = $self->make($make); + + # Index the Object in the global object hash only if requested. + # This feature is not used much. If desired, an object can always + # call Bio::Root::Object::index() any time after construction. + $self->index() if $make =~ /index/; + } + } + + $DEBUG and print STDERR "---> Initialized $ID (${\ref($self)}) ",$name,"\n"; + + ## Return data of potential use to subclass constructors. +# return (($make || 'default'), $strict); # maybe (?) + return $make || 'default'; +} + + + +=head2 DESTROY + + Purpose : Provides indication that the object is being reclaimed + : by the GC for debugging purposes only. + Usage : n/a; automatically called by Perl when the ref count + : on the object drops to zero. + Argument : n/a + Comments : Setting the global $DEBUG to 2 will print messages upon + : object destruction. + : Subclasses should override this method to + : clean up any resources (open file handles, etc.) + : The overridden method should end with a call to + : SUPER::DESTROY; + +See Also : L<destroy()|destroy> + +=cut + +#----------- +sub DESTROY { +#----------- + my $self=shift; + + $DEBUG==2 && print STDERR "DESTROY called in $ID for ${\$self->to_string} ($self)\n"; +} + + +=head2 destroy + + Purpose : Clean up any resources allocated by the object and + : remove links to all objects connected to the present + : object with the ultimate aim of signaling the GC to + : reclaim all memory allocated for the object. + : This method breaks links to any Err, IOManager, and Xref objects + : and drops the present object as a child from any parent objects. + Usage : $object->destroy(); undef $object; + : undef-ing the object reference signals the GC to reclaim + : the object's memory. + Returns : undef + Argument : n/a + Comments : Circular reference structures are problematic for garbage + : collection schemes such as Perl's which are based on reference + : counting. If you create such structures outside of + : the parent-child relationship, be sure to properly break + : the circularity when destroying the object. + : Subclasses should override this method to call destroy() + : on any contained child objects. The overridden method + : should end with a call to SUPER::destroy(). + Bugs : Bio::Root::Xref.pm objects have not been tested and + : may not be handled properly here. + : Bio::Root::Vector.pm objects are also not yet handled + : properly so beware of crunching lots of Vector objects. + +=cut + +#-------------' +sub destroy { +#------------- +## Note: Cannot delete parent and xref object refs since they are not +## owned by this object, merely associated with it. + my $self = shift; + + if(ref($self->{'_parent'})) { + $self->{'_parent'}->_drop_child($self); + undef $self->{'_parent'}; + } + + if(ref($self->{'_io'})) { + $self->{'_io'}->destroy; + undef $self->{'_io'}; + } + + if(ref($self->{'_err'})) { + $self->{'_err'}->remove_all; + undef $self->{'_err'}; + } + + if(ref($self->{'_xref'})) { + $self->{'_xref'}->remove_all; + undef $self->{'_xref'}; + } + + $self->_remove_from_index if scalar %Objects_created; +} + + +=head2 _drop_child + + Usage : $object->_drop_child(object_ref) + : Used internally by destroy(). + Purpose : To remove a parent-to-child inter-object relationship. + : The aim here is to break cyclical object refs to permit Perl's + : GC to reclaim the object's memory. The expectation is that + : a child object requests of its parent that the parent drop the + : child object making the request. Parents do not drop children + : unless requested by the child in question. + Example : $self->parent->_drop_child($self); + Returns : undef + Argument : Object reference for the child object to be dropped + Throws : Exception if an object ref is not provided as an argument. + Comments : This is a simplistic version that systematically checks every + : data member, searching all top-level array, hash, and scalar + : data members. + : It does not recurse through all levels of complex data members. + : Subclasses could override this method to handle complex child + : data members for more optimal child searching. However, the + : version here is probably sufficient for most situations. + : + : _drop_child() is called by Bio::Root::Object::destroy() for + : all objects with parents. + Status : Experimental + +See Also : L<destroy()|destroy> + +=cut + +#---------------' +sub _drop_child { +#--------------- + my ($self, $child) = @_; + my ($member, $found); + + $self->throw("Child not defined or not an object ($child).") unless ref $child; + + local($^W = 0); + foreach $member (keys %{$self}) { + next unless ref($self->{$member}); + # compare references. + if (ref($self->{$member}) eq 'ARRAY') { + my ($i); + for($i=0; $i < @{$self->{$member}}; $i++) { + if ($self->{$member}->[$i] eq $child) { + $DEBUG==2 && print STDERR "Removing array child $child\n"; + undef $self->{$member}->[$i]; + $found = 1; last; + } + } + } elsif(ref($self->{$member}) eq 'HASH') { + foreach(keys %{$self->{$member}}) { + if ($self->{$member}->{$_} eq $child) { + $DEBUG==2 && print STDERR "Removing hash child $child\n"; + undef $self->{$member}->{$_}; + $found = 1; last; + } + } + } else { + if ($self->{$member} eq $child) { + $DEBUG==2 && print STDERR "Removing child $child\n"; + undef $self->{$member}; + $found = 1; last; + } + } + } + # Child not found: + # It is possible that a child object has a parent but has not yet been added to + # the parent due to a failure during construction of the child. Not warning. + #$self->warn(sprintf "Child %s not found in Parent %s.", $child->to_string, $self->to_string) unless $found; + + undef; +} + + +################################################################# +# ACCESSORS & INSTANCE METHODS +################################################################# + + + +=head2 name + + Usage : $object->name([string]); + Purpose : Set/Get an object's common name. + Example : $myName = $myObj->name; + : $myObj->name('fred'); + Returns : String consisting of the object's name or + : "anonymous <CLASSNAME>" if name is not set. + : Thus, this method ALWAYS returns some string. + Argument : String to be used as the common name of the object. + : Should be unique within its class. + +See also : L<has_name()|has_name> + +=cut + +#--------- +sub name { +#--------- + my $self = shift; + +# $DEBUG and do{ print STDERR "\n$ID: name(@_) called.";<STDIN>; }; + + if (@_) { $self->{'_name'} = shift } + return defined $self->{'_name'} ? $self->{'_name'} : 'anonymous '.ref($self); +} + + +=head2 to_string + + Usage : $object->to_string(); + Purpose : Get an object as a simple string useful for debugging purposes. + Example : print $myObj->to_string; # prints: Object <PACKAGE NAME> "<OBJECT NAME>" + Returns : String consisting of the package name + object's name + : Object's name is obtained by calling the name() method. + Argument : n/a + Throws : n/a + +See also : L<name()|name> + +=cut + +#------------- +sub to_string { +#------------- + my $self = shift; + return sprintf "Object %s \"%s\"", ref($self), $self->name; +} + + +=head2 parent + + Usage : $object->parent([object | 'null']); + Purpose : Set/Get the current object's source object. + : An object's source object (parent) is defined as the object + : that is responsible for creating the current object (child). + : The parent object may also have a special mechanism for + : destroying the child object. This should be included + : in the parent object's DESTROY method which should end with a + : call to $self->SUPER::DESTROY. + Example : $myObj->parent($otherObject); + Returns : Object reference for the parent object or undef if none is set. + Argument : Blessed object reference (optional) or the string 'null'. + : 'null' = sets the object's _parent field to undef, + : breaking the child object's link to its parent. + Throws : Exception if argument is not an object reference or 'null'. + Comments : This method may be renamed 'parent' in the near future. + : When and if this happens, parent() will still be supported but + : will be deprecated. + +See also : L<destroy()|destroy> + +=cut + +#------------' +sub parent { +#------------ + my ($self) = shift; + if (@_) { + my $arg = shift; + if(ref $arg) { + $self->{'_parent'} = $arg; + } elsif($arg =~ /null/i) { + $self->{'_parent'} = undef; + } else { + $self->throw("Can't set parent using $arg: Not an object"); + } + } + $self->{'_parent'}; +} + + +=head2 src_obj + + Usage : $object->src_obj([object | 'null']); + : THIS METHOD IS NOW DEPRECATED. USE parent() INSTEAD. + Purpose : Set/Get the current object's source object (parent). + +See also : L<parent()|parent> + +=cut + +#------------' +sub src_obj { +#------------ + my ($self) = shift; + $self->warn("DEPRECATED METHOD src_obj() CALLED. USE parent() INSTEAD.\n"); + $self->parent(@_); +} + + +=head2 has_name + + Usage : $object->has_name(); + Purpose : To determine if an object has a name. + Returns : True (1) if the object's {'Name'} data member is defined. + : False otherwise. + Comments : One may argue, why not just use the name() method as a + : combination setter/getter? has_name() is necessary for + : the following reasons: + : (1) If an object's name is not defined, name() returns + : "anonymous <CLASSNAME>". + : (2) If an object's name is 0 (zero) or '' (empty string), + : conditionals that simply check name() would fail incorrectly. + +See also : L<name()|name> + +=cut + +#--------------' +sub has_name { my $self = shift; return defined $self->{'_name'}; } +#-------------- + + + +=head2 make + + Usage : $object->make([string]); + Purpose : Set/Get an object's constructor option. + : make() is intended for use during object construction + : to essentially permit alternate constructors since + : Perl doesn't have a built-in mechanism for this. + Example : $make = $object->make(); + : $object->make('optionA'); + Returns : String consisting of the object's make option + : or 'default' if make is not set. + : Thus, this method ALWAYS returns some string. + Argument : String to be used as an option during object construction. + Comments : A typical use of a make option is when cloning an object + : from an existing object. In this case, the new() method + : is called with -MAKE => 'clone'. + +See also : L<_initialize()|_initialize>, L<clone()|clone> + +=cut + +#----------' +sub make { +#---------- + my $self = shift; + if(@_) { $self->{'_make'} = shift; } + $self->{'_make'} || 'default'; +} + + +=head2 err + + Usage : $self->err([$data], [$delimit]) + Purpose : Check for exceptions/warnings and get data about them. + : (object validation and error data retrieval) + Example : $self->err && print "has err"; + : $errCount = $self->err('count'); + : $errMsgs = $self->err('msg',"\t"); + : @errNotes = $self->err('note'); + Returns : One of the following: + : 1. If no arguments are given + : a. If the object has an error, the err data member is + : returned (this is an Bio::Root::Err.pm object), + : b. otherwise, undef is returned. + : 2. The number of Errs in the object's err data member (if $data eq 'count'). + : 3. A string containing data from a specific field from an object's err member. + : -- If the object contains multiple errors, data for all errors will be + : strung together in reverse chronological order with each error's data + : preceeded by "Error #n\n" and followed by two delimiters. + : 4. A list containing data from a specific field from an object's err member. + : -- If the object contains multiple errors, data for all errors will be + : added in reverse chronological order as separate elements in the list + : with NO "Error #n\n" identifier. Individual err list data + : (note,tech,stack) will be tab-delimited. + Arguments : $data = The name of a specific Err data member (see %Bio::Root::Err::ERR_FIELDS) + : OR 'count'. + : $delimit = The delimiter separating a single Err's list data member's elements. + : Default is "\n". For multi-error objects, two of these + : delimiters separate data from different errors. + : If wantarray is true or delimiter is 'list', data from multiple + : errors will be returned as a list + : + Comments : Since Err objects are now fatal and are not attached to the object by default, + : this method is largely moot. It is a relic from the former + : error "polling" days. + : It is handy for accessing non-fatal warnings thrown by the object, + : or in situations where fatal errors are converted to warnings + : as when $self->strict is -1 or $WARN_ON_FATAL is true. + : (Note: an object now only attaches Err objects to itself when + : constructed with -RECORD_ERR =>1 or if the global $RECORD_ERR is true). + : + : This method is intended mainly to test whether or not an object + : has any Err objects associated with it and if so, obtaining the + : Err object or specific data about it. + : For obtaining ALL data about an error, use err_string(). + : For more detailed manipulations with the Err data, retrieve the + : Err object and process its data as necessary. + +See also : L<err_string()|err_string>, L<print_err()|print_err>, L<Bio::Root::Err::get_all|Bio::Root::Err> + +=cut + +#---------- +sub err { +#---------- + my( $self, $data, $delimit) = @_; + + return undef unless defined $self->{'_err'}; + + $data ||= 'member'; +# $delimit ||= (wantarray ? 'list' : "\n"); + $delimit ||= "\n"; + + $data eq 'member' and return $self->{'_err'}; + $data eq 'count' and return $self->{'_err'}->size(); + + return $self->{'_err'}->get_all($data, $delimit ); +} + + +=head2 record_err + + Usage : $object->record_err([0|1]); + Purpose : Set/Get indicator for whether an object should save + : the Bio::Root::Err.pm objects it generates via calls + : to throw() or warn(). + Example : $myObj->record_err(1) + Returns : Boolean (0|1) + Argument : Boolean (0|1) + Comments : Record_err is generally useful only for examining + : warnings produced by an object, since calls to throw() + : are normally fatal (unless strictness is set to -2). + : To turn on recording of errors for all objects in a process, + : use Bio::Root::Global::record_err(). + Status : Experimental + +See also : L<err()|err>, and record_err() in L<Bio::Root::Err> + +=cut + +#--------------- +sub record_err { +#--------------- + my $self = shift; + + if (@_) { $self->{'_record_err'} = shift } + return $self->{'_record_err'} || 0; +} + + +=head2 err_state + + Usage : $object->err_state(); + Purpose : To assess the status of the object's Err object (if any). + Returns : A string: 'EXCEPTION' | 'WARNING' | 'FATAL' | 'OKAY' + : (OKAY is returned if there are no Errors) + Status : Experimental + +=cut + +#-------------' +sub err_state { +#------------- + my $self = shift; + return 'OKAY' if not defined $self->{'_err'}; + $self->{'_errState'} || 'OKAY'; +} + + +=head2 clear_err + + Purpose : To remove any error associated with the given object. + Usage : $myObj->clear_err; + +See also : L<err()|err> + +=cut + +#------------- +sub clear_err { +#------------- + my $self = shift; + undef $self->{'_err'}; +} + + + + + +=head2 containment + + Usage : $aref = $object->containment(); + : Since this method can be exported, the following can be used: + : $aref = containment($object); + Purpose : To determine the containment hierarchy of a object. + Returns : An array reference in which each element is a string + : containing the class and name of + : the object in which this object is contained. + : Indentation increases progressively as the + : hierarchy is traversed. + : E.g., Object MyClass "Foo" + : Contained in object YourClass "Bar" + : Contained in object HisClass "Moo" + Comments : This method will report only one object at each level + : since an object can currently have only one source object. + Status : Exported + +See also : L<err()|err> + +=cut + +#------------------ +sub containment { +#------------------ + my( $self) = @_; + my(@hierarchy); + +# print "$ID: getting err hierarchy.\n"; + push @hierarchy, $self->to_string; + my $obj = $self; + my $count = 0; + + while( ref $obj->parent) { + $obj = $obj->parent; + push @hierarchy, sprintf "%sContained in %s", ' ' x ++$count, $obj->to_string; + } + return \@hierarchy; +} + + +=head2 set_stats + + Usage : $object->set_stats(KEY => DATA [,KEY2 => DATA2]) + Purpose : To declare and initialize a set of statistics germain + : to an object. Each statistic name becomes a data member + : prefixed with an underscore (if not already) and first + : character after the underscore is lowercased. + Example : $object->set_stats('num_A' =>1, + : 'Num_B' =>10 ): + : This sets : + : $object->{'_num_A'} = 1 + : $object->{'_num_B'} = 10; + Returns : n/a + Comments : This method implements a convention for naming Perl + : object data members with a leading underscore, + : consistent with the naming convention of private methods. + : Data members should not be part of an object's public + : interface. The leading underscore helps flag the members + : as private and also prevents inadvertant clobbering. + +=cut + +#--------------' +sub set_stats { +#-------------- + my( $self, %param ) = @_; + + my ($val); + foreach (keys %param) { + $val = $param{$_};; + s/^(\w)/_\l$1/; + $self->{$_} = $val; + } +} + + +=head2 strict + + Usage : $object->strict( [-2|-1|0|1|2] ); + : warn $message if $object->strict > 0; + Purpose : To make the object hyper- or hyposensitive to exceptions & warnings. + : Strict = 2 : extremely hyper-sensitive, converts warn() into throw(). + : Strict = 1 : hyper-sensitive, but calls to warn are not converted. + : Strict = 0 : no change (throw() = fatal, warn() = non-fatal). + : Strict = -1 : hypo-sensitive, but calls to throw are not converted. + : Strict = -2 : extremely hypo-sensitive, converts throw() into warn() + : + : Two degrees of positive and negative values for strict permit + : the following functionality: + : 1. Setting strict to 2 or -2 leads to more dramatic strictness + : or permissiveness, respectively. With 2, all calls to warn() + : become calls to throw() and are therefore fatal. With -2, + : the opposite is true and calls to throw become non-fatal. + : A strict value of 2 is thus an object-level version of + : Perl's "use strict" pragma. + : + : 2. Setting strict to 1 or -1 does not affect the behavior of + : throw() and warn(). This allows an object to implement its + : its own strictness policy. A strict value of 1 is thus an + : an object-level version of Perl's -w flag. + : + Returns : Integer between -2 to 2. + Comments : This method no longer accesses an object-specific strictness + : level but rather the global $STRICTNESS variable + : defined in Bio::Root::Global.pm and accessed via the + : strictness() method exported by that package. + : Thus, all objects share the same strictness which + : is generally more convenient. + Status : Experimental + +See also : warn() and throw() in L<Bio::Root::Root>, L<STRICTNESS & VERBOSITY>, strictness() in L<Bio::Root::Global> + +=cut + +#------------ +sub strict { +#------------ + my $self = shift; + + # Use global strictness? + if( $self->{'_use_global_strictness'}) { + return &strictness(@_); + } + else { + # Object-specific strictness + if (@_) { $self->{'_strict'} = shift; } + defined($self->{'_strict'}) + ? return $self->{'_strict'} + : (ref $self->{'_parent'} ? $self->{'_parent'}->strict : 0); + } +} + +=head2 use_global_strictness + + Usage : $object->use_global_strictnness( [1|0] ); + Purpose : Set/Get accessor for a flag indicating whether or not + : to use the global strictness setting or to instead use + : object-specific strictness. + Returns : Boolean + Comments : + Status : Experimental + +See also : L<strict()|strict>, L<STRICTNESS & VERBOSITY>, strictness() in L<Bio::Root::Global> + +=cut + +sub use_global_strictness { + my ($self, $value) = @_; + + if( defined $value ) { + $self->{'_use_global_strictness'} = $value; + } + + return $self->{'_use_global_strictness'}; +} + + +=head2 clone + + Purpose : To deeply copy an object. + : Creates a new object reference containing an exact + : copy of an existing object and all its data members. + Usage : $myClone = $myObj->clone; + Comments : This method only clones the Bio::Root::Object data members. + : To fully clone an object that has data members beyond + : those inherited from Bio::Root::Object, you must provide a + : constructor in your class to copy all data of an object + : data into the clone. For an example, see how _set_clone() + : is called by _initialize() in this class. + : + : clone() will pass the named parameters {-MAKE=>'clone'} + : and {-OBJ=>$self} to the object's constructor. The + : constructor should then either check the -MAKE parameter + : directly or should check the return value from + : a call to the superclass constructor (see _initialize() + : for an example) and then copy the required data members from OBJ + : into the new object, bypassing the normal construction process. + : Cloning of objects has not been extensively tested. + : USE WITH CAUTION. + Status : Experimental + +See Also : L<_set_clone()|_set_clone>, L<_initialize()|_initialize> + +=cut + +#-------------' +sub clone { +#------------- + my($self) = shift; + +# warn sprintf "\nCloning %s \"%s\"\n\n", ref($self),$self->name; + + my $clone = $self->new(-MAKE =>'clone', + -OBJ =>$self); + if($self->err()) { $clone->err($self->err); } + $clone; +} + + + +=head2 _set_clone + + Usage : n/a; internal method used by _initialize() + : $self->_set_clone($object_to_be_cloned) + Purpose : Deep copy all Bio::Root::Object.pm data members + : into a new object reference. + : (This is basically a copy constructor). + Argument : object ref for object to be cloned. + Throws : Exception if argument is not an object reference. + Comments : Data members which are objects are cloned (parent, io, err). + : Cloning of objects has not been extensively tested. + : USE WITH CAUTION. + +See Also : L<_initialize()|_initialize> + +=cut + +#---------------- +sub _set_clone { +#---------------- + my($self, $obj) = @_; + + ref($obj) || throw($self, "Can't clone $ID object: Not an object ref ($obj)"); + + local($^W) = 0; # suppress 'uninitialized' warnings. + + $self->{'_name'} = $obj->{'_name'}; + $self->{'_strict'} = $obj->{'_strict'}; + $self->{'_make'} = $obj->{'_make'}; + $self->{'_verbose'} = $obj->{'_verbose'}; + $self->{'_errState'} = $obj->{'_errState'}; + ## Better to use can() with Perl 5.004. + $self->{'_parent'} = ref($obj->{'_parent'}) and $obj->{'_parent'}->clone; + $self->{'_io'} = ref($obj->{'_io'}) and $obj->{'_io'}->clone; + $self->{'_err'} = ref($obj->{'_err'}) and $obj->{'_err'}->clone; +} + + + +=head2 verbose + + Usage : $object->verbose([-1|0|1]); + Purpose : Set/Get an indicator for how much ruporting an object should do. + Argument : integer (-1, 0, or 1) + Returns : integer (-1, 0, or 1) + : Returns 0 if verbosity has not been defined. + : Verbosity > 0 indicates extra reporting. + : Verbosity < 0 indicates minimal reporting. + : Verbosity = 0 or undefined indicates default reporting. + Comments : This method no longer accesses an object-specific verbosity + : level but rather the global $VERBOSITY variable + : defined in Bio::Root::Global.pm and accessed via the + : verbosity() method exported by that package. + : Thus, all objects share the same verbosity which + : is generally more convenient. + Status : Experimental + +See Also : L<strict()|strict>, L<STRICTNESS & VERBOSITY>, verbosity() in L<Bio::Root::Global> + +=cut + +#------------ +sub verbose { +#------------ + my $self = shift; + + # Using global verbosity + return &verbosity(@_); + + # Object-specific verbosity (not used unless above code is commented out) + if(@_) { $self->{'_verbose'} = shift; } + defined($self->{'_verbose'}) + ? return $self->{'_verbose'} + : (ref $self->{'_parent'} ? $self->{'_parent'}->verbose : 0); +} + + + +=head1 I/O-RELATED METHODS (Delegated to B<Bio::Root::IOManager>) + +=head2 _io + + Usage : $object->_io() + Purpose : Get the Bio::Root::IOManager.pm object for the current object. + +See also : L<display()|display>, L<read()|read>, L<file()|file> + +=cut + +#------- +sub _io { my $self = shift; return $self->{'_io'}; } +#------- + + + +=head2 _set_io + + Usage : n/a; internal use only. + Purpose : Sets a new Bio::Root::IOManager.pm object for the current object. + +See also : L<display()|display>, L<read()|read>, L<file()|file> + +=cut + +#------------ +sub _set_io { +#------------ + my $self = shift; + + require Bio::Root::IOManager; + +# See PR#192. +# $self->{'_io'} = new Bio::Root::IOManager(-PARENT=>$self, @_); + $self->{'_io'} = new Bio::Root::IOManager(-PARENT=>$self); +} + + + +=head2 set_display + + Usage : $object->set_display( %named_parameters). + : See Bio::Root::IOManager::set_display() for a description of parameters. + Purpose : Sets the output stream for displaying data associated with an object. + : Delegates to Bio::Root::IOManager::set_display(). + Argument : Named parameters (optional). + : See Bio::Root::IOManager::set_display() for a + : description of arguments. + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + : I'm not satisfied with the current display()/set_display() strategy. + +See also : set_display() in L<Bio::Root::IOManager> + +=cut + +#----------------' +sub set_display { +#---------------- + my($self, @param) = @_; + + $self->_set_io(@param) if !ref($self->{'_io'}); + + eval { $self->{'_io'}->set_display(@param); }; + + if($@) { + my $er = $@; + $self->throw(-MSG=>$er, -NOTE=>"Can't set_display for ${\$self->name}"); + } + + return $self->{'_io'}->fh; +} + + +=head2 display + + Usage : $object->display( named parameters) + : See Bio::Root::IOManager::display() for a description of parameters. + Purpose : Output information about an object's data. + : Delegates this task to Bio::Root::IOManager::display() + Argument : Named parameters for IOManager::set_display() + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + : IOManager::set_display()is then called on the new IOManager object. + : + : The motivation behind the display() method and IOManager.pm + : is to allow for flexible control over output of an + : object's data to/from filehandles, pipes, or STDIN/STDOUT, + : and for passing file handles between objects. Currently, + : it is used mainly for output to STDOUT. + : + : There is some concern whether this much functionality is + : actually necessary, hence the "Experimental" status of this + : method. + : + : ------- + : It might be worthwhile to also have a string() method + : that will put an object's data into a string that can be + : further processed as desired. Stringification for persistence + : issues might be best handled by Data::Dumper.pm. + : + : When overriding this method, use the following syntax: + : + : sub display { + : my ($self, %param) = @_; + : $self->SUPER::display(%param); + : my $OUT = $self->fh(); + : print $OUT "\nSome data...\n"; + : ... + : } + : Now $OUT holds a filhandle reference (or the string 'STDOUT') + : which can be passed to other methods to display different + : data for the object. + : _set_display() is automatically called with $OUT as the sole + : argument (after $self) by IOManager.pm::display() + : if the -SHOW parameter is set to 'stats' or 'default'. + : + Bugs : Because the $OUT variable can be a FileHandle or a string, + : it is necessary to include the line before using $OUT in + : print statements: + : I am considering a cleaner way of dealing with this. + : Setting $OUT to a glob (*main::STDOUT) was unsuccessful. + : + : I'm not satisfied with the current display()/set_display() strategy. + +See also : display() in L<Bio::Root::IOManager> + +=cut + +#------------- +sub display { +#------------- + my( $self, @param ) = @_; + $self->{'_io'} || $self->set_display(@param); + $self->{'_io'}->display(@param); +} + + + + +=head2 _display_stats + + Usage : n/a; called automatically by Bio::Root::Object::display(-SHOW=>'stats'); + Purpose : Display stereotypical data for an object. + : Automatically called via display(). + Argument : Filehandle reference or string 'STDOUT' 'STDIN' 'STDERR' + Status : Experimental + +See also : L<display()|display> + +=cut + +#------------------- +sub _display_stats { +#------------------- + my($self, $OUT) = @_; + + + printf ( $OUT "%-15s: %s\n","NAME", $self->name()); + printf ( $OUT "%-15s: %s\n","MAKE", $self->make()); + if($self->parent) { + printf ( $OUT "%-15s: %s\n","PARENT", $self->parent->to_string); + } + printf ( $OUT "%-15s: %d\n",'ERRORS', (defined $self->err('count') ? $self->err('count') : 0)); ###JES### + printf ( $OUT "%-15s: %s\n","ERR STATE", $self->err_state()); + if($self->err()) { + print $OUT "ERROR:\n"; + $self->print_err(); + } +} + + + +=head2 read + + Usage : $object->read( named parameters) + : See Bio::Root::IOManager::read() for a description of parameters. + Purpose : Inputs data from an arbitrary source (file or STDIN). + : Delegates this task to Bio::Root::IOManager::read(). + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + : See the comments for the display() method for some comments + : about IO issues for objects. + : Note that the read() method uses a different strategy than + : the display() method. + : IO issues are considered experimental. + +See also : L<display()|display>, read() in L<Bio::Root::IOManager> + +=cut + +#-------- +sub read { +#-------- + my $self = shift; + + $self->_set_io(@_) if not defined $self->{'_io'}; + + $self->{'_io'}->read(@_); +} + + + +=head2 fh + + Usage : $object->fh(['name']) + : See Bio::Root::IOManager::fh() for a complete usage description. + Purpose : Get an object's current FileHandle object or IO stream indicator. + : Delegates to Bio::Root::IOManager.pm. + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : fh() in L<Bio::Root::IOManager> + +=cut + +#--------' +sub fh { +#-------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->fh(@_); +} + + +=head2 show + + Usage : $object->show() + : See Bio::Root::IOManager::show() for details. + Purpose : Get the string used to specify what to display + : using the display() method. + : Delegates to Bio::Root::IOManager.pm. + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : show() in L<Bio::Root::IOManager>, set_display() in L<Bio::Root::IOManager> + +=cut + +#----------- +sub show { +#----------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->show; +} + + + +=head2 file + + Usage : $object->file() + : See Bio::Root::IOManager::file() for details. + Purpose : Set/Get name of a file associated with an object. + : Delegates to Bio::Root::IOManager.pm. + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : file() in L<Bio::Root::IOManager> + +=cut + +#--------- +sub file { +#--------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->file(@_); +} + + +=head2 compress_file + + Usage : $object->compress_file([filename]) + : See Bio::Root::IOManager::compress_file() for details. + Purpose : Compress a file associated with the current object. + : Delegates to Bio::Root::IOManager.pm. + Throws : Propagates exceptions thrown by Bio::Root::IOManager.pm + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : L<file()|file>, compress_file() in L<Bio::Root::IOManager> + +=cut + +#------------------- +sub compress_file { +#------------------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->compress_file(@_); +} + + + +=head2 uncompress_file + + Usage : $object->uncompress_file([filename]) + : Delegates to Bio::Root::IOManager.pm. + Purpose : Uncompress a file associated with the current object. + Throws : Propagates exceptions thrown by Bio::Root::IOManager.pm + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : L<file()|file>, uncompress_file() in L<Bio::Root::IOManager> + +=cut + +#-------------------- +sub uncompress_file { +#-------------------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->uncompress_file(@_); +} + + +=head2 delete_file + + Usage : $object->delete_file([filename]) + : See Bio::Root::IOManager::delete_file() for details. + Purpose : Delete a file associated with the current object. + : Delegates to Bio::Root::IOManager.pm. + Throws : Propagates exceptions thrown by Bio::Root::IOManager.pm + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : L<file()|file>, delete_file() in L<Bio::Root::IOManager> + +=cut + +#----------------- +sub delete_file { +#----------------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->delete_file(@_); +} + + +=head2 file_date + + Usage : $object->file_date( %named_parameters ) + : See Bio::Root::IOManager::file_date() for details. + Purpose : Obtain the last modified data of a file. + : Delegates to Bio::Root::IOManager.pm. + Example : $object->file_date('/usr/home/me/data.txt'); + Throws : Propagates exceptions thrown by Bio::Root::IOManager.pm + Status : Experimental + Comments : Sets the IOManager.pm object if it is not set. + +See also : L<file()|file>, file_date() in L<Bio::Root::IOManager> + +=cut + +#--------------- +sub file_date { +#--------------- + my $self = shift; + $self->_set_io(@_) if !defined $self->{'_io'}; + $self->{'_io'}->file_date(@_); +} + + + +=head1 EXPERIMENTAL METHODS + + +=head2 xref + + Usage : $object->xref([object | 'null']); + Purpose : Sets/Gets an object(s) cross-referenced + : to the current object. + Example : $myObj->xref('null'); #remove all xrefs + : $myObj->xref($otherObject); #add a cross referenced object + Argument : Object reference or 'null' ('undef' also accepted). + Returns : Object reference or undef if the object has no xref set. + Throws : fatal error if argument is not an object reference or 'null'. + Comments : An Xref.pm object is a vectorized wrapper for an object. + : Thus, the number of objects cross-referenced can grow + : and shrink at will. + Status : Experimental + WARNING : NOT FULLY TESTED. + +See Also : L<Bio::Root::Xref> + +=cut + +#--------- +sub xref { +#--------- + my $self = shift; + if(@_) { + my $arg = shift; + if(ref $arg) { + require Bio::Root::Xref; + + if( !defined $self->{'_xref'}) { + $self->{'_xref'} = new Bio::Root::Xref(-PARENT =>$self, + -OBJ =>$arg); + } else { + $self->{'_xref'}->add($arg); + } + } elsif($arg =~ /null|undef/i) { + undef $self->{'_xref'}; + } else { + $self->throw("Can't set Xref using $arg: Not an object"); + } + } + + $self->{'_xref'}; +} + + + +=head2 index + + Purpose : To add an object to a package global hash of objects + : for tracking or rapid retrieval. + Usage : $self->index(); + Status : Experimental + Comments : The object's name is used to index it into a hash. Objects in + : different classes (packages) will be indexed in different hashes. + : An object's name should thus be unique within its class. + : To find an object, use find_object(). + : Uses the package global %Objects_created. + +See also : L<find_object()|find_object> + +=cut + +#---------- +sub index { +#---------- + my $self = shift; + my $class = ref $self; + my $objName = $self->{'_name'}; + + if( not defined $objName ) { + $self->throw("Can't index $class object \"$objName\"."); + } + + $DEBUG and do{ print STDERR "$ID: Indexing $class object \"$objName\"."; <STDIN>; }; + + $Objects_created{ $class }->{ $objName } = $self; +} + +#---------------------- +sub _remove_from_index { +#---------------------- + my $self = shift; + my $class = ref $self; + my $objName = $self->{'_name'}; + + undef $Objects_created{$class}->{$objName} if exists $Objects_created{$class}->{$objName}; +} + + + +=head2 find_object + + Purpose : To obtain any object reference based on its unique name + : within its class. + Usage : $myObj = &find_object('fred'); + : No need to specify the class (package) name of the object. + Comments : To use this method, the object must be previously + : indexed by Bio::Root::Object.pm. This can be accomplished + : by including 'index' in the -MAKE parameter during object + : construction OR by calling the index() method on the + : the object at any point after construction. + : This is not an instance method. + Status : Experimental + +See also : L<index()|index> + +=cut + +#--------------- +sub find_object { +#--------------- + my $name = shift; # Assumes name has been validated. + my $class = undef; + my $object = undef; + + foreach $class ( keys %Objects_created ) { + if( exists $Objects_created{ $class }->{ $name } ) { + $object = $Objects_created{ $class }->{ $name }; + last; + } + } + $object; +} + + + +=head2 has_warning + + Purpose : Test whether or not an object has a non-fatal error (warning). + Usage : $self->has_warning; + Comments : This method is not usually needed. Checking err() is + : sufficient since throw()ing an exception is a fatal event + : and must be handled when it occurs. + Status : Experimental + +See also : L<err()|err>, warn() in L<Bio::Root::Root>, throw() in L<Bio::Root::Root> + +=cut + +#---------------- +sub has_warning { +#---------------- + my $self = shift; + my $errData = $self->err('type'); + return 1 if $errData =~ /WARNING/; + 0; +} + + + +=head2 print_err + + Usage : print_err([-WHERE=>FileHandle_object [,-SHOW=>msg|note|tech|stack] or any combo]) + Purpose : Reports error data for any errors an object may have + : as a string. This will only print warnings since exceptions + : are fatal (unless a strictness of -2 is used). + Example : $myObj->print_err; + : $myObj->print_err(-WHERE=>$myObj->fh('err'), -SHOW=>'msgtechstack'); + Argument : SHOW parameter : specify a sub-set of the err data. + : WHERE parameter : specify a filehandle for printing. + Returns : n/a + Status : Experimental + +See also : L<err_string()|err_string>, L<strict()|strict> + +=cut + +#------------- +sub print_err { +#------------- + my( $self, %param ) = @_; + +# print "$ID: print_err()\n"; + + my $OUT = $self->set_display(%param); + +# print "$ID: OUT = $OUT\n"; + + print $OUT $self->err_string( %param ); + +# print "$ID: done print_err()\n"; +} + + + +=head2 err_string + + Usage : err_string([-SHOW =>msg|note|tech|stack]) + : err_string([-SHOW =>'msgnote'] or other combos) + Purpose : Reports all warnings generated by the object as a string. + Example : $errData = $myObj->err_string; + : print MYHANDLE $myObj->err_string(); + Argument : SHOW parameter : return a specific sub-set of the err data. + Returns : A string containing the error data of the object. + Comments : This method is provided as a safer and slightly easier to type + : alternative to $self->err->string. + Status : Experimental + +See also : L<print_err()|print_err>, string() in L<Bio::Root::Err> + +=cut + +#---------------- +sub err_string { +#---------------- + my( $self, %param ) = @_; + my($out); + my $errCount = $self->err('count'); + +# print "$ID: err_string(): count = $errCount\n"; + + if( $errCount) { + $out = sprintf("\n%d error%s in %s \"%s\"\n", + $errCount, $errCount>1?'s':'', ref($self), $self->name); + $out .= $self->err->string( %param ); + } else { + $out = sprintf("\nNo errors in %s \"%s\"\n", ref($self), $self->name); + } + $out; +} + + + + +################################################################# +# DEPRECATED or HIGHLY EXPERIMENTAL METHODS +################################################################# + +=head1 HIGHLY EXPERIMENTAL/DEPRECATED METHODS + +=head2 terse + + Usage : $object->terse([0|1]); + Purpose : Set/Get an indicator to report less than the normal amount. + Argument : Boolean (0|1) + Returns : Boolean (0|1) + Comments : This method is for reducing the amount of reporting + : an object will do. + : terse can be set during object construction with the + : -TERSE => 1 flag. + : Not putting this method in IOManager.pm since that class + : is concerned with "where" to report, not "what" or "how much". + Status : Deprecated + : Use verbose() with a negative value instead. + +See also : L<verbose()|verbose> + +=cut + +#---------- +sub terse { +#---------- + my $self = shift; + if(@_) { $self->{'_verbose'} = -1 * shift; } + + $self->warn("Deprecated method 'terse()'. Use verbose(-1) instead."); + + my $verbosity = $self->{'_verbose'} or + (ref $self->{'_parent'} and $self->{'_parent'}->verbose) or 0; + + return $verbosity * -1; +} + + +#---------------------- +=head2 set_err_data() +#---------------------- + + Usage : $object->set_err_data( field, data); + Purpose : Alters data within the last error set by the object. + : Interface to Bio::Root::Err::set(). + Returns : Calls Bio::Root::Err::set() + Argument : field = string, name of Bio::Root::Err.pm data field to set. + : data = string, data to set it to. + Throws : Exception if object has no errors. + Status : Deprecated + +See Also : set() in L<Bio::Root::Err> + +=cut + +#----------------- +sub set_err_data { +#----------------- + my( $self, $field, $data) = @_; + + $self->throw("Object has no errors.") if !$self->{'_err'}; + +# print "$ID: set_err_data($field) with data = $data\n in object ${\$self->name}:\n", $self->err->last->string(-CURRENT=>1); <STDIN>; + + $self->{'_err'}->last->set( $field, $data ); +} + +=head2 set_read + + Usage : see Bio::Root::IOManager::set_read() + Purpose : Sets an input stream for importing data associated with an object. + : Delegates to Bio::Root::IOManager::set_read(). + Status : Experimental + WARNING! : This method has not been tested. + +See also : set_read() in L<Bio::Root::IOManager> + +=cut + +#-------------- +sub set_read { +#-------------- + my($self,%param) = @_; + + $self->_set_io(%param) if !defined $self->{'_io'}; + + $self->{'_io'}->set_read(%param); +} + + + +=head2 set_log_err + + Usage : see Bio::Root::IOManager::set_log_err() + Purpose : Sets the output stream for logging information about + : an object's errors. + : Delegates to Bio::Root::IOManager::set_log_err(). + Status : Experimental + WARNING! : This method has not been tested. + +See also : set_log_err() in L<Bio::Root::IOManager> + +=cut + +#---------------' +sub set_log_err { +#--------------- + my($self,%param) = @_; + + $self->_set_io(%param) if !defined $self->{'_io'}; + + $self->{'_io'}->set_log_err(%param); +} + + +1; +__END__ + + +##################################################################################### +# END OF CLASS # +##################################################################################### + +=head1 FOR DEVELOPERS ONLY + +=head2 Data Members + +Information about the various data members of this module is provided for those +wishing to modify or understand the code. Two things to bear in mind: + +=over 4 + +=item 1 Do NOT rely on these in any code outside of this module. + +All data members are prefixed with an underscore to signify that they are private. +Always use accessor methods. If the accessor doesn't exist or is inadequate, +create or modify an accessor (and let me know, too!). + +=item 2 This documentation may be incomplete and out of date. + +It is easy for this documentation to become obsolete as this module is still evolving. +Always double check this info and search for members not described here. + +=back + +An instance of Bio::Root::Object.pm is a blessed reference to a hash containing +all or some of the following fields: + + FIELD VALUE + ------------------------------------------------------------------------ + _name Common name for an object useful for indexing. + Should be unique within its class. + + _parent The object which created and is responsible for this object. + When a parent is destroyed, it takes all of its children with it. + + _err Bio::Root::Err.pm object reference. Undefined if the object has no error + or if the _record_err member is false (which is the default). + If object has multiple errors, err becomes a linked + list of Err objects and the err member always points to latest err. + In theory, an object should care only about whether or not it HAS + an Err not how many it has. I've tried to make the management of + multiple errors as opaque as possible to Bio::Root::Object. + + _errState One of @Bio::Root::Err::ERR_TYPES. Allows an object to quickly determine the + the type of error it has (if any) without having to examine + potentially multiple Err object(s). + + _xref Bio::Root::Xref object (Vector) for tracking other object(s) related to the + present object not by inheritance or composition but by some arbitrary + criteria. This is a new, experimental feature and is not fully implemented. + + _make Used as a switch for custom object initialization. Provides a + mechanism for alternate constructors. This is somewhat experimental. + It may be useful for contruction of complex objects and may be of + use for determining how an object was constructed post facto. + + _io Bio::Root::IOManager.pm object reference. Used primarily for handling the + display of an object's data. + + _strict Integer flag to set the sensitivity to exceptions/warnings + for a given object. + + _verbose Boolean indicator for reporting more or less than the normal amount. + + _record_err Boolean indicator for attaching all thrown exception objects + to the current object. Default = false (don't attach exceptions). + +=cut + + +MODIFICATION NOTES: +----------------------- +0.041, sac --- Thu Feb 4 03:50:58 1999 + * warn() utilizes the Global $CGI indicator to supress output + when script is running as a CGI. + +0.04, sac --- Tue Dec 1 04:32:01 1998 + * Incorporated the new globals $STRICTNESS and $VERBOSITY + and eliminated WARN_ON_FATAL, FATAL_ON_WARN and DONT_WARN. + * Deprecated terse() since it is better to think of terseness + as negative verbosity. + * Removed autoloading-related code and comments. + +0.035, 28 Sep 1998, sac: + * Added _drop_child() method to attempt to break cyclical refs + between parent and child objects. + * Added to_string() method. + * Err objects no longer know their parents (no need). + +0.031, 2 Sep 1998, sac: + * Documentation changes only. Wrapped the data member docs + at the bottom in POD comments which fixes compilation bug + caused by commenting out __END__. + +0.03, 16 Aug 1998, sac: + * Calls to warn() or throw() now no longer result in Err.pm objects + being attached to the current object. For discussion about this + descision, see comments under err(). + * Added the -RECORD_ERR constructor option and Global::record_err() + method to enable the attachment of Err.pm object to the current + object. + * Minor bug fixes with parameter handling (%param -> @param). + * Added note about AUTOLOADing. + +0.023, 20 Jul 1998, sac: + * Changes in Bio::Root::IOManager::read(). + * Improved memory management (destroy(), DESTROY(), and changes + in Bio::Root::Vector.pm). + +0.022, 16 Jun 1998, sac: + * Changes in Bio::Root::IOManager::read(). + +0.021, May 1998, sac: + * Touched up _set_clone(). + * Refined documentation in this and other Bio::Root modules + (converted to use pod2html in Perl 5.004) + +