Devel-Confess-0.008000/000755 000765 000024 00000000000 12543173420 014660 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/Changes000644 000765 000024 00000010055 12543173373 016163 0ustar00gknopstaff000000 000000 Release history for Devel-Confess 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.008000/lib/000755 000765 000024 00000000000 12543173420 015426 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/maint/000755 000765 000024 00000000000 12543173420 015770 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/Makefile.PL000644 000765 000024 00000005345 12374452350 016645 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; use ExtUtils::MakeMaker; (do 'maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; 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, } }, runtime => { requires => { 'perl' => '5.6.0', '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.008000/MANIFEST000644 000765 000024 00000001161 12543173420 016010 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/global-destruct.t t/leak.t t/lib/capture.pm t/lib/test.pm t/lib/threads_check.pm t/names.t t/safe.t t/sig.t t/source.t t/threads.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.008000/META.json000644 000765 000024 00000003231 12543173420 016300 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.0401, CPAN::Meta::Converter version 2.150001", "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" : "v5.6.0" } }, "test" : { "requires" : { "File::Temp" : "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.008000" } Devel-Confess-0.008000/META.yml000644 000765 000024 00000001371 12543173420 016133 0ustar00gknopstaff000000 000000 --- abstract: 'Include stack traces on all warnings and errors' author: - 'haarg - Graham Knop (cpan:HAARG) ' build_requires: File::Temp: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' 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: v5.6.0 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.008000' Devel-Confess-0.008000/README000644 000765 000024 00000011242 12543173420 015540 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), it includes stack traces even when exception objects are thrown. The stack traces are generated using Carp, and will look work for all types of errors. Carp's "carp" and "confess" 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. 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. 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. "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 Please report bugs via CPAN RT http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-Confess. BUGS This module uses several ugly tricks to do its work and surely has bugs. * This module does not play well with other modules which fusses around with "warn", "die", $SIG{'__WARN__'}, $SIG{'__DIE__'}. AUTHORS * Graham Knop * Adriano Ferreira CONTRIBUTORS None yet. 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.008000/t/000755 000765 000024 00000000000 12543173420 015123 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/xt/000755 000765 000024 00000000000 12543173420 015313 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/xt/builtin.t000644 000765 000024 00000002223 12531713110 017136 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use t::lib::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 B; sub g { A::f(); } END my $before = capture_builtin $code.'B::g();'; my $after = capture $code.'require Devel::Confess::Builtin;Devel::Confess::Builtin->import(); B::g();'; like $before, qr/B::g/, "verbose when loaded before $class"; like $after, qr/B::g/, "verbose when loaded after $class"; } Devel-Confess-0.008000/t/color.t000644 000765 000024 00000001447 12543152401 016430 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More; use t::lib::capture capture_color => ['-MDevel::Confess=color']; if ($^O eq 'MSWin32') { plan skip_all => 'color option requires Win32::Console::ANSI in Windows' unless eval { require Win32::Console::ANSI; }; } plan tests => 1; $ENV{DEVEL_CONFESS_FORCE_COLOR} = 1; my $code = <<'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 my $expected = <<"END_OUTPUT"; \e[31mBeware!\e[m at test-block.pl line 1. A::f() called at test-block.pl line 2 A::g() called at test-block.pl line 3 END_OUTPUT { my $out = capture_color $code; is $out, $expected, 'error message properly colorized'; } Devel-Confess-0.008000/t/confess.t000644 000765 000024 00000010014 12543166241 016747 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 32; use t::lib::capture capture => ['-MDevel::Confess']; is capture <<'END_CODE', <<'END_OUTPUT', 'basic test'; 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 Beware! at test-block.pl line 1. A::f() called at test-block.pl line 2 A::g() called at test-block.pl line 3 END_OUTPUT is capture <<'END_CODE', <<'END_OUTPUT', 'interpreter-thrown warnings'; package A; sub f { use strict; my $a; #line 1 test-block.pl my @a = @$a; } sub g { #line 2 test-block.pl f(); } package main; #line 3 test-block.pl A::g(); END_CODE Can't use an undefined value as an ARRAY reference at test-block.pl line 1. A::f() called at test-block.pl line 2 A::g() called at test-block.pl line 3 END_OUTPUT for my $type (qw(die croak confess)) { is capture <<"END_CODE" , <<'END_OUTPUT', "$type at root"; use Carp; #line 1 test-block.pl $type "foo at bar"; END_CODE foo at bar at test-block.pl line 1. END_OUTPUT is capture <<"END_CODE" , <<'END_OUTPUT', "$type in sub"; use Carp; sub foo { #line 1 test-block.pl $type "foo at bar"; } #line 2 test-block.pl foo(); END_CODE foo at bar at test-block.pl line 1. main::foo() called at test-block.pl line 2 END_OUTPUT is capture <<"END_CODE" , <<'END_OUTPUT', "$type with newline"; 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 foo at bar at test-block.pl line 1. main::foo() called at test-block.pl line 2 main::bar() called at test-block.pl line 3 END_OUTPUT like capture <<"END_CODE", qr/\A${\<<'END_OUTPUT'}\z/, "$type with object"; use Carp; sub foo { #line 1 test-block.pl $type bless {}, 'NoOverload'; } #line 2 test-block.pl foo(); END_CODE NoOverload=HASH\(0x\w+\) at test-block\.pl line 1\. main::foo\(\) called at test-block\.pl line 2 END_OUTPUT is capture <<"END_CODE", <<'END_OUTPUT', "$type with object with overload"; 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 message at test-block.pl line 1. main::foo() called at test-block.pl line 2 END_OUTPUT { local $ENV{DEVEL_CONFESS_OPTIONS} = 'dump'; like capture <<"END_CODE", qr/\A${\<<'END_OUTPUT'}\z/, "$type with object + dump"; use Carp; sub foo { #line 1 test-block.pl $type bless {}, 'NoOverload'; } #line 2 test-block.pl foo(); END_CODE bless\( \{\}, 'NoOverload' \) at test-block\.pl line 1\. main::foo\(\) called at test-block\.pl line 2 END_OUTPUT is capture <<"END_CODE", <<'END_OUTPUT', "$type with object with overload + dump"; 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 message at test-block.pl line 1. main::foo() called at test-block.pl line 2 END_OUTPUT } like capture <<"END_CODE", qr/\A${\<<'END_OUTPUT'}\z/, "$type with non-object ref"; use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl foo(); END_CODE ARRAY\(0x\w+\) at test-block\.pl line 1\. main::foo\(\) called at test-block\.pl line 2 END_OUTPUT local $ENV{DEVEL_CONFESS_OPTIONS} = 'dump'; like capture <<"END_CODE", qr/\A${\<<'END_OUTPUT'}\z/, "$type with non-object ref + dump"; use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl foo(); END_CODE \[1\] at test-block\.pl line 1\. main::foo\(\) called at test-block\.pl line 2 END_OUTPUT like capture <<"END_CODE", qr/\A${\<<'END_OUTPUT'}\z/, "$type rethrowing non-object ref + dump"; use Carp; sub foo { #line 1 test-block.pl $type [1]; } #line 2 test-block.pl eval { foo() }; print STDERR \$@ . "\n"; die; END_CODE ARRAY\(0x\w+\) \[1\] at test-block\.pl line 1\. main::foo\(\) called at test-block\.pl line 2 eval \{...\} called at test-block.pl line 2 END_OUTPUT } Devel-Confess-0.008000/t/devel.t000644 000765 000024 00000002054 12543152361 016411 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 2; use t::lib::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. A::f() called at test-block.pl line 2 A::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.008000/t/dump.t000644 000765 000024 00000001734 12543152375 016270 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Carp (); 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.008000/t/end-debugging.t000644 000765 000024 00000000463 12543152352 020013 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 1; use t::lib::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.008000/t/global-destruct.t000644 000765 000024 00000002205 12543152345 020405 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.008000/t/leak.t000644 000765 000024 00000001411 12543171713 016224 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.008000/t/lib/000755 000765 000024 00000000000 12543173420 015671 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/t/names.t000644 000765 000024 00000001234 12543152326 016415 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; like $lines[2], qr/main::__ANON__\[$file:\d+\]\(\) called at/, 'anonymous function names include file and line number'; like $lines[4], qr/baz;/, 'string evals include eval text'; Devel-Confess-0.008000/t/safe.t000644 000765 000024 00000002067 12543152335 016235 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.008000/t/sig.t000644 000765 000024 00000005206 12543152450 016075 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use Test::More tests => 12; use t::lib::capture; # preload to make sure we only test the effect of our own import use base (); use Exporter (); 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', <<'END_OUTPUT', 'trace still added when outer __DIE__ exists'; 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 Beware! at test-block.pl line 1. A::f() called at test-block.pl line 2 A::g() called at test-block.pl line 3 END_OUTPUT is capture <<'END_CODE', '', 'outer __WARN__ can silence warnings'; 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 is capture <<'END_CODE', <<'END_OUTPUT', 'outer __WARN__ gets full location'; 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 Beware! at test-block.pl line 1. A::f() called at test-block.pl line 2 A::g() called at test-block.pl line 3 END_OUTPUT Devel-Confess-0.008000/t/source.t000644 000765 000024 00000000723 12543152447 016620 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.008000/t/threads.t000644 000765 000024 00000002064 12543152444 016747 0ustar00gknopstaff000000 000000 use t::lib::threads_check; use threads; use strict; use warnings; BEGIN { $ENV{DEVEL_CONFESS_OPTIONS} = ''; } use t::lib::test; use Devel::Confess; 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.008000/t/lib/capture.pm000644 000765 000024 00000002037 12531517117 017676 0ustar00gknopstaff000000 000000 package t::lib::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: $!"; open3( $in, my $out, undef, $^X, @PERL5OPTS, @opts, $filename) or die "Couldn't open subprocess: $!\n"; my $output = do { local $/; <$out> }; close $in; close $out; $output =~ s/\r\n?/\n/g; unlink $filename or die "Couldn't unlink $filename: $!\n"; return $output; } 1; Devel-Confess-0.008000/t/lib/test.pm000644 000765 000024 00000002043 12531713110 017176 0ustar00gknopstaff000000 000000 package t::lib::test; 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.008000/t/lib/threads_check.pm000644 000765 000024 00000002042 12461331271 021013 0ustar00gknopstaff000000 000000 package t::lib::threads_check; sub _skip { print "1..0 # SKIP $_[0]\n"; exit 0; } sub import { my ($class, $op) = @_; if ($0 eq '-' && $op) { 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); } require Config; if (! $Config::Config{useithreads}) { _skip "your perl does not support ithreads"; } elsif (system "$^X", '-Mt::lib::threads_check=installed') { _skip "threads.pm not installed"; } elsif (system "$^X", '-Mt::lib::threads_check=create') { _skip "threads are broken on this machine"; } } 1; Devel-Confess-0.008000/maint/Makefile.PL.include000644 000765 000024 00000000331 12223436741 021364 0ustar00gknopstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar; use ExtUtils::MakeMaker 6.58; author 'haarg - Graham Knop (cpan:HAARG) '; Devel-Confess-0.008000/lib/Devel/000755 000765 000024 00000000000 12543173420 016465 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/lib/Devel/Confess/000755 000765 000024 00000000000 12543173420 020065 5ustar00gknopstaff000000 000000 Devel-Confess-0.008000/lib/Devel/Confess.pm000644 000765 000024 00000036533 12543173340 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.008000'; $VERSION = eval $VERSION; use Carp (); use Symbol (); use Devel::Confess::_Util qw(blessed refaddr weaken longmess _str_val _in_END _can_stringify); use Config (); BEGIN { *_can = \&UNIVERSAL::can; *_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 }; } $Carp::Internal{+__PACKAGE__}++; our %NoTrace; $NoTrace{'Throwable::Error'}++; $NoTrace{'Moose::Error::Default'}++; our %OPTIONS; sub _parse_options { my @opts = map { /^-?(no[_-])?(.*)/; [ $_, $2, $1 ? 0 : 1 ] } @_; if (!keys %OPTIONS) { %OPTIONS = ( objects => 1, builtin => undef, dump => 0, color => 0, source => 0, errors => 1, warnings => 1, better_names => 1, ); local $@; eval { _parse_options( grep length, split /[\s,]+/, $ENV{DEVEL_CONFESS_OPTIONS}||'' ); } or warn "DEVEL_CONFESS_OPTIONS: $@"; } for my $opt (@opts) { if ($opt->[1] =~ /^dump(\d*)$/) { $opt->[1] = 'dump'; $opt->[2] = length $1 ? ($1 || 'inf') : 3; } } if (my @bad = grep { !exists $OPTIONS{$_->[1]} } @opts) { local $SIG{__DIE__}; Carp::croak("invalid options: " . join(', ', map { $_->[0] } @bad)); } $OPTIONS{$_->[1]} = $_->[2] for @opts; 1; } our %OLD_SIG; sub import { my $class = shift; _parse_options(@_); if (defined $OPTIONS{builtin}) { require Devel::Confess::Builtin; my $do = $OPTIONS{builtin} ? 'import' : 'unimport'; Devel::Confess::Builtin->$do; } if ($OPTIONS{source}) { require Devel::Confess::Source; } 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; local $@; return $sig if ref $sig && eval { \&{$sig} }; return undef if $sig eq 'DEFAULT' || $sig eq 'IGNORE'; package #hide main; no strict 'refs'; defined &{$sig} ? \&{$sig} : undef; } sub _warn { local $SIG{__WARN__}; my @convert = _convert(@_); if (my $sig = _find_sig($OLD_SIG{__WARN__})) { $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__}; my @convert = _convert(@_); if (my $sig = _find_sig($OLD_SIG{__DIE__})) { $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 ($ENV{DEVEL_CONFESS_FORCE_COLOR} || -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} eq '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}) { $message .= Devel::Confess::Source::source_trace(1); } $message; } 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 $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 ($EXCEPTIONS{$id}) { return @_ if $ex->isa("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; } elsif ((caller(1))[0] eq 'Carp') { my $out = join('', @_); 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/; return ($out, _stack_trace()); } else { my $message = _stack_trace(); $message =~ s/^(.*\n?)//; my $where = $1; my $find = $where; $find =~ s/(\.?\n?)\z//; $find = qr/\Q$find\E(?: during global destruction)?(\.?\n?)/; my $out = join('', @_); $out =~ s/($find)\z// and $where = $1; return ($out, $where . $message); } } 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 { my $ex = $_[0]; my $class = $PACKAGES{Devel::Confess::refaddr($ex)}; my $newclass = ref $ex; bless $ex, $class; my $out = !!$ex; bless $ex, $newclass; return $out; }, '0+' => sub { my $ex = $_[0]; my $class = $PACKAGES{Devel::Confess::refaddr($ex)}; my $newclass = ref $ex; bless $ex, $class; my $out = 0+sprintf '%f', $ex; bless $ex, $newclass; return $out; }, '""' => sub { return join('', Devel::Confess::_ex_as_strings(@_)); }, ; sub DESTROY { my $ex = $_[0]; my $id = Devel::Confess::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 (Devel::Confess::_BROKEN_CLONED_GLOB_UNDEF && delete $Devel::Confess::CLONED{$id}) { $cloned = 1; no strict 'refs'; @{"${newclass}::ISA"} = (); my $stash = \%{"${newclass}::"}; delete @{$stash}{keys %$stash}; } else { Symbol::delete_package($newclass); } if (Devel::Confess::_BROKEN_CLONED_DESTROY_REBLESS && $cloned || delete $Devel::Confess::CLONED{$id}) { my $destroy = $class->can('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 warn()ing or die()ing. Unlike other similar modules (e.g. L), it includes stack traces even when exception objects are thrown. The stack traces are generated using L, and will look 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 C<$SIG{__WARN__}> and C<$SIG{__DIE__}> hooks. Stack traces are also included if raw non-object references are thrown. =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. 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 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 Please report bugs via CPAN RT http://rt.cpan.org/NoAuth/Bugs.html?Dist=Devel-Confess. =head1 BUGS This module uses several ugly tricks to do its work and surely has bugs. =over 4 =item * This module does not play well with other modules which fusses around with C, C, C<$SIG{'__WARN__'}>, C<$SIG{'__DIE__'}>. =back =head1 AUTHORS =over =item * Graham Knop =item * Adriano Ferreira =back =head1 CONTRIBUTORS None yet. =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.008000/lib/Devel/Confess/_Util.pm000644 000765 000024 00000007762 12543166165 021523 0ustar00gknopstaff000000 000000 package Devel::Confess::_Util; use 5.006; use strict; use warnings FATAL => 'all'; no warnings 'once'; use base 'Exporter'; our @EXPORT = qw(blessed refaddr weaken longmess _str_val _in_END _can_stringify); 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; &longmess; }; } : Carp->VERSION <= 1.04 ? eval q{ package Carp; our ($CarpLevel); sub { local $INC{'Carp/Heavy.pm'} = $INC{'Carp/Heavy.pm'} || 1; &longmess; }; } : \&Carp::longmess; if (defined &Carp::format_arg && $Carp::VERSION < 1.32) { my $format_arg = \&Carp::format_arg; eval q{ package Carp; our $in_recurse; $format_arg; # capture no warnings 'redefine'; sub format_arg { if (! $in_recurse) { local $SIG{__DIE__} = sub {}; local $in_recurse = 1; local $@; my $arg; if ( Scalar::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->(@_); } } or die $@; } *_str_val = eval q{ sub { no overloading; "$_[0]"; }; } || eval q{ sub { my $class = &blessed; return "$_[0]" unless defined $class; return sprintf("%s=%s(0x%x)", $class, &reftype, &refaddr); }; }; { 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 $@; } 1; Devel-Confess-0.008000/lib/Devel/Confess/Builtin.pm000644 000765 000024 00000007010 12543173340 022030 0ustar00gknopstaff000000 000000 package Devel::Confess::Builtin; use strict; use warnings FATAL => 'all'; no warnings 'once'; our $VERSION = '0.008000'; $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.008000/lib/Devel/Confess/Source.pm000644 000765 000024 00000003143 12444354507 021673 0ustar00gknopstaff000000 000000 package Devel::Confess::Source; use 5.006; use strict; use warnings FATAL => 'all'; $^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) = @_; $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}; 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 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 not available!"]; } } 1;