package Bio::CDAT::Root;
use strict;
use constant { 
    'DEBUG'   => 3, 
    'INFO'    => 2, 
    'WARNING' => 1, 
    'FATAL'   => 0,
};
use Scalar::Util qw(weaken refaddr);

our $LOGLEVEL  = 1;
our $LOGHANDLE = \*STDOUT;
our $VERSION   = '0.01';

=head1 NAME

Bio::CDAT::Root - Base class for Character Data And Tree objects.

=head1 SYNOPSIS

 No direct usage, use as base class.

=head1 DESCRIPTION

The Bio::CDAT::Root module provides utility methods 
(logging, UID handling, exception handling) for the
Bio::CDAT architecture.

=head1 METHODS

=head2 ID HANDLING

The Bio::CDAT architecture assigns unique IDs to all objects
it keeps track of. These IDs are subsequently used to specify
listeners and observers. At present, the IDs are generated
(auto-incremented) when the C<$cdat-E<gt>initialize_object( $obj )>
method call is placed. This might be changed to reuse the IDs
generated by packages that use the Bio::CDAT architecture. For example,
L<Bio::Phylo> objects have their own C<get_id> method. A combination
of the return value of that method and the object's namespace may
become used instead.

=over

=item initialize_object()

 Type    : ID Handler
 Title   : initialize_object
 Usage   : my $uid = $cdat->initialize_object( $object )
 Function: Initializes a Bio::CDAT contained object.
 Returns : Unique ID assigned to the contained object.
 Args    : A contained object (matrix, tree, taxon)

=cut

{
    # id handling for all child classes
    
    my $id_counter;
    my %id;
    my %lookup;
    sub initialize_object {
        my ( $self, $object )  = @_;
        $id{ refaddr $object } = ++$id_counter;
        my $tied = tied $object if tied $object;
        $id{ refaddr $tied }   = $id_counter;
        $lookup{ $id_counter } = $object;
        weaken $lookup{ $id_counter };
        $self->info("Going to initialize object $object (id: $id_counter)");
        no strict 'refs';
        no warnings 'redefine';
        my $PRIVATE = qr/^(?:_.+|[A-Z]+)$/;
        my $class = ref $object;
        SYMBOL_TABLE_ENTRY: for my $entry ( keys( %{"$class\::"} ) ) {
            if ( $entry =~ $PRIVATE ) {
                $self->debug(
                    "Skipping private entry $class\::$entry"
                );
                next SYMBOL_TABLE_ENTRY;
            }
            else {
                if ( UNIVERSAL::can( $class, $entry ) ) {
                    $self->debug("Going to shadow '$entry'");
                    my $real_method; 
                    $self->_find_fqmn( $class, $entry, \$real_method );
                    if ( not $real_method ) {
                        $self->throw(
                            'Bio::CDAT::Exceptions::NoSuchMethod',
                            "Can't find $entry"
                        );
                    }
                    *{"$class\::$entry"}  = sub {
                        my ( $me, @args ) = @_;
                        my ( $package, $file, $line ) = caller;
                        $self->debug(
                            "Call: \$$me->$entry(@args) at $file, $line"                        
                        ); 
                        if ( $self->is_initialized( $me ) ) {                       
                            $self->notify_listeners( 
                                'observable' => $self->get_id_for_object( $me ),
                                'method'     => $entry, 
                                'args'       => \@args,
                            );    
                        }                
                        return $real_method->( $me, @args );
                    };
                }
            }
        }
    }
    # find fully qualified method name in inheritance tree
    sub _find_fqmn {
        no strict 'refs';
        my ( $self, $class, $method, $scalar_ref ) = @_;
        return if $$scalar_ref;
        if ( defined &{"$class\::$method"} ) {
            $self->debug("Found $class\::$method");
            $$scalar_ref = \&{"$class\::$method"} if not $$scalar_ref;
        }
        else {
            $self->debug("No '$method' in $class");
        }
        $self->_find_fqmn( $_, $method, $scalar_ref ) for ( @{"$class\::ISA"}, 'UNIVERSAL' );
    }
    
=item get_id_for_object()

 Type    : ID Handler
 Title   : get_id_for_object
 Usage   : my $uid = $cdat->get_id_for_object( $object )
 Function: Returns UID for $object
 Returns : Unique ID assigned to the contained object.
 Args    : A contained object (matrix, tree, taxon)

=cut

    sub get_id_for_object {
        my ( $self, $object ) = @_;
        if ( not exists $id{ refaddr $object  } ) {
            $self->info( "No id for that object ($object)!" );
        }        
        return $id{ refaddr $object };
    }

=item get_object_by_id()

 Type    : ID Handler
 Title   : get_object_by_id
 Usage   : my $object = $cdat->get_object_by_id( $uid )
 Function: Returns $object defined by $uid
 Returns : Contained object.
 Args    : A unique ID

=cut    

    sub get_object_by_id {
        my ( $self, $id ) = @_;
        if ( not exists $lookup{ $id } ) {
            $self->info( "No object by that id ($id)!" );
        }
        return $lookup{ $id };        
    }
    
=item is_initialized()

 Type    : ID Handler
 Title   : is_initialized
 Usage   : do 'something' if $cdat->is_initialized( $object );
 Function: Tests whether $cdat has initialized $object
 Returns : BOOLEAN
 Args    : A (possibly) contained object

=cut    

    sub is_initialized {
        my ( $self, $object );
        return defined $id{ refaddr $object };
    }
}

