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