Skip to content

Instantly share code, notes, and snippets.

@wki

wki/gist:334969

Created March 17, 2010 06:12
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save wki/334969 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save wki/334969 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. wki created this gist Mar 17, 2010.
    71 changes: 71 additions & 0 deletions gistfile1.PL
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,71 @@
    # real location of this library:
    # /some/perl-search/path/Devel/CatDebug.pm
    #
    # debug your application like this:
    # $ PERL5LIB=./lib perl -d:CatDebug ./script/name_or_your_app_server.pl
    #
    package DB;

    our $stack_depth = 0;
    our $must_show = 0;

    sub DB {
    $must_show = 0 if ($must_show > $stack_depth);
    return if (!$must_show);

    ($package, $filename, $line, $subroutine, $hasargs,
    $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
    = caller(1);

    print STDERR "[$stack_depth] in $subroutine ($filename $line)\n"
    if ($must_show);
    }

    sub sub {
    if ($sub =~ m{\A Catalyst::Engine::HTTP::_handler}xms) {
    $must_show = $stack_depth + 1;
    }

    if ($must_show) {
    my $p = join(', ',
    map {
    if (tied($_)) {
    '<tied: ' . ref(tied($_)) . '>'
    } elsif (ref($_)) {
    # we need something like this because
    # stringification might cause endless loops...
    '<' . ref($_) . '>'
    } elsif (defined($_)) {
    # this seems to have negative side effects:
    #s{(.*)}{'$1'}xms
    # if (!m{\A (?: -?[\d.]+ | \*[\w:]* ) \z}xms);
    m{\A (?: -?[\d.]+ | \*[\w:]* ) \z}xms
    ? $_
    : "'$_'";
    } else {
    '-undef-'
    }
    }
    @_);
    print STDERR "[$stack_depth] calling $sub($p)\n"
    }

    local $stack_depth = $stack_depth + 1;

    # if we are interested in return values we might use:
    #
    # if (wantarray) {
    # my @result = &$sub;
    # return @result;
    # } elsif (defined wantarray) {
    # my $result = &$sub;
    # return $result;
    # } else {
    # &$sub;
    # return;
    # }

    &$sub;
    }

    1;