# $Id$
package Bio::Phylo;
use strict;
use vars qw($VERSION $CACHING $VERBOSE);

# Because we use a roll-your-own looks_like_number from
# Bio::Phylo::Util::CONSTANT, here we don't have to worry
# about older S::U versions...
use Scalar::Util qw(weaken blessed);

#... instead, Bio::Phylo::Util::CONSTANT can worry about it
# in one location
use Bio::Phylo::Util::CONSTANT qw(looks_like_number);
use Bio::Phylo::Util::IDPool;
use Bio::Phylo::Util::Exceptions;

# Include the revision number from CIPRES subversion in $VERSION
my $rev = '$Id$';
$rev =~ s/^[^\d]+(\d+)\b.*$/$1/;
$VERSION = "0.15_$rev";

# The following allows for semantics like:
# 'use Bio::Phylo verbose => 1;' to increase verbosity,
# or 'use Bio::Phylo caching => 1;' to turn on caching
sub import {
    my $class = shift;
    if ( @_ ) {
        my %opt;
        eval { %opt = @_; };
        if ( $@ ) {
            Bio::Phylo::Util::Exceptions::OddHash->throw( 'error' => $@ );
        }
        else {
            while ( my ( $key, $value ) = each %opt ) {
                if ( $key =~ qr/^CACHING$/i ) {
                    $CACHING = $value;
                }
                elsif ( $key =~ qr/^VERBOSE$/i ) {
                    $VERBOSE = $value;
                }
                else {
                    Bio::Phylo::Util::Exceptions::BadArgs->throw(
                        'error' => "'$key' is not a valid argument for import",
                    );
                }
            }
        }
    }
}