=back

=head2 LOGGING

The Bio::CDAT architecture includes logging facilities, that is, an
abstraction for handling messages of different levels of importance.
Debugging messages are highly verbose (verbosity level 3, or constant 
C<Bio::CDAT::Root::DEBUG>), and usually only of interest to developers. 
Info messages (level 2, constant C<Bio::CDAT::Root::INFO>) give non-vital 
feedback; warnings are vital messages (level 1, constant 
C<Bio::CDAT::Root::WARNING>) to indicate something may be wrong with the 
state of the architecture; fatal messages (level 0, constant 
C<Bio::CDAT::Root::FATAL>) indicate something unrecoverable has gone happened.

Normally, only warnings and fatal messages are actually printed (that is,
log level is 1), while debug and info messages are ignored. This can be
changed by increasing - for more verbosity - or decreasing - less 
verbosity - C<$Bio::CDAT::Root::LOGLEVEL>. For example, to show all messages, 
specify C<$Bio::CDAT::Root::LOGLEVEL = Bio::CDAT::Root::DEBUG>.

By default, log messages are written to STDERR. This can be changed
by setting a different handle for C<$Bio::CDAT::Root::LOGHANDLE> (e.g. 
C<$Bio::CDAT::Root::LOGHANDLE = \*STDOUT>).

The bare bones facilities provided here could be replaced by 
L<Log::Log4perl>.

=over

=item debug()

 Type    : Logger
 Title   : debug
 Usage   : $cdat->debug($msg);
 Function: Handles messages of log level 'DEBUG';
 Returns : VOID, may write $msg to $LOGHANDLE
 Args    : A message string.

=cut

sub debug {
    my ( $self, $msg ) = @_;
    my ( $package, $file, $line ) = caller;
    print $LOGHANDLE "[DEBUG: $package, $file, $line] $msg\n" if $LOGLEVEL >= DEBUG;
}

=item info()

 Type    : Logger
 Title   : info
 Usage   : $cdat->info($msg);
 Function: Handles messages of log level 'INFO';
 Returns : VOID, may write $msg to $LOGHANDLE
 Args    : A message string.

=cut

sub info {
    my ( $self, $msg ) = @_;
    my ( $package, $file, $line ) = caller;
    print $LOGHANDLE "[INFO: $package, $file, $line] $msg\n" if $LOGLEVEL >= INFO;
}

=item warning()

 Type    : Logger
 Title   : warning
 Usage   : $cdat->warning($msg);
 Function: Handles messages of log level 'WARNING';
 Returns : VOID, may write $msg to $LOGHANDLE
 Args    : A message string.

=cut

sub warning {
    my ( $self, $msg ) = @_;
    my ( $package, $file, $line ) = caller;
    print $LOGHANDLE "[WARNING: $package, $file, $line] $msg\n" if $LOGLEVEL >= WARNING;
}

=item fatal()

 Type    : Logger
 Title   : fatal
 Usage   : $cdat->fatal($msg);
 Function: Handles messages of log level 'FATAL';
 Returns : VOID, may write $msg to $LOGHANDLE
 Args    : A message string.

=cut

sub fatal {
    my ( $self, $msg ) = @_;
    my ( $package, $file, $line ) = caller;
    print $LOGHANDLE "[FATAL: $package, $file, $line] $msg\n" if $LOGLEVEL >= FATAL;
}

=back

=head2 EXCEPTION HANDLING

The Bio::CDAT architecture provides an exception mechanism whereby 
the Bio::CDAT object can throw, e.g. 
C<$cdat-E<gt>throw( 'Bio::CDAT::Exception' =E<gt> $msg );>, and 
users can catch these using the standard eval mechanism, e.g.

 eval { $cdat->do_something_dangerous( @args ) };
 if ( $@ and $@->isa( 'Bio::CDAT::Exception::BadArgs' ) {
     # there was something wrong with @args
 }

The current implementation is simply to C<die> with a blessed
hash as argument. This could be replaced to use L<Exception::Class>
and/or L<Exception::Class::TCF>.

=over

=item throw()

 Type    : Exception handler
 Title   : throw
 Usage   : $cdat->throw( 'Bio::CDAT::Exception' => $msg );
 Function: Throws exceptions
 Returns : A blessed $@
 Args    : Exception class, message string

=cut

sub throw {
    my ( $self, $class, $msg ) = @_;
    die bless { 'message' => $msg }, $class;
}

=back

=head1 SEE ALSO

=over

=item L<Bio::CDAT>

The Bio::CDAT object (which inherits from Bio::CDAT::Root) handles the
matrices, trees and taxa, and the callbacks that act on them.

=back

=head1 AUTHOR

Rutger A. Vos,

=over

=item email: C<< rvosa@sfu.ca >>

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

=back

=head1 COPYRIGHT & LICENSE

Copyright 2005 Rutger A. 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

1;