Bio-Phylo

 view release on metacpan or  search on metacpan

lib/Bio/Phylo/NeXML/Writable.pm  view on Meta::CPAN

 Args    : None.
 Comments: throws ObjectMismatch if no linked taxa object 
           can be found

=cut

    my $add_namespaces_to_attributes = sub {
        my ( $self, $attrs ) = @_;
        my $i                       = 0;
        my $inside_to_xml_recursion = 0;
      CHECK_RECURSE: while ( my @frame = caller($i) ) {
            if ( $frame[3] =~ m/::to_xml$/ ) {
                $inside_to_xml_recursion++;
                last CHECK_RECURSE if $inside_to_xml_recursion > 1;
            }
            $i++;
        }
        if ( $inside_to_xml_recursion <= 1 ) {
            my $tmp_namespaces = get_namespaces();
            for my $ns ( keys %{$tmp_namespaces} ) {
                $attrs->{ 'xmlns:' . $ns } = $tmp_namespaces->{$ns};

lib/Bio/Phylo/Treedrawer.pm  view on Meta::CPAN

            my $mutator = lc $key;
            $mutator =~ s/^-/set_/;
            $self->$mutator( $opts{$key} );
        }
    }
    return $self;
}

sub _cascading_setter {
    my ( $self, $value ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ( my $tree = $self->get_tree ) {
        if ( $tree->can($subroutine) ) {
            $tree->$subroutine($value);
        }
    }
    $subroutine =~ s/^set_//;
    $self->{ uc $subroutine } = $value;
    return $self;
}

sub _cascading_getter {
    my ( $self, $invocant ) = @_;
    my ( $package, $filename, $line, $subroutine ) = caller(1);
    $subroutine =~ s/.*://;
    $logger->debug($subroutine);
    if ( $invocant ) {
        
        # The general idea is that there are certain properties that can potentially be
        # set globally (i.e. in this package) or at the level of the object it applies
        # to. For example, maybe we want to set the node radius globally here, or maybe
        # we want to set it on the node. The idea, here, is then that we might first
        # check to see if the values are set on $invocant, and if not, return the global
        # value. The way this used to be done was by calling ->can(), however, because of

lib/Bio/Phylo/Util/Logger.pm  view on Meta::CPAN

        }
        return $class;
    }
    
    # this is never called directly. rather, messages are dispatched here
    # by the DEBUG() ... FATAL() subs below
    sub LOG ($$) {
        my ( $message, $level ) = @_;
        
        # probe the call stack
        my ( $pack2, $file2, $line2, $sub  ) = caller( $TRACEBACK + 2 );
        my ( $pack1, $file,  $line,  $sub1 ) = caller( $TRACEBACK + 1 );
        
        # cascade verbosity from global to local
        my $verbosity = $VERBOSITY{'*'}; # global
        $verbosity = $VERBOSITY{$pack1} if exists $VERBOSITY{$pack1}; # package
        $verbosity = $VERBOSITY{$sub}  if $sub and exists $VERBOSITY{$sub}; # sub
        
        # verbosity is higher than the current caller, proceed
        if ( $verbosity >= $levels{$level} ) {            

            # strip the prefix from the calling file's path

lib/Bio/Phylo/Util/StackTrace.pm  view on Meta::CPAN

=cut

sub new {
    my $class = shift;
    my $self  = [];
    my $i     = 0;
    my $j     = 0;

    package DB;    # to get @_ stack from previous frames, see perldoc -f caller
    while ( my @frame = caller($i) ) {
        my $package = $frame[0];
        if ( not Bio::Phylo::Util::StackTrace::_skip_me($package) ) {
            my @args = @DB::args;
            $self->[ $j++ ] = [ @frame, @args ];
        }
        $i++;
    }

    package Bio::Phylo::Util::StackTrace;
    shift @$self;    # to remove "throw" frame