{

    # inside out class arrays
    my @name;
    my @desc;
    my @score;
    my @generic;
    my @cache;
    my @container;

    # $fields hashref necessary for object destruction
    my $fields = {
        '-name'      => \@name,
        '-desc'      => \@desc,
        '-score'     => \@score,
        '-generic'   => \@generic,
        '-cache'     => \@cache,
        '-container' => \@container,
    };

    # global container for Forest, Matrix and Taxa objects (a la Mesquite
    # project)
    my $super = {};

=head1 NAME

Bio::Phylo - Phylogenetic analysis using perl.

=head1 SYNOPSIS

 # 'caching' is experimental and under development, default is '0'
 use Bio::Phylo verbose => 1, caching => 0;

=head1 DESCRIPTION

This is the base class for the Bio::Phylo package. All other modules inherit
from it, the methods defined here are applicable to all. Consult the manual
for usage examples: L<Bio::Phylo::Manual>.

=head1 METHODS

=head2 CONSTRUCTOR

=over

=item new()

The Bio::Phylo object itself, and thus its constructor, is rarely, if ever, used
directly. Rather, all other objects in this package inherit its methods, and call
its constructor internally.

 Type    : Constructor
 Title   : new
 Usage   : my $phylo = Bio::Phylo->new;
 Function: Instantiates Bio::Phylo object
 Returns : a Bio::Phylo object
 Args    : -name    => (object name)
           -desc    => (object description)
           -score   => (numerical score)
           -generic => (generic key/value pair)

=cut

    sub new {
        my $class = shift;
        my $self  = Bio::Phylo::Util::IDPool->_initialize();
        bless $self, __PACKAGE__;
        if (@_) {
            my %opt;
            eval { %opt = @_; };
            if ($@) {
                Bio::Phylo::Util::Exceptions::OddHash->throw( error => $@ );
            }
            else {
                while ( my ( $key, $value ) = each %opt ) {
                    if ( $fields->{$key} ) {
                        $fields->{$key}->[ $self->get_id ] = $value;
                        delete $opt{$key};
                    }
                }
                @_ = %opt;
            }
        }
        return $self;
    }

=back

=head2 MUTATORS

=over

=item set_name()

 Type    : Mutator
 Title   : set_name
 Usage   : $obj->set_name($name);
 Function: Assigns an object's name.
 Returns : Modified object.
 Args    : Argument must be a string, single 
           quoted if it contains [;|,|:\(|\)] 
           or spaces.

=cut

    sub set_name {
        my ( $self, $name ) = @_;
        my $ref = ref $self;
        if ( $name && $name !~ m/^['"][^'"]*['"]$/ && $name =~ m/(?:;|,|:|\(|\)|\s)/ ) {
            Bio::Phylo::Util::Exceptions::BadString->throw(
                error => "\"$name\" is a bad name format for $ref names" 
            );
        }
        else {
            $name =~ s/^\s*(.*?)\s*$/$1/;
            $name[ $self->get_id ] = $name;
        }
        return $self;
    }

=item set_desc()

 Type    : Mutator
 Title   : set_desc
 Usage   : $obj->set_desc($desc);
 Function: Assigns an object's description.
 Returns : Modified object.
 Args    : Argument must be a string.

=cut

    sub set_desc {
        my ( $self, $desc ) = @_;
        $desc[ $self->get_id ] = $desc;
        return $self;
    }

=item set_score()

 Type    : Mutator
 Title   : set_score
 Usage   : $obj->set_score($score);
 Function: Assigns an object's numerical score.
 Returns : Modified object.
 Args    : Argument must be any of
           perl's number formats.

=cut

    sub set_score {
        my $self = $_[0];
        if ( defined $_[1] ) {
            my $score = $_[1];
            if ( looks_like_number $score ) {
                $score[ $self->get_id ] = $score;
            }
            else {
                Bio::Phylo::Util::Exceptions::BadNumber->throw(
                    error => "Score \"$score\" is a bad number" );
            }
        }
        else {
            $score[ $self->get_id ] = undef;
        }
        return $self;
    }

=item set_generic()

 Type    : Mutator
 Title   : set_generic
 Usage   : $obj->set_generic(%generic);
 Function: Assigns generic key/value pairs to the invocant.
 Returns : Modified object.
 Args    : Valid arguments constitute
           key/value pairs, for example:
           $node->set_generic(
               '-posterior' => 0.87565,
           );

=cut

    sub set_generic {
        my $self = shift;
        if (@_) {
            my %args;
            eval { %args = @_ };
            if ($@) {
                Bio::Phylo::Util::Exceptions::OddHash->throw( error => $@ );
            }
            else {
                foreach my $key ( keys %args ) {
                    $generic[ $self->get_id ]->{$key} = $args{$key};
                }
            }
        }
        else {
            $generic[ $self->get_id ] = {};
        }
        return $self;
    }

=back

=head2 ACCESSORS

=over

=item get_name()

 Type    : Accessor
 Title   : get_name
 Usage   : my $name = $obj->get_name;
 Function: Returns the object's name (if any).
 Returns : A string
 Args    : None

=cut

    sub get_name {
        my $self = shift;
        return $name[ $self->get_id ];
    }

=item get_desc()

 Type    : Accessor
 Title   : get_desc
 Usage   : my $desc = $obj->get_desc;
 Function: Returns the object's description (if any).
 Returns : A string
 Args    : None

=cut

    sub get_desc {
        my $self = shift;
        return $desc[ $self->get_id ];
    }

=item get_score()

 Type    : Accessor
 Title   : get_score
 Usage   : my $score = $obj->get_score;
 Function: Returns the object's numerical score (if any).
 Returns : A number
 Args    : None

=cut

    sub get_score {
        my $self = shift;
        return $score[ $self->get_id ];
    }

=item get_generic()

 Type    : Accessor
 Title   : get_generic
 Usage   : my $value = $obj->get_generic($key);
           or
           my %hash = %{ $obj->get_generic() };
 Function: Returns the object's generic data. If an
           argument is used, it is considered a key
           for which the associated value is return.
           Without arguments, a reference to the whole
           hash is returned.
 Returns : A string or hash reference.
 Args    : None

=cut

    sub get_generic {
        my ( $self, $key ) = @_;
        if ( defined $key ) {
            return $generic[ $self->get_id ]->{$key};
        }
        else {
            return $generic[ $self->get_id ];
        }
    }

=item get_id()

 Type    : Accessor
 Title   : get_id
 Usage   : my $id = $obj->get_id;
 Function: Returns the object's unique ID
 Returns : INT
 Args    : None

=cut

    sub get_id {
        my $self = shift;
        if ( UNIVERSAL::isa( $self, 'SCALAR' ) ) {
            return $$self;
        }
        # for tied Bio::Phylo::Listable arrays
        elsif ( UNIVERSAL::isa( $self, 'ARRAY' ) ) {
            my $tied = tied @{ $self };
            if ( $tied and UNIVERSAL::isa( $tied, 'SCALAR' ) ) {
                return $$tied;
            }
            elsif ( not $tied ) {
#                die "No object tied to \"$self\"\n";
            }            
        }
        else {
#            die "Object \"$self\" neither a tied ARRAY nor a SCALAR\n";
        }
    }

=back

=head2 PACKAGE METHODS

=over

=item get()

All objects in the package subclass the Bio::Phylo object, and so, for example,
you can do C<$node-E<gt>get('get_branch_length');> instead of C<$node-E<gt>get_branch_length>.
This is a useful feature for listable objects especially, as they have the
get_by_value method, which allows you to retrieve, for instance, a list of nodes
whose branch length exceeds a certain value. That method (and
get_by_regular_expression) uses this C<$obj-E<gt>get method>.

 Type    : Accessor
 Title   : get
 Usage   : my $treename = $tree->get('get_name');
 Function: Alternative syntax for safely accessing
           any of the object data; useful for
           interpolating runtime $vars.
 Returns : (context dependent)
 Args    : a SCALAR variable, e.g. $var = 'get_name';

=cut

    sub get {
        my ( $self, $var ) = @_;
        if ( $self->can($var) ) {
            return $self->$var;
        }
        else {
            my $ref = ref $self;
            Bio::Phylo::Util::Exceptions::UnknownMethod->throw(
                error => "sorry, a \"$ref\" can't \"$var\"" );
        }
    }

=item clone()

 Type    : Utility method
 Title   : clone
 Usage   : my $clone = $object->clone;
 Function: Creates a copy of the invocant object.
 Returns : A copy of the invocant.
 Args    : none.

=cut

    sub clone {
        my $self  = shift;
        #my $clone = dclone($self);
        #return $clone;
    }

=item VERBOSE()

Getter and setter for the verbose level. Currently it's just 0 = no messages,
1 = messages, but perhaps there could be more levels? For caller diagnostics
and so on?

 Type    : Accessor
 Title   : VERBOSE(0|1)
 Usage   : Phylo->VERBOSE(0|1)
 Function: Sets/gets verbose level
 Returns : Verbose level
 Args    : 0 = no messages; 1 = error messages
 Comments:

=cut

    sub VERBOSE {
        my $class = shift;
        if (@_) {
            my %opt;
            eval { %opt = @_; };
            if ($@) {
                Bio::Phylo::Util::Exceptions::OddHash->throw( error => $@ );
            }
            $VERBOSE = $opt{'-level'};
        }
        return $VERBOSE;
    }

=item CITATION()

 Type    : Accessor
 Title   : CITATION
 Usage   : $phylo->CITATION;
 Function: Returns suggested citation.
 Returns : Returns suggested citation.
 Args    : None
 Comments:

=cut

    sub CITATION {
        my $self    = shift;
        my $name    = __PACKAGE__;
        my $version = __PACKAGE__->VERSION;
        my $string  = qq{Rutger A. Vos, 2006. $name: };
        $string .= qq{Phylogenetic analysis using Perl, version $version};
        return $string;
    }

=item VERSION()

 Type    : Accessor
 Title   : VERSION
 Usage   : $phylo->VERSION;
 Function: Returns version number
           (including CVS revision number).
 Alias   :
 Returns : SCALAR
 Args    : NONE
 Comments:

=cut

    sub VERSION { $VERSION; }

=item to_xml()

 Type    : Format converter
 Title   : to_xml
 Usage   : my $xml = $obj->to_xml;
 Function: Returns an XML representation of the invocant object.
 Returns : SCALAR
 Args    : NONE

=cut

    sub to_xml {
        my $self  = shift;
        my $class = ref $self;
        $class =~ s/^.*:([^:]+)$/$1/g;
        $class = lc($class);
        my $xml     = '<' . $class . ' id="' . $class . $self->get_id . '">';
        my $generic = $self->get_generic;
        my ( $name, $score, $desc ) =
          ( $self->get_name, $self->get_score, $self->get_desc );
        $xml .= '<name>' . $name . '</name>'    if $name;
        $xml .= '<score>' . $score . '</score>' if $score;
        $xml .= '<desc>' . $desc . '</desc>'    if $desc;
        if ( $generic and ref $generic eq 'HASH' ) {
            $xml .= "<generic>\n";
            $xml .= "<opt><key>$_</key><val>$generic->{$_}</val></opt>" for keys %$generic;
            $xml .= "</generic>";
        }

        if ( $self->isa('Bio::Phylo::Listable') ) {
            foreach my $ent ( @{ $self->get_entities } ) {
                $xml .= $ent->to_xml;
            }
        }
        $xml .= '</' . $class . '>';
        return $xml;
    }

=back

=head2 DESTRUCTOR

=over

=item DESTROY()

 Type    : Destructor
 Title   : DESTROY
 Usage   : $phylo->DESTROY
 Function: Destroys Phylo object
 Alias   :
 Returns : TRUE
 Args    : none
 Comments: You don't really need this,
           it is called automatically when
           the object goes out of scope.

=cut

    sub DESTROY {
        my $self = shift;
        if ( my $i = $self->get_id ) {
            foreach ( keys %{$fields} ) {
                delete $fields->{$_}->[$i];
            }
        }
        Bio::Phylo::Util::IDPool->_reclaim($self);
        return 1;
    }

=begin comment

 Type    : Internal method
 Title   : _check_cache
 Usage   : $node->_check_cache;
 Function: Retrieves intermediate calculation results.
 Returns : SCALAR
 Args    :

=end comment

=cut

    sub _check_cache {
        my $self   = shift;
        my @caller = caller(1);
        if ( $CACHING && exists $cache[ $self->get_id ]->{ $caller[3] } ) {
            return 1, $cache[ $self->get_id ]->{ $caller[3] };
        }
        return 0, 0;
    }

=begin comment

 Type    : Internal method
 Title   : _store_cache
 Usage   : $node->_store_cache($value);
 Function: Stores intermediate calculation results.
 Returns : VOID
 Args    :

=end comment

=cut

    sub _store_cache {
        my ( $self, $result ) = @_;
        my @caller = caller(1);
        $cache[ $self->get_id ]->{ $caller[3] } = $result if $CACHING;
    }

=begin comment

 Type    : Internal method
 Title   : _flush_cache
 Usage   : $node->_flush_cache;
 Function: Stores intermediate calculation results.
 Returns : VOID
 Args    :

=end comment

=cut

    sub _flush_cache {
        my $self = shift;
        $cache[ $self->get_id ] = {} if $CACHING;
    }

=begin comment

 Type    : Internal method
 Title   : _get_container
 Usage   : $phylo->_get_container;
 Function: Retrieves the object that contains the invocant (e.g. for a node,
           returns the tree it is in).
 Returns : Bio::Phylo::* object
 Args    : None

=end comment

=cut

    sub _get_container {
        my $self = shift;
        return $container[ $self->get_id ];
    }

=begin comment

 Type    : Internal method
 Title   : _set_container
 Usage   : $phylo->_set_container($obj);
 Function: Creates a reference from the invocant to the object that contains
           it (e.g. for a node, creates a reference to the tree it is in).
 Returns : Bio::Phylo::* object
 Args    : A Bio::Phylo::Listable object

=end comment

=cut

    sub _set_container {
        my ( $self, $container ) = @_;
        if ( blessed $container ) {
            if ( $container->can('_type') && $self->can('_container') ) {
                if ( $container->_type == $self->_container ) {
                    if ( $container->contains($self) ) {
                        $container[ $self->get_id ] = $container;
                        weaken( $container[ $self->get_id ] );
                        return $self;
                    }
                    else {
                        Bio::Phylo::Util::Exceptions::ObjectMismatch->throw(
                            error => "\"$self\" not in \"$container\"", );
                    }
                }
                else {
                    Bio::Phylo::Util::Exceptions::ObjectMismatch->throw(
                        error => "\"$container\" cannot contain \"$self\"", );
                }
            }
            else {
                Bio::Phylo::Util::Exceptions::ObjectMismatch->throw(
                    error => "Invalid objects", );
            }
        }
        else {
            Bio::Phylo::Util::Exceptions::BadArgs->throw(
                error => "Argument not an object", );
        }
    }

=begin comment

 Type    : Internal method
 Title   : _set_super
 Usage   : $phylo->_set_super;
 Function: Creates a reference to the invocant in the static $super hashref
 Returns : Bio::Phylo::* object
 Args    : None;

=end comment

=cut

    sub _set_super {
        my $self = shift;
        $super->{$self} = $self;
        weaken( $super->{$self} );
        return $self;
    }

=begin comment

 Type    : Internal method
 Title   : _get_super
 Usage   : Bio::Phylo->_get_super;
 Function: Returns all references in the static $super hashref
 Returns : Bio::Phylo::* objects in an array ref
 Args    : None;

=end comment

=cut

    sub _get_super {
        my @tmp = values %{$super};
        return \@tmp;
    }

=begin comment

 Type    : Internal method
 Title   : _del_from_super;
 Usage   : $phylo->_del_from_super;
 Function: Deletes invocant from $super hashref
 Returns : VOID
 Args    : None;

=end comment

=cut

    sub _del_from_super {
        my $self = shift;
        delete $super->{$self};
        return;
    }

=back

=head1 SEE ALSO

Also see the manual: L<Bio::Phylo::Manual>.

=head1 FORUM

CPAN hosts a discussion forum for Bio::Phylo. If you have trouble using this
module the discussion forum is a good place to start posting questions (NOT bug
reports, see below): L<http://www.cpanforum.com/dist/Bio-Phylo>

=head1 BUGS

Please report any bugs or feature requests to C<< bug-bio-phylo@rt.cpan.org >>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Bio-Phylo>. I will be notified,
and then you'll automatically be notified of progress on your bug as I make
changes. Be sure to include the following in your request or comment, so that
I know what version you're using:

$Id$

=head1 AUTHOR

Rutger Vos,

=over

=item email: L<mailto://rvosa@sfu.ca>

=item web page: L<http://www.sfu.ca/~rvosa/>

=back

=head1 ACKNOWLEDGEMENTS

The author would like to thank Jason Stajich for many ideas borrowed from
BioPerl L<http://www.bioperl.org>, and CIPRES L<http://www.phylo.org> and
FAB* L<http://www.sfu.ca/~fabstar> for comments and requests.

=head1 COPYRIGHT & LICENSE

Copyright 2005 Rutger Vos, All Rights Reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

}

package Bio::Phylo::Deprecated;

package Bio::Phylo::Parsers::Fastnewick;
push @Bio::Phylo::Parsers::Fastnewick::ISA, 'Bio::Phylo::Deprecated';

package Bio::Phylo::Parsers::Fastnexus;
push @Bio::Phylo::Parsers::Fastnexus::ISA, 'Bio::Phylo::Deprecated';

package Bio::Phylo::Matrices::Sequence;
push @Bio::Phylo::Matrices::Sequence::ISA, 'Bio::Phylo::Deprecated';

package Bio::Phylo::Matrices::Alignment;
push @Bio::Phylo::Matrices::Alignment::ISA, 'Bio::Phylo::Deprecated';

package Bio::Phylo::Parsers;
push @Bio::Phylo::Parsers::ISA, 'Bio::Phylo::Deprecated';

package Bio::Phylo::Unparsers;
push @Bio::Phylo::Unparsers::ISA, 'Bio::Phylo::Deprecated';

1;