r18209 - in /branches/upstream/libdevel-stacktrace-perl: ./ current/ current/lib/ current/lib/Devel/ current/t/
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Mon Mar 31 18:46:37 UTC 2008
Author: gregoa-guest
Date: Mon Mar 31 18:46:36 2008
New Revision: 18209
URL: http://svn.debian.org/wsvn/?sc=1&rev=18209
Log:
[svn-inject] Installing original source of libdevel-stacktrace-perl
Added:
branches/upstream/libdevel-stacktrace-perl/
branches/upstream/libdevel-stacktrace-perl/current/
branches/upstream/libdevel-stacktrace-perl/current/Build.PL
branches/upstream/libdevel-stacktrace-perl/current/Changes
branches/upstream/libdevel-stacktrace-perl/current/LICENSE
branches/upstream/libdevel-stacktrace-perl/current/MANIFEST
branches/upstream/libdevel-stacktrace-perl/current/META.yml
branches/upstream/libdevel-stacktrace-perl/current/Makefile.PL
branches/upstream/libdevel-stacktrace-perl/current/README
branches/upstream/libdevel-stacktrace-perl/current/SIGNATURE
branches/upstream/libdevel-stacktrace-perl/current/lib/
branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/
branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/StackTrace.pm
branches/upstream/libdevel-stacktrace-perl/current/t/
branches/upstream/libdevel-stacktrace-perl/current/t/01-basic.t
branches/upstream/libdevel-stacktrace-perl/current/t/99-pod.t
Added: branches/upstream/libdevel-stacktrace-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/Build.PL?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/Build.PL (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/Build.PL Mon Mar 31 18:46:36 2008
@@ -1,0 +1,14 @@
+use strict;
+
+use Module::Build;
+
+my $build =
+ Module::Build->new( module_name => 'Devel::StackTrace',
+ license => 'perl',
+ requires => { 'Test::More' => '0.46'
+ },
+ sign => 1,
+ create_makefile_pl => 'traditional',
+ );
+
+$build->create_build_script;
Added: branches/upstream/libdevel-stacktrace-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/Changes?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/Changes (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/Changes Mon Mar 31 18:46:36 2008
@@ -1,0 +1,116 @@
+1.11 Apr 12, 2004
+
+- No code changes, just switching to including a Makefile.PL that uses
+ExtUtils::MakeMaker instead of one that sneakily uses Module::Build.
+Requested by Perrin Harkins.
+
+
+1.10 Mar 10, 2004
+
+- Silence a warning from the test code if Exception::Class isn't
+installed. Reported by Stefano Ruberti.
+
+- Localize $@ to avoid overwriting a previously set $@ while creating
+a Devel::StackTrace object. This caused a test failure in the
+Exception::Class tests when run with Perl 5.6.1, but not with 5.8.3.
+I don't really know how to test for it outside of Exception::Class.
+Reported by Jesse Erlbaum.
+
+
+1.09 Feb 26, 2004
+
+- The overload workaround blows up if a DBI handle is anywhere in the
+stack, because of a bad interaction between overload::Overloaded and
+DBI's custom dispatching. This release works around that.
+
+
+1.08 Feb 23, 2004
+
+- Some tests failed on Win32 because they were hardcoded to expect a
+file name with forward slashes. Reported by Steve Hay.
+
+
+1.07 Feb 21, 2004
+
+- This release includes a change to the overload handling that is
+necessary for cooperation with Exception::Class.
+
+
+1.06 Feb 21, 2004
+
+- Devel::StackTrace now uses overload::StrVal() to get the underlying
+string value of an overloaded object when creating a stack frame for
+display. This can be turned off by setting respect_overload to a true
+value. Suggested by Matt Sisk.
+
+
+1.05 Feb 17, 2004
+
+- Devel::StackTrace incorrectly reported that arguments were being
+passed to eval blocks (which isn't possible). Reported by Mark Dedlow.
+
+
+1.04 Sep 25, 2003
+
+- The special handling of Exception::Class::Base objects was broken.
+This was exposed by the fact that Exception::Class 1.15 now uses
+Devel::StackTrace in a slightly different way than it did previously.
+
+
+1.03 Jan 22, 2003
+
+- Special handling of Exception::Class::Base objects when stringifying
+references. This avoids infinite recursion between the two classes.
+
+
+1.02 Sep 19, 2002
+
+- Forgot to add Test::More to PREREQ_PM for previous releases.
+
+
+1.01 Sep 18, 2002
+
+- Change the "no object refs" feature to be a plain old "no refs"
+feature. As was pointed out to me by Jean-Phillippe Bouchard, a plain
+reference (to an array, for example), can easily hold references to
+objects internally. And since I'm not going to bother descending
+through nested data structures weeding out objects, this is an easier
+way to handle the problem. Thanks to Jean-Phillippe Bouchard for a
+patch for this as well.
+
+The "no_object_refs" parameter is deprecated, and now does the same
+thing as the "no_refs" parameter.
+
+
+1.00 Aug 23, 2002 (from Taiwan)
+
+- Add an option to not store references to objects in stack frames.
+This can be important if you're expecting DESTROY to be called but a
+Devel::StackTraceFrame object is still holding a reference to your
+object(s). Based on discussion with Tatsuhiko Miyagawa.
+
+
+0.9 Nov 24, 2001
+
+- Doc tweaks.
+
+
+0.85
+
+- doc bug fix that made it seem like args method was only available
+under Perl 5.6.0
+- converted objects from pseudo-hashes to regular hashes.
+
+
+0.8
+
+- Should work under Perl 5.6.0+.
+- Added hints & bitmask methods for use under Perl 5.6.0.
+
+
+0.75
+
+- Added frames method (and docs for it).
+- Added 'use 5.005' which I should have put in there earlier.
+- DOCS: explanation of 'top' and 'bottom' as they refer to the stack.
+
Added: branches/upstream/libdevel-stacktrace-perl/current/LICENSE
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/LICENSE?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/LICENSE (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/LICENSE Mon Mar 31 18:46:36 2008
@@ -1,0 +1,4 @@
+Copyright (c) 2000-2001 Dave Rolsky
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: branches/upstream/libdevel-stacktrace-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/MANIFEST?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/MANIFEST (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/MANIFEST Mon Mar 31 18:46:36 2008
@@ -1,0 +1,12 @@
+Build.PL
+Changes
+lib/Devel/StackTrace.pm
+LICENSE
+Makefile.PL
+MANIFEST This list of files
+README
+t/01-basic.t
+t/99-pod.t
+META.yml Module meta-data (added by MakeMaker)
+
+SIGNATURE Added here by Module::Build
Added: branches/upstream/libdevel-stacktrace-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/META.yml?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/META.yml (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/META.yml Mon Mar 31 18:46:36 2008
@@ -1,0 +1,17 @@
+--- #YAML:1.0
+name: Devel-StackTrace
+version: 1.11
+author:
+ - Dave Rolsky, <autarch at urth.org>
+abstract: Stack trace and stack trace frame objects
+license: perl
+requires:
+ Test::More: 0.46
+provides:
+ Devel::StackTrace:
+ file: lib/Devel/StackTrace.pm
+ version: 1.11
+ Devel::StackTraceFrame:
+ file: lib/Devel/StackTrace.pm
+ version: 1.11
+generated_by: Module::Build version 0.23
Added: branches/upstream/libdevel-stacktrace-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/Makefile.PL?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/Makefile.PL (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/Makefile.PL Mon Mar 31 18:46:36 2008
@@ -1,0 +1,13 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'Devel::StackTrace',
+ 'VERSION_FROM' => 'lib/Devel/StackTrace.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => '0.46'
+ },
+ 'INSTALLDIRS' => 'site',
+ 'PL_FILES' => {}
+ )
+;
Added: branches/upstream/libdevel-stacktrace-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/README?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/README (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/README Mon Mar 31 18:46:36 2008
@@ -1,0 +1,14 @@
+Simple objects to deal with stack traces. The parent object,
+Devel::StackTrace, holds a number of Devel::StackTraceFrame objects
+(which have the same information as is returned from caller()). You
+can step through these frames forwards and backwards as you want or
+retrieve specific frames.
+
+BUGS
+
+** Perl 5.6.0 and caller function
+
+There are bugs in the caller function under Perl 5.6.0 that this
+module may trigger. One common symptom is an error message like
+'Bizarre copy of HASH' or 'Bizarre copy of ARRAY'. There is no
+workaround. 5.6.1 does not have this problem.
Added: branches/upstream/libdevel-stacktrace-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/SIGNATURE?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/SIGNATURE (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/SIGNATURE Mon Mar 31 18:46:36 2008
@@ -1,0 +1,33 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.38.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+ % cpansign -v
+
+It would check each file's integrity, as well as the signature's
+validity. If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 49dc36dbae54f26629d498c157fc5594452bd9ac Build.PL
+SHA1 d613650fc0186b90c870e1fbc558d864fac5d4c0 Changes
+SHA1 c7c75920490e79ec24e2c7ea34482c65e4f7550c LICENSE
+SHA1 813c30cc69d24c869a330e6ac8a8675790657a3b MANIFEST
+SHA1 ebb2738c603a5a65ec5d378428ff2bb4d2e50628 META.yml
+SHA1 faae4d26812c60098fa5585bb6306d6509eb27da Makefile.PL
+SHA1 1140b1d8c68fe79b8797fc23a0b0e01a3f9a3cb9 README
+SHA1 a720b0ca84ad7d6677b90bef0476276ae64db20f lib/Devel/StackTrace.pm
+SHA1 51bcaf77b81beb369555994585a24ee0f434483a t/01-basic.t
+SHA1 157c4c93c5a1b2325a244c54aa71f790b7addbe5 t/99-pod.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.4 (GNU/Linux)
+
+iD8DBQFAeiSN+4tbS/niBUoRApUPAJsH4yzhA5+1JqZ8vEWe6Iq2+husAACePpbi
+hGLEInLCTNPHGfhM8GL0i+Y=
+=Y6b4
+-----END PGP SIGNATURE-----
Added: branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/StackTrace.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/StackTrace.pm?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/StackTrace.pm (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/lib/Devel/StackTrace.pm Mon Mar 31 18:46:36 2008
@@ -1,0 +1,531 @@
+package Devel::StackTrace;
+
+use 5.005;
+
+use strict;
+use vars qw($VERSION);
+
+use fields qw( index frames );
+
+use overload
+ '""' => \&as_string,
+ fallback => 1;
+
+$VERSION = '1.11';
+
+sub new
+{
+ my $class = shift;
+ my %p = @_;
+
+ my $self = bless { index => undef,
+ frames => [],
+ respect_overload => $p{respect_overload},
+ }, $class;
+
+ $self->_add_frames(%p);
+
+ return $self;
+}
+
+sub _add_frames
+{
+ my $self = shift;
+ my %p = @_;
+
+ $p{no_refs} = delete $p{no_object_refs} if exists $p{no_object_refs};
+
+ my (@i_pack_re, %i_class);
+ if ($p{ignore_package})
+ {
+ $p{ignore_package} =
+ [$p{ignore_package}] unless UNIVERSAL::isa( $p{ignore_package}, 'ARRAY' );
+
+ @i_pack_re = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $p{ignore_package} };
+ }
+
+ if ($p{ignore_class})
+ {
+ $p{ignore_class} = [$p{ignore_class}] unless ref $p{ignore_class};
+ %i_class = map {$_ => 1} @{ $p{ignore_class} };
+ }
+
+ my $p = __PACKAGE__;
+ push @i_pack_re, qr/^\Q$p\E$/;
+
+ my $x = 0;
+ my @c;
+ while ( do { package DB; @DB::args = (); @c = caller($x++) } )
+ {
+ next if grep { $c[0] =~ /$_/ } @i_pack_re;
+ next if grep { $c[0]->isa($_) } keys %i_class;
+
+ $self->_add_frame( $p{no_refs}, \@c )
+ if @c;
+ }
+}
+
+sub _add_frame
+{
+ my $self = shift;
+ my $no_refs = shift;
+ my $c = shift;
+
+ # eval and is_require are only returned when applicable under 5.00503.
+ push @$c, (undef, undef) if scalar @$c == 6;
+
+ my @a = @DB::args;
+
+ if ( $no_refs )
+ {
+ @a = map { ( ref $_
+ ? ( UNIVERSAL::isa( $_, 'Exception::Class::Base' ) ?
+ do { if ( $_->can('show_trace') )
+ {
+ my $t = $_->show_trace;
+ $_->show_trace(0);
+ my $s = "$_";
+ $_->show_trace($t);
+ $s;
+ }
+ else
+ {
+ # hack but should work with older
+ # versions of E::C::B
+ $_->{message};
+ } }
+ : $self->_ref_as_string($_)
+ )
+ : $_
+ ) } @a;
+ }
+
+ push @{ $self->{frames} },
+ Devel::StackTraceFrame->new( $c, \@a, $self->{respect_overload} );
+}
+
+sub _ref_as_string
+{
+ my $self = shift;
+
+ local $@;
+ if ( ref $_[0] &&
+ ! $self->{respect_overload} &&
+ eval { overload::Overloaded($_[0]) }
+ )
+ {
+ return overload::StrVal($_[0]);
+ }
+ else
+ {
+ # force stringification
+ $_[0] . '';
+ }
+}
+
+sub next_frame
+{
+ my $self = shift;
+
+ # reset to top if necessary.
+ $self->{index} = -1 unless defined $self->{index};
+
+ if (defined $self->{frames}[ $self->{index} + 1 ])
+ {
+ return $self->{frames}[ ++$self->{index} ];
+ }
+ else
+ {
+ $self->{index} = undef;
+ return undef;
+ }
+}
+
+sub prev_frame
+{
+ my $self = shift;
+
+ # reset to top if necessary.
+ $self->{index} = scalar @{ $self->{frames} } unless defined $self->{index};
+
+ if (defined $self->{frames}[ $self->{index} - 1 ] && $self->{index} >= 1)
+ {
+ return $self->{frames}[ --$self->{index} ];
+ }
+ else
+ {
+ $self->{index} = undef;
+ return undef;
+ }
+}
+
+sub reset_pointer
+{
+ my $self = shift;
+
+ $self->{index} = undef;
+}
+
+sub frames
+{
+ my $self = shift;
+
+ return @{ $self->{frames} };
+}
+
+sub frame
+{
+ my $self = shift;
+ my $i = shift;
+
+ return unless defined $i;
+
+ return $self->{frames}[$i];
+}
+
+sub frame_count
+{
+ my $self = shift;
+
+ return scalar @{ $self->{frames} };
+}
+
+sub as_string
+{
+ my $self = shift;
+
+ my $st = '';
+ my $first = 1;
+ foreach my $f (@{ $self->{frames} })
+ {
+ $st .= $f->as_string($first) . "\n";
+ $first = 0;
+ }
+
+ return $st;
+}
+
+package Devel::StackTraceFrame;
+
+use strict;
+use vars qw($VERSION);
+
+use fields qw( package filename line subroutine hasargs wantarray evaltext is_require hints bitmask args );
+
+$VERSION = '0.6';
+
+# Create accessor routines
+BEGIN
+{
+ no strict 'refs';
+ foreach my $f ( qw( package filename line subroutine hasargs
+ wantarray evaltext is_require hints bitmask args ) )
+ {
+ next if $f eq 'args';
+ *{$f} = sub { my $s = shift; return $s->{$f} };
+ }
+}
+
+sub new
+{
+ my $proto = shift;
+ my $class = ref $proto || $proto;
+
+ my $self = bless {}, $class;
+
+ my @fields =
+ ( qw( package filename line subroutine hasargs wantarray evaltext is_require ) );
+ push @fields, ( qw( hints bitmask ) ) if $] >= 5.006;
+
+ @{ $self }{ @fields } = @{$_[0]};
+
+ $self->{args} = $_[1];
+
+ $self->{respect_overload} = $_[2];
+
+ return $self;
+}
+
+sub args
+{
+ my $self = shift;
+
+ return @{ $self->{args} };
+}
+
+sub as_string
+{
+ my $self = shift;
+ my $first = shift;
+
+ my $sub = $self->subroutine;
+ # This code stolen straight from Carp.pm and then tweaked. All
+ # errors are probably my fault -dave
+ if ($first)
+ {
+ $sub = 'Trace begun';
+ }
+ else
+ {
+ # Build a string, $sub, which names the sub-routine called.
+ # This may also be "require ...", "eval '...' or "eval {...}"
+ if (my $eval = $self->evaltext)
+ {
+ if ($self->is_require)
+ {
+ $sub = "require $eval";
+ }
+ else
+ {
+ $eval =~ s/([\\\'])/\\$1/g;
+ $sub = "eval '$eval'";
+ }
+ }
+ elsif ($sub eq '(eval)')
+ {
+ $sub = 'eval {...}';
+ }
+
+ # if there are any arguments in the sub-routine call, format
+ # them according to the format variables defined earlier in
+ # this file and join them onto the $sub sub-routine string
+ #
+ # We copy them because they're going to be modified.
+ #
+ if ( my @a = $self->args )
+ {
+ for (@a)
+ {
+ # set args to the string "undef" if undefined
+ $_ = "undef", next unless defined $_;
+
+ # hack!
+ $_ = $self->Devel::StackTrace::_ref_as_string($_)
+ if ref $_;
+
+ s/'/\\'/g;
+
+ # 'quote' arg unless it looks like a number
+ $_ = "'$_'" unless /^-?[\d.]+$/;
+
+ # print control/high ASCII chars as 'M-<char>' or '^<char>'
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+
+ # append ('all', 'the', 'arguments') to the $sub string
+ $sub .= '(' . join(', ', @a) . ')';
+ $sub .= ' called';
+ }
+ }
+
+ return "$sub at " . $self->filename . ' line ' . $self->line;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Devel::StackTrace - Stack trace and stack trace frame objects
+
+=head1 SYNOPSIS
+
+ use Devel::StackTrace;
+
+ my $trace = Devel::StackTrace->new;
+
+ print $trace->as_string; # like carp
+
+ # from top (most recent) of stack to bottom.
+ while (my $frame = $trace->next_frame)
+ {
+ print "Has args\n" if $f->hasargs;
+ }
+
+ # from bottom (least recent) of stack to top.
+ while (my $frame = $trace->prev_frame)
+ {
+ print "Sub: ", $f->subroutine, "\n";
+ }
+
+=head1 DESCRIPTION
+
+The Devel::StackTrace module contains two classes, Devel::StackTrace
+and Devel::StackTraceFrame. The goal of this object is to encapsulate
+the information that can found through using the caller() function, as
+well as providing a simple interface to this data.
+
+The Devel::StackTrace object contains a set of Devel::StackTraceFrame
+objects, one for each level of the stack. The frames contain all the
+data available from caller() as of Perl 5.6.0 though this module still
+works with 5.00503.
+
+This code was created to support my L<Exception::Class::Base> class
+(part of Exception::Class) but may be useful in other contexts.
+
+=head1 'TOP' AND 'BOTTOM' OF THE STACK
+
+When describing the methods of the trace object, I use the words 'top'
+and 'bottom'. In this context, the 'top' frame on the stack is the
+most recent frame and the 'bottom' is the least recent.
+
+Here's an example:
+
+ foo(); # bottom frame is here
+
+ sub foo
+ {
+ bar();
+ }
+
+ sub bar
+ {
+ Devel::StackTrace->new; # top frame is here.
+ }
+
+=head1 Devel::StackTrace METHODS
+
+=over 4
+
+=item * new(%named_params)
+
+Returns a new Devel::StackTrace object.
+
+Takes the following parameters:
+
+=over 8
+
+=item * ignore_package => $package_name OR \@package_names
+
+Any frames where the package is one of these packages will not be on
+the stack.
+
+=item * ignore_class => $package_name OR \@package_names
+
+Any frames where the package is a subclass of one of these packages
+(or is the same package) will not be on the stack.
+
+Devel::StackTrace internally adds itself to the 'ignore_package'
+parameter, meaning that the Devel::StackTrace package is B<ALWAYS>
+ignored. However, if you create a subclass of Devel::StackTrace it
+will not be ignored.
+
+=item * no_refs => $boolean
+
+If this parameter is true, then Devel::StackTrace will not store
+references internally when generating stacktrace frames. This lets
+your objects go out of scope.
+
+Devel::StackTrace replaces any references with their stringified
+representation.
+
+=item * respect_overload => $boolean
+
+By default, Devel::StackTrace will call C<overload::StrVal()> to get
+the underlying string representation of an object, instead of
+respecting the object's stringification overloading. If you would
+prefer to see the overloaded representation of objects in stack
+traces, then set this parameter to true.
+
+=back
+
+=item * next_frame
+
+Returns the next Devel::StackTraceFrame object down on the stack. If
+it hasn't been called before it returns the first frame. It returns
+undef when it reaches the bottom of the stack and then resets its
+pointer so the next call to C<next_frame> or C<prev_frame> will work
+properly.
+
+=item * prev_frame
+
+Returns the next Devel::StackTraceFrame object up on the stack. If it
+hasn't been called before it returns the last frame. It returns undef
+when it reaches the top of the stack and then resets its pointer so
+pointer so the next call to C<next_frame> or C<prev_frame> will work
+properly.
+
+=item * reset_pointer
+
+Resets the pointer so that the next call C<next_frame> or
+C<prev_frame> will start at the top or bottom of the stack, as
+appropriate.
+
+=item * frames
+
+Returns a list of Devel::StackTraceFrame objects. The order they are
+returned is from top (most recent) to bottom.
+
+=item * frame ($index)
+
+Given an index, returns the relevant frame or undef if there is not
+frame at that index. The index is exactly like a Perl array. The
+first frame is 0 and negative indexes are allowed.
+
+=item * frame_count
+
+Returns the number of frames in the trace object.
+
+=item * as_string
+
+Calls as_string on each frame from top to bottom, producing output
+quite similar to the Carp module's cluck/confess methods.
+
+=back
+
+=head1 Devel::StackTraceFrame METHODS
+
+See the L<caller> documentation for more information on what these
+methods return.
+
+=over 4
+
+=item * package
+
+=item * filename
+
+=item * line
+
+=item * subroutine
+
+=item * hasargs
+
+=item * wantarray
+
+=item * evaltext
+
+Returns undef if the frame was not part of an eval.
+
+=item * is_require
+
+Returns undef if the frame was not part of a require.
+
+=item * args
+
+Returns the arguments passed to the frame. Note that any arguments
+that are references are returned as references, not copies.
+
+=back
+
+=head2 These only contain data as of Perl 5.6.0 or later
+
+=over 4
+
+=item * hints
+
+=item * bitmask
+
+=back
+
+=head1 AUTHOR
+
+Dave Rolsky, <autarch at urth.org>
+
+=head1 SEE ALSO
+
+Exception::Class
+
+=cut
Added: branches/upstream/libdevel-stacktrace-perl/current/t/01-basic.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/t/01-basic.t?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/t/01-basic.t (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/t/01-basic.t Mon Mar 31 18:46:36 2008
@@ -1,0 +1,361 @@
+use strict;
+
+use Test::More;
+
+BEGIN
+{
+ my $tests = 33;
+ eval { require Exception::Class };
+ $tests++ if ! $@ && $Exception::Class::VERSION >= 1.09;
+
+ plan tests => $tests;
+
+ use_ok('Devel::StackTrace');
+}
+
+sub get_file_name { (caller(0))[1] }
+my $test_file_name = get_file_name();
+
+# Test all accessors
+{
+ my $trace = foo();
+
+ my @f = ();
+ while ( my $f = $trace->prev_frame ) { push @f, $f; }
+
+ my $cnt = scalar @f;
+ is( $cnt, 4,
+ "Trace should have 4 frames" );
+
+ @f = ();
+ while ( my $f = $trace->next_frame ) { push @f, $f; }
+
+ $cnt = scalar @f;
+ is( $cnt, 4,
+ "Trace should have 4 frames" );
+
+ is( $f[0]->package, 'main',
+ "First frame package should be main" );
+
+ is( $f[0]->filename, $test_file_name, "First frame filename should be $test_file_name" );
+
+ is( $f[0]->line, 1012, "First frame line should be 1012" );
+
+ is( $f[0]->subroutine, 'Devel::StackTrace::new',
+ "First frame subroutine should be Devel::StackTrace::new" );
+
+ is( $f[0]->hasargs, 1, "First frame hasargs should be true" );
+
+ is( $f[0]->wantarray, 0,
+ "First frame wantarray should be false" );
+
+ my $trace_text = <<"EOF";
+Trace begun at $test_file_name line 1012
+main::baz(1, 2) called at $test_file_name line 1007
+main::bar(1) called at $test_file_name line 1002
+main::foo at $test_file_name line 21
+EOF
+
+ is( $trace->as_string, $trace_text, 'trace text' );
+}
+
+# Test constructor params
+{
+ my $trace = SubTest::foo( ignore_class => 'Test' );
+
+ my @f = ();
+ while ( my $f = $trace->prev_frame ) { push @f, $f; }
+
+ my $cnt = scalar @f;
+
+ is( $cnt, 1, "Trace should have 1 frame" );
+
+ is( $f[0]->package, 'main',
+ "The package for this frame should be main" );
+
+ $trace = Test::foo( ignore_class => 'Test' );
+
+ @f = ();
+ while ( my $f = $trace->prev_frame ) { push @f, $f; }
+
+ $cnt = scalar @f;
+
+ is( $cnt, 1, "Trace should have 1 frame" );
+ is( $f[0]->package, 'main',
+ "The package for this frame should be main" );
+}
+
+# 15 - stringification overloading
+{
+ my $trace = baz();
+
+ my $trace_text = <<"EOF";
+Trace begun at $test_file_name line 1012
+main::baz at $test_file_name line 90
+EOF
+
+ my $t = "$trace";
+ is( $t, $trace_text, 'trace text' );
+}
+
+# 16-18 - frame_count, frame, reset_pointer, frames methods
+{
+ my $trace = foo();
+
+ is( $trace->frame_count, 4,
+ "Trace should have 4 frames" );
+
+ my $f = $trace->frame(2);
+
+ is( $f->subroutine, 'main::bar',
+ "Frame 2's subroutine should be 'main::bar'" );
+
+ $trace->next_frame; $trace->next_frame;
+ $trace->reset_pointer;
+
+ $f = $trace->next_frame;
+ is( $f->subroutine, 'Devel::StackTrace::new',
+ "next_frame should return first frame after call to reset_pointer" );
+
+ my @f = $trace->frames;
+ is( scalar @f, 4,
+ "frames method should return four frames" );
+
+ is( $f[0]->subroutine, 'Devel::StackTrace::new',
+ "first frame's subroutine should be Devel::StackTrace::new" );
+
+ is( $f[3]->subroutine, 'main::foo',
+ "last frame's subroutine should be main::foo" );
+}
+
+# Storing references
+{
+ my $obj = RefTest->new;
+
+ my $trace = $obj->{trace};
+
+ my $call_to_trace = ($trace->frames)[1];
+
+ my @args = $call_to_trace->args;
+
+ is( scalar @args, 1,
+ "Only one argument should have been passed in the call to trace()" );
+
+ isa_ok( $args[0], 'RefTest' );
+}
+
+# Not storing references
+{
+ my $obj = RefTest2->new;
+
+ my $trace = $obj->{trace};
+
+ my $call_to_trace = ($trace->frames)[1];
+
+ my @args = $call_to_trace->args;
+
+ is( scalar @args, 1,
+ "Only one argument should have been passed in the call to trace()" );
+
+ like( $args[0], qr/RefTest2=HASH/,
+ "Actual object should be replaced by string 'RefTest2=HASH'" );
+}
+
+# Not storing references (deprecated interface)
+{
+ my $obj = RefTest3->new;
+
+ my $trace = $obj->{trace};
+
+ my $call_to_trace = ($trace->frames)[1];
+
+ my @args = $call_to_trace->args;
+
+ is( scalar @args, 1,
+ "Only one argument should have been passed in the call to trace()" );
+
+ like( $args[0], qr/RefTest3=HASH/,
+ "Actual object should be replaced by string 'RefTest3=HASH'" );
+}
+
+# No ref to Exception::Class::Base object without refs
+if ( $Exception::Class::VERSION && $Exception::Class::VERSION >= 1.09 )
+{
+ eval { Exception::Class::Base->throw( error => 'error',
+ show_trace => 1,
+ ) };
+ my $exc = $@;
+ eval { quux($exc) };
+
+ ok( ! $@, 'create stacktrace with no refs and exception object on stack' );
+}
+
+{
+ sub FooBar::some_sub { return Devel::StackTrace->new }
+
+ my $trace = eval { FooBar::some_sub('args') };
+
+ my $f = ($trace->frames)[2];
+
+ is( $f->subroutine, '(eval)', 'subroutine is (eval)' );
+
+ my @args = $f->args;
+
+ is( scalar @args, 0, 'no args given to eval block' );
+}
+
+{
+ {
+ package FooBarBaz;
+
+ sub func2 { return Devel::StackTrace->new( ignore_package => qr/^FooBar/ ) }
+ sub func1 { FooBarBaz::func2() }
+ }
+
+ my $trace = FooBarBaz::func1('args');
+
+ my @f = $trace->frames;
+
+ is( scalar @f, 1, 'check regex as ignore_package arg' );
+}
+
+{
+ package StringOverloaded;
+
+ use overload '""' => sub { 'overloaded' };
+}
+
+{
+ my $o = bless {}, 'StringOverloaded';
+
+ my $trace = baz($o);
+
+ unlike( $trace->as_string, qr/\boverloaded\b/, 'overloading is ignored by default' );
+}
+
+{
+ my $o = bless {}, 'StringOverloaded';
+
+ my $trace = respect_overloading($o);
+
+ like( $trace->as_string, qr/\boverloaded\b/, 'overloading is ignored by default' );
+}
+
+{
+ package BlowOnCan;
+
+ sub can { die 'foo' }
+}
+
+{
+ my $o = bless {}, 'BlowOnCan';
+
+ my $trace = baz($o);
+
+ like( $trace->as_string, qr/BlowOnCan/, 'death in overload::Overloaded is ignored' );
+}
+
+
+# This means I can move these lines down without constantly fiddling
+# with the checks for line numbers in the tests.
+
+#line 1000
+sub foo
+{
+ bar(@_, 1);
+}
+
+sub bar
+{
+ baz(@_, 2);
+}
+
+sub baz
+{
+ Devel::StackTrace->new( @_ ? @_[0,1] : () );
+}
+
+sub quux
+{
+ Devel::StackTrace->new( no_refs => 1 );
+}
+
+sub respect_overloading
+{
+ Devel::StackTrace->new( respect_overload => 1 );
+}
+
+
+package Test;
+
+sub foo
+{
+ trace(@_);
+}
+
+sub trace
+{
+ Devel::StackTrace->new(@_);
+}
+
+package SubTest;
+
+use base qw(Test);
+
+sub foo
+{
+ trace(@_);
+}
+
+sub trace
+{
+ Devel::StackTrace->new(@_);
+}
+
+package RefTest;
+
+sub new
+{
+ my $self = bless {}, shift;
+
+ $self->{trace} = trace($self);
+
+ return $self;
+}
+
+sub trace
+{
+ Devel::StackTrace->new();
+}
+
+package RefTest2;
+
+sub new
+{
+ my $self = bless {}, shift;
+
+ $self->{trace} = trace($self);
+
+ return $self;
+}
+
+sub trace
+{
+ Devel::StackTrace->new( no_refs => 1 );
+}
+
+package RefTest3;
+
+sub new
+{
+ my $self = bless {}, shift;
+
+ $self->{trace} = trace($self);
+
+ return $self;
+}
+
+sub trace
+{
+ Devel::StackTrace->new( no_object_refs => 1 );
+}
Added: branches/upstream/libdevel-stacktrace-perl/current/t/99-pod.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-stacktrace-perl/current/t/99-pod.t?rev=18209&op=file
==============================================================================
--- branches/upstream/libdevel-stacktrace-perl/current/t/99-pod.t (added)
+++ branches/upstream/libdevel-stacktrace-perl/current/t/99-pod.t Mon Mar 31 18:46:36 2008
@@ -1,0 +1,7 @@
+use strict;
+
+use Test::More;
+
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
More information about the Pkg-perl-cvs-commits
mailing list