Devel-Confess-0.009004/000755 000765 000024 00000000000 13050444252 014663 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/Changes000644 000765 000024 00000012452 13050444226 016163 0ustar00gknopstaff000000 000000 Release history for Devel-Confess 0.009004 - 2017-02-14 - prevent handlers from recursing, such as if our handlers are wrapped by other code. IO::All for example will do this. 0.009003 - 2016-11-18 - more complete prereq list - fix inf handling - work around UNIVERSAL::isa and UNIVERSAL::can 0.009002 - 2016-09-04 - fix test failures on perl 5.10.0 - fix regex warnings in perl 5.6 - work around threads issue in Carp in Safe compartments - don't skip dump test on Carp versions that use Carp::Heavy - test diagnostic and formatting improvements - avoid triggering overloads when checking for exception existence 0.009001 - 2016-08-19 - fix handling of infinite options (dump, source, evalsource) - fix evalsource test by running with the debugger 0.009000 - 2016-08-18 - documentation fixes and improvements - more accurate handling of existing %SIG handlers - updated option parsing to allow setting specific values, such as color=force - stop relying on . being in @INC in tests - source option now accepts a number of lines of context to show - added evalsource option, which shows the source only of string evals - fix adding redundant trace information when errors are rethrown - improved warning messages when source option can't find source to display 0.008000 - 2015-06-26 - if dump option is used, bare references and objects without stringify overloads will be dumpered when being output to the screen - stack trace properly attached to bare references are rethrown and will be output to the screen - avoid Test::More in threads test to limit code run as much as possible - other test cleanups - fix DEBUGGING detection in newer perls - protect tests against DEVEL_CONFESS_OPTIONS set in environment 0.007012 - 2015-03-30 - avoid re-throwing errors during END on debugging perls 0.007011 - 2015-02-03 - avoid triggering overloads when CLONEing 0.007010 - 2015-01-29 - fix incorrect version check that prevented using better names option - fix removing hooks when unimport called - fix stringifying refs in stack trace inside a Safe compartment on old perl - avoid updating stored refaddrs when they haven't changed - less noise when checking for broken threads - prevent leaking namespaces even in broken threads - fix version check for broken threads 0.007009 - 2015-01-23 - prevent segfaults on perl 5.10.0 and 5.8.9 with threads - fix leaking exception objects if another is thrown or a thread created 0.007008 - 2015-01-20 - don't attempt threading tests if threading is broken 0.007007 - 2015-01-19 - fatal warnings in destructors can cause segfaults, so disable them - protect against losing information during global destruction and then triggering our own errors - improve stack trace formatting when generated during global destruction 0.007006 - 2015-01-08 - don't delete packages that exceptions are currently blessed as - protect tests against other loaded modules effecting hooks - add test for warning passing fix from 0.007005 0.007005 - 2014-12-16 - fix how we pass options on to other warn/die handlers (RT#100951) - minor pod cleanups - improve diagnostics for bad options in DEVEL_CONFESS_OPTIONS 0.007004 - 2014-09-22 - make sure unwanted debugging flags are disabled as early as possible, fixing several possible crashes 0.007003 - 2014-07-26 - fix leak test on new versions of Test::More - prevent PAUSE from trying (and failing) to index an internal package 0.007002 - 2014-07-16 - further fixes for interactions with Safe.pm on perl 5.8 0.007001 - 2014-06-27 - fix Safe.pm interaction in perls older than 5.20 0.007000 - 2014-06-26 - fix dist name in metadata - add dump1, dump2, etc options to control dump max depth - quote arguments differently, ensuring they will always be on one line - fix issues when triggered in Safe compartments 0.006001 - 2014-03-06 - fix test failures on Windows when optional module not installed 0.006000 - 2014-03-04 - rewrote docs with better enables - allow DEVEL_CONFESS_OPTIONS to use comma separators - no longer disables itself during global destruction - warnings and errors can now be enabled/disabled individually - use Win32::Console::ANSI for color on Windows if available 0.005000 - 2013-11-07 - add source option to dump source of code surrounding trace. 0.004000 - 2013-11-05 - rename 'hacks' option and module to 'builtin' - add dump option to include contents of references in traces. - add color option to colorize warnings or errors in terminal. - fix handling of outer __DIE__ hooks - prevent slowdown when loaded via -d - fixed Exception::Base builtin handling 0.003001 - 2013-10-07 - fix compatibility with perl 5.6 - fix some minor memory leaks - trigger overloads more carefully - check roles using ->does as well as ->DOES 0.003000 - 2013-10-04 - Rename to Devel::Confess instead of having an alias (I am bad at naming things) - Ouch exceptions can now work without hacks 0.002002 - 2013-09-21 - fix 5.8 compatibility 0.002001 - 2013-09-20 - properly list Scalar::Util as a prereq - fix tests on Windows 0.002000 - 2013-09-19 - rename module from Carp::Always::AndRefs to Carp::Always::EvenObjects - some documentation tweaks - fix using Devel::Confess under debugger 0.001000 - 2013-09-19 - initial release Devel-Confess-0.009004/lib/000755 000765 000024 00000000000 13050444251 015430 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/maint/000755 000765 000024 00000000000 13050444251 015772 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/Makefile.PL000644 000765 000024 00000005364 13000514653 016643 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; my %META = ( name => 'Devel-Confess', license => 'perl_5', dynamic_config => 0, prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, build => { requires => { } }, test => { requires => { 'File::Temp' => 0, 'Test::More' => 0, 'Safe' => 0, 'Cwd' => 0, 'File::Spec' => 0, 'IPC::Open3' => 0, } }, runtime => { requires => { 'perl' => '5.006', 'Carp' => 0, 'Scalar::Util' => 0, } }, develop => { requires => { 'Exception::Class' => 0, 'Ouch' => 0, 'Class::Throwable' => 0, 'Exception::Base' => 0, } }, }, resources => { repository => { url => 'git://github.com/haarg/Devel-Confess', web => 'https://github.com/haarg/Devel-Confess', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Confess', mailto => 'bug-Devel-Confess@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, ); my %MM_ARGS = (); ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### Devel-Confess-0.009004/MANIFEST000644 000765 000024 00000001266 13050444252 016021 0ustar00gknopstaff000000 000000 Changes lib/Devel/Confess.pm lib/Devel/Confess/_Util.pm lib/Devel/Confess/Builtin.pm lib/Devel/Confess/Source.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/color.t t/confess.t t/devel.t t/dump.t t/end-debugging.t t/evalsource.t t/find_sig.t t/global-destruct.t t/leak.t t/lib/Capture.pm t/lib/MiniTest.pm t/lib/ThreadsCheck.pm t/names.t t/options.t t/rethrow.t t/safe.t t/sig.t t/source.t t/threads.t t/universal.t xt/builtin.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Devel-Confess-0.009004/META.json000644 000765 000024 00000003504 13050444251 016305 0ustar00gknopstaff000000 000000 { "abstract" : "Include stack traces on all warnings and errors", "author" : [ "haarg - Graham Knop (cpan:HAARG) " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-Confess", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Class::Throwable" : "0", "Exception::Base" : "0", "Exception::Class" : "0", "Ouch" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Scalar::Util" : "0", "perl" : "5.006" } }, "test" : { "requires" : { "Cwd" : "0", "File::Spec" : "0", "File::Temp" : "0", "IPC::Open3" : "0", "Safe" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Devel-Confess@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Confess" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/haarg/Devel-Confess", "web" : "https://github.com/haarg/Devel-Confess" } }, "version" : "0.009004", "x_serialization_backend" : "JSON::PP version 2.27300" } Devel-Confess-0.009004/META.yml000644 000765 000024 00000001555 13050444251 016141 0ustar00gknopstaff000000 000000 --- abstract: 'Include stack traces on all warnings and errors' author: - 'haarg - Graham Knop (cpan:HAARG) ' build_requires: Cwd: '0' File::Spec: '0' File::Temp: '0' IPC::Open3: '0' Safe: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-Confess no_index: directory: - t - inc requires: Carp: '0' Scalar::Util: '0' perl: '5.006' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Confess license: http://dev.perl.org/licenses/ repository: git://github.com/haarg/Devel-Confess version: '0.009004' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-Confess-0.009004/README000644 000765 000024 00000014426 13050444252 015552 0ustar00gknopstaff000000 000000 NAME Devel::Confess - Include stack traces on all warnings and errors SYNOPSIS Use on the command line: # Make every warning and error include a full stack trace perl -d:Confess script.pl # Also usable as a module perl -MDevel::Confess script.pl # display warnings in yellow and errors in red perl -d:Confess=color script.pl # set options by environment export DEVEL_CONFESS_OPTIONS='color dump' perl -d:Confess script.pl Can also be used inside a script: use Devel::Confess; use Devel::Confess 'color'; # disable stack traces no Devel::Confess; DESCRIPTION This module is meant as a debugging aid. It can be used to make a script complain loudly with stack backtraces when "warn()"ing or "die()"ing. Unlike other similar modules (e.g. Carp::Always), stack traces will also be included when exception objects are thrown. The stack traces are generated using Carp, and will work for all types of errors. Carp's "carp" and "croak" functions will also be made to include stack traces. # it works for explicit die's and warn's $ perl -d:Confess -e 'sub f { die "arghh" }; sub g { f }; g' arghh at -e line 1. main::f() called at -e line 1 main::g() called at -e line 1 # it works for interpreter-thrown failures $ perl -d:Confess -w -e 'sub f { $a = shift; @a = @$a };' \ -e 'sub g { f(undef) }; g' Use of uninitialized value $a in array dereference at -e line 1. main::f(undef) called at -e line 2 main::g() called at -e line 2 Internally, this is implemented with $SIG{__WARN__} and $SIG{__DIE__} hooks. Stack traces are also included if raw non-object references are thrown. This module is compatible with all perl versions back to 5.6.2, without additional prerequisites. It contains workarounds for a number of bugs in the perl interpreter, some of which effect comparatively simpler modules, like Carp::Always. METHODS import( @options ) Enables stack traces and sets options. A list of options to enable can be passed in. Prefixing the options with "no_" will disable them. "objects" Enable attaching stack traces to exception objects. Enabled by default. "builtin" Load the Devel::Confess::Builtin module to use built in stack traces on supported exception types. Disabled by default. "dump" Dumps the contents of references in arguments in stack trace, instead of only showing their stringified version. Also causes exceptions that are non-object references and objects without string overloads to be dumped if being displayed. Shows up to three references deep. Disabled by default. "dump0", "dump1", "dump2", etc The same as the dump option, but with a different max depth to dump. A depth of 0 is treated as infinite. "color" Colorizes error messages in red and warnings in yellow. Disabled by default. "source" Includes a snippet of the source for each level of the stack trace. Disabled by default. "source0", "source1", "source2", etc Enables source display, but with a specified number of lines of context to show. Context of 0 will show the entire source of the files. "evalsource" Similar to the source option, but only shows includes source for string evals. Useful for seeing the results of code generation. Disabled by default. Overrides the source option. "evalsource0", "evalsource1", "evalsource2", etc Enables eval source display, but with a specified number of lines of context to show. Context of 0 will show the entire source of the evals. "better_names" Use more informative names to string evals and anonymous subs in stack traces. Enabled by default. "errors" Add stack traces to errors. Enabled by default. "warnings" Add stack traces to warnings. Enabled by default. The default options can be changed by setting the "DEVEL_CONFESS_OPTIONS" environment variable to a space separated list of options. CONFIGURATION %Devel::Confess::NoTrace Classes or roles added to this hash will not have stack traces attached to them. This is useful for exception classes that provide their own stack traces, or classes that don't cope well with being re-blessed. If Devel::Confess::Builtin is loaded, it will automatically add its supported exception types to this hash. Default Entries: Throwable::Error Provides a stack trace Moose::Error::Default Provides a stack trace ACKNOWLEDGMENTS The idea and parts of the code and documentation are taken from Carp::Always. SEE ALSO * Carp::Always * Carp * Acme::JavaTrace and Devel::SimpleTrace * Carp::Always::Color * Carp::Source::Always * Carp::Always::Dump CAVEATS This module uses several ugly tricks to do its work and surely has bugs. * This module uses $SIG{__WARN__} and $SIG{__DIE__} to accomplish its goal, and thus may not play well with other modules that try to use these hooks. Significant effort has gone into making this work as well as possible, but global variables like these can never be fully encapsulated. * To provide stack traces on exception objects, this module re-blesses the exception objects into a generated class. While it tries to have the smallest effect it can, some things cannot be worked around. In particular, "ref($exception)" will return a different value than may be expected. Any module that relies on the specific return value from "ref" like already has bugs though. SUPPORT Please report bugs via CPAN RT . AUTHORS * Graham Knop CONTRIBUTORS * Adriano Ferreira COPYRIGHT Copyright (c) 2005-2013 the "AUTHORS" and "CONTRIBUTORS" as listed above. LICENSE This library is free software and may be distributed under the same terms as perl itself. See . Devel-Confess-0.009004/t/000755 000765 000024 00000000000 13050444251 015125 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/xt/000755 000765 000024 00000000000 13050444251 015315 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/xt/builtin.t000644 000765 000024 00000002315 13012142277 017152 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use lib 't/lib'; use Capture 'capture', capture_builtin => ['-MDevel::Confess::Builtin'], ; use Devel::Confess::Builtin (); my @class = ( 'Exception::Class' => { declare => 'use Exception::Class qw(MyException);', throw => 'MyException->throw("nope");', }, 'Ouch' => { throw => 'Ouch::ouch(100, "nope");', }, 'Class::Throwable' => { throw => 'Class::Throwable->throw("nope");', }, 'Exception::Base' => { declare => 'use Exception::Base qw(MyException);', throw => 'MyException->throw("nope");', }, ); plan tests => scalar @class; while (@class) { my ($class, $info) = splice @class, 0, 2; (my $module = "$class.pm") =~ s{::}{/}g; require $module; my $declare = $info->{declare} || "use $class;"; my $code = <{throw} } package PackageB; sub g { PackageA::f(); } END my $before = capture_builtin $code.'PackageB::g();'; my $after = capture $code.'require Devel::Confess::Builtin;Devel::Confess::Builtin->import(); PackageB::g();'; like $before, qr/PackageB::g/, "verbose when loaded before $class"; like $after, qr/PackageB::g/, "verbose when loaded after $class"; } Devel-Confess-0.009004/t/color.t000644 000765 000024 00000001061 12755226241 016436 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 1; use lib 't/lib'; use Capture capture_color => ['-MDevel::Confess=color=force']; is capture_color <<"END_CODE", package A; sub f { #line 1 test-block.pl die "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", \e[31mBeware!\e[m at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'error message properly colorized'; Devel-Confess-0.009004/t/confess.t000644 000765 000024 00000010216 13012136417 016752 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 32; use lib 't/lib'; use Capture capture => ['-MDevel::Confess'], capture_dump => ['-MDevel::Confess=dump'], ; sub scrub_refaddr ($) { my $in = shift; $in =~ s/\b([A-Z]+)\(0x[0-9a-zA-Z]+\)/$1(0xXXXXXX)/g; $in; } is capture <<"END_CODE", package A; sub f { #line 1 test-block.pl warn "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'basic test'; is capture <<"END_CODE", package A; sub f { \tuse strict; \tmy \$a; #line 1 test-block.pl \tmy \@a = \@\$a; } sub g { #line 2 test-block.pl \tf(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Can't use an undefined value as an ARRAY reference at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'interpreter-thrown warnings'; for my $type (qw(die croak confess)) { is capture <<"END_CODE", use Carp; #line 1 test-block.pl $type "foo at bar"; END_CODE <<"END_OUTPUT", foo at bar at test-block.pl line 1. END_OUTPUT "$type at root"; is capture <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type "foo at bar"; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", foo at bar at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type in sub"; is capture <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type "foo at bar\\n"; } sub bar { #line 2 test-block.pl foo(); } #line 3 test-block.pl bar(); END_CODE <<"END_OUTPUT", foo at bar at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 \tmain::bar() called at test-block.pl line 3 END_OUTPUT "$type with newline"; is scrub_refaddr capture <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type bless {}, 'NoOverload'; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", NoOverload=HASH(0xXXXXXX) at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with object"; is capture <<"END_CODE", use Carp; { package HasOverload; use overload '""' => sub { "message" }; } sub foo { #line 1 test-block.pl $type bless {}, 'HasOverload'; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", message at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with object with overload"; is capture_dump <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type bless {}, 'NoOverload'; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", bless( {}, 'NoOverload' ) at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with object + dump"; is capture_dump <<"END_CODE", use Carp; { package HasOverload; use overload '""' => sub { "message" }; } sub foo { #line 1 test-block.pl $type bless {}, 'HasOverload'; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", message at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with object with overload + dump"; is scrub_refaddr capture <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", ARRAY(0xXXXXXX) at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with non-object ref"; is capture_dump <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl foo(); END_CODE <<"END_OUTPUT", [1] at test-block.pl line 1. \tmain::foo() called at test-block.pl line 2 END_OUTPUT "$type with non-object ref + dump"; is scrub_refaddr capture_dump <<"END_CODE", use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl eval { foo(); }; print STDERR \$@ . "\\n"; die; END_CODE <<"END_OUTPUT", ARRAY(0xXXXXXX) [1] at test-block.pl line 1. \tmain::foo() called at test-block.pl line 3 \teval {...} called at test-block.pl line 2 END_OUTPUT "$type rethrowing non-object ref + dump"; } Devel-Confess-0.009004/t/devel.t000644 000765 000024 00000002067 12755226241 016426 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 2; use lib 't/lib'; use Capture capture_as_debugger => ['-d:Confess'], capture_with_debugger => ['-d', '-MDevel::Confess'], ; use Cwd qw(cwd); my $code = <<'END_CODE'; BEGIN { print STDERR "started\n" } package A; sub f { #line 1 test-block.pl die "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE my $expected = <<"END_OUTPUT"; Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT { my $out = capture_as_debugger $code; $out =~ s/\A.*?^started\s+//ms; is $out, $expected, 'Devel::Confess usable as a debugger'; } { local %ENV = %ENV; delete $ENV{$_} for grep /^PERL5?DB/, keys %ENV; delete $ENV{LOGDIR}; $ENV{HOME} = cwd; $ENV{PERLDB_OPTS} = 'NonStop noTTY dieLevel=1'; my $out = capture_with_debugger $code; $out =~ s/\A.*?^started\s+//ms; like $out, qr/^\Q$expected/, 'Devel::Confess usable with the debugger'; } Devel-Confess-0.009004/t/dump.t000644 000765 000024 00000001760 12763067776 016312 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Carp (); use Carp::Heavy (); use Test::More defined &Carp::format_arg ? (tests => 5) : (skip_all => 'Dump option not supported on ancient carp'); use Devel::Confess qw(dump); sub Foo::foo { die "error"; } sub Bar::bar { Foo::foo(@_); } sub Baz::baz { Bar::bar(@_); } eval { Baz::baz([1]) }; like $@, qr/Foo::foo\(\[1\]\)/, 'references are dumped in arguments'; eval { Baz::baz(["yarp\nnarp"]) }; like $@, qr/Foo::foo\(\["yarp\\nnarp"\]\)/, 'newlines are dumped in escaped form'; Devel::Confess->import('dump'); eval { Baz::baz([[[[]]]]) }; like $@, qr/Foo::foo\(\[\[\['ARRAY\(0x\w+\)'\]\]\]\)/, 'dump option limits depth to 3'; Devel::Confess->import('dump1'); eval { Baz::baz([[[[]]]]) }; like $@, qr/Foo::foo\(\['ARRAY\(0x\w+\)'\]\)/, 'dump1 option limits depth to 1'; Devel::Confess->import('dump0'); eval { Baz::baz([[[[]]]]) }; like $@, qr/Foo::foo\(\[\[\[\[\]\]\]\]\)/, 'dump0 option does not limit depth'; Devel-Confess-0.009004/t/end-debugging.t000644 000765 000024 00000000474 12755226241 020026 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 1; use lib 't/lib'; use Capture capture => ['-MDevel::Confess']; unlike capture <<"END_CODE", qr/Assertion failed/, "die in END"; sub error { #line 1 test-block.pl die "error in something"; } END { error() } END_CODE Devel-Confess-0.009004/t/evalsource.t000644 000765 000024 00000002071 12756756075 017510 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 3; use lib 't/lib'; use Capture capture_with_debugger => ['-d', '-MDevel::Confess=evalsource,nowarnings'], ; use Cwd qw(cwd); my $code = <<'END_CODE'; #line 1 test-block.pl sub Foo::foo { die "error"; } sub Bar::bar { eval 'Foo::foo()'; die $@ if $@; } eval 'sub Baz::baz { Bar::bar() } 1;' or die $@; Baz::baz(); END_CODE { local %ENV = %ENV; delete $ENV{$_} for grep /^PERL5?DB/, keys %ENV; delete $ENV{LOGDIR}; $ENV{HOME} = cwd; $ENV{PERLDB_OPTS} = 'NonStop noTTY dieLevel=1'; my $out = capture_with_debugger $code; for my $eval ('Foo::foo()', 'sub Baz::baz { Bar::bar() } 1;') { local $TODO = 'eval source not preserved after run in 5.10.0' if "$]" == 5.010_000 && $eval =~ /sub/; like $out, qr/context for \(eval \d+\).* line 1:\n\s*1 :.*\Q$eval\E/, 'trace includes eval text'; } my @file_context = grep !/\(eval/, $out =~ /context for (.*?) line/g; is join(', ', @file_context), '', 'trace only includes eval frames'; } Devel-Confess-0.009004/t/find_sig.t000644 000765 000024 00000003303 12661644426 017110 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 14; use Devel::Confess (); use Scalar::Util qw(blessed); sub DEFAULT { die "DEFAULT\n" } sub IGNORE { die "IGNORE\n" } sub string { die "string\n" } sub stub; sub Namespaced::string { die "Namespaced::string\n" } { no strict 'refs'; *{"main::0"} = sub { die "zero\n" }; } my $coderef = sub { die "coderef\n" }; { package CodeOverload; use overload '&{}' => sub { sub { die "CodeOverload\n" } }; sub new { bless {} } } { package StringOverload; use overload '""' => sub { "StringOverload::named" }; sub named { die "StringOverload::named\n" } sub new { bless {} } } { package FalseOverload; use overload 'bool' => sub { 0 }, '&{}' => sub { sub { die "FalseOverload\n" } }, ; sub new { bless {} } } sub _ex (&) { my $sub = $_[0]; local $@; eval { $sub->(); 1 } and return undef; my $e = $@; $e =~ s/(?: at .*? line [0-9]+\.)?\n//; return $e; } sub check_find { my $sub = do { no warnings 'uninitialized'; local $SIG{__DIE__} = $_[0]; Devel::Confess::_find_sig($SIG{__DIE__}); }; return "none" if !defined $sub; _ex { (\&$sub)->("welp"); }; } sub check_sig { no warnings 'uninitialized'; local $SIG{__DIE__} = $_[0]; _ex { die "none\n"; }; } for my $sig ( undef, 0, {}, '', $coderef, 'DEFAULT', 'IGNORE', 'string', 'stub', 'Namespaced::string', 'nonexistant', CodeOverload->new, StringOverload->new, FalseOverload->new, ) { my $name = blessed $sig ? (blessed($sig) . " instance") : ref $sig ? (ref($sig) . " ref") : defined $sig ? qq{"$sig"} : 'undef'; is(check_find($sig), check_sig($sig), "correct signal handler for $name" ); } Devel-Confess-0.009004/t/global-destruct.t000644 000765 000024 00000002205 12764245212 020413 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } no warnings 'once'; use Devel::Confess; use POSIX (); $| = 1; print "1..1\n"; { package MyException; use overload fallback => 1, '""' => sub { $_[0]->{message}; }, ; sub new { my ($class, $message) = @_; my $self = bless { message => $message }, $class; return $self; } } sub foo { eval { die MyException->new("yarp") }; $@; } sub bar { foo(); } # gd order is unpredictable, try multiple times our $last01 = bless {}, 'InGD'; our $last02 = bless {}, 'InGD'; our $ex = bar(); our $stringy = "$ex"; our $last03 = bless {}, 'InGD'; our $last04 = bless {}, 'InGD'; sub InGD::DESTROY { if (!defined $ex) { print "ok 1 # skip got unlucky on GD order, can't test\n"; } else { my $gd_stringy = "$ex"; my $ok = $gd_stringy eq $stringy; print ( ($ok ? '' : 'not ') . "ok 1 - stringifies properly in global destruction\n"); unless ($ok) { s/^/# /mg, s/\n$// for $stringy, $gd_stringy; print "# Got:\n$gd_stringy\n#\n# Expected:\n$stringy\n"; POSIX::_exit(1); } } POSIX::_exit(0); } Devel-Confess-0.009004/t/leak.t000644 000765 000024 00000001411 12545357231 016234 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Scalar::Util; use Test::More defined &Scalar::Util::weaken ? (tests => 4) : (skip_all => "Can't prevent leaks without Scalar::Util::weaken"); use Devel::Confess; my $gone = 0; { package MyException; sub new { bless {}, __PACKAGE__; } sub throw { die __PACKAGE__->new; } sub DESTROY { $gone++; } } eval { MyException->throw; }; my $class = ref $@; is $gone, 0, "exception not destroyed when captured"; undef $@; is $gone, 1, "exception destroyed after \$@ cleared"; ok !UNIVERSAL::can($class, 'DESTROY'), "temp packages don't leak"; $gone = 0; eval { MyException->throw; }; Devel::Confess->CLONE; undef $@; is $gone, 1, "exception destroyed after \$@ cleared"; Devel-Confess-0.009004/t/lib/000755 000765 000024 00000000000 13050444251 015673 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/t/names.t000644 000765 000024 00000001356 13043141373 016423 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Devel::Confess (); use Test::More Devel::Confess::_CAN_USE_INFORMATIVE_NAMES ? (tests => 2) : (skip_all => "Can't enable better names at runtime on perl < 5.8"); use Devel::Confess qw(better_names); sub foo { die "welp"; } my $bar = sub { foo(); }; sub baz { $bar->(); } eval q{ baz; }; my $err = $@; Devel::Confess->unimport; my $file = quotemeta __FILE__; my @lines = split /\n/, $err; my $fail; like $lines[2], qr/main::__ANON__\[$file:\d+\]\(\) called at/, 'anonymous function names include file and line number' or $fail = 1; like $lines[4], qr/baz;/, 'string evals include eval text' or $fail = 1; diag "Full error:\n$err" if $fail; Devel-Confess-0.009004/t/options.t000644 000765 000024 00000003234 12755472512 017023 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 19; use Devel::Confess (); sub parse; *parse = \&Devel::Confess::_parse_options; is_deeply parse(), {}, 'can parse no options'; is_deeply parse('objects'), { objects => 1 }, 'enable boolean option'; is_deeply parse('noobjects'), { objects => !1 }, 'disable boolean option'; is_deeply parse('no_objects'), { objects => !1 }, 'disable boolean option with underscore'; is_deeply parse('no-objects'), { objects => !1 }, 'disable boolean option with dash'; is_deeply parse('objects' => 5), { objects => 5 }, 'numeric argument separate'; is_deeply parse('objects5'), { objects => 5 }, 'numeric argument joined'; is_deeply parse('objects' => undef), { objects => undef }, 'undef argument separate'; is_deeply parse('objects=5'), { objects => 5 }, 'numeric argument with equals'; is_deeply parse('objects=force'), { objects => 'force' }, 'string argument with equals'; is_deeply parse('betternames'), { better_names => 1 }, 'missing underscore'; is_deeply parse('better-names'), { better_names => 1 }, 'using dash'; is_deeply parse('dump'), { dump => 3 }, 'dump defaults to 3 when enabled'; is_deeply parse('dump0'), { dump => 1e10000 }, 'dump converts 0 to inf'; eval { parse('noobjects5') }; like $@, qr/noobjects5/, 'invalid: no with numeric joined'; eval { parse('noobjects=5') }; like $@, qr/noobjects=5/, 'invalid: no with numeric equals'; eval { parse('welp') }; like $@, qr/welp/, 'invalid: unrecognized'; eval { parse(undef) }; like $@, qr/\[undef\]/, 'invalid: undef'; eval { parse('welp', 'color', 'guff') }; like $@, qr/welp, guff/, 'multiple invalid'; Devel-Confess-0.009004/t/rethrow.t000644 000765 000024 00000002027 12755226242 017016 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 18; use Devel::Confess (); use Carp; my @dies = qw(die Carp::croak Carp::confess); for my $options ([], ['source']) { for my $innerdie (@dies) { for my $outerdie (@dies) { my $package = "_Die::${innerdie}::Then::${outerdie}" . (@$options ? (join '::', '', 'Options', @$options) : ''); eval sprintf <<'END_CODE', $package, $innerdie, $outerdie; package %s; sub layer1 { %s("die") } sub layer2 { layer1() } sub layer3 { eval { layer2() }; %s(our $inner_error = $@) } sub layer4 { layer3() } END_CODE Devel::Confess->import('nowarnings', @$options); eval { $package->can('layer4')->(); }; my $e = $@; my $inner = do { no strict 'refs'; ${$package.'::inner_error'} }; Devel::Confess->unimport; is $e, $inner, "rethrow from $innerdie to $outerdie doesn't modify trace" . (@$options ? ' with ' . join(', ', @$options) : ''); } } } Devel-Confess-0.009004/t/safe.t000644 000765 000024 00000002071 12763640621 016241 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 3; use Safe; use Devel::Confess (); local $TODO = 'not working reliably with Safe in perl 5.6' if "$]" < 5.008; { package Shared::Ex; use overload '""' => sub { $_[0]->{message} }; sub foo { die @_; } sub bar { foo(@_); } sub new { my $class = shift; bless {@_}, $class; } } my $comp = Safe->new; $comp->share_from('main', [ '*Shared::Ex::' ]); $comp->permit('entereval'); Devel::Confess->import; $comp->reval('Shared::Ex::bar("string")'); Devel::Confess->unimport; like $@, qr{ \Astring\ at\ \S+\ line\ \d+\.[\r\n]+ [\t]Shared::Ex::foo\(.*?\)\ called\ at\ .*\ line\ \d+[\r\n]+ [\t]Shared::Ex::bar\(.*?\)\ called\ at\ .*\ line\ \d+[\r\n]+ }x, 'works in Safe compartment with string error'; Devel::Confess->import; sub { sub { $comp->reval('Shared::Ex->new(message => "welp")->bar'); }->(2) }->(1); Devel::Confess->unimport; isa_ok $@, 'Shared::Ex'; ok !$@->isa('Devel::Confess::_Attached'), "didn't interfere with object inside Safe"; Devel-Confess-0.009004/t/sig.t000644 000765 000024 00000007356 13023041637 016110 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 14; use lib 't/lib'; use Capture; # preload to make sure we only test the effect of our own import use base (); use Exporter (); use Exporter::Heavy (); use Carp (); use Carp::Heavy (); use Symbol (); my $pre_die; BEGIN { $pre_die = $SIG{__DIE__} } use Devel::Confess (); is $SIG{__DIE__}, $pre_die, 'not activated without import'; my $called; sub CALLED { $called++ }; $SIG{__DIE__} = \&CALLED; Devel::Confess->import; isnt $SIG{__DIE__}, \&CALLED, 'import overwrites existing __DIE__ handler'; $called = 0; eval { die }; is 0+$called, 1, 'calls outer __DIE__ handler'; Devel::Confess->unimport; is $SIG{__DIE__}, \&CALLED, 'unimport restores __DIE__ handler'; $SIG{__DIE__} = ''; Devel::Confess->import; Devel::Confess->unimport; ok !$SIG{__DIE__}, 'unimport restores nonexistent __DIE__ handler'; sub IGNORE { $called++ } sub DEFAULT { $called++ } sub other::sub { $called++ } $SIG{__DIE__} = 'IGNORE'; Devel::Confess->import; $called = 0; eval { die }; is 0+$called, 0, 'no dispatching to IGNORE'; Devel::Confess->unimport; $SIG{__DIE__} = 'DEFAULT'; Devel::Confess->import; $called = 0; eval { die }; is 0+$called, 0, 'no dispatching to DEFAULT'; Devel::Confess->unimport; $SIG{__DIE__} = 'CALLED'; Devel::Confess->import; $called = 0; eval { die }; is 0+$called, 1, 'dispatches by name'; Devel::Confess->unimport; $SIG{__DIE__} = 'other::sub'; Devel::Confess->import; $called = 0; eval { die }; is 0+$called, 1, 'dispatches by name to package sub'; Devel::Confess->unimport; is capture <<'END_CODE', BEGIN { $SIG{__DIE__} = sub { 1 } } use Devel::Confess; package A; sub f { #line 1 test-block.pl die "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'trace still added when outer __DIE__ exists'; is capture <<'END_CODE', '', BEGIN { $SIG{__WARN__} = sub { } } use Devel::Confess; package A; sub f { #line 1 test-block.pl warn "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE 'outer __WARN__ can silence warnings'; is capture <<'END_CODE', BEGIN { $SIG{__WARN__} = sub { warn $_[0] } } use Devel::Confess; package A; sub f { #line 1 test-block.pl warn "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'outer __WARN__ gets full location'; is capture <<'END_CODE', use strict; use warnings 'FATAL' => 'all'; use Devel::Confess; BEGIN { my $warn = $SIG{__WARN__} || die; $SIG{__WARN__} = sub { $warn->(@_) }; } use Devel::Confess; package A; sub f { #line 1 test-block.pl warn "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'no infinite loop with mutually recursing __WARN__'; is capture <<'END_CODE', use strict; use warnings 'FATAL' => 'all'; use Devel::Confess; BEGIN { my $die = $SIG{__DIE__} or die; $SIG{__DIE__} = sub { $die->(\@_) }; } use Devel::Confess; package A; sub f { #line 1 test-block.pl die "Beware!"; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE <<"END_OUTPUT", Beware! at test-block.pl line 1. \tA::f() called at test-block.pl line 2 \tA::g() called at test-block.pl line 3 END_OUTPUT 'no infinite loop with mutually recursing __DIE__'; Devel-Confess-0.009004/t/source.t000644 000765 000024 00000000723 12755226223 016624 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 3; use Devel::Confess qw(source); my $file = __FILE__; my @lines; sub Foo::foo { push @lines, __LINE__; die "error"; } sub Bar::bar { push @lines, __LINE__; Foo::foo(@_); } sub Baz::baz { push @lines, __LINE__; Bar::bar(@_); } eval { Baz::baz([1]) }; for my $line (@lines) { ok $@ =~ /context for \Q$file\E line $line:/, 'trace includes required line'; } Devel-Confess-0.009004/t/threads.t000644 000765 000024 00000002107 12764242103 016747 0ustar00gknopstaff000000 000000 use lib 't/lib'; use ThreadsCheck; use threads; use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use MiniTest; use Devel::Confess qw(nowarnings); my $gone = 0; { package MyException; use overload fallback => 1, '""' => sub { $_[0]->{message}; }, ; sub new { my ($class, $message) = @_; my $self = bless { message => $message }, $class; return $self; } sub DESTROY { $gone++; } } sub foo { eval { die MyException->new("yarp") }; $@; } sub bar { foo(); } my $ex = bar(); my $stringy_ex = "$ex"; my $stringy_from_thread = threads->create(sub { "$ex"; })->join; is $stringy_from_thread, $stringy_ex, 'stack trace maintained across threads'; my $thread_gone = threads->create(sub { undef $ex; $gone; })->join; is $thread_gone, $gone + 1, 'DESTROY called in threads for cloned exception'; my $cleared = threads->create(sub { my $class = ref $ex; undef $ex; UNIVERSAL::can($class, 'DESTROY') ? 0 : 1; })->join; ok $cleared, 'cloned exception cleans up namespace when destroyed'; done_testing; Devel-Confess-0.009004/t/universal.t000644 000765 000024 00000001217 13013613565 017330 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More ($ENV{RELEASE_TESTING} || eval { require UNIVERSAL::isa; require UNIVERSAL::can; }) ? (tests => 1) : (skip_all => 'UNIVERSAL::can and UNIVERSAL::isa required for this test'); use Carp (); use Carp::Heavy (); use Devel::Confess qw(nowarnings); { package Thing1; sub isa { UNIVERSAL::isa(@_) } sub can { UNIVERSAL::can(@_) } } my @warnings; my $o = bless {}, 'Thing1'; local $SIG{__WARN__} = sub { push @warnings, $_[0] }; eval { die $o; }; eval { die $o; }; is join('', @warnings), '', "no warnings produced from error class with overridden can"; Devel-Confess-0.009004/t/lib/Capture.pm000644 000765 000024 00000002010 12755226241 017635 0ustar00gknopstaff000000 000000 package Capture; use strict; use warnings; use File::Temp qw(tempfile); use IPC::Open3; use File::Spec; my @PERL5OPTS = map "-I$_", @INC; sub import { my $class = shift; my $target = caller; my @args = @_ ? @_ : 'capture'; while (my $sub = shift @args) { die "bad option: $sub" if ref $sub; my @opts; @opts = @{ shift @args } if ref $args[0]; my $export = sub ($) { _capture($_[0], @opts) }; no strict 'refs'; *{"${target}::${sub}"} = $export; } } sub _capture { my ($code, @opts) = @_; my ($fh, $filename) = tempfile() or die "can't open temp file: $!"; print { $fh } $code; close $fh; open my $in, '<', File::Spec->devnull or die "can't open null: $!"; my $pid = open3( $in, my $out, undef, $^X, @PERL5OPTS, @opts, $filename); my $output = do { local $/; <$out> }; close $in; close $out; waitpid $pid, 0; $output =~ s/\r\n?/\n/g; unlink $filename or die "Couldn't unlink $filename: $!\n"; return $output; } 1; Devel-Confess-0.009004/t/lib/MiniTest.pm000644 000765 000024 00000002037 12755226241 017777 0ustar00gknopstaff000000 000000 package MiniTest; use strict; use warnings; my $done; my $tests = 0; my $failed = 0; END { die "done_testing not seen!" if !$done; $? ||= $failed; } sub is ($$;$) { my ($got, $want, $message) = @_; $_ = defined $_ ? qq{'$_'} : 'undef' for $got, $want; ok ($got eq $want, $message) or do { s/\n/\n# /g for $got, $want; print STDERR "# Failed test" . ($message ? " '$message'" : '') . "\n"; print STDERR "# got: $got\n"; print STDERR "# expected: $want\n"; return !!0; }; } sub ok ($;$) { my ($ok, $message) = @_; $tests++; if (!$ok) { print 'not '; $failed++; } print "ok $tests"; print " - $message" if defined $message && length $message; print "\n"; return $ok; } sub done_testing (;$) { if (@_) { die "tests done ($tests) doesn't match tests planned ($_[0])" if $tests != $_[0]; } $done = 1; print "1..$tests\n"; } sub import { my $target = caller; no strict 'refs'; *{"${target}::$_"} = \&$_ for qw(is ok done_testing); } 1; Devel-Confess-0.009004/t/lib/ThreadsCheck.pm000644 000765 000024 00000002026 12755226241 020571 0ustar00gknopstaff000000 000000 package ThreadsCheck; use strict; use warnings; no warnings 'once'; sub _skip { print "1..0 # SKIP $_[0]\n"; exit 0; } sub import { my ($class, $op) = @_; require Config; if (! $Config::Config{useithreads}) { _skip "your perl does not support ithreads"; } elsif (system "$^X", __FILE__, 'installed') { _skip "threads.pm not installed"; } elsif (system "$^X", __FILE__, 'create') { _skip "threads are broken on this machine"; } } if (!caller && @ARGV) { my ($op) = @ARGV; require POSIX; if ($op eq 'installed') { eval { require threads } or POSIX::_exit(1); } elsif ($op eq 'create') { require threads; require File::Spec; open my $olderr, '>&', \*STDERR or die "can't dup filehandle: $!"; open STDERR, '>', File::Spec->devnull or die "can't open null: $!"; my $out = threads->create(sub { 1 })->join; open STDERR, '>&', $olderr; POSIX::_exit((defined $out && $out eq '1') ? 0 : 1); } else { die "Invalid option $op!\n"; } POSIX::_exit(0); } 1; Devel-Confess-0.009004/maint/Makefile.PL.include000644 000765 000024 00000000272 12763067776 021416 0ustar00gknopstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar; author 'haarg - Graham Knop (cpan:HAARG) '; Devel-Confess-0.009004/lib/Devel/000755 000765 000024 00000000000 13050444251 016467 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/lib/Devel/Confess/000755 000765 000024 00000000000 13050444251 020067 5ustar00gknopstaff000000 000000 Devel-Confess-0.009004/lib/Devel/Confess.pm000644 000765 000024 00000045516 13050444222 020436 0ustar00gknopstaff000000 000000 package Devel::Confess; BEGIN { my $can_use_informative_names = "$]" >= 5.008; # detect -d:Confess. disable debugger features for now. we'll # enable them when we need them. if (!defined &DB::DB && $^P & 0x02) { $can_use_informative_names = 1; $^P = 0; } *_CAN_USE_INFORMATIVE_NAMES = $can_use_informative_names ? sub () { 1 } : sub () { 0 }; } use 5.006; use strict; use warnings; no warnings 'once'; our $VERSION = '0.009004'; $VERSION = eval $VERSION; use Carp (); use Symbol (); use Devel::Confess::_Util qw( blessed refaddr weaken longmess _str_val _in_END _can_stringify _can _isa ); use Config (); BEGIN { *_BROKEN_CLONED_DESTROY_REBLESS = ("$]" >= 5.008009 && "$]" < 5.010000) ? sub () { 1 } : sub () { 0 }; *_BROKEN_CLONED_GLOB_UNDEF = ("$]" > 5.008009 && "$]" <= 5.010000) ? sub () { 1 } : sub () { 0 }; *_BROKEN_SIG_DELETE = ("$]" < 5.008008) ? sub () { 1 } : sub () { 0 }; *_DEBUGGING = ( defined &Config::non_bincompat_options ? (grep $_ eq 'DEBUGGING', Config::non_bincompat_options()) : ($Config::Config{ccflags} =~ /-DDEBUGGING\b/) ) ? sub () { 1 } : sub () { 0 }; my $inf = 9**9**9; *_INF = sub () { $inf } } $Carp::Internal{+__PACKAGE__}++; our %NoTrace; $NoTrace{'Throwable::Error'}++; $NoTrace{'Moose::Error::Default'}++; our %OPTIONS = ( objects => !!1, builtin => undef, dump => !!0, color => !!0, source => 0, evalsource => 0, errors => !!1, warnings => !!1, better_names => !!1, ); our %ENABLEOPTS = ( dump => 3, source => 3, evalsource => 3, ); our %NUMOPTS = ( dump => 1, source => 1, evalsource => 1, ); our @options = sort keys %OPTIONS; our ($opt_match) = map qr/^-?(?:(no[_-]?)(?:$_)|(?:$_)(?:(\d+)|=(.*)|))$/, join '|', map { my $o = $_; $o =~ s/_/[-_]?/g; '('.$o.')'; } @options; sub _parse_options { my %opts; my @bad; while (@_) { my $arg = shift; my @match = defined $arg ? $arg =~ $opt_match : (); if (@match) { my $no = shift @match; my $equal = pop @match; my $num = pop @match; my ($opt) = map $options[$_ % @options], grep defined $match[$_], 0 .. $#match; my $value = defined $no ? !!0 : defined $equal ? $equal : defined $num ? $num : @_ && (!defined $_[0] || $_[0] =~ /^\d+$/) ? shift : defined $ENABLEOPTS{$opt} ? $ENABLEOPTS{$opt} : !!1; if ($NUMOPTS{$opt}) { $value = !defined $value ? 0 : !$value ? _INF : 0+$value; } $opts{$opt} = $value; } else { push @bad, $arg; } } if (@bad) { local $SIG{__DIE__}; Carp::croak("invalid options: " . join(', ', map { defined $_ ? $_ : '[undef]' } @bad)); } \%opts; } if (my $env = $ENV{DEVEL_CONFESS_OPTIONS}) { local $@; eval { my $options = _parse_options(grep length, split /[\s,]+/, $env); @OPTIONS{keys %$options} = values %$options; 1; } or warn "DEVEL_CONFESS_OPTIONS: $@"; } our %OLD_SIG; sub import { my $class = shift; my $options = _parse_options(@_); @OPTIONS{keys %$options} = values %$options; if (defined $OPTIONS{builtin}) { require Devel::Confess::Builtin; my $do = $OPTIONS{builtin} ? 'import' : 'unimport'; Devel::Confess::Builtin->$do; } if ($OPTIONS{source} || $OPTIONS{evalsource}) { require Devel::Confess::Source; Devel::Confess::Source->import; } if ($OPTIONS{color} && $^O eq 'MSWin32') { if (eval { require Win32::Console::ANSI }) { Win32::Console::ANSI->import; } else { local $SIG{__WARN__}; Carp::carp "Devel::Confess color option requires Win32::Console::ANSI on Windows"; $OPTIONS{color} = 0; } } if ($OPTIONS{errors} && !$OLD_SIG{__DIE__}) { $OLD_SIG{__DIE__} = $SIG{__DIE__} if $SIG{__DIE__} && $SIG{__DIE__} ne \&_die; $SIG{__DIE__} = \&_die; } if ($OPTIONS{warnings} && !$OLD_SIG{__WARN__}) { $OLD_SIG{__WARN__} = $SIG{__WARN__} if $SIG{__WARN__} && $SIG{__WARN__} ne \&_warn; $SIG{__WARN__} = \&_warn; } # enable better names for evals and anon subs $^P |= 0x100 | 0x200 if _CAN_USE_INFORMATIVE_NAMES && $OPTIONS{better_names}; } sub unimport { for my $sig ( [ __DIE__ => \&_die ], [ __WARN__ => \&_warn ], ) { my ($name, $sub) = @$sig; my $now = $SIG{$name} or next; my $old = $OLD_SIG{$name}; if ($now ne $sub && $old) { local $SIG{__WARN__}; warn "Can't restore $name handler!\n"; delete $SIG{$sig}; } elsif ($old) { $SIG{$name} = $old; delete $OLD_SIG{$name}; } else { no warnings 'uninitialized'; # bogus warnings on perl < 5.8.8 undef $SIG{$name} if _BROKEN_SIG_DELETE; delete $SIG{$name}; } } } sub _find_sig { my $sig = $_[0]; return undef if !defined $sig; return $sig if ref $sig; return undef if $sig eq 'DEFAULT' || $sig eq 'IGNORE'; # this isn't really needed because %SIG entries are always fully qualified package #hide main; no strict 'refs'; defined &{$sig} ? \&{$sig} : undef; } sub _warn { local $SIG{__WARN__}; return warn @_ if our $warn_deep; my @convert = _convert(@_); if (my $sig = _find_sig($OLD_SIG{__WARN__})) { local $warn_deep = 1; (\&$sig)->(ref $convert[0] ? $convert[0] : join('', @convert)); } else { @convert = _ex_as_strings(@convert); @convert = _colorize(33, @convert) if $OPTIONS{color}; warn @convert; } } sub _die { local $SIG{__DIE__}; return if our $die_deep; my @convert = _convert(@_); if (my $sig = _find_sig($OLD_SIG{__DIE__})) { local $die_deep = 1; (\&$sig)->(ref $convert[0] ? $convert[0] : join('', @convert)); } @convert = _ex_as_strings(@convert) if _can_stringify; @convert = _colorize(31, @convert) if $OPTIONS{color} && _can_stringify; if (_DEBUGGING && _in_END) { local $SIG{__WARN__}; warn @convert; $! ||= 1; return; } die @convert unless ref $convert[0]; } sub _colorize { my ($color, @convert) = @_; if ($OPTIONS{color} eq 'force' || -t *STDERR) { if (@convert == 1) { $convert[0] = s/(.*)//; unshift @convert, $1; } $convert[0] = "\e[${color}m$convert[0]\e[m"; } return @convert; } sub _ref_formatter { require Data::Dumper; local $SIG{__WARN__} = sub {}; local $SIG{__DIE__} = sub {}; no warnings 'once'; local $Data::Dumper::Indent = 0; local $Data::Dumper::Purity = 0; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 1; local $Data::Dumper::Maxdepth = $OPTIONS{dump} == _INF ? 0 : $OPTIONS{dump}; Data::Dumper::Dumper($_[0]); } sub _stack_trace { no warnings 'once'; local $Carp::RefArgFormatter = $OPTIONS{dump} ? \&_ref_formatter : \&_str_val; my $message = &longmess; $message =~ s/\.?$/./m; if ($OPTIONS{source} || $OPTIONS{evalsource}) { $message .= Devel::Confess::Source::source_trace(1, $OPTIONS{evalsource} ? ($OPTIONS{evalsource}, 1) : $OPTIONS{source}); } $message; } # these are package varibles to control their lifetime. they should not be # used externally. our $PACK_SUFFIX = 'A000'; our %EXCEPTIONS; our %PACKAGES; our %MESSAGES; our %CLONED; sub CLONE { my %id_map = map { my $ex = $EXCEPTIONS{$_}; defined $ex ? ($_ => refaddr($ex)) : (); } keys %EXCEPTIONS; %EXCEPTIONS = map {; $id_map{$_} => $EXCEPTIONS{$_}} keys %id_map; %PACKAGES = map {; $id_map{$_} => $PACKAGES{$_}} keys %id_map; %MESSAGES = map {; $id_map{$_} => $MESSAGES{$_}} keys %id_map; %CLONED = map {; $_ => 1 } values %id_map if _BROKEN_CLONED_DESTROY_REBLESS || _BROKEN_CLONED_GLOB_UNDEF; weaken($_) for values %EXCEPTIONS; } sub _update_ex_refs { for my $id ( keys %EXCEPTIONS ) { next if defined $EXCEPTIONS{$id}; delete $EXCEPTIONS{$id}; delete $PACKAGES{$id}; delete $MESSAGES{$id}; delete $CLONED{$id} if _BROKEN_CLONED_DESTROY_REBLESS || _BROKEN_CLONED_GLOB_UNDEF; } } sub _convert { _update_ex_refs; if (my $class = blessed(my $ex = $_[0])) { return @_ unless $OPTIONS{objects}; return @_ if ! do {no strict 'refs'; defined &{"Devel::Confess::_Attached::DESTROY"} }; my $message; my $id = refaddr($ex); if (defined $EXCEPTIONS{$id}) { return @_ if _isa($ex, "Devel::Confess::_Attached"); # something is going very wrong. possibly from a Safe compartment. # we probably broke something, but do the best we can. if ((ref $ex) =~ /^Devel::Confess::__ANON_/) { my $oldclass = $PACKAGES{$id}; $message = $MESSAGES{$id}; bless $ex, $oldclass; } else { # give up return @_; } } my $does = _can($ex, 'can') && ($ex->can('does') || $ex->can('DOES')) || sub () { 0 }; if ( grep { $NoTrace{$_} && _can($ex, 'isa') && $ex->isa($_) || $ex->$does($_) } keys %NoTrace ) { return @_; } $message ||= _stack_trace(); weaken($EXCEPTIONS{$id} = $ex); $PACKAGES{$id} = $class; $MESSAGES{$id} = $message; my $newclass = __PACKAGE__ . '::__ANON_' . $PACK_SUFFIX++ . '__'; { no strict 'refs'; @{$newclass . '::ISA'} = ('Devel::Confess::_Attached', $class); } bless $ex, $newclass; return $ex; } elsif (ref($ex = $_[0])) { my $id = refaddr($ex); my $message = _stack_trace; weaken($EXCEPTIONS{$id} = $ex); $PACKAGES{$id} = undef; $MESSAGES{$id} ||= $message; return $ex; } my $out = join('', @_); if (caller(1) eq 'Carp') { my $long = longmess(); my $long_trail = $long; $long_trail =~ s/.*?\n//; $out =~ s/\Q$long\E\z|\Q$long_trail\E\z// or $out =~ s/(.*) at .*? line .*?\n\z/$1/; } my $source_trace; $out =~ s/^(={75}\ncontext for .*^={75}\n\z)//ms and $source_trace = $1 if $OPTIONS{source} || $OPTIONS{evalsource}; my $trace = _stack_trace(); $trace =~ s/^(.*\n?)//; my $where = $1; my $new_source_trace; $trace =~ s/^(={75}\ncontext for .*^={75}\n\z)//ms and $new_source_trace = $1 if $OPTIONS{source} || $OPTIONS{evalsource}; my $find = $where; $find =~ s/(\.?\n?)\z//; my $trace_re = length $trace ? "(?:\Q$trace\E)?" : ''; $out =~ s/(\Q$find\E(?: during global destruction)?(\.?\n?))$trace_re\z// and $where = $1; if (defined $source_trace) { if (defined $new_source_trace) { $new_source_trace =~ s/^={75}\n//; $source_trace =~ s/^(([-=])\2{74}\n)(?:\Q$new_source_trace\E)?\z/$1/ms; } $trace .= $source_trace; } if (defined $new_source_trace) { $trace .= $new_source_trace; } return ($out, $where . $trace); } sub _ex_as_strings { my $ex = $_[0]; return @_ unless ref $ex; my $id = refaddr($ex); my $class = $PACKAGES{$id}; my $message = $MESSAGES{$id}; my $out; if (blessed $ex) { my $newclass = ref $ex; bless $ex, $class if $class; if ($OPTIONS{dump} && !overload::OverloadedStringify($ex)) { $out = _ref_formatter($ex); } else { $out = "$ex"; } bless $ex, $newclass if $class; } elsif ($OPTIONS{dump}) { $out = _ref_formatter($ex); } else { $out = "$ex"; } return ($out, $message); } { package #hide Devel::Confess::_Attached; use overload fallback => 1, 'bool' => sub { package Devel::Confess; my $ex = $_[0]; my $class = $PACKAGES{refaddr($ex)}; my $newclass = ref $ex; bless $ex, $class; my $out = $ex ? !!1 : !!0; bless $ex, $newclass; return $out; }, '0+' => sub { package Devel::Confess; my $ex = $_[0]; my $class = $PACKAGES{refaddr($ex)}; my $newclass = ref $ex; bless $ex, $class; my $out = 0+sprintf '%.20g', $ex; bless $ex, $newclass; return $out; }, '""' => sub { package Devel::Confess; join('', _ex_as_strings(@_)); }, ; sub DESTROY { package Devel::Confess; my $ex = $_[0]; my $id = refaddr($ex); my $class = delete $PACKAGES{$id} or return; delete $MESSAGES{$id}; delete $EXCEPTIONS{$id}; my $newclass = ref $ex; my $cloned; # delete_package is more complete, but can explode on some perls if (_BROKEN_CLONED_GLOB_UNDEF && delete $CLONED{$id}) { $cloned = 1; no strict 'refs'; @{"${newclass}::ISA"} = (); my $stash = \%{"${newclass}::"}; delete @{$stash}{keys %$stash}; } else { Symbol::delete_package($newclass); } if (_BROKEN_CLONED_DESTROY_REBLESS && $cloned || delete $CLONED{$id}) { my $destroy = _can($class, 'DESTROY') || return; goto $destroy; } bless $ex, $class; # after reblessing, perl will re-dispatch to the class's own DESTROY. (); } } 1; __END__ =encoding utf8 =head1 NAME Devel::Confess - Include stack traces on all warnings and errors =head1 SYNOPSIS Use on the command line: # Make every warning and error include a full stack trace perl -d:Confess script.pl # Also usable as a module perl -MDevel::Confess script.pl # display warnings in yellow and errors in red perl -d:Confess=color script.pl # set options by environment export DEVEL_CONFESS_OPTIONS='color dump' perl -d:Confess script.pl Can also be used inside a script: use Devel::Confess; use Devel::Confess 'color'; # disable stack traces no Devel::Confess; =head1 DESCRIPTION This module is meant as a debugging aid. It can be used to make a script complain loudly with stack backtraces when Cing or Cing. Unlike other similar modules (e.g. L), stack traces will also be included when exception objects are thrown. The stack traces are generated using L, and will work for all types of errors. L's C and C functions will also be made to include stack traces. # it works for explicit die's and warn's $ perl -d:Confess -e 'sub f { die "arghh" }; sub g { f }; g' arghh at -e line 1. main::f() called at -e line 1 main::g() called at -e line 1 # it works for interpreter-thrown failures $ perl -d:Confess -w -e 'sub f { $a = shift; @a = @$a };' \ -e 'sub g { f(undef) }; g' Use of uninitialized value $a in array dereference at -e line 1. main::f(undef) called at -e line 2 main::g() called at -e line 2 Internally, this is implemented with L<$SIG{__WARN__}|perlvar/%SIG> and L<$SIG{__DIE__}|perlvar/%SIG> hooks. Stack traces are also included if raw non-object references are thrown. This module is compatible with all perl versions back to 5.6.2, without additional prerequisites. It contains workarounds for a number of bugs in the perl interpreter, some of which effect comparatively simpler modules, like L. =head1 METHODS =head2 import( @options ) Enables stack traces and sets options. A list of options to enable can be passed in. Prefixing the options with C will disable them. =over 4 =item C Enable attaching stack traces to exception objects. Enabled by default. =item C Load the L module to use built in stack traces on supported exception types. Disabled by default. =item C Dumps the contents of references in arguments in stack trace, instead of only showing their stringified version. Also causes exceptions that are non-object references and objects without string overloads to be dumped if being displayed. Shows up to three references deep. Disabled by default. =item C, C, C, etc The same as the dump option, but with a different max depth to dump. A depth of 0 is treated as infinite. =item C Colorizes error messages in red and warnings in yellow. Disabled by default. =item C Includes a snippet of the source for each level of the stack trace. Disabled by default. =item C, C, C, etc Enables source display, but with a specified number of lines of context to show. Context of 0 will show the entire source of the files. =item C Similar to the source option, but only shows includes source for string evals. Useful for seeing the results of code generation. Disabled by default. Overrides the source option. =item C, C, C, etc Enables eval source display, but with a specified number of lines of context to show. Context of 0 will show the entire source of the evals. =item C Use more informative names to string evals and anonymous subs in stack traces. Enabled by default. =item C Add stack traces to errors. Enabled by default. =item C Add stack traces to warnings. Enabled by default. =back The default options can be changed by setting the C environment variable to a space separated list of options. =head1 CONFIGURATION =head2 C<%Devel::Confess::NoTrace> Classes or roles added to this hash will not have stack traces attached to them. This is useful for exception classes that provide their own stack traces, or classes that don't cope well with being re-blessed. If L is loaded, it will automatically add its supported exception types to this hash. Default Entries: =over 4 =item L Provides a stack trace =item L Provides a stack trace =back =head1 ACKNOWLEDGMENTS The idea and parts of the code and documentation are taken from L. =head1 SEE ALSO =over 4 =item * L =item * L =item * L and L =item * L =item * L =item * L =back =head1 CAVEATS This module uses several ugly tricks to do its work and surely has bugs. =over 4 =item * This module uses C<$SIG{__WARN__}> and C<$SIG{__DIE__}> to accomplish its goal, and thus may not play well with other modules that try to use these hooks. Significant effort has gone into making this work as well as possible, but global variables like these can never be fully encapsulated. =item * To provide stack traces on exception objects, this module re-blesses the exception objects into a generated class. While it tries to have the smallest effect it can, some things cannot be worked around. In particular, C will return a different value than may be expected. Any module that relies on the specific return value from C like already has bugs though. =back =head1 SUPPORT Please report bugs via L. =head1 AUTHORS =over 4 =item * Graham Knop =back =head1 CONTRIBUTORS =over 4 =item * Adriano Ferreira =back =head1 COPYRIGHT Copyright (c) 2005-2013 the L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. See L. =cut Devel-Confess-0.009004/lib/Devel/Confess/_Util.pm000644 000765 000024 00000011436 13013172337 021510 0ustar00gknopstaff000000 000000 package Devel::Confess::_Util; use 5.006; use strict; use warnings FATAL => 'all'; no warnings 'once'; use Exporter (); BEGIN { *import = \&Exporter::import } our @EXPORT = qw( blessed refaddr weaken longmess _str_val _in_END _can_stringify _can _isa ); use Carp (); use Carp::Heavy (); use Scalar::Util qw(blessed refaddr reftype); # fake weaken if it isn't available. will cause leaks, but this # is a brute force debugging tool, so we can deal with it. *weaken = defined &Scalar::Util::weaken ? \&Scalar::Util::weaken : sub ($) { 0 }; *longmess = !Carp->VERSION ? eval q{ package Carp; our (%CarpInternal, %Internal, $CarpLevel); $CarpInternal{Carp}++; $CarpInternal{warnings}++; $Internal{Exporter}++; $Internal{'Exporter::Heavy'}++; sub { my $level = 0; while (1) { my $p = (caller($level))[0] || last; last unless $CarpInternal{$p} || $Internal{$p}; $level++; } local $CarpLevel = $CarpLevel + $level; no strict 'refs'; local *{"threads::tid"} = \&threads::tid if defined &threads::tid && !defined &{"threads::tid"}; &longmess; }; } : eval q{ package Carp; sub { local $INC{'Carp/Heavy.pm'} = $INC{'Carp/Heavy.pm'} || 1; no strict 'refs'; local *{"threads::tid"} = \&threads::tid if defined &threads::tid && !defined &{"threads::tid"}; &longmess; }; } or die $@; if (defined &Carp::format_arg && $Carp::VERSION < 1.32) { my $format_arg = \&Carp::format_arg; eval q{ package Carp; our $in_recurse; $format_arg if 0; # capture no warnings 'redefine'; sub format_arg { if (! $in_recurse) { local $SIG{__DIE__} = sub {}; local $in_recurse = 1; local $@; my $arg; if ( Devel::Confess::_Util::blessed($_[0]) && eval { $_[0]->can('CARP_TRACE') } ) { return $_[0]->CARP_TRACE; } elsif ( ref $_[0] and our $RefArgFormatter and eval { $arg = $RefArgFormatter->(@_); 1 } ) { return $arg; } } $format_arg->(@_); } 1; } or die $@; } eval q{ sub _str_val { no overloading; "$_[0]"; } 1; } or eval q{ sub _str_val { my $class = &blessed; return "$_[0]" unless defined $class; return sprintf("%s=%s(0x%x)", $class, &reftype, &refaddr); } 1; } or die $@; { if (defined ${^GLOBAL_PHASE}) { eval q{ sub _global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] } sub _in_END () { ${^GLOBAL_PHASE} eq "END" } 1; } or die $@; } else { eval q{ # this is slightly a lie, but accurate enough for our purposes our $global_phase = 'RUN'; sub _global_destruction () { if ($global_phase ne 'DESTRUCT') { local $SIG{__WARN__} = sub { $global_phase = 'DESTRUCT' if $_[0] =~ /global destruction\.\n\z/ }; warn 1; } $global_phase eq 'DESTRUCT'; } sub _in_END () { if ($global_phase eq 'RUN' && $^S) { # END blocks are FILO so we can't install one to run first. # only way to detect END reliably seems to be by using caller. # I hate this but it seems to be the best available option. # The top two frames will be an eval and the END block. my $i; 1 while CORE::caller(++$i); if ($i > 2) { my @top = CORE::caller($i - 1); my @next = CORE::caller($i - 2); if ( $top[3] eq '(eval)' && $next[3] =~ /::END$/ && $top[2] == $next[2] && $top[1] eq $next[1] && $top[0] eq 'main' && $next[0] eq 'main' ) { $global_phase = 'END'; } } } $global_phase eq 'END'; } END { $global_phase = 'END'; } 1; } or die $@; } } if ("$]" < 5.008) { eval q{ sub _can_stringify () { my $i = 0; while (my @caller = caller($i++)) { if ($caller[3] eq '(eval)') { return 0; } elsif ($caller[7]) { return 0; } } return 1; } 1; } or die $@; } else { eval q{ sub _can_stringify () { defined $^S && !$^S; } 1; } or die $@; } sub _isa; if ($INC{'UNIVERSAL/isa.pm'}) { *__isa = \&UNIVERSAL::isa; eval q{ sub _isa { local $UNIVERSAL::isa::recursing = 1; local $UNIVERSAL::isa::_recursing = 1; __isa(@_); } 1; } or die $@; } else { *_isa = \&UNIVERSAL::isa; } sub _can; if ($INC{'UNIVERSAL/can.pm'}) { *__can = \&UNIVERSAL::can; eval q{ sub _can { local $UNIVERSAL::can::recursing = 1; __can(@_); } 1; } or die $@; } else { *_can = \&UNIVERSAL::can; } 1; Devel-Confess-0.009004/lib/Devel/Confess/Builtin.pm000644 000765 000024 00000007010 13050444222 022027 0ustar00gknopstaff000000 000000 package Devel::Confess::Builtin; use strict; use warnings FATAL => 'all'; no warnings 'once'; our $VERSION = '0.009004'; $VERSION = eval $VERSION; use Devel::Confess::_Util (); { package #hide Devel::Confess::Builtin::_Guard; use overload bool => sub () { 0 }; sub new { bless [@_[1 .. $#_]], $_[0] } sub DESTROY { return if Devel::Confess::_Util::_global_destruction; $_->() for @{$_[0]} } } our %CLASS = ( 'Exception::Class::Base' => { enable => sub { Exception::Class::Base->Trace(1) }, store => '$Exception::Class::BASE_EXC_CLASS', }, 'Ouch' => { enable => sub { overload::OVERLOAD('Ouch', '""', 'trace') }, store => '@Ouch::EXPORT_OK', }, 'Class::Throwable' => { enable => sub { $Class::Throwable::DEFAULT_VERBOSITY = 2 }, store => '$Class::Throwable::DEFAULT_VERBOSITY', }, 'Exception::Base' => { enable => sub { Exception::Base->import(verbosity => 3) }, store => sub { my $guard = shift; $Exception::Base::_qualify_to_ref = Devel::Confess::Builtin::_Guard->new(sub { $Exception::Base::VERSION = $guard; }); }, }, ); sub import { my ($class, @enable) = @_; @enable = keys %CLASS unless @enable; for my $class (@enable) { my $class_data = $CLASS{$class} or die "invalid class $class!"; next if $class_data->{enabled}; (my $module = "$class.pm") =~ s{::}{/}g; if ($INC{$module}) { $class_data->{enable}->(); $Devel::Confess::NoTrace{$class}++; } else { my $store = $class_data->{store}; my $guard = Devel::Confess::Builtin::_Guard->new( $class_data->{enable}, sub { $Devel::Confess::NoTrace{$class}++ }, ); if (ref $store) { $store->($guard); } else { eval $store . ' = $guard; 1' or die $@; } } $class_data->{enabled}++; } } sub unimport { my ($class, @disable) = @_; @disable = keys %CLASS unless @disable; for my $class (@disable) { my $class_data = $CLASS{$class} or die "invalid class $class!"; next unless $class_data->{enabled}; (my $module = "$class.pm") =~ s{::}{/}g; if ($INC{$module}) { # can't really disable if it's already been loaded, so just do nothing } else { my $store = $class_data->{store}; if (ref $store) { $class_data->{disable}->(); } else { eval q{ my ($guard) = }.$store.q{; @$guard = (); }.$store.q{ = (); 1; } or die $@; } $class_data->{enabled}--; $Devel::Confess::NoTrace{$class}--; } } } 1; __END__ =head1 NAME Devel::Confess::Builtin - Enable built in stack traces on exception objects =head1 SYNOPSIS use Devel::Confess::Builtin; use Exception::Class 'MyException'; MyException->throw; # includes stack trace =head1 DESCRIPTION Many existing exception module can provide stack traces, but this is often not the default setting. This module will force as many modules as possible to include stack traces by default. It can be loaded before or after the exception modules, and it will still function. For supported modules, it will also prevent L from attaching its own stack traces. =head1 SUPPORTED MODULES =over 4 =item * L =item * L =item * L =item * L =back =head1 CAVEATS This module relies partly on the internal implementation of the modules it effects. Future updates to the modules could break or be broken by this module. =cut Devel-Confess-0.009004/lib/Devel/Confess/Source.pm000644 000765 000024 00000003364 12763640632 021706 0ustar00gknopstaff000000 000000 package Devel::Confess::Source; use 5.006; use strict; use warnings FATAL => 'all'; sub import { $^P |= "$]" >= 5.010 ? 0x400 : do { *DB::DB = sub {} unless defined &DB::DB; 0x02; }; } my $want_color = $^O ne 'MSWin32' ? 1 : eval { require Win32::Console::ANSI; Win32::Console::ANSI->import; 1; }; sub source_trace { my ($skip, $context, $evalonly) = @_; $skip ||= 1; $skip += $Carp::CarpLevel; $context ||= 3; my $i = $skip; my @out; while (my ($pack, $file, $line) = (caller($i++))[0..2]) { next if $Carp::Internal{$pack} || $Carp::CarpInternal{$pack}; next if $evalonly && $file !~ /^\(eval \d+\)(?:\[|$)/; my $lines = _get_content($file) || next; my $start = $line - $context; $start = 1 if $start < 1; $start = $#$lines if $start > $#$lines; my $end = $line + $context; $end = $#$lines if $end > $#$lines; my $context = "context for $file line $line:\n"; for my $read_line ($start..$end) { my $code = $lines->[$read_line]; $code =~ s/\n\z//; if ($want_color && $read_line == $line) { $code = "\e[30;43m$code\e[m"; } $context .= sprintf "%5s : %s\n", $read_line, $code; } push @out, $context; } return '' if !@out; return join(('=' x 75) . "\n", '', join(('-' x 75) . "\n", @out), '', ); } sub _get_content { my $file = shift; no strict 'refs'; if (exists $::{'_<'.$file} && @{ '::_<'.$file }) { return \@{ '::_<'.$file }; } elsif ($file =~ /^\(eval \d+\)(?:\[.*\])?$/) { return ["Can't get source of evals unless debugger available!"]; } elsif (open my $fh, '<', $file) { my @lines = ('', <$fh>); return \@lines; } else { return ["Source file not available!"]; } } 1;