view release on metacpan or  search on metacpan

lib/Sepia/Debug.pm  view on Meta::CPAN

package Sepia::Debug;
# use Sepia;
use Carp ();                    # old Carp doesn't export shortmess.
use Text::Abbrev;
use strict;
use vars qw($pack $file $line $sub $level
            $STOPDIE $STOPWARN);

sub define_shortcut;
*define_shortcut = *Sepia::define_shortcut;

BEGIN {
    ## Just leave it on -- with $DB::trace = 0, there doesn't seem
    ## to be a performance penalty!
    ##
    ## Flags we use are (see PERLDBf_* in perl.h):
    ## 0x1	Debugging sub enter/exit (call DB::sub if defined)
    ## 0x2      per-line debugging (keep line numbers)
    ## 0x8      "preserve more data" (call DB::postponed??)
    ## 0x10     keep line ranges for sub definitions in %DB::sub
    ## 0x100    give evals informative names
    ## 0x200    give anon subs informative names
    ## 0x400    save source lines in %{"_<$filename"}
    $^P = 0x01 | 0x02 | 0x10 | 0x100 | 0x200;
    $STOPDIE = 1;
    $STOPWARN = 0;
}

sub peek_my
{
    eval q{ require PadWalker };
    if ($@) {
        +{ }
    } else {
        *peek_my = \&PadWalker::peek_my;
        goto &peek_my;
    }
}

# set debugging level
sub repl_debug
{
    debug(@_);
}

sub repl_backtrace
{
    for (my $i = 0; ; ++$i) {
        my ($pack, $file, $line, $sub) = caller($i);
        last unless $pack;
        $Sepia::SIGGED && do { $Sepia::SIGGED--; last };
        # XXX: 4 is the magic number...
        print($i == $level+4 ? "*" : ' ', " [$i]\t$sub ($file:$line)\n");
    }
}

# return value from die
sub repl_return
{
    if ($Sepia::WANTARRAY) {
        @Sepia::REPL_RESULT = $Sepia::REPL{eval}->(@_);
    } else {
        $Sepia::REPL_RESULT[0] = $Sepia::REPL{eval}->(@_);
    }
    last repl;
}

use vars qw($DIE_TO @DIE_RETURN $DIE_LEVEL);
$DIE_LEVEL = 0;

sub xreturn
{
    eval q{ use Scope::Upper ':all' };
    if ($@) {
        print "xreturn requires Sub::Uplevel.\n";
        return;
    } else {
        *xreturn = eval <<'EOS';
        sub {
            my $exp = shift;
            $exp = '""' unless defined $exp;
            my $ctx = CALLER($level+4); # XXX: ok?
            local $Sepia::WANTARRAY = want_at $ctx;
            my @res = eval_in_env($exp, peek_my($level + 4));
            print STDERR "unwind(@res)\n";
            unwind @res, SUB UP $ctx;
        };
EOS
        goto &xreturn;
    }
}

sub repl_xreturn
{
    print STDERR "XRETURN(@_)\n";