Devel-StackTrace-1.30000755001750001750 012052607734 14765 5ustar00autarchautarch000000000000README100644001750001750 37512052607734 15713 0ustar00autarchautarch000000000000Devel-StackTrace-1.30 This archive contains the distribution Devel-StackTrace, version 1.30: An object representing a stack trace This software is Copyright (c) 2012 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) Changes100644001750001750 2027012052607734 16362 0ustar00autarchautarch000000000000Devel-StackTrace-1.301.30 2012-11-19 - There was an eval which did not first localize $@ and $SIG{__DIE__}. This broke Plack::Middleware::StackTrace (and possibly other tihngs). 1.29 2012-11-16 - The Devel::StackTrace->frames() method is now read-write. This allows you to do more complex filtering of frames than is easily possible with the frame_filter argument to the constructor. Patch by David Cantrell. 1.28 2012-11-16 - Allow arguments to a trace's as_string method, specifically max_arg_length Patch by Ricardo Signes. - Added a no_args option to the constructor in 1.26 but forgot to mention it in Changes. Requested by Scott J. Miller. RT #71482. 1.27 2011-01-16 - Skip some tests on 5.13.8+ that are no longer relevant because of a change in the Perl core. Reported by Andreas Koenig. RT #64828. 1.26 2010-10-15 - The as_string method did not localize $@ and $SIG{__DIE__} before doing an eval. Reported and tested by Marc Mims. RT #61072. 1.25 2010-09-06 - Devel::StackTraceFrame was not actually subclassing Devel::StackTrace::Frame. Patch by Tatsuhiko Miyagawa. 1.24 2010-09-03 - Version 1.23 was missing a $VERSION assignment. Reported by Sergei Vyshenski. - Moved the frame object to its own file, and renamed it Devel::StackTrace::Frame. The old package name, Devel::StackTraceFrame, is now a subclass of the new package, to provide a backwards compatibility shim. 1.23 2010-08-27 - Added message and indent constructor parameters. Based on a patch by James Laver. RT #59830. 1.22 2009-07-15 - Apparently, overload::StrVal on older Perls (5.8.5, but not 5.8.8) tried to call a stringification method if it existed. So now, Devel::StackTrace just uses overload::AddrRef instead, which should always be safe. Reported by Michael Stevens. Fixes RT #47900. 1.21 2009-07-01 - Overloaded objects which didn't provide a stringification method cause Devel::StackTrace to die when respect_overload was true. Reported by Laurent Dami. RT #39533. - Added a frame_filter option which allows for fine-grained control over what frames are included in a trace. Based on (but expanded) from a patch proposed by Florian Ragwitz. RT #47415. 1.20 2008-10-25 - The change in 1.15 to object creation broke the no_refs feature, causing references to be stored until the trace's frame objects were created. * Exception::Class objects are always stringified by calling overload::StrVal(). 1.1902 2008-07-16 - This release just contains another test fix. - The new tests for bad utf-8 apparently fail with any Perl before 5.8.8. Reported by Lee Heagney. RT #37702. 1.1901 2008-06-13 - This release just contains a test fix. - The new tests for bad utf-8 fail with Perl 5.8.x where x <= 6. Apparently, utf-8 was just more broken back then. Reported by Andreas Koenig's smokebots. 1.19 2008-06-13 - Dropped support for Perl 5.005. - If a function was in stack trace had been called with invalid utf-8 bytes, this could cause stringifying a stack trace to blow up when it tried to stringify that argument. We now catch those (and other) errors and simply put "(bad utf-8)" or "?" in the stringified argument list. Reported by Alex Vandiver. 1.18 2008-03-31 - Fix a test failure on Win32. No changes to the non-test code. 1.17 2008-03-30 - Added a max_arg_length parameter, which if set causes Devel::StackTrace to truncate long strings when printing out a frame. RT #33519. Patch by Ian Burrell. 1.16 2008-02-02 - A test fix for bleadperl. The value of wantarray from caller() needs to be treated as a boolean, as opposed to expecting 0 (vs undef). RT #32583. Patch by Jerry Hedden. 1.15 2007-04-28 - Changed how objects are created in order to greatly speed up the constructor. Instead of processing all the stack trace data when the object is first created, this is delayed until it is needed. This was done in order to help speed up Exception::Class. There are cases where code may be throwing many exceptions but never examining the stack traces. Here is a representative benchmark of object construction for the old code versus the new code: Rate old new old 1764/s -- -76% new 7353/s 317% -- 1.14 2007-03-16 - Added a few micro-optimizations from Ruslan Zakirov, who is hoping this will ultimately help speed up RT. 1.13 2006-04-01 - Add another fix for filename handling in the tests. Tests were giving false failures on Win32 because the tests needed to use File::Spec->canonpath(), just like Devel::StackTrace does internally. 1.12 2005-09-30 - Newer versions of Perl use Unix-style filenames when reporting the filename in caller(), which breaks Exception::Class tests on other platforms, and is just kind of funky. This module now calls File::Spec->canonpath() to clean up the filename in each frame. Reported by Garret Goebel. 1.11 2004-04-12 - 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 2004-03-10 - 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 2004-02-26 - 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 2004-02-23 - Some tests failed on Win32 because they were hardcoded to expect a file name with forward slashes. Reported by Steve Hay. 1.07 2004-02-21 - This release includes a change to the overload handling that is necessary for cooperation with Exception::Class. 1.06 2004-02-21 - 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 2004-02-17 - Devel::StackTrace incorrectly reported that arguments were being passed to eval blocks (which isn't possible). Reported by Mark Dedlow. 1.04 2003-09-25 - 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 2003-01-22 - Special handling of Exception::Class::Base objects when stringifying references. This avoids infinite recursion between the two classes. 1.02 2002-09-19 - Forgot to add Test::More to PREREQ_PM for previous releases. 1.01 2002-09-18 - 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 2010-10-15 - 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 2001-11-24 - Doc tweaks. 0.85 2000-09-02 - 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 2000-09-02 - Should work under Perl 5.6.0+. - Added hints & bitmask methods for use under Perl 5.6.0. 0.75 2000-06-29 - 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. 0.7 2000-06-27 - First release (I think) LICENSE100644001750001750 2152012052607734 16073 0ustar00autarchautarch000000000000Devel-StackTrace-1.30This software is Copyright (c) 2012 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. INSTALL100644001750001750 172612052607734 16105 0ustar00autarchautarch000000000000Devel-StackTrace-1.30 This is the Perl distribution Devel-StackTrace. Installing Devel-StackTrace is straightforward. ## Installation with cpanm If you have cpanm, you only need one line: % cpanm Devel::StackTrace If you are installing into a system-wide directory, you may need to pass the "-S" flag to cpanm, which uses sudo to install the module: % cpanm -S Devel::StackTrace ## Installing with the CPAN shell Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan Devel::StackTrace ## Manual installation As a last resort, you can manually install it. Download the tarball, untar it, then build it: % perl Makefile.PL % make && make test Then install it: % make install If you are installing into a system-wide directory, you may need to run: % sudo make install ## Documentation Devel-StackTrace documentation is available as POD. You can run perldoc from a shell to read the documentation: % perldoc Devel::StackTrace dist.ini100644001750001750 132412052607734 16512 0ustar00autarchautarch000000000000Devel-StackTrace-1.30name = Devel-StackTrace author = Dave Rolsky license = Artistic_2_0 copyright_holder = Dave Rolsky copyright_year = 2012 version = 1.30 [NextRelease] format = %-6v %{yyyy-MM-dd}d [@Basic] [InstallGuide] [MetaJSON] [MetaResources] bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-StackTrace bugtracker.mailto = bug-devel-stacktrace@rt.cpan.org repository.url = git://git.urth.org/Devel-StackTrace.git repository.web = http://git.urth.org/Devel-StackTrace.git repository.type = git [PodWeaver] [PkgVersion] [EOLTests] [NoTabsTests] [PodSyntaxTests] [Test::CPAN::Changes] [Test::Pod::LinkCheck] [Test::Pod::No404s] [CheckChangeLog] [AutoPrereqs] skip = ^Test$ [@Git] META.yml100644001750001750 125612052607734 16323 0ustar00autarchautarch000000000000Devel-StackTrace-1.30--- abstract: 'An object representing a stack trace' author: - 'Dave Rolsky ' build_requires: Test::More: 0.88 base: 0 bytes: 0 configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300028, CPAN::Meta::Converter version 2.120921' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Devel-StackTrace requires: File::Spec: 0 Scalar::Util: 0 overload: 0 perl: 5.006 strict: 0 warnings: 0 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-StackTrace repository: git://git.urth.org/Devel-StackTrace.git version: 1.30 MANIFEST100644001750001750 64712052607734 16166 0ustar00autarchautarch000000000000Devel-StackTrace-1.30Changes INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini lib/Devel/StackTrace.pm lib/Devel/StackTrace/Frame.pm t/01-basic.t t/02-bad-utf8.t t/03-message.t t/04-indent.t t/05-back-compat.t t/06-dollar-at.t t/07-no-args.t t/release-cpan-changes.t t/release-eol.t t/release-no-tabs.t t/release-pod-coverage.t t/release-pod-linkcheck.t t/release-pod-no404s.t t/release-pod-spell.t t/release-pod-syntax.t META.json100644001750001750 267412052607734 16500 0ustar00autarchautarch000000000000Devel-StackTrace-1.30{ "abstract" : "An object representing a stack trace", "author" : [ "Dave Rolsky " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.300028, CPAN::Meta::Converter version 2.120921", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-StackTrace", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "File::Spec" : "0", "Scalar::Util" : "0", "overload" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Test::More" : "0.88", "base" : "0", "bytes" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-devel-stacktrace@rt.cpan.org", "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-StackTrace" }, "repository" : { "type" : "git", "url" : "git://git.urth.org/Devel-StackTrace.git", "web" : "http://git.urth.org/Devel-StackTrace.git" } }, "version" : "1.30" } Makefile.PL100644001750001750 221312052607734 17016 0ustar00autarchautarch000000000000Devel-StackTrace-1.30 use strict; use warnings; use 5.006; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "An object representing a stack trace", "AUTHOR" => "Dave Rolsky ", "BUILD_REQUIRES" => { "Test::More" => "0.88", "base" => 0, "bytes" => 0 }, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Devel-StackTrace", "EXE_FILES" => [], "LICENSE" => "artistic_2", "NAME" => "Devel::StackTrace", "PREREQ_PM" => { "File::Spec" => 0, "Scalar::Util" => 0, "overload" => 0, "strict" => 0, "warnings" => 0 }, "VERSION" => "1.30", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); t000755001750001750 012052607734 15151 5ustar00autarchautarch000000000000Devel-StackTrace-1.3001-basic.t100644001750001750 2424112052607734 17020 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More 0.88; use Devel::StackTrace; sub get_file_name { File::Spec->canonpath( ( 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, 1009, "First frame line should be 1009" ); 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" ); ok( !$f[0]->wantarray, "First frame wantarray should be false" ); my $trace_text = <<"EOF"; Trace begun at $test_file_name line 1009 main::baz(1, 2) called at $test_file_name line 1005 main::bar(1) called at $test_file_name line 1001 main::foo at $test_file_name line 13 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 1009 main::baz at $test_file_name line 99 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' ); } { my $trace = max_arg_length('abcdefghijklmnop'); my $trace_text = <<"EOF"; Trace begun at $test_file_name line 1021 main::max_arg_length('abcdefghij...') called at $test_file_name line 308 EOF is( $trace->as_string, $trace_text, 'trace text' ); my $trace_text_1 = <<"EOF"; Trace begun at $test_file_name line 1021 main::max_arg_length('abc...') called at $test_file_name line 308 EOF is( $trace->as_string( { max_arg_length => 3 } ), $trace_text_1, 'trace text, max_arg_length = 3', ); } SKIP: { skip "Test only runs on Linux", 1 unless $^O eq 'linux'; my $frame = Devel::StackTrace::Frame->new( [ 'Foo', 'foo/bar///baz.pm', 10, 'bar', 1, 1, '', 0 ], [] ); is( $frame->filename, 'foo/bar/baz.pm', 'filename is canonicalized' ); } { my $obj = RefTest4->new(); my $trace = $obj->{trace}; ok( ( !grep { ref $_ } map { @{ $_->{args} } } @{ $trace->{raw} } ), 'raw data does not contain any references when no_refs is true' ); is( $trace->{raw}[1]{args}[1], 'not a ref', 'non-refs are preserved properly in raw data as well' ); } { my $trace = overload_no_stringify( CodeOverload->new() ); eval { $trace->as_string() }; is( $@, q{}, 'no error when respect_overload is true and object overloads but does not stringify' ); } { my $trace = Filter::foo(); my @frames = $trace->frames(); is( scalar @frames, 2, 'frame_filtered trace has just 2 frames' ); is( $frames[0]->subroutine(), 'Devel::StackTrace::new', 'first subroutine' ); is( $frames[1]->subroutine(), 'Filter::bar', 'second subroutine (skipped Filter::foo)' ); } { my $trace = FilterAllFrames::a_foo(); my @frames = $trace->frames(); is( scalar @frames, 2, 'after filtering whole list of frames, got just 2 frames' ); is( $frames[0]->subroutine(), 'FilterAllFrames::a_bar', 'first subroutine' ); is( $frames[1]->subroutine(), 'FilterAllFrames::a_foo', 'second subroutine' ); } done_testing(); # 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 ); } sub max_arg_length { Devel::StackTrace->new( max_arg_length => 10 ); } sub overload_no_stringify { return Devel::StackTrace->new( no_refs => 1, 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 ); } package RefTest4; sub new { my $self = bless {}, shift; $self->{trace} = trace( $self, 'not a ref' ); return $self; } sub trace { Devel::StackTrace->new( no_refs => 1 ); } package CodeOverload; use overload '&{}' => sub {'foo'}; sub new { my $class = shift; return bless {}, $class; } package Filter; sub foo { bar(); } sub bar { return Devel::StackTrace->new( frame_filter => sub { $_[0]{caller}[3] ne 'Filter::foo' } ); } package FilterAllFrames; sub a_foo { b_foo() } sub b_foo { a_bar() } sub a_bar { b_bar() } sub b_bar { my $stacktrace = Devel::StackTrace->new(); $stacktrace->frames( only_a_frames( $stacktrace->frames() ) ); return $stacktrace; } sub only_a_frames { my @frames = @_; return grep { $_->subroutine() =~ /^FilterAllFrames::a/ } @frames; } 04-indent.t100644001750001750 103312052607734 17175 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; use Devel::StackTrace; sub foo { return Devel::StackTrace->new(@_); } sub make_dst { foo(@_); } { my $dst = make_dst(); for my $line ( split /\n/, $dst->as_string() ) { unlike( $line, qr/^\s/, 'line does not start with whitespace' ); } } { my $dst = make_dst( indent => 1 ); my @lines = split /\n/, $dst->as_string(); shift @lines; for my $line (@lines) { like( $line, qr/^\s/, 'line starts with whitespace' ); } } done_testing(); 03-message.t100644001750001750 71312052607734 17323 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; use Devel::StackTrace; sub foo { return Devel::StackTrace->new(@_); } sub make_dst { foo(@_); } { my $dst = make_dst(); like( $dst->as_string(), qr/^Trace begun/, q{default message is "Trace begun"} ); } { my $dst = make_dst( message => 'Foo bar' ); like( $dst->as_string(), qr/^Foo bar/, q{set explicit message for trace} ); } done_testing(); 07-no-args.t100644001750001750 127312052607734 17273 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; use Devel::StackTrace; { my $trace = foo( 1, 2 ); is_deeply( [ map { [ $_->args() ] } $trace->frames() ], [ ['Devel::StackTrace'], [ 3, 4 ], [ 1, 2 ], ], 'trace includes args' ); $trace = foo( 0, 2 ); is_deeply( [ map { [ $_->args() ] } $trace->frames() ], [ [], [], [], ], 'trace does not include args' ); } done_testing(); sub foo { $_[0] ? bar( 3, 4 ) : baz( 3, 4 ); } sub bar { return Devel::StackTrace->new(); } sub baz { return Devel::StackTrace->new( no_args => 1 ); } 02-bad-utf8.t100644001750001750 141412052607734 17327 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; eval 'use Encode'; plan skip_all => 'These tests require Encode.pm' unless eval 'use Encode; 1'; plan skip_all => 'These tests require Perl 5.8.8+' unless $] >= 5.008008; plan skip_all => 'These tests are not relevant with Perl 5.13.8+' if $] >= 5.013008; use Devel::StackTrace; # This should be invalid UTF8 my $raw_bad = do { use bytes; chr(0xED) . chr(0xA1) . chr(0xBA) }; my $decoded = Encode::decode( 'utf8' => $raw_bad ); my $trace = foo($decoded); my $string = eval { $trace->as_string() }; my $e = $@; is( $e, '', 'as_string() does not throw an exception' ); like( $string, qr/\Q(bad utf-8)/, 'stringified output notes bad utf-8' ); sub foo { Devel::StackTrace->new(); } done_testing(); release-eol.t100644001750001750 47612052607734 17662 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::EOL'; plan skip_all => 'Test::EOL required' if $@; all_perl_files_ok({ trailing_whitespace => 1 }); 06-dollar-at.t100644001750001750 66312052607734 17565 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; use Devel::StackTrace; { $@ = my $msg = q{Don't tread on me}; Devel::StackTrace->new()->frame(0)->as_string(); is( $@, $msg, '$@ is not overwritten in as_string() method' ); } { $@ = my $msg = q{Don't tread on me}; Devel::StackTrace->new( ignore_package => 'Foo' )->frames(); is( $@, $msg, '$@ is not overwritten in _make_filter() method' ); } done_testing(); 05-back-compat.t100644001750001750 22512052607734 20060 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/tuse strict; use warnings; use Test::More; use Devel::StackTrace; isa_ok( 'Devel::StackTraceFrame', 'Devel::StackTrace::Frame' ); done_testing(); release-no-tabs.t100644001750001750 45012052607734 20436 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::NoTabs'; plan skip_all => 'Test::NoTabs required' if $@; all_perl_files_ok(); release-pod-spell.t100644001750001750 115512052607734 21015 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::Spelling; my @stopwords; for () { chomp; push @stopwords, $_ unless /\A (?: \# | \s* \z)/msx; # skip comments, whitespace } add_stopwords(@stopwords); set_spell_cmd('aspell list -l en'); # This prevents a weird segfault from the aspell command - see # https://bugs.launchpad.net/ubuntu/+source/aspell/+bug/71322 local $ENV{LC_ALL} = 'C'; all_pod_files_spelling_ok; __DATA__ CPAN Rolsky stacktrace release-pod-syntax.t100644001750001750 45012052607734 21201 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); release-pod-no404s.t100644001750001750 76512052607734 20713 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; foreach my $env_skip ( qw( SKIP_POD_NO404S AUTOMATED_TESTING ) ){ plan skip_all => "\$ENV{$env_skip} is set, skipping" if $ENV{$env_skip}; } eval "use Test::Pod::No404s"; if ( $@ ) { plan skip_all => 'Test::Pod::No404s required for testing POD'; } else { all_pod_files_ok(); } Devel000755001750001750 012052607734 16513 5ustar00autarchautarch000000000000Devel-StackTrace-1.30/libStackTrace.pm100644001750001750 2703512052607734 21264 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/lib/Develpackage Devel::StackTrace; { $Devel::StackTrace::VERSION = '1.30'; } use 5.006; use strict; use warnings; use Devel::StackTrace::Frame; use File::Spec; use Scalar::Util qw( blessed ); use overload '""' => \&as_string, fallback => 1; sub new { my $class = shift; my %p = @_; # Backwards compatibility - this parameter was renamed to no_refs # ages ago. $p{no_refs} = delete $p{no_object_refs} if exists $p{no_object_refs}; my $self = bless { index => undef, frames => [], raw => [], %p, }, $class; $self->_record_caller_data(); return $self; } sub _record_caller_data { my $self = shift; # We exclude this method by starting one frame back. my $x = 1; while ( my @c = $self->{no_args} ? caller( $x++ ) : do { package # the newline keeps dzil from adding a version here DB; @DB::args = (); caller( $x++ ); } ) { my @args; unless ( $self->{no_args} ) { @args = @DB::args; if ( $self->{no_refs} ) { @args = map { ref $_ ? $self->_ref_to_string($_) : $_ } @args; } } push @{ $self->{raw} }, { caller => \@c, args => \@args, }; } } sub _ref_to_string { my $self = shift; my $ref = shift; return overload::AddrRef($ref) if blessed $ref && $ref->isa('Exception::Class::Base'); return overload::AddrRef($ref) unless $self->{respect_overload}; local $@; local $SIG{__DIE__}; my $str = eval { $ref . '' }; return $@ ? overload::AddrRef($ref) : $str; } sub _make_frames { my $self = shift; my $filter = $self->_make_frame_filter; my $raw = delete $self->{raw}; for my $r ( @{$raw} ) { next unless $filter->($r); $self->_add_frame( $r->{caller}, $r->{args} ); } } my $default_filter = sub { 1 }; sub _make_frame_filter { my $self = shift; my ( @i_pack_re, %i_class ); if ( $self->{ignore_package} ) { local $@; local $SIG{__DIE__}; $self->{ignore_package} = [ $self->{ignore_package} ] unless eval { @{ $self->{ignore_package} } }; @i_pack_re = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} }; } my $p = __PACKAGE__; push @i_pack_re, qr/^\Q$p\E$/; if ( $self->{ignore_class} ) { $self->{ignore_class} = [ $self->{ignore_class} ] unless ref $self->{ignore_class}; %i_class = map { $_ => 1 } @{ $self->{ignore_class} }; } my $user_filter = $self->{frame_filter}; return sub { return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re; return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class; if ($user_filter) { return $user_filter->( $_[0] ); } return 1; }; } sub _add_frame { my $self = shift; my $c = shift; my $p = shift; # eval and is_require are only returned when applicable under 5.00503. push @$c, ( undef, undef ) if scalar @$c == 6; push @{ $self->{frames} }, Devel::StackTrace::Frame->new( $c, $p, $self->{respect_overload}, $self->{max_arg_length}, $self->{message}, $self->{indent} ); } sub next_frame { my $self = shift; # reset to top if necessary. $self->{index} = -1 unless defined $self->{index}; my @f = $self->frames(); if ( defined $f[ $self->{index} + 1 ] ) { return $f[ ++$self->{index} ]; } else { $self->{index} = undef; return undef; } } sub prev_frame { my $self = shift; my @f = $self->frames(); # reset to top if necessary. $self->{index} = scalar @f unless defined $self->{index}; if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) { return $f[ --$self->{index} ]; } else { $self->{index} = undef; return undef; } } sub reset_pointer { my $self = shift; $self->{index} = undef; } sub frames { my $self = shift; if (@_) { die "Devel::StackTrace->frames() can only take Devel::StackTrace::Frame args\n" if grep { !$_->isa('Devel::StackTrace::Frame') } @_; $self->{frames} = \@_; } else { $self->_make_frames() if $self->{raw}; } 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 $p = shift; my $st = ''; my $first = 1; foreach my $f ( $self->frames() ) { $st .= $f->as_string( $first, $p ) . "\n"; $first = 0; } return $st; } { package Devel::StackTraceFrame; our @ISA = 'Devel::StackTrace::Frame'; } 1; # ABSTRACT: An object representing a stack trace __END__ =pod =head1 NAME Devel::StackTrace - An object representing a stack trace =head1 VERSION version 1.30 =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 $frame->hasargs; } # from bottom (least recent) of stack to top. while (my $frame = $trace->prev_frame) { print "Sub: ", $frame->subroutine, "\n"; } =head1 DESCRIPTION The Devel::StackTrace module contains two classes, Devel::StackTrace and Devel::StackTrace::Frame. 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::StackTrace::Frame objects, one for each level of the stack. The frames contain all the data available from C. This code was created to support my L 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 * Devel::StackTrace->new(%named_params) Returns a new Devel::StackTrace object. Takes the following parameters: =over 8 =item * frame_filter => $sub By default, Devel::StackTrace will include all stack frames before the call to its its constructor. However, you may want to filter out some frames with more granularity than 'ignore_package' or 'ignore_class' allow. You can provide a subroutine which is called with the raw frame data for each frame. This is a hash reference with two keys, "caller", and "args", both of which are array references. The "caller" key is the raw data as returned by Perl's C function, and the "args" key are the subroutine arguments found in C<@DB::args>. The filter should return true if the frame should be included, or false if it should be skipped. =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 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 * no_args => $boolean If this parameter is true, then Devel::StackTrace will not store caller arguments in stack trace frames at all. =item * respect_overload => $boolean By default, Devel::StackTrace will call C 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. =item * max_arg_length => $integer By default, Devel::StackTrace will display the entire argument for each subroutine call. Setting this parameter causes truncates each subroutine argument's string representation if it is longer than this number of characters. =item * message => $string By default, Devel::StackTrace will use 'Trace begun' as the message for the first stack frame when you call C. You can supply an alternative message using this option. =item * indent => $boolean If this parameter is true, each stack frame after the first will start with a tab character, just like C. =back =item * $trace->next_frame Returns the next Devel::StackTrace::Frame 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 or C will work properly. =item * $trace->prev_frame Returns the next Devel::StackTrace::Frame 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 or C will work properly. =item * $trace->reset_pointer Resets the pointer so that the next call C or C will start at the top or bottom of the stack, as appropriate. =item * $trace->frames When this method is called with no arguments, it returns a list of L objects. They are returned in order from top (most recent) to bottom. This method can also be used to set the object's frames if you pass it a list of L objects objects. This is useful if you want to filter the list of frames in ways that are more complex than can be handled by C: $stacktrace->frames( my_filter( $stacktrace->frames() ) ); =item * $trace->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 * $trace->frame_count Returns the number of frames in the trace object. =item * $trace->as_string(\%p) Calls as_string on each frame from top to bottom, producing output quite similar to the Carp module's cluck/confess methods. The optional C<\%p> parameter only has one useful option. The C parameter truncates each subroutine argument's string representation if it is longer than this number of characters. =back =head1 SUPPORT Please submit bugs to the CPAN RT system at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel%3A%3AStackTrace or via email at bug-devel-stacktrace@rt.cpan.org. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2012 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut release-pod-coverage.t100644001750001750 123512052607734 21470 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; use Test::Pod::Coverage 1.04; my @modules = all_modules(); plan tests => scalar @modules; my %trustme = ( 'Devel::StackTrace::Frame' => [qw( new as_string )], ); for my $module ( sort @modules ) { my $trustme = []; if ( $trustme{$module} ) { my $methods = join '|', @{ $trustme{$module} }; $trustme = [qr/^(?:$methods)$/]; } pod_coverage_ok( $module, { trustme => $trustme }, "Pod coverage for $module" ); } release-cpan-changes.t100644001750001750 47112052607734 21425 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); done_testing(); release-pod-linkcheck.t100644001750001750 77512052607734 21620 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; foreach my $env_skip ( qw( SKIP_POD_LINKCHECK ) ){ plan skip_all => "\$ENV{$env_skip} is set, skipping" if $ENV{$env_skip}; } eval "use Test::Pod::LinkCheck"; if ( $@ ) { plan skip_all => 'Test::Pod::LinkCheck required for testing POD'; } else { Test::Pod::LinkCheck->new->all_pod_ok; } StackTrace000755001750001750 012052607734 20537 5ustar00autarchautarch000000000000Devel-StackTrace-1.30/lib/DevelFrame.pm100644001750001750 1161312052607734 22311 0ustar00autarchautarch000000000000Devel-StackTrace-1.30/lib/Devel/StackTracepackage Devel::StackTrace::Frame; { $Devel::StackTrace::Frame::VERSION = '1.30'; } use strict; use warnings; # 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} }; } } { my @fields = ( qw( package filename line subroutine hasargs wantarray evaltext is_require hints bitmask ) ); sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless {}, $class; @{$self}{@fields} = @{ shift() }; # fixup unix-style paths on win32 $self->{filename} = File::Spec->canonpath( $self->{filename} ); $self->{args} = shift; $self->{respect_overload} = shift; $self->{max_arg_length} = shift; $self->{message} = shift; $self->{indent} = shift; return $self; } } sub args { my $self = shift; return @{ $self->{args} }; } sub as_string { my $self = shift; my $first = shift; my $p = 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 = defined $self->{message} ? $self->{message} : '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_to_string($_) if ref $_; local $SIG{__DIE__}; local $@; eval { my $max_arg_length = exists $p->{max_arg_length} ? $p->{max_arg_length} : $self->{max_arg_length}; if ( $max_arg_length && length $_ > $max_arg_length ) { substr( $_, $max_arg_length ) = '...'; } s/'/\\'/g; # 'quote' arg unless it looks like a number $_ = "'$_'" unless /^-?[\d.]+$/; # print control/high ASCII chars as 'M-' or '^' s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; }; if ( my $e = $@ ) { $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?'; } } # append ('all', 'the', 'arguments') to the $sub string $sub .= '(' . join( ', ', @a ) . ')'; $sub .= ' called'; } } # If the user opted into indentation (a la Carp::confess), pre-add a tab my $tab = $self->{indent} && !$first ? "\t" : q{}; return "${tab}$sub at " . $self->filename . ' line ' . $self->line; } 1; # ABSTRACT: A single frame in a stack trace __END__ =pod =head1 NAME Devel::StackTrace::Frame - A single frame in a stack trace =head1 VERSION version 1.30 =head1 DESCRIPTION See L for details. =head1 METHODS See the L documentation for more information on what these methods return. =over 4 =item * $frame->package =item * $frame->filename =item * $frame->line =item * $frame->subroutine =item * $frame->hasargs =item * $frame->wantarray =item * $frame->evaltext Returns undef if the frame was not part of an eval. =item * $frame->is_require Returns undef if the frame was not part of a require. =item * $frame->args Returns the arguments passed to the frame. Note that any arguments that are references are returned as references, not copies. =item * $frame->hints =item * $frame->bitmask =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2012 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut