Devel-Backtrace-0.12/0000755000175000001440000000000011137447731013230 5ustar pepeusersDevel-Backtrace-0.12/lib/0000755000175000001440000000000011137447731013776 5ustar pepeusersDevel-Backtrace-0.12/lib/Devel/0000755000175000001440000000000011137447731015035 5ustar pepeusersDevel-Backtrace-0.12/lib/Devel/DollarAt.pm0000444000175000001440000002002611137447731017073 0ustar pepeuserspackage Devel::DollarAt; use strict; use warnings; use base qw(Class::Accessor::Fast); use Devel::Backtrace; our $VERSION = '0.02'; __PACKAGE__->mk_accessors( qw(backtrace err propagated inputline inputhandle filename line) ); # Note that to_string also internally called if an exception isn't catched by # any eval and the error must be printed to STDERR. use overload '""' => \&to_string; $SIG{__DIE__} = \&_diehandler; our $FRAME; # This will be called every time the code says "die". However it won't be # called for other errors, such as division by zero. So we still have to use # $SIG{__DIE__}. *CORE::GLOBAL::die = sub (@) { my $text = ''; defined and $text .= $_ for @_; my $err = $@; if (defined($err) && length($err) && !length $text) { # In this case, perl would pass "$@\t...propagated at foo line bar.\n" # to the __DIE__ handler. Because we don't want to parse that, we make # perl think $text is not empty. # We have to store $err in our NullMessage because perl will cleanse $@ # before calling the __DIE__ handler. This is very strange, because it # won't get cleansed if we don't override *CORE::GLOBAL::die. $text = Devel::DollarAt::NullMessage->_new(propagated=>$err); } CORE::die($text); }; sub _diehandler { my ($err) = @_; my $propagated = $@; if (ref($err) && $err->isa('Devel::DollarAt::NullMessage')) { $propagated = $err->{propagated}; $err = ''; } my $backtrace = Devel::Backtrace->new(1); my $skip = $backtrace->skipmysubs(); # skips this handler plus our overridden # CORE::GLOBAL::die if possible CORE::die "Strange:\n$backtrace" unless $skip; my ($inputhandle, $inputline); if ($err =~ s/^(.*) at .*?(?:<(.*)> line (\d+)|)\.\n\z/$1/s) { ($inputhandle, $inputline) = ($2, $3); } my $dollarat = __PACKAGE__->_new({ backtrace => $backtrace, err => $err, filename => $skip->filename, line => $skip->line, } ); if (defined $inputline) { $dollarat->inputline($inputline); $dollarat->inputhandle($inputhandle); } if (defined $propagated and length $propagated) { $dollarat->propagated($propagated); } CORE::die($dollarat); } # Try to appear exactly like the normal $@ sub to_string { my $this = shift; my $text = $this->err; if (defined ($this->propagated)) { if (!length($text)) { $text = $this->propagated . "\t...propagated"; } } unless ($text =~ /\n\z/) { $text .= ' at ' . $this->filename . ' line ' . $this->line; if (defined $this->inputline) { $text .= ', <'.$this->inputhandle . '> line ' . $this->inputline; } } $text .= '.'; $text = "[[$text]]" if $FRAME; $text .= "\n"; return $text; } sub _new { my $class = shift; my $this = $class->SUPER::new(@_); return $this; } sub import { my $class = shift; for (@_) { if ('frame' eq $_) { $FRAME = 1; } else { die 'Unknown parameter for '.__PACKAGE__.": $_"; } }; } sub redie { my $this = shift; my ($package, $filename, $line) = caller; push @{$this->{redispatch_points}}, Devel::DollarAt::RedispatchPoint->new({ package => $package, filename => $filename, line => $line, } ); local $SIG{__DIE__}; CORE::die($this); } sub redispatch_points { my $this = shift; return @{$this->{redispatch_points} || []}; } package # hide from pause Devel::DollarAt::NullMessage; #use overload '""' => sub {''}; sub _new { shift; bless {@_}; } package # hide from pause Devel::DollarAt::RedispatchPoint; use base qw(Class::Accessor::Fast); __PACKAGE__->mk_ro_accessors(qw(package filename line)); use overload '""' => sub { my $this = shift; return 'redispatched from '.$this->package.' at ' .$this->filename.':'.$this->line."\n"; }; 1 __END__ =head1 NAME Devel::DollarAt - Give magic abilities to $@ =head1 SYNOPSIS use Devel::DollarAt; eval "0/0"; print $@, $@->backtrace; $@->redie; =head1 DESCRIPTION Using eval {}, you may catch Perl exceptions almost like you do it with try {} in Java. However there are days when you miss some features of exceptions. The only thing you know about the error that occured is the string $@, which combines the error message and technical data like the line number. The Devel::DollarAt module gives some functionality to the $@ scalar. Once you say "use Devel::DollarAt", the module is active program-wide. If an exception occurs anywhere in any module, $@ will be globally set to an object of class Devel::DollarAt. Apart from performance, this shouldn't be a problem because $@ tries to be downwardly compatible to the normal $@. However using this package in CPAN modules or large software projects is discouraged. =head1 DISCLAIMER Use this module only for debugging. Don't think of it as an exception framework for Perl or something like that. It just gives magic abilities to $@, that's all. =head1 METHODS =over 8 =item backtrace Returns a L object, which lets you inspect the callers of the fatality. =item filename Returns the name of the file in which the error occured. =item inputhandle Returns the file handle which has most recently be read from at the time of the error. =item inputline Returns the line number of C<< $@->inputhandle >> (which is $.) at the time of the error. =item line Returns the number of the line in which the error occured. =item redie Redispatches this exception to the next eval{}. =item redispatch_points Returns a list of objects with informations about when this exception was redispatched. Each object has got the accessors "package", "filename" and "line". In string context, the objects will look like "redispatched from FooPackage at file.pl:17\n". =item to_string Returns a string that looks quite like the normal $@, e. g. "Illegal division by zero at foo.pl line 42, <> line 13." Devel::DollarAt overloads the "" (stringification) operator to this method. =back =head1 EXAMPLES A very simple (and pointless) way to use Devel::DollarAt is this oneliner: perl -MDevel::DollarAt -e '0/0' It bails out with "Illegal division by zero at -e line 1." and an exit status of 1, just like it would have done if you hadn't supplied -MDevel::DollarAt. This is because the magically modified $@ variable gets stringified when perl prints it as exit reason. If you actually want to see the difference, use perl -MDevel::DollarAt=frame -e '0/0' This bails out with "[[Illegal division by zero at -e line 1.]]" so you can see that something has happened. =head1 KNOWN PROBLEMS This module requires that no other code tampers with C<$SIG{__DIE__}> or C<*CORE::GLOBAL::die>. A not widely known feature of Perl is that it can propagate $@. If you call die() without parameters or with an empty string or an undefined value, the error message will be "Died". However, if $@ was set to some value before this, the previous error message will be used with "\t...propagated" appended: perl -e '$@="7"; die" 7 ...propagated at -e line 1. Devel::DollarAt emulates this behaviour. If you use the above example but leave out the double quotes, perl's behaviour is different as of version 5.8.8: perl -e '$@=7; die' 7 at -e line 1. Devel::DollarAt does not emulate this behaviour: perl -MDevel::DollarAt -e '$@=7; die' 7 ...propagated at -e line 1. If a previous $@ is propagated, inputhandle and inputline won't work. They won't be interpolated into the stringified $@, either. If perl comes across syntax errors, $@ appears to be just a string as usual. Apparently C<$SIG{__DIE__}> won't be called for syntax errors. =head1 AUTHOR Christoph Bussenius If you use this module, I'll be glad if you drop me a note. You should mention this module's name in the subject of your mails, in order to make sure they won't get lost in all the spam. =head1 LICENSE This module is in the public domain. If your country's law does not allow this module being in the public domain or does not include the concept of public domain, you may use the module under the same terms as perl itself. =cut Devel-Backtrace-0.12/lib/Devel/Backtrace.pm0000444000175000001440000001472711137447731017263 0ustar pepeuserspackage Devel::Backtrace; use strict; use warnings; use Devel::Backtrace::Point; use Carp; use overload '""' => \&to_string; =head1 NAME Devel::Backtrace - Object-oriented backtrace =head1 VERSION This is version 0.12. =cut our $VERSION = '0.12'; =head1 SYNOPSIS my $backtrace = Devel::Backtrace->new; print $backtrace; # use automatic stringification # See EXAMPLES to see what the output might look like print $backtrace->point(0)->line; =head1 METHODS =head2 Devel::Backtrace->new() Optional parameters: -start => $start, -format => $format If only one parameter is given, it will be used as $start. Constructs a new C which is filled with all the information C provides, where C<$i> starts from C<$start>. If no argument is given, C<$start> defaults to 0. If C<$start> is 1 (or higher), the backtrace won't contain the information that (and where) Devel::Backtrace::new() was called. =cut sub new { my $class = shift; my (@opts) = @_; my $start; my %pointopts; if (1 == @opts) { $start = shift @opts; } while (my $opt = shift @opts) { if ('-format' eq $opt) { $pointopts{$opt} = shift @opts; } elsif ('-start' eq $opt) { $start = shift @opts; } else { croak "Unknown option $opt"; } } if (defined $start) { $pointopts{'-skip'} = $start; } else { $start = 0; } my @backtrace; for (my $deep = $start; my @caller = caller($deep); ++$deep) { push @backtrace, Devel::Backtrace::Point->new( \@caller, -level => $deep, %pointopts, ); } return bless \@backtrace, $class; } =head2 $backtrace->point($i) Returns the i'th tracepoint as a L object (see its documentation for how to access every bit of information). Note that the following code snippet will print the information of C: print Devel::Backtrace->new($start)->point($i) =cut sub point { my $this = shift; my ($i) = @_; return $this->[$i]; } =head2 $backtrace->points() Returns a list of all tracepoints. In scalar context, the number of tracepoints is returned. =cut sub points { my $this = shift; return @$this; } =head2 $backtrace->skipme([$package]) This method deletes all leading tracepoints that contain information about calls within C<$package>. Afterwards the C<$backtrace> will look as though it had been created with a higher value of C<$start>. If the optional parameter C<$package> is not given, it defaults to the calling package. The effect is similar to what the L module does. This module ships with an example "skipme.pl" that demonstrates how to use this method. See also L. =cut sub skipme { my $this = shift; my $package = @_ ? $_[0] : caller; my $skip = 0; my $skipped; while (@$this and $package eq $this->point(0)->package) { $skipped = shift @$this; $skip++; } $this->_adjustskip($skip); return $skipped; } sub _adjustskip { my ($this, $newskip) = @_; $_->_skip($newskip + ($_->_skip || 0)) for $this->points; } =head2 $backtrace->skipmysubs([$package]) This method is like C except that it deletes calls I the package rather than calls I the package. Before discarding those calls, C is called. This is because usually the topmost call in the stack is to Devel::Backtrace->new, which would not be catched by C otherwise. This means that skipmysubs usually deletes more lines than skipme would. C was added in Devel::Backtrace version 0.06. See also L and the example "skipme.pl". =cut sub skipmysubs { my $this = shift; my $package = @_ ? $_[0] : caller; my $skipped = $this->skipme($package); my $skip = 0; while (@$this and $package eq $this->point(0)->called_package) { $skipped = shift @$this; $skip++; } $this->_adjustskip($skip); return $skipped; } =head2 $backtrace->to_string() Returns a string that contains one line for each tracepoint. It will contain the information from C's to_string() method. To get more information, use the to_long_string() method. Note that you don't have to call to_string() if you print a C object or otherwise treat it as a string, as the stringification operator is overloaded. See L. =cut sub to_string { my $this = shift; return join '', map "$_\n", $this->points; } =head2 $backtrace->to_long_string() Returns a very long string that contains several lines for each trace point. The result will contain every available bit of information. See L for an example of what the result looks like. =cut sub to_long_string { my $this = shift; return join "\n", map $_->to_long_string, $this->points; } 1 __END__ =head1 EXAMPLES A sample stringification might look like this: Devel::Backtrace::new called from MyPackage (foo.pl:30) MyPackage::test2 called from MyPackage (foo.pl:28) MyPackage::test1 called from main (foo.pl:18) main::bar called from main (foo.pl:6) main::foo called from main (foo.pl:13) If MyPackage called skipme, the first two lines would be removed. If it called skipmysubs, the first three lines would be removed. If you don't like the format, you can change it: my $backtrace = Devel::Backtrace->new(-format => '%I. %s'); This would produce a stringification of the following form: 0. Devel::Backtrace::new 1. MyPackage::test2 2. MyPackage::test1 3. main::bar 4. main::foo =head1 SEE ALSO L does mostly the same as this module. I'm afraid I hadn't noticed it until I uploaded this module. L is a simpler module which gives you a backtrace in string form. L comes with this distribution and is a nice application of this module. You can use it for debugging to get a backtrace out of $@. =head1 AUTHOR Christoph Bussenius If you use this module, I'll be glad if you drop me a note. You should mention this module's name in the subject of your mails, in order to make sure they won't get lost in all the spam. =head1 LICENSE This module is in the public domain. If your country's law does not allow this module being in the public domain or does not include the concept of public domain, you may use the module under the same terms as perl itself. =cut Devel-Backtrace-0.12/lib/Devel/Backtrace/0000755000175000001440000000000011137447731016714 5ustar pepeusersDevel-Backtrace-0.12/lib/Devel/Backtrace/Point.pm0000444000175000001440000001753311137447731020352 0ustar pepeuserspackage Devel::Backtrace::Point; use strict; use warnings; our $VERSION = '0.11'; use Carp; use String::Escape qw(printable); =head1 NAME Devel::Backtrace::Point - Object oriented access to the information caller() provides =head1 SYNOPSIS print Devel::Backtrace::Point->new([caller(0)])->to_long_string; =head1 DESCRIPTION This class is a nice way to access all the information caller provides on a given level. It is used by L, which generates an array of all trace points. =cut use base qw(Class::Accessor::Fast); use overload '""' => \&to_string; use constant; BEGIN { my @known_fields = (qw(package filename line subroutine hasargs wantarray evaltext is_require hints bitmask hinthash)); # The number of caller()'s return values depends on the perl version. For # instance, hinthash is not available below perl 5.9. We try and see how # many fields are supported my $supported_fields_number = () = caller(0) or die "Caller doesn't work as expected"; # If not all known fields are supported, remove some while (@known_fields > $supported_fields_number) { pop @known_fields; } # If not all supported fields are known, add placeholders while (@known_fields < $supported_fields_number) { push @known_fields, "_unknown".scalar(@known_fields); } constant->import (FIELDS => @known_fields); } =head1 METHODS =head2 $p->package, $p->filename, $p->line, $p->subroutine, $p->hasargs, $p->wantarray, $p->evaltext, $p->is_require, $p->hints, $p->bitmask, $p->hinthash See L for documentation of these fields. hinthash is only available in perl 5.9 and higher. When this module is loaded, it tests how many values caller returns. Depending on the result, it adds the necessary accessors. Thus, you should be able to find out if your perl supports hinthash by using L: Devel::Backtrace::Point->can('hinthash'); =cut __PACKAGE__->mk_ro_accessors(FIELDS); =head2 $p->level This is the level given to new(). It's intended to be the parameter that was given to caller(). =cut __PACKAGE__->mk_ro_accessors('level'); =head2 $p->called_package This returns the package that $p->subroutine is in. If $p->subroutine does not contain '::', then '(unknown)' is returned. This is the case if $p->subroutine is '(eval)'. =cut sub called_package { my $this = shift; my $sub = $this->subroutine; my $idx = rindex($sub, '::'); return '(unknown)' if -1 == $idx; return substr($sub, 0, $idx); } =head2 $p->by_index($i) You may also access the fields by their index in the list that caller() returns. This may be useful if some future perl version introduces a new field for caller, and the author of this module doesn't react in time. =cut sub by_index { my ($this, $idx) = @_; my $fieldname = (FIELDS)[$idx]; unless (defined $fieldname) { croak "There is no field with index $idx."; } return $this->$fieldname(); } =head2 new([caller($i)]) This constructs a Devel::Backtrace object. The argument must be a reference to an array holding the return values of caller(). This array must have either three or ten elements (or eleven if hinthash is supported) (see L). Optional additional parameters: -format => 'formatstring', -level => $i The format string will be used as a default for to_string(). The level should be the parameter that was given to caller() to obtain the caller information. =cut __PACKAGE__->mk_ro_accessors('_format'); __PACKAGE__->mk_accessors('_skip'); sub new { my $class = shift; my ($caller, %opts) = @_; my %data; unless ('ARRAY' eq ref $caller) { croak 'That is not an array reference.'; } if (@$caller == (() = FIELDS)) { for (FIELDS) { $data{$_} = $caller->[keys %data] } } elsif (@$caller == 3) { @data{qw(package filename line)} = @$caller; } else { croak 'That does not look like the return values of caller.'; } for my $opt (keys %opts) { if ('-format' eq $opt) { $data{'_format'} = $opts{$opt}; } elsif ('-level' eq $opt) { $data{'level'} = $opts{$opt}; } elsif ('-skip' eq $opt) { $data{'_skip'} = $opts{$opt}; } else { croak "Unknown option $opt"; } } return $class->SUPER::new(\%data); } sub _virtlevel { my $this = shift; return $this->level - ($this->_skip || 0); } =head2 $tracepoint->to_string() Returns a string of the form "Blah::subname called from main (foo.pl:17)". This means that the subroutine C from package C was called by package C
in C line 17. If you print a C object or otherwise treat it as a string, to_string() will be called automatically due to overloading. Optional parameters: -format => 'formatstring' The format string changes the appearance of the return value. It can contain C<%p> (package), C<%c> (called_package), C<%f> (filename), C<%l> (line), C<%s> (subroutine), C<%a> (hasargs), C<%e> (evaltext), C<%r> (is_require), C<%h> (hints), C<%b> (bitmask), C<%i> (level), C<%I> (level, see below). The difference between C<%i> and C<%I> is that the former is the argument to caller() while the latter is actually the index in $backtrace->points(). C<%i> and C<%I> are different if C<-start>, skipme() or skipmysubs() is used in L. If no format string is given, the one passed to C will be used. If none was given to C, the format string defaults to 'default', which is an abbreviation for C<%s called from %p (%f:%l)>. Format strings have been added in Devel-Backtrace-0.10. =cut my %formats = ( 'default' => '%s called from %p (%f:%l)', ); my %percent = ( 'p' => 'package', 'c' => 'called_package', 'f' => 'filename', 'l' => 'line', 's' => 'subroutine', 'a' => 'hasargs', 'w' => 'wantarray', 'e' => 'evaltext', 'r' => 'is_require', 'h' => 'hints', 'b' => 'bitmask', 'i' => 'level', 'I' => '_virtlevel', ); sub to_string { my ($this, @opts) = @_; my %opts; if (defined $opts[0]) { # check that we are not called as stringification %opts = @opts; } my $format = $this->_format(); for my $opt (keys %opts) { if ($opt eq '-format') { $format = $opts{$opt}; } else { croak "Unknown option $opt"; } } $format = 'default' unless defined $format; $format = $formats{$format} if exists $formats{$format}; my $result = $format; $result =~ s{%(\S)} { my $percent = $percent{$1} or croak "Unknown symbol %$1\n"; my $val = $this->$percent(); defined($val) ? printable($val) : 'undef'; }ge; return $result; } =head2 $tracepoint->to_long_string() This returns a string which lists all available fields in a table that spans several lines. Example: package: main filename: /tmp/foo.pl line: 6 subroutine: main::foo hasargs: 1 wantarray: undef evaltext: undef is_require: undef hints: 0 bitmask: \00\00\00\00\00\00\00\00\00\00\00\00 hinthash is not included in the output, as it is a hash. =cut sub to_long_string { my $this = shift; return join '', map { "$_: " . (defined ($this->{$_}) ? printable($this->{$_}) : 'undef') . "\n" } grep { ! /^_/ && 'hinthash' ne $_ } FIELDS; } =head2 FIELDS This constant contains a list of all the available field names. The number of fields depends on your perl version. =cut 1 __END__ =head1 SEE ALSO L =head1 AUTHOR Christoph Bussenius =head1 LICENSE This Perl module is in the public domain. If your country's law does not allow this module being in the public domain or does not include the concept of public domain, you may use the module under the same terms as perl itself. =cut Devel-Backtrace-0.12/t/0000755000175000001440000000000011137447731013473 5ustar pepeusersDevel-Backtrace-0.12/t/dollarat.t0000444000175000001440000000106211137447731015457 0ustar pepeusers#!perl use strict; use warnings; use Test::More tests => 4; use Devel::DollarAt; eval 'print 0/0; "foo"'; # Don't worry about the "foo"; it serves to make perl 5.8 and 5.10 output the # same line number so I can use this example in the tests. my $dollarat = $@; like("$dollarat", qr{^Illegal division by zero at \(eval \d+\) line 1\.$}, 'stringification'); is ($dollarat->line, 1, 'line'); is ($dollarat->backtrace->point(0)->subroutine, '(eval)', 'subroutine is eval'); is ($dollarat->backtrace->point(0)->called_package, '(unknown)', 'called_package'); Devel-Backtrace-0.12/t/basic.t0000444000175000001440000000315511137447731014743 0ustar pepeusers#!perl use strict; use warnings; use Test::More tests => 7; use Devel::Backtrace; my ($line0, $line1, $line2); sub foo { $line1 = __LINE__; bar(); } sub bar { $line2 = __LINE__; my $backtrace1 = Devel::Backtrace->new; my $backtrace1_str = "$backtrace1"; $backtrace1_str =~ tr#\\#/#; is ($backtrace1_str, qq{Devel::Backtrace::new called from main (t/basic.t:$line2) main::bar called from main (t/basic.t:$line1) main::foo called from main (t/basic.t:$line0)\n}, 'stringification'); my $backtrace2 = Devel::Backtrace->new(1); $backtrace2 =~ tr#\\#/#; is ("$backtrace2", qq{main::bar called from main (t/basic.t:$line1) main::foo called from main (t/basic.t:$line0)\n}, 'stringification with argument 1 to new'); my $backtrace3 = Devel::Backtrace->new(2); my $backtrace3_str = "$backtrace3"; $backtrace3_str =~ tr#\\#/#; is($backtrace3_str, qq{main::foo called from main (t/basic.t:$line0)\n}, 'stringification with argument 2 to new'); like($backtrace3->to_long_string, qr{^ package:\s*main\n filename:\s*t[\\/]basic\.t\n line:\s*\Q$line0\E\n subroutine:\s*main::foo\n hasargs:\s*1\n wantarray:\s*undef\n evaltext:\s*undef\n is_require:\s*undef\n hints:.*\n bitmask:.*\n \z}x, 'to_long_string'); is ($backtrace1->point(1)->line, $line1, 'line number'); is( $backtrace1->point(0)->called_package, 'Devel::Backtrace', 'called_package'); my $backtrace4 = Devel::Backtrace->new(-start => 1, -format => 'subroutine %s, package %c from %p'); is($backtrace4->point(0).'', 'subroutine main::bar, package main from main', 'format strings'); } $line0 = __LINE__; foo(); Devel-Backtrace-0.12/t/by_index.t0000444000175000001440000000057611137447731015467 0ustar pepeusers#!perl use Test::More tests => 2; use Devel::Backtrace; sub get_caller_index { my $idx = shift; my $bt = Devel::Backtrace->new; return $bt->point(1)->by_index($idx); } my $sub = get_caller_index(3); # 3 is subroutine is($sub, 'main::get_caller_index', 'field 3'); eval { get_caller_index(7000); }; like($@, qr/There is no field with index 7000/, 'field 7000'); Devel-Backtrace-0.12/t/skipme.t0000444000175000001440000000427411137447731015155 0ustar pepeusers#!/usr/bin/perl use strict; use warnings; use Devel::Backtrace; use Test::More tests => 8; Foo::foo1(); { package Foo; sub foo1 { foo2(); } sub foo2 { Bar::bar1(); } } { package Bar; sub bar1 { bar2(); } sub bar2 { Baz::baz1(); } } { package Baz; sub baz1 { baz2(); } sub baz2 { baz3(); } sub baz3 { my $backtrace = Devel::Backtrace->new; warn "pure backtrace: $backtrace" if $ENV{DEBUG}; # Tell Devel::Backtrace that we are not interested in what Baz method # calls which Baz method. $backtrace->skipme; warn "backtrace: $backtrace" if $ENV{DEBUG}; use Test::More; is(scalar($backtrace->points), 5, 'skipme count') or warn "skipme count: $backtrace"; is($backtrace->point(0)->subroutine, 'Baz::baz1', 'skipme') or warn "skipme: $backtrace"; my $backtrace2 = Devel::Backtrace->new; # Tell Devel::Backtrace that we are not even interested where the first # Baz method was called. $backtrace2->skipmysubs; is (scalar($backtrace2->points), 4, 'skipmysubs count') or warn "skipmysubs count: $backtrace"; is ($backtrace2->point(0)->subroutine, 'Bar::bar2', 'skipmysubs') or warn "skipmysubs: $backtrace"; warn "backtrace2: $backtrace2" if $ENV{DEBUG}; my $backtrace3 = Devel::Backtrace->new(1); $backtrace3->skipmysubs('Baz'); warn "backtrace3: $backtrace3" if $ENV{DEBUG}; is ($backtrace3->point(1)->to_string(-format => '%I'), 1, '%I') or warn "%I: $backtrace3"; is ($backtrace3->point(1)->_skip, 4, '_skip') or warn "_skip: $backtrace3"; is ($backtrace3->point(1)->to_string(-format => '%i'), 5, '%i') or warn "%i: $backtrace3"; # Same as above, but use -start instead of plain argument to new. my $backtrace4 = Devel::Backtrace->new(-start => 1); $backtrace4->skipmysubs('Baz'); is ($backtrace4->point(1)->_skip, 4, '_skip / -start') or warn "_skip / -start: $backtrace3 --\n$backtrace4"; } } Devel-Backtrace-0.12/t/00-load.t0000444000175000001440000000023611137447731015013 0ustar pepeusers#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Devel::Backtrace' ); } diag( "Testing Devel::Backtrace $Devel::Backtrace::VERSION, Perl $], $^X" ); Devel-Backtrace-0.12/t/pod-coverage.t0000444000175000001440000000025411137447731016232 0ustar pepeusers#!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); Devel-Backtrace-0.12/t/pod.t0000444000175000001440000000021411137447731014435 0ustar pepeusers#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Devel-Backtrace-0.12/Changes0000444000175000001440000000430011137447731014516 0ustar pepeusersRevision history for Devel-Backtrace 0.01 Apr 25 2007 First version, released on an unsuspecting world. 0.02 May 11 17:42:40 CEST 2007 Disabled a test for Windows, because it failed due to perl features that are not available on Windows. 0.03 May 12 02:19:24 CEST 2007 Update documentation 0.04 May 13 01:30:13 CEST 2007 Added support for perl 5.9's caller's hinthash. Added by_index method to Devel::Backtrace::Point. 0.05 May 20 19:59:28 CEST 2007 Make the tests work with perl 5.9 0.06 Mar 27 15:17:04 CET 2008 Change the license to public domain. Added Devel::DollarAt. Added skipmysubs to Devel::Backtrace and called_package to Devel::Backtrace::Point. 0.07 Thu Mar 27 16:14:03 CET 2008 Some minor changes (nothing in the code). 0.08 Sat Mar 29 18:43:42 CET 2008 Added some documentation fixes. Previously, some tests were skipped in perl 5.6. I made them work in 5.6 and don't skip them any more. Previously, a test failed in 5.10 because perl 5.8 and 5.10 sometimes generate different line numbers in error messages. I made the test work (see examples/dollarat.pl). 0.09 Sun Mar 30 16:08:25 CEST 2008 Documentation fixes Added version to Devel::Backtrace::Point 0.10 Wed Apr 2 02:51:43 CEST 2008 Format strings for stringification. Level information in Devel::Backtrace::Point. Fix a warning in examples/dollarat.pl in perl 5.10. Change the test system. Previously it used to automatically run the examples, but now it's independent from the examples because that's more flexible. Again, added some fixes to make the tests work on all platforms. 0.11 Mon Jul 7 00:55:37 CEST 2008 DBP is in the public domain too. (Forgot that in 0.06) Fix a test that failed on Windows because of path separators. Add the Perl license as a fallback license... 0.11_01 Wed Jan 21 00:14:18 CET 2009 Try again to make the test suite windows-compatible. 0.12 2009-01-27 Non-dev release after 0.11_01 seemed fine with testers. Pod fix. Devel-Backtrace-0.12/examples/0000755000175000001440000000000011137447731015046 5ustar pepeusersDevel-Backtrace-0.12/examples/dollarat.pl0000444000175000001440000000045111137447731017203 0ustar pepeusers#!perl use strict; use warnings; use Devel::DollarAt; eval 'print 0/0'; # Output: Error line is 1 print "Error line is ", $@->line, "\n"; # Output: Error text is Illegal division by zero at (eval 3) line 1. print "Error text is $@"; # Note: In perl 5.8 and below, the line gets reported as 2. Devel-Backtrace-0.12/examples/basic.pl0000444000175000001440000000360011137447731016461 0ustar pepeusers#!perl use strict; use warnings; use Devel::Backtrace; sub foo { bar(); } sub bar { my $backtrace1 = Devel::Backtrace->new; print "First backtrace:\n$backtrace1\n"; my $backtrace2 = Devel::Backtrace->new(1); print "Second (shorter) backtrace:\n$backtrace2\n"; my $backtrace3 = Devel::Backtrace->new(2); print "Third (even shorter) backtrace:\n$backtrace3\n"; print "The third backtrace in a very long form:\n"; print "(Note that the bitmask may depend on the perl version.)\n"; print $backtrace3->to_long_string, "\n"; print "The line number from the second line of the first backtrace:\n"; print $backtrace1->point(1)->line, "\n"; print "The called package from the first line of the first backtrace:\n"; print $backtrace1->point(0)->called_package, "\n"; my $backtrace4 = Devel::Backtrace->new(-start => 1, -format => 'subroutine %s, package %c from %p'); print "bar call in different format:\n"; print $backtrace4->point(0); } foo(); __END__ Output: First backtrace: Devel::Backtrace::new called from main (examples/basic.pl:12) main::bar called from main (examples/basic.pl:8) main::foo called from main (examples/basic.pl:38) Second (shorter) backtrace: main::bar called from main (examples/basic.pl:8) main::foo called from main (examples/basic.pl:38) Third (even shorter) backtrace: main::foo called from main (examples/basic.pl:38) The third backtrace in a very long form: (Note that the bitmask may depend on the perl version.) package: main filename: examples/basic.pl line: 38 subroutine: main::foo hasargs: 1 wantarray: undef evaltext: undef is_require: undef hints: 2 bitmask: UUUUUUUUUUUU\05 The line number from the second line of the first backtrace: 8 The called package from the first line of the first backtrace: Devel::Backtrace bar call in different format: subroutine main::bar, package main from main Devel-Backtrace-0.12/examples/skipme.pl0000444000175000001440000000271111137447731016672 0ustar pepeusers#!/usr/bin/perl use strict; use warnings; use Devel::Backtrace; # This script demonstrates the use of the skipme method. Foo::foo1(); { package Foo; sub foo1 { foo2(); } sub foo2 { Bar::bar1(); } } { package Bar; sub bar1 { bar2(); } sub bar2 { Baz::baz1(); } } { package Baz; sub baz1 { baz2(); } sub baz2 { baz3(); } sub baz3 { my $backtrace = Devel::Backtrace->new; # Tell Devel::Backtrace that we are not interested in what Baz method # calls which Baz method. $backtrace->skipme; print "skipme result:\n"; print $backtrace; my $backtrace2 = Devel::Backtrace->new; # Tell Devel::Backtrace that we are not even interested where the first # Baz method was called. $backtrace2->skipmysubs; print "\nskipmycalls result:\n"; print $backtrace2; } } __END__ Output: skipme result: Baz::baz1 called from Bar (examples/skipme.pl:30) Bar::bar2 called from Bar (examples/skipme.pl:26) Bar::bar1 called from Foo (examples/skipme.pl:18) Foo::foo2 called from Foo (examples/skipme.pl:14) Foo::foo1 called from main (examples/skipme.pl:8) skipmycalls result: Bar::bar2 called from Bar (examples/skipme.pl:26) Bar::bar1 called from Foo (examples/skipme.pl:18) Foo::foo2 called from Foo (examples/skipme.pl:14) Foo::foo1 called from main (examples/skipme.pl:8) Devel-Backtrace-0.12/MANIFEST0000444000175000001440000000046311137447731014362 0ustar pepeusersBuild.PL Changes examples/basic.pl examples/dollarat.pl examples/skipme.pl INSTALL lib/Devel/Backtrace.pm lib/Devel/Backtrace/Point.pm lib/Devel/DollarAt.pm LICENSE MANIFEST This list of files t/00-load.t t/basic.t t/by_index.t t/dollarat.t t/pod-coverage.t t/pod.t t/skipme.t Makefile.PL README META.yml Devel-Backtrace-0.12/META.yml0000444000175000001440000000123611137447731014501 0ustar pepeusers--- name: Devel-Backtrace version: 0.12 author: - 'Christoph Bussenius ' abstract: Object-oriented backtrace license: perl resources: license: ~ requires: Carp: 0 Class::Accessor: 0 String::Escape: 0 perl: 5.006_000 build_requires: Test::More: 0 provides: Devel::Backtrace: file: lib/Devel/Backtrace.pm version: 0.12 Devel::Backtrace::Point: file: lib/Devel/Backtrace/Point.pm version: 0.11 Devel::DollarAt: file: lib/Devel/DollarAt.pm version: 0.02 no_index: directory: example generated_by: Module::Build version 0.31 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 Devel-Backtrace-0.12/INSTALL0000444000175000001440000000147611137447731014267 0ustar pepeusersINSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Devel::Backtrace You can also look for information at: Search CPAN http://search.cpan.org/dist/Devel-Backtrace CPAN Request Tracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-Backtrace AnnoCPAN, annotated CPAN documentation: http://annocpan.org/dist/Devel-Backtrace CPAN Ratings: http://cpanratings.perl.org/d/Devel-Backtrace COPYRIGHT AND LICENCE Copyright (C) 2007 Christoph Bussenius This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Devel-Backtrace-0.12/README0000444000175000001440000001114711137447731014112 0ustar pepeusersNAME Devel::Backtrace - Object-oriented backtrace VERSION This is version 0.12. SYNOPSIS my $backtrace = Devel::Backtrace->new; print $backtrace; # use automatic stringification # See EXAMPLES to see what the output might look like print $backtrace->point(0)->line; METHODS Devel::Backtrace->new() Optional parameters: -start => $start, -format => $format If only one parameter is given, it will be used as $start. Constructs a new "Devel::Backtrace" which is filled with all the information "caller($i)" provides, where $i starts from $start. If no argument is given, $start defaults to 0. If $start is 1 (or higher), the backtrace won't contain the information that (and where) Devel::Backtrace::new() was called. $backtrace->point($i) Returns the i'th tracepoint as a Devel::Backtrace::Point object (see its documentation for how to access every bit of information). Note that the following code snippet will print the information of "caller($start+$i)": print Devel::Backtrace->new($start)->point($i) $backtrace->points() Returns a list of all tracepoints. In scalar context, the number of tracepoints is returned. $backtrace->skipme([$package]) This method deletes all leading tracepoints that contain information about calls within $package. Afterwards the $backtrace will look as though it had been created with a higher value of $start. If the optional parameter $package is not given, it defaults to the calling package. The effect is similar to what the Carp module does. This module ships with an example "skipme.pl" that demonstrates how to use this method. See also "EXAMPLES". $backtrace->skipmysubs([$package]) This method is like "skipme" except that it deletes calls *to* the package rather than calls *from* the package. Before discarding those calls, "skipme" is called. This is because usually the topmost call in the stack is to Devel::Backtrace->new, which would not be catched by "skipmysubs" otherwise. This means that skipmysubs usually deletes more lines than skipme would. "skipmysubs" was added in Devel::Backtrace version 0.06. See also "EXAMPLES" and the example "skipme.pl". $backtrace->to_string() Returns a string that contains one line for each tracepoint. It will contain the information from "Devel::Backtrace::Point"'s to_string() method. To get more information, use the to_long_string() method. Note that you don't have to call to_string() if you print a "Devel::Backtrace" object or otherwise treat it as a string, as the stringification operator is overloaded. See "EXAMPLES". $backtrace->to_long_string() Returns a very long string that contains several lines for each trace point. The result will contain every available bit of information. See "to_long_string" in Devel::Backtrace::Point for an example of what the result looks like. EXAMPLES A sample stringification might look like this: Devel::Backtrace::new called from MyPackage (foo.pl:30) MyPackage::test2 called from MyPackage (foo.pl:28) MyPackage::test1 called from main (foo.pl:18) main::bar called from main (foo.pl:6) main::foo called from main (foo.pl:13) If MyPackage called skipme, the first two lines would be removed. If it called skipmysubs, the first three lines would be removed. If you don't like the format, you can change it: my $backtrace = Devel::Backtrace->new(-format => '%I. %s'); This would produce a stringification of the following form: 0. Devel::Backtrace::new 1. MyPackage::test2 2. MyPackage::test1 3. main::bar 4. main::foo SEE ALSO Devel::StackTrace does mostly the same as this module. I'm afraid I hadn't noticed it until I uploaded this module. Carp::Trace is a simpler module which gives you a backtrace in string form. Devel::DollarAt comes with this distribution and is a nice application of this module. You can use it for debugging to get a backtrace out of $@. AUTHOR Christoph Bussenius If you use this module, I'll be glad if you drop me a note. You should mention this module's name in the subject of your mails, in order to make sure they won't get lost in all the spam. LICENSE This module is in the public domain. If your country's law does not allow this module being in the public domain or does not include the concept of public domain, you may use the module under the same terms as perl itself. Devel-Backtrace-0.12/Makefile.PL0000444000175000001440000000104111137447731015174 0ustar pepeusers# Note: this file was auto-generated by Module::Build::Compat version 0.31 require 5.006_000; use ExtUtils::MakeMaker; WriteMakefile ( 'INSTALLDIRS' => 'site', 'NAME' => 'Devel::Backtrace', 'EXE_FILES' => [], 'VERSION_FROM' => 'lib/Devel/Backtrace.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'String::Escape' => 0, 'Class::Accessor' => 0, 'Carp' => 0 } ) ; Devel-Backtrace-0.12/Build.PL0000444000175000001440000000134411137447731014524 0ustar pepeusersuse strict; use warnings; use Module::Build; my $builder = Module::Build->new( create_readme => 1, create_makefile_pl => 'traditional', module_name => 'Devel::Backtrace', license => 'perl', dist_author => 'Christoph Bussenius ', dist_version_from => 'lib/Devel/Backtrace.pm', no_index => { directory => 'example', }, requires => { 'String::Escape' => 0, 'Class::Accessor' => 0, 'Carp' => 0, 'perl' => '5.006_000', }, build_requires => { 'Test::More' => 0, }, # add_to_cleanup => [ 'Devel-Backtrace-*' ], ); $builder->create_build_script(); Devel-Backtrace-0.12/LICENSE0000444000175000001440000000046211137447731014235 0ustar pepeusersThe Perl module distribution Devel::Backtrace is in the public domain. The author is Christoph Bussenius. If your country's law does not allow this distribution being in the public domain or does not include the concept of public domain, you may use the distribution under the same terms as perl itself.