File Coverage

blib/lib/Devel/Chitin/Stack.pm

Criterion	Covered	Total	%
statement	13	88	14.7
branch	0	28	0.0
condition	0	17	0.0
subroutine	5	19	26.3
pod	5	7	71.4
total	23	159	14.4

package Devel::Chitin::Stack;

use strict;
use warnings;

our $VERSION = '0.16';

our @saved_ARGV;
BEGIN {
    @saved_ARGV = @ARGV;
}

my @caller_values = qw(package filename line subroutine hasargs wantarray
                       evaltext is_require hints bitmask);

# DB::DB will wipe this out between stoppages.
our $stack_object;

sub invalidate { undef($stack_object) }

sub new {
    my $class = shift;
    return $stack_object if $stack_object;

    my @frames;
    my $in_debugger_frames = 1;
    my $next_AUTOLOAD_idx = 0;
    my $serial_iter = _serial_iterator();
    my @prev_loc;

    my $level;
    for($level = 0; ; $level++) {
        my %caller;
        do {
            package DB;
            @caller{@caller_values} = caller($level);
        };
        last unless defined($caller{line});  # no more frames

        {
            my @this = @caller{'filename','line','package'};
            @caller{'filename','line','package'} = @prev_loc;
            @prev_loc = @this;
        }

        if ($caller{subroutine} eq 'DB::DB') {
            # entered the debugger here, start over recording frames
            $in_debugger_frames = 0;
            next;
        }
        next if $in_debugger_frames;

        #next if $skip;

        $caller{args} = [ @DB::args ];
        $caller{callsite} = Devel::Chitin::Location::get_callsite($level);

        # subname is the subroutine without the package part
        $caller{subname} = $caller{subroutine} =~ m/\b(\w+$|__ANON__)/ ? $1 : $caller{subroutine};
        if ($caller{subname} eq 'AUTOLOAD') {
            # needs support in DB::sub for storing the names of AUTOLOADed subs
            my($autoload) = $DB::AUTOLOAD_names[ $next_AUTOLOAD_idx++ ] =~ m/::(\w+)$/;
            $caller{autoload} = $autoload;
        } else {
            $caller{autoload} = undef;
        }

        # if it's a string eval, add info about what file and line the source string
        # came from
        @caller{'evalfile','evalline'} = ($caller{filename} || '')  =~ m/\(eval \d+\)\[(.*?):(\d+)\]/;

        # perl 5.10.* and earlier use 0 for scalar context.
        # Normalize this value to the empty string for scalar context
        $caller{wantarray} = '' if (defined($caller{wantarray}) and !$caller{wantarray});

        # Normalize hasargs.  eval-frames will always have 0.  Subroutines called with the
        # &subname; syntax will have '' returned from caller() starting with perl 5.12.
        $caller{hasargs} = '' if (! $caller{hasargs} and $caller{subroutine} ne '(eval)');

        $caller{serial} = $serial_iter->(@caller{'subroutine','filename','line'});

        $caller{level} = $level;

        push @frames, Devel::Chitin::StackFrame->_new(%caller);
    }

    # fab up a frame for the main program
    push @frames, Devel::Chitin::StackFrame->_new(
                    'package'   => 'main',
                    filename    => $prev_loc[0],
                    line        => $prev_loc[1],
                    subroutine  => 'main::MAIN',
                    subname     => 'MAIN',
                    'wantarray' => undef,
                    evaltext    => undef,
                    evalfile    => undef,
                    evalline    => undef,
                    is_require  => undef,
                    hints       => '',   # hints and bitmask here are just the values
                    bitmask     => 256,  # caller() always gives for the top-level caller
                    autoload    => undef,
                    hasargs     => 1,
                    args        => \@saved_ARGV,
                    level       => $level,
                    serial      => $Devel::Chitin::stack_serial[0]->[-1],
                    callsite    => undef,
                );

    return $stack_object = bless \@frames, $class;
}

sub _serial_iterator {
    my $next_idx = $#Devel::Chitin::stack_serial;

    return sub {
        my($subname, $filename, $line) = @_;

        return unless @Devel::Chitin::stack_serial;

        if (index($subname, '(eval') >= 0) {
            my $this_sub_serial = $Devel::Chitin::stack_serial[$next_idx]->[1];
            return $Devel::Chitin::eval_serial{$this_sub_serial}{$line} ||= DB::_allocate_sub_serial();
        }

        for (my $i = $next_idx; $i >= 0; $i--) {
            if ($subname eq $Devel::Chitin::stack_serial[$i]->[0]
                or
                (index($subname, '__ANON__[') >= 0 and ref($Devel::Chitin::stack_serial[$i]->[0]) eq 'CODE')
            ) {
                $next_idx = $i - 1;
                return $Devel::Chitin::stack_serial[$i]->[-1];
            }
        }
        return DB::_allocate_sub_serial();  # Punt by making a new one up
    };
}

sub depth {
    my $self = shift;
    return scalar(@$self);
}

sub iterator {
    my $self = shift;
    my $i = 0;
    return sub {
        return unless $self;

        my $frame = $self->[$i++];
        unless ($frame) {
            undef($self);
        }
        return $frame;
    };
}

sub frame {
    my($self, $i) = @_;
    return ($i < @$self) ? $self->[$i] : ();
}

sub frames {
    my $self = shift;
    return @$self;
}

sub as_string {
    my $self = shift;
    my $string = '';
    for (my $iter = $self->iterator; my $frame = $iter->(); ) {
        $string .= $frame->as_string . "\n";
    }
    return $string;
}


package Devel::Chitin::StackFrame;

sub _new {
    my($class, %params) = @_;
    return bless \%params, $class;
}

# Accessors
BEGIN {
    no strict 'refs';
    foreach my $acc ( qw(package filename line subroutine hasargs wantarray
                         evaltext is_require hints bitmask
                         subname autoload level evalfile evalline serial callsite ) ) {
        *{$acc} = sub { return shift->{$acc} };
    }
}

sub args {
    my $args = shift->{args};
    return @$args;
}

sub as_string {
    my $self = shift;
    return sprintf('%s at %s:%d', map { $self->$_ } qw(subroutine filename line));
}

1;

__END__