Test-Trap-v0.3.2000755001750001750 012472732613 13125 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/Build.PL000444001750001750 534512472732613 14565 0ustar00eirikeirik000000000000use strict; use warnings; use Module::Build; my $class = Module::Build->subclass( code => do { local $/; } ); my $builder = $class->new ( module_name => 'Test::Trap', license => 'perl', create_makefile_pl => 'traditional', dist_author => 'Eirik Berg Hanssen ', dist_version_from => 'lib/Test/Trap.pm', configure_requires => { 'Module::Build' => 0, }, requires => { 'base' => 0, # core ... 'constant' => 0, # core ... 'Carp' => 0, 'Data::Dump' => 0, 'Exporter' => 0, 'File::Temp' => 0, 'IO::Handle' => 0, 'lib' => 0, # core ... 'strict' => 0, # now _that's_ core! 'Test::Builder' => 0, 'Test::More' => 0, 'Test::Tester' => 0.107, # fails with at least some earlier ones 'perl' => '5.6.2', 'version' => 0, 'warnings' => 0, }, PL_files => { 't/08-fork.PL' => 't/08-fork.t', 't/11-systemsafe-basic.PL' => 't/11-systemsafe-basic.t', }, add_to_cleanup => [ 'Test-Trap-*', 'MYMETA.yml', 't/08-fork.t', 't/11-systemsafe-basic.t', ], ); $builder->create_build_script(); __DATA__ =head1 ACTIONS =head2 authortest This runs all the C tests, as well as the ordinary tests, after making sure that the build, manifest, and distmeta actions have been taken. =cut sub ACTION_authortest { my ($self) = @_; $self->depends_on('build'); $self->depends_on('manifest'); $self->depends_on('distmeta'); $self->test_files( qw< t xt/author > ); $self->recursive_test_files(1); $self->depends_on('test'); return; } sub ACTION_distdir { my ($self) = @_; $self->depends_on('authortest'); return $self->SUPER::ACTION_distdir(); } sub ACTION_distmeta { my ($self) = @_; require Module::Build::Compat; unless (Module::Build::Compat->VERSION gt 0.31 or eval { Module::Build::Compat->PL_FILES_PATCH }) { die <<'DIE' Too old Module::Build::Compat to Build distmeta. Upgrade if possible or apply the following hack patch: --- Compat.pm 2008-10-04 02:14:02.000000000 +0200 +++ Compat.pm 2008-10-04 02:15:10.000000000 +0200 @@ -139,7 +139,7 @@ $MM_Args{EXE_FILES} = [ sort keys %{$build->script_files} ] if $build->script_files; - $MM_Args{PL_FILES} = {}; + $MM_Args{PL_FILES} = $build->PL_files; local $Data::Dumper::Terse = 1; my $args = Data::Dumper::Dumper(\%MM_Args); @@ -153,6 +153,7 @@ } } +sub PL_FILES_PATCH { 1 } sub subclass_dir { my ($self, $build) = @_; DIE } return $self->SUPER::ACTION_distmeta(); } Test-Trap-v0.3.2/META.yml000444001750001750 220512472732613 14532 0ustar00eirikeirik000000000000--- abstract: 'Trap exit codes, exceptions, output, etc.' author: - 'Eirik Berg Hanssen ' build_requires: {} configure_requires: Module::Build: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.421, CPAN::Meta::Converter version 2.142060' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Trap provides: Test::Trap: file: lib/Test/Trap.pm version: v0.3.2 Test::Trap::Builder: file: lib/Test/Trap/Builder.pm version: v0.3.2 Test::Trap::Builder::PerlIO: file: lib/Test/Trap/Builder/PerlIO.pm version: v0.3.2 Test::Trap::Builder::SystemSafe: file: lib/Test/Trap/Builder/SystemSafe.pm version: v0.3.2 Test::Trap::Builder::TempFile: file: lib/Test/Trap/Builder/TempFile.pm version: v0.3.2 requires: Carp: '0' Data::Dump: '0' Exporter: '0' File::Temp: '0' IO::Handle: '0' Test::Builder: '0' Test::More: '0' Test::Tester: '0.107' base: '0' constant: '0' lib: '0' perl: v5.6.2 strict: '0' version: '0' warnings: '0' resources: license: http://dev.perl.org/licenses/ version: v0.3.2 Test-Trap-v0.3.2/META.json000444001750001750 344112472732613 14705 0ustar00eirikeirik000000000000{ "abstract" : "Trap exit codes, exceptions, output, etc.", "author" : [ "Eirik Berg Hanssen " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.421", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Trap", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Data::Dump" : "0", "Exporter" : "0", "File::Temp" : "0", "IO::Handle" : "0", "Test::Builder" : "0", "Test::More" : "0", "Test::Tester" : "0.107", "base" : "0", "constant" : "0", "lib" : "0", "perl" : "v5.6.2", "strict" : "0", "version" : "0", "warnings" : "0" } } }, "provides" : { "Test::Trap" : { "file" : "lib/Test/Trap.pm", "version" : "v0.3.2" }, "Test::Trap::Builder" : { "file" : "lib/Test/Trap/Builder.pm", "version" : "v0.3.2" }, "Test::Trap::Builder::PerlIO" : { "file" : "lib/Test/Trap/Builder/PerlIO.pm", "version" : "v0.3.2" }, "Test::Trap::Builder::SystemSafe" : { "file" : "lib/Test/Trap/Builder/SystemSafe.pm", "version" : "v0.3.2" }, "Test::Trap::Builder::TempFile" : { "file" : "lib/Test/Trap/Builder/TempFile.pm", "version" : "v0.3.2" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "v0.3.2" } Test-Trap-v0.3.2/Changes000444001750001750 5715112472732613 14606 0ustar00eirikeirik000000000000Revision history for Test-Trap 0.3.2 Tue Feb 24 00:19:23 CET 2015 The tempfile-preserve strategy was (always) broken on non-perlio perls. Also, some of the tests were (recently) noisy on old perls. Test::Trap::Builder::TempFile: - add a GOTPERLIO guard to each IO_LAYERS block. Tests: - 03-files.pl now avoid "used only once" warnings. 0.3.1 Mon Feb 23 21:43:30 CET 2015 This release doesn't touch library code, but addresses some test issues: - It fixes RT #102271 by checking for the presence of a utf8-layer on the original STDOUT, instead of assuming its absence. - It makes some test code cleaner. - It silences redefine warnings during testing on certain platforms. Library files: No change but version bump. Tests: - 03-files* now use another global to specify the class to require, replacing a quick-and-dirty hack that turned out to be noisy on some platforms, including Cygwin. - {15-tempfile,16-systemsafe}-options.t now check for the presence of utf8-layer on STDOUT, instead of assuming its absence. (Either of the environment variables PERL_UNICODE and PERL5OPT could cause such a layer to be present, and there might be other ways to do it.) 0.3.0 Thu Dec 18 21:57:51 CET 2014 This release, in brief: - improves clarity through nomenclature: * renames "(output layer) backend implementation" to "(capture) strategy", for more standard nomenclature (and less of a mouthful); * renames "pseudo-layer" to "multi-layer" (if so declared) or "non-trapping layer" (neither is a direct analogue to PerlIO pseudo layers, so the nomenclature was misleading); - adds (import) options to the TempFile and SystemSafe capture strategy factories, allowing for different ways to handle PerlIO layers; - using these for two new standard capture strategies, "tempfile-preserve" and "systemsafe-preserve"; and - fixes a bug in SystemSafe. And, in more detail ... Test::Trap::Builder: - Changes method names per the nomenclature changes, leaving back-compat aliases behind. - Changes error message per the nomenclature changes. (No back-compat possible, sorry.) - Updates the documentation. Test::Trap::Builder::{TempFile,SystemSafe}: - Import now takes arguments: strategy name (default {"tempfile","systemsafe"}); and strategy options (default empty hash). - The following options are supported: preserve_io_layers (boolean; default false); and io_layers (colon-separated string; default unset). Test::Trap::Builder::SystemSafe: - Fixes a bug where the original perlio layers were not restored after the trap was sprung. Test::Trap::Builder::{PerlIO,TempFile,SystemSafe}: - Updates the code in accordance with Test::Trap::Builder changes; see above. - Updates the documentation. Test::Trap: - Imports new capture strategy, "tempfile-preserve", from TempFile with option preserve_io_layers. - Imports new capture strategy, "systemsafe-preserve", from SystemSafe with option preserve_io_layers. - Updates the code in accordance with Test::Trap::Builder changes; see above. - Updates the documentation. Tests: - changes variable names and comments in accordance with nomenclature changes; - adds tests for the no-restore bug in t/03-files.pl (hence for each tested strategy); - adds t/03-files-{tempfile,systemsafe}-preserve.t to run the basic tests against the new capture strategies; - accounts for the changed error message in t/06-layers.t; - adds t/{15-tempfile,16-systemsafe}-options.t to check capture strategies of varying options. 0.2.5 Sun Nov 16 18:31:42 CET 2014 This release localizes $! (ERRNO) for internal operations that change it, as suggested by Felipe Gasper. For the same operations, it also localizes $^E (extended OS error). Library files: - Localize $! and $^E for internal operations that change them. Tests: - Check that bare test blocks leave $!, %!, and $^E unchanged, but that blocks that modify $! and $^E still do so. Also: - Added Module::Build to the configure_requires. - Fix emacs mode line on t/14-leaks.t. - Better comments in lib/Test/Trap/Builder.pm. 0.2.4 Sun Mar 30 10:02:16 CEST 2014 This release fixes a memory leak with the default tempfile backend layer implementation for trapping output. The systemsafe alternative backend had the same kind of leak, and has also been fixed. (The perlio alternative backend was not affected.) Thanks go again to Felipe Gasper for discovering this! Test::Trap::Builder: - Add a method ExceptionFunction to make it easier to avoid circular references arising from registered closures. Document and export this method. Test::Trap::Builder::TempFile: - Break a circular reference chain. Test::Trap::Builder::SystemSafe: - Break a similar but slightly more complicated circular reference chain. Tests: - Added t/14-leaks.t to check that the reference count is as expected, at least with trivial code and standard setup for all three output layer backends. Also: - Use ebhanssen@cpan.org for my email address. - Update copyright years. - Update MANIFEST.SKIP &c for use of git (goodbye subversion). 0.2.3 Mon Dec 30 14:46:15 CET 2013 Library files: - RT #87263: typo fixes, courtesy dsteinbrunner@pobox.com. - Localize the trap coderef, so that it does not hold on to what it closes over, creating stale references, but lets them go out of scope; thanks go to Felipe Gasper. Documentation: - Some clarification for RT #91687: Wrong exit code after die. Tests: - Regression test for the stale references. 0.2.2 Fri Mar 2 02:23:04 CET 2012 Test::Trap::Builder::TempFile & Test::Trap::Builder::SystemSafe: - RT #61776: Remove temporary files at first opportunity; thanks go to Ian Goodacre. Documentation: - RT #61773: return from trap function Document what trap { ... } returns. Tests: - RT #75430: Failing tests in 06-layer.t Convert a number of die_is to die_like, handling cases with and without trailing comma from carp. - Unset another taint-checked environment variable, CDPATH; thanks go to CPAN testers. 0.2.1 Tue Dec 29 23:14:45 CET 2009 Documentation: - fix a typo, [RT #48941]; thanks go to David Taylor; Tests: - use .PL-files to build the test files t/08-fork.t and t/11-systemsafe-basic.t instead of dispatching through *-taint.t and *-no-taint.t files at runtime; Build: - setup the build of the above test files in Build.PL; - add a ACTION_distmeta override to check for patch to or version of Module::Build::Compat with correct handling of PL_FILES/PL_files; - update the MANIFEST and .SKIP files accordingly. 0.2.0 Tue Sep 30 04:28:30 CEST 2008 Test::Trap::Builder::SystemSafe: - add explicit close()s, as it seems various files otherwise remain open for too long; - register the teardown sub as soon as we have a tempfile, so that we'll close it in teardown even if internal exceptions are raised; Test::Trap::Builder::Tempfile: - added an explicit close($fh), as it seems it otherwise remains open for too long; - register the teardown sub as soon as we have a tempfile, so that we'll close it in teardown even if internal exceptions are raised; Test::Trap::Builder: - add an ' id ' member to the object, for use with tag-on properties, as the ref stringification does not survive a pseudo-fork (inside-out objects are *hard*); - make sure all registered teardowns are called, even after one or more internal exceptions; Test::Trap: - use a different workaround (by way of Teardown) for $SIG{__WARN__} temporary value, as it seems local %SIG does not restore the previous value or lack thereof upon scope exit (may perlbug that one); Tests: - add a regression test for $SIG{__WARN__} restoration to t/03-files.pl; - add a regression test for the ", <$fh> line 1." bug to t/03-files.pl; - t/03-files.pl and t/06-layers.t: add necessary close()s and local *FH to make sure all files are closed before exiting (as otherwise, tempfiles are not being cleaned on windows); - added "~" to the characters accepted in the $^X path, for t/11-systemsafe-basic.pl; - reorganize: move "unnumbered" tests to xt/author; Build: - bump the minor version number, in response to the internal changes in Test::Trap::Builder; - don't list Config as a prereq, as that seems to mess up CPANPLUS(?) installations; - updated MANIFEST, MANIFEST.SKIP, and Build.PL (adding ACTION_authortest) in accordance with the above test reorganization. 0.1.2 Fri Sep 12 17:30:42 CEST 2008 Test::Trap::Builder::TempFile: - use *$globref, not $globref directly -- I have no idea why this suddenly broke, but it did; Tests: - make t/10-tester.t independent of the exact format of the Test::More diagnostics -- just dependent on it staying the same within one process; - thanks go to Andreas Koenig, cpantesters, and Michael Schwern for providing early warning that this was going to fail! - make t/03-files.pl use backticks (`) instead of null chars (\0) as a warning record separator -- makeshift fix -- I should do better, but this must do for now; Build: - up the perl dependency to 5.6.2 -- 5.6.0/5.6.1 may be salvageable, but do not seem worth it. 0.1.1 Tue Mar 11 20:08:31 CET 2008 Documentation: - document the indexing/slicing of ->return and ->warn; - smaller tweaks; - new methods *_isa_ok; Test::Trap: - usage patterns clearly indicate we need *_isa_ok tests: a $trap->did_return w/BAIL_OUT followed by an isa_ok($trap->return(0)) w/BAIL_OUT must constitute the clearest test-trap anti-pattern since C<() = trap {...}>; - note: *_can_ok is still out, since it does not take any kind of name, and the TTB interface still expects a name; Tests: - subclass Pod::Coverage so that it treats the functions "imported" from Test::Trap::Builder as though they were native, not imported, to the package we're testing; - update t/pod-coverage.t to ignore the latest methods and functions somehow documented: layer:*, *_isa_ok, Next, Prop, Run, etc; - prevent t/99-coverage.t exiting with code 8 on success, now that Test-Simple actually catches that stuff; Build: - up the Test::Tester dependency to 0.107 -- I don't know what broke t/10-tester.t; I don't think it was anything of mine -- but upgrading Test::Tester fixed it. 0.1.0 Mon Jan 14 18:31:09 CET 2008 Overall: - Continuing to fix small stuff, but also beginning to mess with the interfaces, adding new stuff and rewriting most of the builder. - Applied a patch from Michael Schilli (in response to a bug reported by Kimo Rosenbaum) adding UNLINK => 1 to the arguments for File::Temp::tempfile(). (Duh!) Documentation: - revised section on TTB exports; - revised section on TTB methods; - document the new pseudo-layers; Nomenclature: - s/trapper layer/trap layer/g; - s/trap (module|package)/trapper/g; # (and similar) - s/result object/trap object/g; # consistency - s/object/trap/g; # argspec ~~ clarity - s/all/entirety/g; # argspec ~~ s/adjective/noun/ - s/indexed/element/g; # argspec ~~ s/adjective/noun/ - ... but keep backwards compatibility with the previous argspec, for now (just don't advertise it in the docs); Test::Trap::Builder: - clean up the test method generation code; - clean up the accessor method generation code; - clean up the layer registration code; - pass the args string to the simple layers; - new export method: Prop, returning a hash for tag-on properies; - new export method: DESTROY, cleaning up tag-on properties; - new export method: TestFailure, running on_test_failure tag-on; - new export method: TestAccessor, returning test_accessor tag-on; - pull out members test and accessor, as these are conceptually (private) trapper class state, not builder instance members; - pull out member output_layer_backend, as this is conceptually (private) builder class state, not a builder instance member; - turn members _code, _layers, _teardown, _test_accessor, and _exception, (all without the leading underscore) into tag-on properties, rather than pollute the trap object; - get rid of more trap object pollution: __exception; - in test callback argspecs, refer to trap objects as "trap", not "object"; - better handling of exceptions in layers and teardown. Test::Trap: - run the test failure callback from the quiet() test; - new utility method: diag_all, basically {diag dump $self}; - new utility method: diag_all_once, a "smarter" version. - new (non-default) pseudo-layers: :void - user code is trapped in void context :scalar - user code is trapped in scalar context :list - user code is trapped in list context :on_fail() - method name for test failures callback Tests: - full coverage for the new methods and exception handling; - t/00-load.t does BAIL_OUT if Test::Trap cannot be used; - t/07-subclass.t no longer needs to test the case of the empty default_output_layer_backends(), since this has now been removed from the extension interface; - t/06-layers.t cleaned up and expanded to cover the new layers; except - t/10-tester.t covers the :on_fail() layer; - t/10-tester.t now tests a simple non-leaveby accessor too; - t/11-systemsafe-basic.pl now actually prints diagnostics when the system() call fails. Duh! (I still don't know why some Cygwin setups fails these tests, but I'd sure like to.) 0.0.23 Mon Jun 25 22:47:50 CEST 2007 More blead stuff; otherwise just making a convenient small-stuff cut. Test::Trap: - Don't use IO::Handle here. (Only needed with File::Temp.) Test::Trap::Builder::PerlIO: - Don't need ->autoflush, nor IO::Handle. Test::Trap::Builder::TempFile: - Need IO::Handle, so use it. Test::Trap::Builder::SystemSafe: - Need IO::Handle, so use it. - The strange buffering bug seems to have disappeared (between revisions 99 and 100), though I have no idea how. This ought to mean I no longer need to maintain the clumsy work-around. So, removed! Tests: - As a concession to the CPANTS game, reinstated the pod tests. :) - The regression test for the workaround for the pseudo-fork bug was broken. Fixed by using the (implicit) :default layer in t/08-fork.pl. - t/02-reentrant.t caused a warning under bleed. Fixed. - t/03-files.pl is now blead-ready (warning texts changed). - t/11-systemsafe-basic.pl now detects system() failure and fails the relevant tests as well (thank you cpan testsers). 0.0.22 Sun May 20 23:21:36 CEST 2007 No big changes this time. Cleanup: - remove unused Getopt::Long from tests; - rearrange some tests for better readability; - rewrite some systemsafe pod for better readability. Tests: - delete $ENV{ENV} (tainted); - for coverage, first don't use Test::More in t/99-coverage.t; - for coverage, test the internals of exiting breaking badly; - simpler (and better covering) subclass tests. Test::Trap: - don't AUTOLOAD on behalf of Test::More after all (unclean); - last TEST_TRAP_EXITING rather than goto EXITING (avoid collisions). Test::Trap::Builder: - localize the builder's internals of the trap object, so that they are gone as soon as the trap has sprung, leaving pay data only; - last TEST_TRAP_BUILDER_INTERNAL_EXCEPTION rather than goto INTERNAL_EXCEPTION (avoid collision); - note (in the pod) a caveat for diamond inheritance wrt autogeneration of test methods. Build: - don't include author's tests (pod*, kwalitee, etc) in the tarball; - note _all_ mandatory module dependencies (overkill?). 0.0.21 Sun Oct 29 15:53:07 CET 2006 Test::Trap::Builder::SystemSafe: - Fix typo in the NAME section of the POD. Test::Trap::Builder: - Export a method ->TestAccessor, giving the tested accessor's name. - Remove (ugly) register method ->test_method. - Add (cleaner) register method ->test. Test::Trap: - Better diagnostics to failing *_ok/*_nok test. - AUTOLOAD Test::More when required. 0.0.20 Sun Oct 22 09:21:55 CEST 2006 Test::Trap::Builder: - Backend implementations are now methods, almost layers, not functions. - Called with the (layer) name, the fileno, and the globref. - local(*$globref) is now left to the implementation. - Add method ->trap, implementing trap entry. - Add exportable methods Run, Next, Exception, Teardown: - Run runs the user's code; - Next continues to the next layer; - Exception raises an internal exception; - Teardown registers cleanup code. Test::Trap::Builder::TempFile, Test::Trap::Builder::PerlIO: - Use ->Teardown instead of &DESTROY. Add Test::Trap::Builder::SystemSafe. - Add three test scripts for this. - Work hard, and make those tests pass on 5.6.2! :-) t/03-files.pl: Simpler, less hacky, choice of backend. t/07-subclass.t: Use the core alarm(), not the Time::HiRes one. t/08-fork.t: Remember to wait() on all children. t/99-coverage.t: What I cannot test without hacking. t/*{-no-,-}taint.t: - Since Windows fork() does not work with taint mode. t/*.t, t/*.pl: - Add comments and refactor into subroutines. - Replace pass()/fail() with simpler/clearer ok(). 0.0.19 Wed Sep 27 20:48:20 CEST 2006 No new functionality -- just bugfixes! Address three portability issues: - added binmode to the second handle on the tempfile; - skip timout tests if Time::HiRes::ualarm cannot be imported; - todo & skip the fork test on windows; - thanks go to Alexandr Ciornii for reporting these failures! Also: - document the fork() issue on Windows as a Test::Trap bug; - just skip the fork tests on platforms without fork; - drop the Time::HiRes dependency (we only need it for a test); - a little more POD and code (readability) cleanup. 0.0.18 Mon Sep 25 23:49:48 CEST 2006 Basically just pushing to get a well-packaged version out. Packaged with a newer MB to get a (hopefully) better META.yml. Cleaned up the error messages somewhat. 0.0.17 Sat Sep 23 00:47:13 CEST 2006 Overview: - Test::Temp gets new optional layers: :stdout(perlio) :stdout(tempfile) :stderr(perlio) :stderr(tempfile) - Test::Temp interface is otherwise unchanged. - Test::Trap::Builder interface is mostly unchanged, but now: - treats braces in layer names as syntactical; - has an interface for registering output layer backends; - also lets you register default backends; - has some more changes in non-interface (internal) functions. - Test::Trap::Builder::TempFile added. - Test::Trap::Builder::PerlIO added. Added a File::Temp backend for output layers, and require it. Made the PerlIO backend optional, and require no more than 5.6.0. Moved each backend to its own file. Update the tests to cover both backends. Skip the PerlIO backend tests if PerlIO is not availible. For whatever reason, make noisy ugly META.yml after upgrades. Let the user specify implementation, f ex: ":stdout(perlio)". Test this new interface. Update the POD. 0.0.16 Tue Sep 19 21:52:03 CEST 2006 Note dependency on perl 5.8.0 and Time::HiRes. Pod updates to Builder.pm. Added tests for layer permutation :raw:warn:stderr:stdout:exit:die. Added tester tests for TODO and SKIP. 0.0.15 Mon Sep 18 23:53:05 CEST 2006 Move the extension interface into its own Test::Trap::Builder. Change the extension interface somewhat: - methods on the builder object, not the calling package; - simpler methods for making accessors; - methods also for registering test method prototypes; - generate test methods from accessor + test pairs; - ... even if the test or accessor is inherited; - &layer_implementation needs both $module and $Builder now; - update the tests accordingly. Also, added some new tests for the builder. 0.0.14 Tue Sep 5 16:40:13 CEST 2006 Rewrite the "layer:$name" methods: - return the layer implementation rather than be it, and - can handle multi_layer definitions as well, - changing &layer, &layer_implementation, and &multi_layer. Update the POD accordingly. Add an example using the extension interface. Polish the POD, and add some more vertical spacing. 0.0.13 Tue Aug 29 06:54:05 CEST 2006 Add the standard test methods. Document them -- overall, not one by one. Test them -- using Test::Tester. Add a dependency on Test::Tester. Add a trustme for the pod coverage check. Add a dependency on Data::Dump (for quoting, more or less). Add factories for accessors and test methods. Let array accessors produce elements and slices as well. Add extra test methods: did_die, did_exit, did_return, quiet. Document these. Test them -- using Test::Tester. 0.0.12 Sun Aug 27 03:05:45 CEST 2006 Don't trap exits in children! Revert to outer exit-handler instead. Test undefined *CORE::GLOBAL::exit. Test forked exits. Document the fork/exit caveat. Rename some layers: :return:raw are now :raw:flow. Base non-empty layer specifications too on :default. Tests updated accordingly. 0.0.11 Sun Aug 27 01:51:30 CEST 2006 Test a bad class definition. Clean up the code. 0.0.10 Sun Aug 27 01:18:09 CEST 2006 Add tests for subclassing. Implement subclassing. 0.0.9 Sat Aug 26 23:51:26 CEST 2006 Implement layers as methods, anonymous or with mangled names. Update the special layers test accordingly. Move POD to beyond __END__. 0.0.8 Sat Aug 26 22:19:53 CEST 2006 s/mode/leaveby/g; 0.0.7 Thu Aug 24 04:35:04 CEST 2006 Implement user-defined trapper layers! Wrappers are now layers! Test trapper layers! 0.0.6 Thu Aug 24 02:28:08 CEST 2006 Protect the method calls of the local $trap test. Pull the wrapper list out of the exported sub and into its factory. Add a &write_trapper factory to replace &_trap_std{err,out}. Trap warnings as well. Add tests for trapping warnings. 0.0.5 Wed Aug 23 18:32:28 CEST 2006 Back to exporting just a scalar instead of the glob. Export an anonymous closure combo instead of our $trap / &trap. Eliminate our $trap / &trap. (Use a factory instead.) Update the tests accordingly. 0.0.4 Wed Aug 23 15:44:00 CEST 2006 New test: Apply local() to the scalar. Implementation: Export a glob instead of just the scalar. 0.0.3 Wed Aug 23 03:39:03 CEST 2006 Decompose the different wrappers. Eliminate the %trap hash. Update tests to account for: - missing 'die' was '', is now undef; - void 'return' was [undef], is now []; - missing 'return' was context dependent, is now undef. 0.0.2 Wed Aug 23 00:01:14 CEST 2006 Export a global scalar, by default $trap, instead of &trapped. Make &trap merely the default name of the function. Update tests accordingly. Test for ->import failing in various ways. Query exists &CORE::GLOBAL::exit instead of defined *...{CODE}. Add pod. 0.0.1 Sun Aug 6 15:26:47 CEST 2006 Began extracting useful stuff from messy old code. Test-Trap-v0.3.2/MANIFEST000444001750001750 126012472732613 14412 0ustar00eirikeirik000000000000Build.PL Changes lib/Test/Trap.pm lib/Test/Trap/Builder.pm lib/Test/Trap/Builder/PerlIO.pm lib/Test/Trap/Builder/SystemSafe.pm lib/Test/Trap/Builder/TempFile.pm Makefile.PL MANIFEST META.json META.yml README t/00-load.t t/01-basic.t t/02-reentrant.t t/03-files-perlio.t t/03-files-systemsafe-preserve.t t/03-files-systemsafe.t t/03-files-tempfile-preserve.t t/03-files-tempfile.t t/03-files.pl t/04-exit.t t/05-import.t t/06-layers.t t/07-subclass.t t/08-fork.PL t/09-array-accessor.t t/10-tester.t t/11-systemsafe-basic.PL t/12-systemsafe-errors.t t/13-regressions.t t/14-leaks.t t/15-tempfile-options.t t/16-systemsafe-options.t t/99-coverage.t xt/author/pod-coverage.t xt/author/pod.t Test-Trap-v0.3.2/README000444001750001750 156012472732613 14144 0ustar00eirikeirik000000000000Test-Trap Primarily (but not exclusively) for use in test scripts: A block eval on steroids, configurable and extensible, but by default trapping (Perl) STDOUT, STDERR, warnings, exceptions, would-be exit codes, and return values from boxed blocks of test code. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test sudo make install (If you are running as root, you may drop "sudo", and just run "make install".) Alternatively, for those without a proper make, the Module::Build approach: perl Build.PL perl Build perl Build test sudo perl Build install (Again, if you are running as root, you may run "make install" without "sudo".) COPYRIGHT AND LICENCE Copyright (C) 2006-2014 Eirik Berg Hanssen This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Test-Trap-v0.3.2/Makefile.PL000444001750001750 170412472732613 15236 0ustar00eirikeirik000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4210 require 5.006002; use ExtUtils::MakeMaker; WriteMakefile ( 'PREREQ_PM' => { 'constant' => 0, 'version' => 0, 'IO::Handle' => 0, 'Data::Dump' => 0, 'Test::Builder' => 0, 'Exporter' => 0, 'Test::Tester' => '0.107', 'File::Temp' => 0, 'Carp' => 0, 'Test::More' => 0, 'base' => 0, 'strict' => 0, 'warnings' => 0, 'lib' => 0 }, 'VERSION_FROM' => 'lib/Test/Trap.pm', 'EXE_FILES' => [], 'INSTALLDIRS' => 'site', 'NAME' => 'Test::Trap', 'PL_FILES' => { 't/11-systemsafe-basic.PL' => 't/11-systemsafe-basic.t', 't/08-fork.PL' => 't/08-fork.t' } ) ; Test-Trap-v0.3.2/lib000755001750001750 012472732613 13673 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/lib/Test000755001750001750 012472732613 14612 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/lib/Test/Trap.pm000444001750001750 5400012472732613 16232 0ustar00eirikeirik000000000000package Test::Trap; use version; $VERSION = qv('0.3.2'); use strict; use warnings; use Carp qw( croak ); use Data::Dump qw(dump); use Test::Trap::Builder qw( :methods ); my $B = Test::Trap::Builder->new; sub import { my $trapper = shift; my $callpkg = caller; my (@function, @scalar, @layer); while (@_) { my $sym = shift; UNIVERSAL::isa($sym, 'CODE') ? push @layer, $sym : $sym =~ s/^:// ? push @layer, split/:/, $sym : $sym =~ s/^\$// ? push @scalar, $sym : $sym !~ m/^[@%*]/ ? push @function, $sym : croak qq["$sym" is not exported by the $trapper module]; } if (@function > 1) { croak qq[The $trapper module does not export more than one function]; } if (@scalar > 1) { croak qq[The $trapper module does not export more than one scalar]; } my $function = @function ? $function[0] : 'trap'; my $scalar = @scalar ? $scalar[0] : 'trap'; @layer = $B->layer_implementation($trapper, default => @layer); no strict 'refs'; my $gref = \*{"$callpkg\::$scalar"}; *$gref = \ do { my $x = bless {}, $trapper }; *{"$callpkg\::$function"} = sub (&) { $B->trap($trapper, $gref, \@layer, shift); } } #################### # Standard layers # #################### # The big one: trapping exits correctly: EXIT_LAYER: { # A versatile &CORE::GLOBAL::exit candidate: sub _global_exit (;$) { my $exit = @_ ? 0+shift : 0; ___exit($exit) if exists &___exit; CORE::exit($exit); }; # Need to have &CORE::GLOBAL::exit set, one way or the other, # before any code to be trapped is compiled: *CORE::GLOBAL::exit = \&_global_exit unless exists &CORE::GLOBAL::exit; # And at last, the layer for exits: $B->layer(exit => $_) for sub { my $self = shift; # in case someone else is messing with exit: my $pid = $$; my $outer = \&CORE::GLOBAL::exit; undef $outer if $outer == \&_global_exit; local *___exit; TEST_TRAP_EXITING: { { no warnings 'redefine'; *___exit = sub { if ($$ != $pid) { return $outer->(@_) if $outer; # XXX: This is fuzzy ... how to test this right? CORE::exit(shift); } $self->{exit} = shift; $self->{leaveby} = 'exit'; no warnings 'exiting'; last TEST_TRAP_EXITING; }; } local *CORE::GLOBAL::exit; *CORE::GLOBAL::exit = \&_global_exit; $self->Next; } return; }; } # The other layers and standard accessors: # Note: :raw is a terminating layer -- it does not call any lower # layer, but is the layer responsible for calling the actual code! $B->layer(raw => $_) for sub { my $self = shift; my $wantarray = $self->{wantarray}; my @return; unless (defined $wantarray) { $self->Run } elsif ($wantarray) { @return = $self->Run } else { @return = scalar $self->Run } $self->{return} = \@return; $self->{leaveby} = 'return'; }; # A simple layer for exceptions: $B->layer(die => $_) for sub { my $self = shift; local *@; return if eval { $self->Next; 1 }; $self->{die} = $@; $self->{leaveby} = 'die'; }; # Layers for STDOUT and STDERR, from the factory: $B->output_layer( stdout => \*STDOUT ); $B->output_layer( stderr => \*STDERR ); BEGIN { # Make available some capture strategies: use Test::Trap::Builder::TempFile; use Test::Trap::Builder::TempFile 'tempfile-preserve' => { preserve_io_layers => 1 }; # optional capture strategies: eval q{ use Test::Trap::Builder::PerlIO }; eval q{ use Test::Trap::Builder::SystemSafe }; eval q{ use Test::Trap::Builder::SystemSafe 'systemsafe-preserve' => { preserve_io_layers => 1 } }; } # A simple layer for warnings: $B->layer(warn => $_) for sub { my $self = shift; my @warn; # Can't local($SIG{__WARN__}) because of a perl bug with local() on # scalar values under the Windows fork() emulation -- work around: my $sigwarn = $SIG{__WARN__}; my $sigwarn_exists = exists $SIG{__WARN__}; $SIG{__WARN__} = sub { my $w = shift; push @warn, $w; print STDERR $w if defined fileno STDERR; }; $self->Teardown($_) for sub { if ($sigwarn_exists) { $SIG{__WARN__} = $sigwarn; } else { delete $SIG{__WARN__}; } }; $self->{warn} = \@warn; $self->Next; }; # Multi-layers: $B->multi_layer(flow => qw/ raw die exit /); $B->multi_layer(default => qw/ flow stdout stderr warn /); # Non-default non-trapping layers: $B->layer( void => $_ ) for sub { my $self = shift; undef $self->{wantarray}; $self->Next; }; $B->layer( scalar => $_ ) for sub { my $self = shift; $self->{wantarray} = ''; $self->Next; }; $B->layer( list => $_ ) for sub { my $self = shift; $self->{wantarray} = 1; $self->Next; }; $B->layer( on_fail => $_ ) for sub { my $self = shift; my ($arg) = @_; $self->Prop('Test::Trap::Builder')->{on_test_failure} = $arg; $self->Next; }; $B->layer( output => $_ ) for sub { my $self = shift; my $strategy = eval { $B->first_capture_strategy(@_) }; $self->Exception($@) if $@; $self->Prop('Test::Trap::Builder')->{capture_strategy} = $strategy; $self->Next; }; ######################## # Standard accessors # ######################## $B->accessor( simple => [ qw/ leaveby stdout stderr wantarray / ], flexible => { list => sub { $_[0]{wantarray}; }, scalar => sub { my $x = $_[0]{wantarray}; !$x and defined $x; }, void => sub { not defined $_[0]{wantarray}; }, }, ); $B->accessor( is_leaveby => 1, simple => [ qw/ exit die / ], ); $B->accessor( is_array => 1, simple => [ qw/ warn / ], ); $B->accessor( is_array => 1, is_leaveby => 1, simple => [ qw/ return / ], ); #################### # Standard tests # #################### # This helper and similar strategies below delay loading Test::More # until we actually use this stuff, so that It Just Works if we: # 0) have already loaded and planned with Test::More ;-) # 1) have already loaded and planned with some other Test::Builder module # 2) aren't actually testing, just trapping sub _test_more($) { my $sym = shift; sub { require Test::More; goto &{"Test::More::$sym"}; }; } for my $simple (qw/ is isnt like unlike isa_ok /) { $B->test( $simple => 'element, predicate, name', _test_more $simple ); } $B->test( is_deeply => 'entirety, predicate, name', _test_more 'is_deeply' ); $B->test( ok => 'trap, element, name', $_ ) for sub { my $self = shift; my ($got, $name) = @_; require Test::More; my $Test = Test::More->builder; my $ok = $Test->ok( $got, $name ); $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok; Expecting true value in %s, but got %s instead OK return $ok; }; $B->test( nok => 'trap, element, name', $_ ) for sub { my $self = shift; my ($got, $name) = @_; require Test::More; my $Test = Test::More->builder; my $ok = $Test->ok( !$got, $name ); $Test->diag(sprintf<TestAccessor, dump($got)) unless $ok; Expecting false value in %s, but got %s instead NOK return $ok; }; # Extra convenience test method: sub quiet { my $self = shift; my ($name) = @_; my @fail; for my $m (qw/stdout stderr/) { my $buf = $self->$m . ''; # coerce to string push @fail, "Expecting no \U$m\E, but got " . dump($buf) if $buf ne ''; } require Test::More; my $Test = Test::More->builder; my $ok = $Test->ok(!@fail, $name) or do { $Test->diag(join"\n", @fail); $self->TestFailure; }; $ok; } ##################### # Utility methods # ##################### sub diag_all { my $self = shift; require Test::More; Test::More::diag( dump $self ); } sub diag_all_once { my $self = shift; my $msg = $self->Prop->{diag_all_once}++ ? '(as above)' : dump $self; require Test::More; Test::More::diag( $msg ); } 1; # End of Test::Trap __END__ =head1 NAME Test::Trap - Trap exit codes, exceptions, output, etc. =head1 VERSION Version 0.3.2 =head1 SYNOPSIS use Test::More; use Test::Trap; my @r = trap { some_code(@some_parameters) }; is ( $trap->exit, 1, 'Expecting &some_code to exit with 1' ); is ( $trap->stdout, '', 'Expecting no STDOUT' ); like ( $trap->stderr, qr/^Bad parameters; exiting\b/, 'Expecting warnings.' ); =head1 DESCRIPTION Primarily (but not exclusively) for use in test scripts: A block eval on steroids, configurable and extensible, but by default trapping (Perl) STDOUT, STDERR, warnings, exceptions, would-be exit codes, and return values from boxed blocks of test code. The values collected by the latest trap can then be queried or tested through a special trap object. =head1 EXPORT A function and a scalar may be exported by any name. The function (by default named C) is an analogue to block eval(), and the scalar (by default named C<$trap>) is the corresponding analogue to C<$@>. Optionally, you may specify the layers of the exported trap. Layers may be specified by name, with a colon sigil. Multiple layers may be given in a list, or just stringed together like C<:flow:stderr:warn>. (For the advanced user, you may also specify anonymous layer implementations -- i.e. an appropriate subroutine.) See below for a list of the built-in layers, most of which are enabled by default. Note, finally, that the ordering of the layers matter: The :raw layer is always on the bottom (anything underneath it is ignored), and any other "flow control" layers used should be right down there with it. =head1 FUNCTION =head2 trap BLOCK This function may be exported by any name, but defaults to C. By default, traps exceptions (like block eval), but also exits and exit codes, returns and return values, context, and (Perl) output on STDOUT or STDERR, and warnings. All information trapped can be queried through the trap object, which is by default exported as C<$trap>, but can be exported by any name. The value returned from C mimics that returned from C: If the I would die or exit, it returns an undefined value in scalar context or an empty list in list context; otherwise it returns whatever the I would return in the given context (also available as the trapped return values). =head1 TRAP LAYERS Exactly what the C traps depends on the layers of the trap. It is possible to register more (see L), but the following layers are pre-defined by this module: =head2 :raw The only built-in terminating layer, at which the processing of the layers stops, and the actual call to the user code is performed. On success, it collects the return value(s) in the appropriate context. Pushing the :raw layer on a trap will for most purposes remove all layers below. =head2 :die The layer emulating block eval, trapping normal exceptions. =head2 :exit The third "flow control" layer, capturing exit codes if anything used in the dynamic scope of the trap calls CORE::GLOBAL::exit(). (See CAVEATS below for more.) =head2 :flow A shortcut for :raw:die:exit (effectively pushing all three layers on the trap). Since this includes :raw, it is also terminating: Pushing :flow on a trap will effectively remove all layers below. =head2 :stdout, :stderr Layers trapping Perl output on STDOUT and STDERR, respectively. =head2 :stdout(perlio), :stderr(perlio) As above, but specifying a capture strategy using PerlIO::scalar. If this strategy is not available (typically if PerlIO is not), this is an error. See L. =head2 :stdout(tempfile), :stderr(tempfile) As above, but specifying a capture strategy using File::Temp. Note that this is the default strategy, unless the C<:output()> layer is used to set another default. See L. =head2 :stdout(a;b;c), :stderr(a,b,c) (Either syntax, commas or semicolons, is permitted, as is any number of names in the list.) As above, but specifying the capture strategy by the first existing name among I, I, and I. If no such strategy is found, this is an error. See L. =head2 :warn A layer trapping warnings, with additional tee: If STDERR is open, it will also print the warnings there. (This output may be trapped by the :stderr layer, be it above or below the :warn layer.) =head2 :default A short-cut for :raw:die:exit:stdout:stderr:warn (effectively pushing all six layers on the trap). Since this includes :raw, it is also terminating: Pushing :default on a trap will effectively remove all layers below. The other interesting property of :default is that it is what every trap starts with: In order not to include the six layers that make up :default, you need to push a terminating layer (such as :raw or :flow) on the trap. =head2 :on_fail(m) A (non-default, non-trapping) layer that installs a callback method (by name) I to be run on test failures. To run the L method every time a test fails: use Test::Trap qw/ :on_fail(diag_all) /; =head2 :void, :scalar, :list These (non-default, non-trapping) layers will cause the trapped user code to be run in void, scalar, or list context, respectively. (By default, the trap will propagate context, that is, it will run the code in whatever context the trap itself is in.) If more than one of these layers are pushed on the trap, the deepest (that is, leftmost) takes precedence: use Test::Trap qw/ :scalar:void:list /; trap { 42, 13 }; $trap->return_is_deeply( [ 13 ], 'Scalar comma.' ); =head2 :output(a;b;c) A (non-default, non-trapping) layer that sets the default capture strategy for any output trapping (C<:stdout>, C<:stderr>, or other similarly defined) layers below iton the trap. use Test::Trap qw/ :output(systemsafe) /; trap { system echo => 'Hello Unix!' }; # trapped! use Test::Trap qw/ :flow:stderr:output(systemsafe):stdout /; trap { system echo => 'Hello Unix!' }; # *not* trapped! trap { system q/ echo 'Hello Unix!' >&2 / }; # trapped! See L. =head1 CAPTURE STRATEGIES How output is trapped, depends on the capture strategy used. It is possible to register more (see L), but the following strategies are pre-defined by this module: =head2 tempfile The default capture strategy, provided by L, in which output is temporarily redirected to (and read back from) a tempfile. =head2 tempfile-preserve A variant of the capture strategy provided by L, in which the handles used to write to and read from the tempfile are both binmoded with the same perlio layers as the trapped output handle originally had. Caveat emptor: If the handle has perlio custom layers, they may (or may not) fail to apply to the tempfile read and write handles. =head2 systemsafe A capture strategy provided by L, like the default strategy, except it outputs on file handles with the same file descriptors as the trapped output handle originally had, and so can be used to trap output from forked-off processes, including system(). This strategy may be "safe" in relation to forked-off processes, but it is fragile. For one, it only works with handles that have "real" file descriptors. For another, it depends on the original file descriptors being available after closing. (If signal handlers or threads open files, they may well not be.) And it may fail in other ways. But in relation to forked-off processes, the other pre-defined strategies will silently fail to trap, as will similarly simple strategies. This one, when not crashing, will trap that output. =head2 systemsafe-preserve A variant of the capture strategy provided by L, in which the handles used to write to and read from the tempfile are both binmoded with the same perlio layers as the trapped output handle originally had. Caveat emptor: If the handle has perlio custom layers, they may (or may not) fail to apply to the tempfile read and write handles. =head2 perlio A capture strategy provided by L, in which output is temporarily redirected to an in-memory file via PerlIO::scalar. If PerlIO::scalar is not available, neither is this strategy. =head1 RESULT ACCESSORS The following methods may be called on the trap objects after any trap has been sprung, and access the outcome of the run. Any property will be undef if not actually trapped -- whether because there is no layer to trap them or because flow control passed them by. (If there is an active and successful trap layer, empty strings and empty arrays trapped will of course be defined.) When properties are set, their values will be as follows: =head2 leaveby A string indicating how the trap terminated: C, C, or C. =head2 die The exception, if the latest trap threw one. =head2 exit The exit code, if the latest trap tried to exit (by way of the trap's own &CORE::GLOBAL::exit only; see L). =head2 return [INDEX ...] Returns undef if the latest trap did not terminate with a return; otherwise returns three different views of the return array: =over =item if no I is passed, returns a reference to the array (NB! an empty array of indices qualifies as "no index") =item if called with at least one I in scalar context, returns the array element indexed by the first I (ignoring the rest) =item if called with at least one I in list context, returns the slice of the array by these indices =back Note: The array will hold but a single value if the trap was sprung in scalar context, and will be empty if it was in void context. =head2 stdout, stderr The captured output on the respective file handles. =head2 warn [INDEX] Returns undef if the latest trap had no warning-trapping layer; otherwise returns three different views of the warn array: =over =item if no I is passed, returns a reference to the array (NB! an empty array of indices qualifies as "no index") =item if called with at least one I in scalar context, returns the array element indexed by the first I (ignoring the rest) =item if called with at least one I in list context, returns the slice of the array by these indices =back =head2 wantarray The context in which the latest code trapped was called. (By default a propagated context, but layers can override this.) =head2 list, scalar, void True if the latest code trapped was called in the indicated context. (By default the code will be called in a propagated context, but layers can override this.) =head1 RESULT TESTS For each accessor, a number of convenient standard test methods are also available. By default, these are a few standard tests from Test::More, plus the C test (a negated C test). All for convenience: =head2 I_ok [INDEX,] TEST_NAME =head2 I_nok [INDEX,] TEST_NAME =head2 I_is [INDEX,] SCALAR, TEST_NAME =head2 I_isnt [INDEX,] SCALAR, TEST_NAME =head2 I_isa_ok [INDEX,] SCALAR, INVOCANT_NAME =head2 I_like [INDEX,] REGEX, TEST_NAME =head2 I_unlike [INDEX,] REGEX, TEST_NAME =head2 I_is_deeply STRUCTURE, TEST_NAME I is not optional: It is required for array accessors (like C and C), and disallowed for scalar accessors. Note that the C test does not accept an index. Even for array accessors, it operates on the entire array. For convenience and clarity, tests against a flow control I (C, C, C, or any you define yourself) will first test whether the trap was left by way of the flow control mechanism in question, and fail with appropriate diagnostics otherwise. =head2 did_die, did_exit, did_return Conveniences: Tests whether the trap was left by way of the flow control mechanism in question. Much like C etc, but with better diagnostics and (run-time) spell checking. =head2 quiet Convenience: Passes if zero-length output was trapped on both STDOUT and STDERR, and generate better diagnostics otherwise. =head1 UTILITIES =head2 diag_all Prints a diagnostic message (as per L) consisting of a dump (in Perl code, as per L) of the trap object. =head2 diag_all_once As L, except if this instance of the trap object has already been diag_all_once'd, the diagnostic message will instead consist of the string C<(as above)>. This could be useful with the C layer: use Test::Trap qw/ :on_fail(diag_all_once) /; =head1 CAVEATS This module must be loaded before any code containing exit()s to be trapped is compiled. Any exit() already compiled won't be trappable, and will terminate the program anyway. This module overrides &CORE::GLOBAL::exit, so may not work correctly (or even at all) in the presence of other code overriding &CORE::GLOBAL::exit. More precisely: This module installs its own exit() on entry of the block, and restores the previous one, if any, only upon leaving the block. If you use fork() in the dynamic scope of a trap, beware that the (default) :exit layer of that trap does not trap exit() in the children, but passes them to the outer handler. If you think about it, this is what you are likely to want it to do in most cases. Note that the (default) :exit layer only traps &CORE::GLOBAL::exit calls (and bare exit() calls that compile to that). It makes no attempt to trap CORE::exit(), POSIX::_exit(), exec(), untrapped exceptions from die(), nor segfault. Nor does it attempt to trap anything else that might terminate the program. The trap is a block eval on steroids -- not the last block eval of Krypton! This module traps warnings using C<$SIG{__WARN__}>, so may not work correctly (or even at all) in the presence of other code setting this handler. More precisely: This module installs its own __WARN__ handler on entry of the block, and restores the previous one, if any, only upon leaving the block. The (default) :stdout and :stderr handlers will not trap output from system() calls. Threads? No idea. It might even work correctly. =head1 BUGS Please report any bugs or feature requests directly to the author. =head1 AUTHOR Eirik Berg Hanssen, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Trap-v0.3.2/lib/Test/Trap000755001750001750 012472732613 15520 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/lib/Test/Trap/Builder.pm000444001750001750 6017412472732613 17631 0ustar00eirikeirik000000000000package Test::Trap::Builder; use version; $VERSION = qv('0.3.2'); use strict; use warnings; use Data::Dump qw(dump); BEGIN { use Exporter (); *import = \&Exporter::import; my @methods = qw( Next Exception ExceptionFunction Teardown Run TestAccessor TestFailure Prop DESTROY ); our @EXPORT_OK = (@methods); our %EXPORT_TAGS = ( methods => \@methods ); } use constant GOT_CARP_NOT => $] >= 5.008; use Carp qw(croak); our (@CARP_NOT, @ISA); my $builder = bless {}; # Methods on the trap object ... basically a trap object "base class": BEGIN { my %Prop; my $prefix = "$^T/$$/"; my $counter; sub DESTROY { my $self = shift; delete $Prop{ $self->{' id '} || '' }; } sub Prop { my $self = shift; my ($package) = @_; $package = caller unless $package; $self->{' id '} = $prefix . ++$counter unless $self->{' id '}; return $Prop{$self->{' id '}}{$package} ||= {}; } sub Next { goto &{ pop @{$_[0]->Prop->{layers}} } } sub Teardown { my $self = shift; push @{$self->Prop->{teardown}}, @_ } sub Run { my $self = shift; @_ = (); goto &{$self->Prop->{code}} } sub TestAccessor { shift->Prop->{test_accessor} } sub TestFailure { my $self = shift; my $m = $self->Prop->{on_test_failure} or return; $self->$m(@_); } sub ExceptionFunction { my $self = shift; my $exception = $self->Prop->{exception} ||= []; $self->Prop->{exception_function} ||= sub { push @$exception, @_; local *@; eval { no warnings 'exiting'; last TEST_TRAP_BUILDER_INTERNAL_EXCEPTION; }; # XXX: PANIC! We returned!?! CORE::exit(8); # XXX: Is there a more appropriate exit value? }; return $self->Prop->{exception_function}; } sub Exception { my $self = shift; $self->ExceptionFunction->(@_); } } # Utility functions and methods on the builder class/object: sub _carpnot_for (@) { my %seen = ( __PACKAGE__, 1 ); my @pkg = grep { !$seen{$_}++ } @_; return @pkg; } sub new { $builder } sub trap { my $self = shift; my ($trapper, $glob, $layers, $code) = @_; my $trap = bless { wantarray => (my $wantarray = wantarray) }, $trapper; TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: { local *@; local $trap->Prop->{code} = $code; $trap->Prop->{layers} = [@$layers]; $trap->Prop->{teardown} = []; TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: { eval { $trap->Next; 1} or $trap->Exception("Rethrowing internal exception: $@"); } for (reverse @{$trap->Prop->{teardown}}) { TEST_TRAP_BUILDER_INTERNAL_EXCEPTION: { eval { $_->(); 1} or $trap->Exception("Rethrowing teardown exception: $@"); } } last if @{$trap->Prop->{exception}||[]}; ${*$glob} = $trap; my @return = eval { @{$trap->return} }; return $wantarray ? @return : $return[0]; } local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for $trapper, scalar caller; croak join"\n", @{$trap->Prop->{exception}}; } BEGIN { # The register (private) functions: my %register; sub _register { my ($type, $package, $name, $val) = @_; $register{$type}{$package}{$name} = $val; } sub _register_packages { my ($type) = @_; return keys %{$register{$type}}; } sub _register_names { my ($type, $package) = @_; return keys %{$register{$type}{$package}}; } sub _register_value { my ($type, $package, $name) = @_; return $register{$type}{$package}{$name}; } } BEGIN { # Test callback registration and test method generation: # state for the closures in %argspec -- obviously not reentrant: my ($accessor, $test, $index, $trap, @arg); my %argspec = ( trap => sub { $trap }, element => sub { $accessor->{code}->( $trap, _need_index() ? $index = shift(@arg) : () ) }, entirety => sub { $accessor->{code}->( $trap ) }, predicate => sub { shift @arg }, name => sub { shift @arg }, ); # backwards compatibility -- don't use these: @argspec{ qw( object all indexed ) } = @argspec{ qw( trap entirety element ) }; # stringifying the CODE refs, that we may easily check if we have a specific one: my %isname = ( $argspec{name} => 1 ); my %iselement = ( $argspec{element} => 1 ); my %takesarg = ( $argspec{predicate} => 1 ); sub _need_index { $accessor->{is_array} && grep $iselement{$_}, @{$test->{argspec}} } # a single universal test -- the leaveby test: # (don't worry -- the UNIVERSAL package is not actually touched) _register test => UNIVERSAL => did => { argspec => [ $argspec{name} ], code => sub { require Test::More; goto &Test::More::pass }, pattern => '%s::did_%s', builder => __PACKAGE__->new, }; my $basic_test = sub { ($accessor, $test, $trap, @arg) = @_; $index = ''; my @targs = map $_->(), @{$test->{argspec}}; my $ok; local $trap->Prop->{test_accessor} = "$accessor->{name}($index)"; local $Test::Builder::Level = $Test::Builder::Level+1; $ok = $test->{code}->(@targs) or $trap->TestFailure; $ok; }; my $wrong_leaveby = sub { ($accessor, $test, $trap, @arg) = @_; require Test::More; my $Test = Test::More->builder; my $test_name_index = 0; for (@{$test->{argspec}}) { last if $isname{$_}; $test_name_index++ if $takesarg{$_} or $accessor->{is_array} && $iselement{$_}; } my $ok = $Test->ok('', $arg[$test_name_index]); my $got = $trap->leaveby; $Test->diag(sprintf<{name}, $got, dump($trap->$got)); Expecting to %s(), but instead %s()ed with %s DIAGNOSTIC $trap->TestFailure; $ok; }; sub _accessor_test { my ($apkgs, $anames, $tpkgs, $tnames) = @_; for my $apkg (@$apkgs ? @$apkgs : _register_packages 'accessor') { for my $aname (@$anames ? @$anames : _register_names accessor => $apkg) { my $adef = _register_value accessor => $apkg => $aname; for my $tpkg (@$tpkgs ? @$tpkgs : _register_packages 'test') { my $mpkg = $apkg->isa($tpkg) ? $apkg : $tpkg->isa($apkg) ? $tpkg : next; for my $tname (@$tnames ? @$tnames : _register_names test => $tpkg) { my $tdef = _register_value test => $tpkg => $tname; my $mname = sprintf $tdef->{pattern}, $mpkg, $aname; no strict 'refs'; *$mname = sub { my ($trap) = @_; unshift @_, $adef, $tdef; goto &$wrong_leaveby if $adef->{is_leaveby} and $trap->leaveby ne $adef->{name}; goto &$basic_test; }; } } } } } sub test { my $self = shift; my ($tname, $targs, $code) = @_; my $tpkg = caller; my @targs = map { $argspec{$_} || croak "Unrecognized identifier $_ in argspec" } $targs =~ /(\w+)/g; _register test => $tpkg => $tname => { argspec => \@targs, code => $code, pattern => "%s::%s_$tname", builder => $self, }; # make the test methods: _accessor_test( [], [], [$tpkg], [$tname] ); } } BEGIN { # Accessor registration: my $export_accessor = sub { my ($apkg, $aname, $par, $code) = @_; no strict 'refs'; *{"$apkg\::$aname"} = $code; _register accessor => $apkg => $aname => { %$par, code => $code, name => $aname, }; # make the test methods: _accessor_test( [$apkg], [$aname], [], [] ); }; my %accessor_factory = ( scalar => sub { my $name = shift; return sub { $_[0]{$name} }; }, array => sub { my $name = shift; return sub { my $trap = shift; return $trap->{$name} unless @_; return @{$trap->{$name}}[@_] if wantarray; return $trap->{$name}[shift]; }; }, ); sub accessor { my $self = shift; my %par = @_; my $simple = delete $par{simple}; my $flexible = delete $par{flexible}; my $pkg = caller; for my $name (keys %{$flexible||{}}) { $export_accessor->($pkg, $name, \%par, $flexible->{$name}); } my $factory = $accessor_factory{ $par{is_array} ? 'array' : 'scalar' }; for my $name (@{$simple||[]}) { $export_accessor->($pkg, $name, \%par, $factory->($name)); } } } BEGIN { # Layer registration: my $export_layer = sub { my ($pkg, $name, $sub) = @_; no strict 'refs'; *{"$pkg\::layer:$name"} = $sub; }; sub layer { my $self = shift; my ($name, $sub) = @_; $export_layer->(scalar caller, $name, sub { my ($self, @arg) = @_; sub { shift->$sub(@arg) } }); } sub multi_layer { my $self = shift; my $name = shift; my $callpkg = caller; my @layer = $self->layer_implementation($callpkg, @_); $export_layer->($callpkg, $name, sub { @layer }); } sub output_layer { my $self = shift; my ($name, $globref) = @_; my $code = sub { my $class = shift; my ($arg) = @_; my $strategy = $self->first_capture_strategy($arg); return sub { my $trap = shift; $trap->{$name} = ''; # XXX: Encapsulation violation! my $fileno; # common stuff: unless (tied *$globref or defined($fileno = fileno *$globref)) { return $trap->Next; } my $m = $strategy; # placate Devel::Cover: $m = $trap->Prop->{capture_strategy} unless $m; $m = $self->capture_strategy('tempfile') unless $m; $trap->$m($name, $fileno, $globref); }; }; $export_layer->(scalar caller, $name, $code); } } BEGIN { my %strategy; # Backwards compatibility aliases; don't use: *output_layer_backend = \&capture_strategy; *first_output_layer_backend = \&first_capture_strategy; sub capture_strategy { my $this = shift; my ($name, $strategy) = @_; $strategy{$name} = $strategy if $strategy; return $strategy{$name}; } sub first_capture_strategy { my $self = shift; my ($arg) = @_; return unless $arg; my @strategy = split /[,;]/, $arg; for (@strategy) { my $strategy = $self->capture_strategy($_); return $strategy if $strategy; } croak "No capture strategy found for " . dump(@strategy); } } sub layer_implementation { my $self = shift; # Directly querying layer implementation, we should know what we're doing: local( GOT_CARP_NOT ? @CARP_NOT : @ISA ) = _carpnot_for caller; my $trapper = shift; my @r; for (@_) { if ( length ref and eval { exists &$_ } ) { push @r, $_; next; } my ($name, $arg) = /^ ( [^\(]+ ) # layer name: anything but '(' (?: # begin optional group \( # literal '(' ( [^\)]* ) # arg: anything but ')' \) # literal ')' )? # end optional group \z/x; my $meth = $trapper->can("layer:$name") or croak qq[Unknown trap layer "$_"]; push @r, $trapper->$meth($arg); } return @r; } 1; # End of Test::Trap::Builder __END__ =head1 NAME Test::Trap::Builder - Backend for building test traps =head1 VERSION Version 0.3.2 =head1 SYNOPSIS package My::Test::Trap; use Test::Trap::Builder; my $B = Test::Trap::Builder->new; $B->layer( $layer_name => \&layer_implementation ); $B->accessor( simple => [ $layer_name ] ); $B->multi_layer( $multi_name => @names ); $B->test( $test_name => 'trap, predicate, name', \&test_function ); =head1 DESCRIPTION L neither traps nor tests everything you may want to trap or test. So, Test::Trap::Builder provides methods to write your own trap layers, accessors, and test callbacks -- preferably for use with your own modules (trappers). Note that layers are methods with mangled names (names are prefixed with C), and so inherited like any other method, while accessors are ordinary methods. Meanwhile, test callbacks are not referenced in the symbol table by themselves, but only in combinations with accessors, all methods of the form I_I. =head1 EXPORTS Trappers should not inherit from Test::Trap::Builder, but may import a few convenience methods for use in building the trap. Do not use them as methods of Test::Trap::Builder -- they are intended to be methods of trap objects. (If you inherit from another trapper, you need not, and probably should not, import these yourself -- you should inherit these methods like any other.) Trappers may import any number of these methods, or all of them by way of the C<:methods> tag. Layers should be implemented as methods, and while they need not call any of these convenience methods in turn, that likely makes for more readable code than any alternative. Likewise, test callbacks may use convenience methods for more readable code. Of course, certain convenience methods may also be useful in more generic methods messing with trap or builder objects. =head2 Prop [PACKAGE] A method returning a reference to a hash, holding the I's (by default the caller's) tag-on properties for the (current) trap object. Currently, Test::Trap::Builder defines the following properties: =over =item layers While the trap is springing, the queue of layers remaining. Usually set by the L method and consumed by the L method. =item teardown While the trap is springing, the queue of teardown actions remaining. Usually accumulated through the L method and invoked by the L method. =item code The user code trapped. Usually set by the L method and invoked by the L method. =item exception An internal exception. Usually set through the L method and examined by the L method. =item on_test_failure A callback invoked by the L method. Layers in particular may want to set this. =item test_accessor The name and (optionally) the index of the accessor, the contents of which we're currently testing. Best accessed through the L method, and usually set by the L and L methods, but if you are writing your own tests or accessors directly, you just might need to set it. Perhaps. =back Be nice: Treat another module's tag-on properties as you would treat another module's global variables. Don't use them except as documented. Example: # in a layer, setting the callback for TestFailure: $self->Prop('Test::Trap::Builder')->{on_test_failure} = \&mydiag; =head2 DESTROY This cleans up the tag-on properties when the trap object is destroyed. Don't try to make a trapper that doesn't call this; it will get confused. If your trapper needs its own C, make sure it calls this one as well: sub DESTROY { my $self = shift; # do your thing $self->Test::Trap::Builder::DESTROY; # and more things } =head2 Run A terminating layer should call this method to run the user code. Should only be called in a dynamic context in which layers are being applied. =head2 Next Every non-terminating layer should call this method (or an equivalent) to progress to the next layer. Should only be called in a dynamic context in which layers are being applied. Note that this method need not return, so any tear-down actions should probably be registered with the Teardown method (see below). =head2 Teardown SUBS If your layer wants to clean up its setup, it may use this method to register any number of tear-down actions, to be performed (in reverse registration order) once the user code has been executed. Should only be called in a dynamic context in which layers are being applied. =head2 TestAccessor Returns a string of the form C<"I(I)">, where I and I are the name of the accessor and the index (if any) being tested. Should only be called in the dynamic context of test callbacks. This is intended for diagnostics: diag( sprintf 'Expected %s in %s; got %s', $expected, $self->TestAccessor, dump($got), ); =head2 TestFailure Runs the C tag-on property (if any) on the trap object. If you are writing unregistered tests, you might want to include (some variation of) this call: $ok or $self->TestFailure; =head2 Exception STRINGS Layer implementations may run into exceptional situations, in which they want the entire trap to fail. Unfortunately, another layer may be trapping ordinary exceptions, so you need some kind of magic in order to throw an untrappable exception. This is one convenient way. Should only be called in a dynamic context in which layers are being applied. Note: The Exception method won't work if called from outside of the regular control flow, like inside a DESTROY method or signal handler. If anything like this happens, CORE::exit will be called with an exit code of 8. Note: Direct calls to the Exception method within closures may cause circular references and so leakage. To avoid this, fetch an L and call it from the closure instead. =head2 ExceptionFunction This method returns a function that may be called with the same effect as calling the L method, allowing closures to throw exceptions without causing circular references by closing over the trap object itself. To illustrate: # this will create a circular reference chain: # trap object has property collection has teardown closure has trap object $self->Teardown($_) for sub { do_stuff() or $self->Exception("Stuff didn't work."); }; # this will break the circular reference chain: # teardown closure no longer has trap object $Exception = $self->ExceptionFunction; $self->Teardown($_) for sub { do_things() or $Exception->("Things didn't work."); }; =head1 METHODS =head2 new Returns a singleton object. Don't expect this module to work with a different instance object of this class. =head2 trap TRAPPER, GLOBREF, LAYERARRAYREF, CODE Implements a trap for the I module, applying the layers of I, trapping various outcomes of the user I, and storing the trap object into the scalar slot of I. In most cases, the trapper should conveniently export a function calling this method. =head2 layer NAME, CODE Registers a layer by I to the calling trapper. When the layer is applied, the I will be invoked on the trap object being built, with no arguments, and should call either the Next() or Run() method or equivalent. =head2 output_layer NAME, GLOBREF Registers (by I and to the calling trapper) a layer for trapping output on the file handle of the I, using I also as the attribute name. =head2 capture_strategy NAME, [CODE] When called with two arguments, registers (by I and globally) a strategy for output trap layers. When called with a single argument, looks up and returns the strategy registered by I (or undef). When a layer using this strategy is applied, the I will be called on the trap object, with the layer name and the output handle's fileno and globref as arguments. =head2 output_layer_backend SPEC Back-compat alias of the above. =head2 first_capture_strategy SPEC Where I is empty, just returns. Where I is a string of comma-or-semicolon separated names, runs through the names, returning the first strategy it finds. Dies if no strategy is found by any of these names. =head2 first_output_layer_backend SPEC Back-compat alias of the above. =head2 multi_layer NAME, LAYERS Registers (by I) a layer that just pushes a number of other I on the stack of layers. If any of the I is neither an anonymous method nor the name of a layer registered to the caller or a trapper it inherits from, an exception is raised. =head2 layer_implementation TRAPPER, LAYERS Returns the subroutines that implement the requested I. If any of the I is neither an anonymous method nor the name of a layer registered to or inherited by the I, an exception is raised. =head2 accessor NAMED_ARGS Generates and registers any number of accessors according to the I, and also generates the proper test methods for these accessors (see below). The following named arguments are recognized: =over =item is_leaveby If true, the tests methods will generate better diagnostics if the trap was not left as specified. Also, a special did_I test method will be generated (unless already present), simply passing as long as the trap was left as specified. =item is_array If true, the simple accessor(s) will be smart about context and arguments, returning an arrayref on no argument (in any context), an array slice in list context (on any number of arguments), and the element indexed by the first argument otherwise. =item simple Should be a reference to an array of accessor names. For each name, an accessor (assuming hash based trap object with accessor names as keys), will be generated and registered. =item flexible Should be a reference to a hash. For each pair, a name and an implementation, an accessor is generated and registered. =back =head2 test NAME, ARGSPEC, CODE Registers a test callback by I and to the calling trapper. Trappers inherit test callbacks like methods (though they are not implemented as such; don't expect to find them in the symbol table). Test methods of the form I_I will be made available (directly or by inheritance) to every trapper that registers or inherits both the accessor named I and the test named I. (In more detail, the method will be generated in every trapper that either (1) registers both the test and the accessor, or (2) registers either and inherits the other.) When the test method is called, any implicit leaveby condition will be tested first, and if it passes (or there were none), the I is called with arguments according to the words found in the I string: =over =item trap The trap object. =item entirety The I's return value when called without arguments. =item element The I's return value when called with index, if applicable (i.e. for array accessors). Index is not applicable to scalar accessors, so such are still called without index. The index, when applicable, will be taken from the test method's arguments. =item predicate What the I's return value should be tested against (taken from the test method's arguments). (There may be any fixed number of predicates.) =item name The test name (taken from the test method's arguments). =back =head1 EXAMPLE A complete example, implementing a I layer (depending on Time::HiRes::ualarm being present), a I layer (printing the trapped stdout/stderr to the original file handles after the trap has sprung), and a I test method template: package My::Test::Trap; use base 'Test::Trap'; # for example use Test::Trap::Builder; my $B = Test::Trap::Builder->new; # example (layer:timeout): use Time::HiRes qw/ualarm/; $B->layer( timeout => $_ ) for sub { my $self = shift; eval { local $SIG{ALRM} = sub { $self->{timeout} = 1; # simple truth $SIG{ALRM} = sub {die}; die; }; ualarm 1000, 1; # one second max, then die repeatedly! $self->Next; }; alarm 0; if ($self->{timeout}) { $self->{leaveby} = 'timeout'; delete $self->{$_} for qw/ die exit return /; } }; $B->accessor( is_leaveby => 1, simple => ['timeout'], ); # example (layer:simpletee): $B->layer( simpletee => $_ ) for sub { my $self = shift; for (qw/ stdout stderr /) { exists $self->{$_} or $self->Exception("Too late to tee $_"); } $self->Teardown($_) for sub { print STDOUT $self->{stdout} if exists $self->{stdout}; print STDERR $self->{stderr} if exists $self->{stderr}; }; $self->Next; }; # no accessor for this layer $B->multi_layer( flow => qw/ raw die exit timeout / ); $B->multi_layer( default => qw/ flow stdout stderr warn simpletee / ); $B->test_method( cmp_ok => 1, 2, \&Test::More::cmp_ok ); =head1 CAVEATS The interface of this module is likely to remain somewhat in flux for a while yet. The different strategies for output trap layers have their own caveats; see L, L, L. Multiple inheritance is not (yet?) fully supported. If one parent has registered a test callback C and another has registered an accessor C, the test method C will not be generated. Threads? No idea. It might even work correctly. =head1 BUGS Please report any bugs or feature requests directly to the author. =head1 AUTHOR Eirik Berg Hanssen, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Trap-v0.3.2/lib/Test/Trap/Builder000755001750001750 012472732613 17106 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/lib/Test/Trap/Builder/PerlIO.pm000444001750001750 262512472732613 20740 0ustar00eirikeirik000000000000package Test::Trap::Builder::PerlIO; use version; $VERSION = qv('0.3.2'); use strict; use warnings; use Test::Trap::Builder; use PerlIO 'scalar'; sub import { Test::Trap::Builder->capture_strategy( perlio => $_ ) for sub { my $self = shift; my ($name, $fileno, $globref) = @_; local *$globref; { no warnings 'io'; open *$globref, '>', \$self->{$name}; } $self->Next; }; } 1; # End of Test::Trap::Builder::PerlIO __END__ =head1 NAME Test::Trap::Builder::PerlIO - Capture strategy using PerlIO::scalar =head1 VERSION Version 0.3.2 =head1 DESCRIPTION This module provides a capture strategy I, based on PerlIO::scalar, for the trap's output layers. Note that you may specify different strategies for each output layer on the trap. See also L (:stdout and :stderr) and L (output_layer). =head1 CAVEATS These layers use in-memory files, and so will not (indeed cannot) trap output from forked-off processes -- including system() calls. Threads? No idea. It might even work correctly. =head1 BUGS Please report any bugs or feature requests directly to the author. =head1 AUTHOR Eirik Berg Hanssen, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Trap-v0.3.2/lib/Test/Trap/Builder/SystemSafe.pm000444001750001750 1533412472732613 21712 0ustar00eirikeirik000000000000package Test::Trap::Builder::SystemSafe; use version; $VERSION = qv('0.3.2'); use strict; use warnings; use Test::Trap::Builder; use File::Temp qw( tempfile ); use IO::Handle; ######## # # I can no longer (easily?) install Devel::Cover on 5.6.2, so silence the coverage report: # # uncoverable condition right # uncoverable condition false use constant GOTPERLIO => (eval "use PerlIO (); 1" || 0); sub import { shift; # package name my $strategy_name = @_ ? shift : 'systemsafe'; my $strategy_option = @_ ? shift : {}; Test::Trap::Builder->capture_strategy( $strategy_name => $_ ) for sub { my $self = shift; my ($name, $fileno, $globref) = @_; my $pid = $$; if (tied *$globref or $fileno < 0) { $self->Exception("SystemSafe only works with real file descriptors; aborting"); } my ($fh, $file) = do { local ($!, $^E); tempfile( UNLINK => 1 ); # XXX: Test? }; my ($fh_keeper, $autoflush_keeper, @io_layers, @restore_io_layers); my $Die = $self->ExceptionFunction; for my $buffer ($self->{$name}) { $self->Teardown($_) for sub { local ($!, $^E); if ($pid == $$) { # this process opened it, so it gets to collect the contents: local $/; $buffer .= $fh->getline; close $fh; # don't leak this one either! unlink $file; } close *$globref; return unless $fh_keeper; # close and reopen the file to the keeper! my $fno = fileno $fh_keeper; _close_reopen( $Die, $globref, $fileno, ">&$fno", sub { close $fh_keeper; sprintf "Cannot dup '%s' for %s: '%s'", $fno, $name, $!; }, ); close $fh_keeper; # another potential leak, I suppose. $globref->autoflush($autoflush_keeper); IO_LAYERS: { GOTPERLIO or last IO_LAYERS; local($!, $^E); binmode *$globref; my @tmp = @restore_io_layers; $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*$globref); binmode *$globref, $_ for @tmp; } }; } binmode $fh; # superfluous? { local ($!, $^E); open $fh_keeper, ">&$fileno" or $self->Exception("Cannot dup '$fileno' for $name: '$!'"); } IO_LAYERS: { GOTPERLIO or last IO_LAYERS; local($!, $^E); @restore_io_layers = PerlIO::get_layers(*$globref, output => 1); if ($strategy_option->{preserve_io_layers}) { @io_layers = @restore_io_layers; } if ($strategy_option->{io_layers}) { push @io_layers, $strategy_option->{io_layers}; } } $autoflush_keeper = $globref->autoflush; _close_reopen( $self->ExceptionFunction, $globref, $fileno, ">>$file", sub { sprintf "Cannot open %s for %s: '%s'", $file, $name, $!; }, ); IO_LAYERS: { GOTPERLIO or last IO_LAYERS; local($!, $^E); for my $h (*$globref, $fh) { binmode $h; my @tmp = @io_layers or next; $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers($h); binmode $h, $_ for @tmp; } } $globref->autoflush(1); $self->Next; }; } sub _close_reopen { my ($Die, $glob, $fno_want, $what, $err) = @_; local ($!, $^E); close *$glob; my @fh; while (1) { no warnings 'io'; open *$glob, $what or $Die->($err->()); my $fileno = fileno *$glob; last if $fileno == $fno_want; close *$glob; if ($fileno > $fno_want) { $Die->("Cannot get the desired descriptor, '$fno_want' (could it be that it is fdopened and so still open?)"); } if (grep{$fileno == fileno($_)}@fh) { $Die->("Getting several files opened on fileno $fileno"); } open my $fh, $what or $Die->($err->()); if (fileno($fh) != $fileno) { $Die->("Getting fileno " . fileno($fh) . "; expecting $fileno"); } push @fh, $fh; } close $_ for @fh; } 1; # End of Test::Trap::Builder::SystemSafe __END__ =head1 NAME Test::Trap::Builder::SystemSafe - "Safe" capture strategies using File::Temp =head1 VERSION Version 0.3.2 =head1 DESCRIPTION This module provides capture strategies I, based on File::Temp, for the trap's output layers. These strategies insists on reopening the output file handles with the same descriptors, and therefore, unlike L and L, is able to trap output from forked-off processes, including system(). The import accepts a name (as a string; default I) and options (as a hashref; by default empty), and registers a capture strategy with that name and a variant implementation based on the options. Note that you may specify different strategies for each output layer on the trap. See also L (:stdout and :stderr) and L (output_layer). =head1 OPTIONS The following options are recognized: =head2 preserve_io_layers A boolean, indicating whether to apply to the handles writing to and reading from the tempfile, the same perlio layers as are found on the to-be-trapped output handle. =head2 io_layers A colon-separated string representing perlio layers to be applied to the handles writing to and reading from the tempfile. If the I option is set, these perlio layers will be applied on top of the original (preserved) perlio layers. =head1 CAVEATS Using File::Temp, we need privileges to create tempfiles. We need disk space for the output of every trap (it should clean up after the trap is sprung). Disk access may be slow -- certainly compared to the in-memory files of PerlIO. If the file handle we try to trap using this strategy is on an in-memory file, it would not be available to other processes in any case. Rather than change the semantics of the trapped code or silently fail to trap output from forked-off processes, we just raise an exception in this case. If there is another file handle with the same descriptor (f ex after an C<< open OTHER, '>&=', THIS >>), we can't get that file descriptor. Rather than silently fail, we again raise an exception. If the options specify (explicitly or via preserve on handles with) perlio custom layers, they may (or may not) fail to apply to the tempfile read and write handles. Threads? No idea. It might even work correctly. =head1 BUGS Please report any bugs or feature requests directly to the author. =head1 AUTHOR Eirik Berg Hanssen, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Trap-v0.3.2/lib/Test/Trap/Builder/TempFile.pm000444001750001750 757412472732613 21323 0ustar00eirikeirik000000000000package Test::Trap::Builder::TempFile; use version; $VERSION = qv('0.3.2'); use strict; use warnings; use IO::Handle; use File::Temp qw( tempfile ); use Test::Trap::Builder; ######## # # I can no longer (easily?) install Devel::Cover on 5.6.2, so silence the coverage report: # # uncoverable condition right # uncoverable condition false use constant GOTPERLIO => (eval "use PerlIO (); 1" || 0); sub import { shift; # package name my $strategy_name = @_ ? shift : 'tempfile'; my $strategy_option = @_ ? shift : {}; Test::Trap::Builder->capture_strategy( $strategy_name => $_ ) for sub { my $self = shift; my ($name, $fileno, $globref) = @_; my $pid = $$; my ($fh, $file) = do { local ($!, $^E); tempfile( UNLINK => 1 ); # XXX: Test? }; # make an alias to $self->{$name}, so that the closure does not hold $self: for my $buffer ($self->{$name}) { $self->Teardown($_) for sub { # if the file is opened by some other process, that one should deal with it: return unless $pid == $$; local $/; local ($!, $^E); $buffer .= <$fh>; close $fh; unlink $file; }; } my @io_layers; IO_LAYERS: { GOTPERLIO or last IO_LAYERS; local($!, $^E); if ($strategy_option->{preserve_io_layers}) { @io_layers = PerlIO::get_layers(*$globref, output => 1); } if ($strategy_option->{io_layers}) { push @io_layers, $strategy_option->{io_layers}; } binmode $fh; # set the perlio layers for reading: binmode $fh, $_ for @io_layers; } local *$globref; { no warnings 'io'; local ($!, $^E); open *$globref, '>>', $file; } IO_LAYERS: { GOTPERLIO or last IO_LAYERS; local($!, $^E); binmode *$globref; # set the perlio layers for writing: binmode *$globref, $_ for @io_layers; } *$globref->autoflush(1); $self->Next; }; } 1; # End of Test::Trap::Builder::TempFile __END__ =head1 NAME Test::Trap::Builder::TempFile - Capture strategies using File::Temp =head1 VERSION Version 0.3.2 =head1 DESCRIPTION This module by default provides a capture strategy based on File::Temp for the trap's output layers. The import accepts a name (as a string; default I) and options (as a hashref; by default empty), and registers a capture strategy with that name and a variant implementation based on the options. Note that you may specify different strategies for each output layer on the trap. See also L (:stdout and :stderr) and L (output_layer). =head1 OPTIONS The following options are recognized: =head2 preserve_io_layers A boolean, indicating whether to apply to the handles writing to and reading from the tempfile, the same perlio layers as are found on the to-be-trapped output handle. =head2 io_layers A colon-separated string representing perlio layers to be applied to the handles writing to and reading from the tempfile. If the I option is set, these perlio layers will be applied on top of the original (preserved) perlio layers. =head1 CAVEATS Using File::Temp, we need privileges to create tempfiles. We need disk space for the output of every trap (it should clean up after the trap is sprung). Disk access may be slow -- certainly compared to the in-memory files of PerlIO. If the options specify (explicitly or via preserve on handles with) perlio custom layers, they may (or may not) fail to apply to the tempfile read and write handles. Threads? No idea. It might even work correctly. =head1 BUGS Please report any bugs or feature requests directly to the author. =head1 AUTHOR Eirik Berg Hanssen, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Trap-v0.3.2/xt000755001750001750 012472732613 13560 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/xt/author000755001750001750 012472732613 15062 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/xt/author/pod-coverage.t000444001750001750 344412472732613 17764 0ustar00eirikeirik000000000000#!perl -T # -*-mode:cperl-*- use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; { package MyPodCoverage; our @ISA = 'Pod::Coverage'; my $package; sub _CvGV { my $self = shift; my $owner = $self->SUPER::_CvGV(@_); return $owner unless my $p = $self->{package}; # guard ... $owner =~ s/^\*Test::Trap::Builder/*$p/; # evil! return $owner; } $INC{'MyPodCoverage.pm'} = 1; # pretend we're loaded :) # In newer Pod::Coverage, _CvGV above is not used, and no interface # is exposed to deal with this! Bad Pod::Coverage! # All I can think of doing, is mess with B::GV::GvFLAGS instead: my $old = \&B::GV::GvFLAGS; my $imported_cv = eval { B::GVf_IMPORTED_CV() } || 0x80; no warnings 'redefine'; *B::GV::GvFLAGS = sub { # truly evil! my $r = $old->(@_); $r &= ~$imported_cv if $_[0]->FILE =~ m,/blib/lib/Test/Trap/Builder,; return $r; }; } my $layer = qr/ ^ layer: (?: raw | die | exit | flow | stdout | stderr | warn | default | list | scalar | void | output | on_fail ) $ /x; my $accessor = qr/ (?: leaveby | exit | die | stdout | stderr | wantarray | return | warn | list | scalar | void ) /x; my $did = qr/ ^ did _ $accessor $ /x; my $test = qr/ ^ $accessor _ (?: ok | nok | is | isnt | isa_ok | like | unlike | cmp_ok | is_deeply ) $ /x; my $more = qr/ ^ (?: Exception | Next | Prop | Run | Teardown | TestAccessor | TestFailure ) $ /x; all_pod_coverage_ok({ trustme => [$layer, $did, $test, $more], coverage_class => 'MyPodCoverage', }); Test-Trap-v0.3.2/xt/author/pod.t000444001750001750 23712472732613 16150 0ustar00eirikeirik000000000000# -*-mode:cperl-*- #!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Test-Trap-v0.3.2/t000755001750001750 012472732613 13370 5ustar00eirikeirik000000000000Test-Trap-v0.3.2/t/99-coverage.t000444001750001750 204612472732613 15746 0ustar00eirikeirik000000000000#!perl # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/99-*.t" -*- use strict; use warnings; # Tests for the purpose of shutting up Devel::Cover about some stuff # that really is tested. Like, trust me already? use Test::Trap; # Set up a plan: use Test::Builder; BEGIN { my $t = Test::Builder->new; $t->plan( tests => 7 ) } BEGIN { scalar trap { exists &Test::More::ok }; $trap->return_nok( 0, '&Test::More::ok not created before the use' ); $trap->quiet; } use Test::More; BEGIN { scalar trap { exists &Test::More::ok }; $trap->return_ok( 0, '&Test::More::ok created now' ); $trap->quiet; } trap { Test::Trap::Builder->new->layer_implementation('Test::Trap', []); }; $trap->die_like( qr/^Unknown trap layer \"ARRAY/, 'Cannot specify layers as arrayrefs' ); my $early_exit = 1; END { ok( $early_exit, 'Failing to raise an exception: Early exit' ); is( $?, 8, 'Exiting with exit code 8' ); # let Test::More handle exit codes different from 8: $? = 0 if $? == 8; } $trap->Exception("Failing"); undef $early_exit; Test-Trap-v0.3.2/t/03-files-systemsafe-preserve.t000444001750001750 43012472732613 21223 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/03-*systemsafe-preserve.t" -*- use strict; use warnings; our ($strategy, $class); $strategy = 'systemsafe-preserve'; $class = 'Test::Trap::Builder::SystemSafe'; use lib '.'; require 't/03-files.pl'; Test-Trap-v0.3.2/t/03-files-tempfile.t000444001750001750 31412472732613 17015 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/03-*tempfile.t" -*- use strict; use warnings; our $strategy; $strategy = 'TempFile'; use lib '.'; require 't/03-files.pl'; Test-Trap-v0.3.2/t/01-basic.t000444001750001750 643712472732613 15223 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/01-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 2 + 8*9; use strict; use warnings; BEGIN { use_ok( 'Test::Trap', 'trap', '$trap' ); } my $name; # name of the test group sub is_scalar { ok( !$trap->list, "$name: Not list context" ); ok( $trap->scalar, "$name: Scalar context" ); ok( !$trap->void, "$name: Not void context" ); } sub is_list { ok( $trap->list, "$name: List context" ); ok( !$trap->scalar, "$name: Not scalar context" ); ok( !$trap->void, "$name: Not void context" ); } sub is_void { ok( !$trap->list, "$name: Not list context" ); ok( !$trap->scalar, "$name: Not scalar context" ); ok( $trap->void, "$name: Void context" ); } sub is_return { is( $trap->leaveby, 'return', "$name: Returned" ); is( $trap->die, undef, "$name: No exception trapped" ); is( $trap->exit, undef, "$name: No exit trapped" ); } sub is_die { is( $trap->leaveby, 'die', "$name: Died" ); is_deeply( $trap->return, undef, "$name: Trapped return: none" ); is( $trap->exit, undef, "$name: No exit trapped" ); } sub is_exit { is( $trap->leaveby, 'exit', "$name: Exited" ); is_deeply( $trap->return, undef, "$name: Trapped return: none" ); is( $trap->die, undef, "$name: No exception trapped" ); } my @x = qw( Example text ); $name = 'Return 2 in scalar context'; my $r = trap { @x }; is_scalar; is_return; is( $r, 2, "$name: Return: 2" ); is_deeply( $trap->return, [2], "$name: Trapped return: [2]" ); $name = "Return qw( @x ) in list context"; my @r = trap { @x }; is_list; is_return; is_deeply( \@r, \@x, "$name: Return: qw( @x )" ); is_deeply( $trap->return, \@x, "$name: Trapped return: [ qw( @x ) ]" ); $name = 'Return in void context'; trap { $r = defined wantarray ? 'non-void' : 'void' }; is_void; is_return; is_deeply( $trap->return, [], "$name: Trapped return: none" ); is( $r, 'void', "$name: Extra test -- side effect" ); $name = 'Die in scalar context'; $r = trap { die "My bad 1\n" }; is_scalar; is_die; is( $trap->die, "My bad 1\n", "$name: Trapped exception" ); is( $r, undef, "$name: Return: undef" ); $name = 'Die in list context'; @r = trap { die "My bad 2\n" }; is_list; is_die; is( $trap->die, "My bad 2\n", "$name: Trapped exception" ); is_deeply( \@r, [], "$name: Return: ()" ); $name = 'Die in void context'; trap { $r = defined wantarray ? 'non-void' : 'still void'; die "My bad 3\n" }; is_void; is_die; is( $trap->die, "My bad 3\n", "$name: Trapped exception" ); is( $r, 'still void', "$name: Extra test -- side effect" ); $name = 'Exit in scalar context'; $r = trap { exit 42 }; is_scalar; is_exit; is( $trap->exit, 42, "$name: Trapped exit 42" ); is( $r, undef, "$name: Return: undef" ); $name = 'Exit in list context'; @r = trap { exit }; is_list; is_exit; is( $trap->exit, 0, "$name: Trapped exit 0" ); is_deeply( \@r, [], "$name: Return: ()" ); $name = 'Exit in void context'; trap { $r = defined wantarray ? 'non-void' : 'and still void'; my @x = qw( a b c d ); exit @x }; is_void; is_exit; is( $trap->exit, 4, "$name: Trapped exit 4" ); is( $r, 'and still void', "$name: Extra test -- side effect" ); exit 0; my $tricky = 1; END { is($tricky, undef, ' --==-- END block past exit --==-- '); } Test-Trap-v0.3.2/t/07-subclass.t000444001750001750 1552712472732613 16007 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/07-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 8 + 5*18; use strict; use warnings; use Test::Trap::Builder; my $Builder; BEGIN { $Builder = Test::Trap::Builder->new } local @ARGV; # in case some harness wants to mess with it ... my @argv = ('A'); BEGIN { package TT::A; use base 'Test::Trap'; $Builder->layer( argv => $_ ) for sub { my $self = shift; local *ARGV = \@argv; $self->{inargv} = [@argv]; $self->Next; $self->{outargv} = [@argv]; }; $Builder->accessor( is_array => 1, simple => [qw/inargv outargv/] ); $Builder->accessor( flexible => { argv => sub { $_[1] && $_[1] !~ /in/i ? $_[0]{outargv} : $_[0]{inargv}; }, }, ); $Builder->test( can => 'element, predicate, name', $_ ) for sub { my ($got, $methods) = @_; @_ = ($got, @$methods); goto &Test::More::can_ok; }; # Hack! Make perl think we have successfully required this package, # so that we can "use" it, even though it can't be found: $INC{'TT/A.pm'} = 'Hack!'; } BEGIN { package TT::B; use base 'Test::Trap'; $Builder->accessor( flexible => { leavewith => sub { my $self = shift; my $leaveby = $self->leaveby; $self->$leaveby; }, }, ); # Hack! Make perl think we have successfully required this package, # so that we can "use" it, even though it can't be found: $INC{'TT/B.pm'} = 'Hack!'; } BEGIN { package TT::AB; use base qw( TT::A TT::B ); $Builder->test( fail => 'name', \&Test::More::fail ); # Hack! Make perl think we have successfully required this package, # so that we can "use" it, even though it can't be found: $INC{'TT/AB.pm'} = 'Hack!'; } BEGIN { package TT::A2; use base qw( TT::A ); $Builder->test( anotherfail => 'name', \&Test::More::fail ); $Builder->accessor( flexible => { anotherouterr => sub { my $self = shift; $self->stdout . $self->stderr; }, }, ); # Hack! Make perl think we have successfully required this package, # so that we can "use" it, even though it can't be found: $INC{'TT/A2.pm'} = 'Hack!'; } BEGIN { # Insert s'mores into Test::Trap itself ... not clean, but a nice # quick thing to be able to do, in need: package Test::Trap; $Builder->test( pass => 'name', \&Test::More::pass ); $Builder->accessor( flexible => { outerr => sub { my $self = shift; $self->stdout . $self->stderr; }, }, ); } BEGIN { use_ok( 'Test::Trap' ); # import a standard trap/$trap use_ok( 'Test::Trap', '$D', 'D' ); use_ok( 'TT::A', '$A', 'A', ':argv' ); use_ok( 'TT::B', '$B', 'B' ); use_ok( 'TT::AB', '$AB', 'AB', ':argv' ); use_ok( 'TT::A2', '$A2', 'A2', ':argv' ); } BEGIN { trap { package TT::badclass; use base 'Test::Trap'; $Builder->multi_layer( trouble => qw( warn no_such_layer ) ); }; like( $trap->die, qr/^\QUnknown trap layer "no_such_layer" at ${\__FILE__} line/, 'Bad definition: unknown layer', ); } BEGIN { trap { package TT::badclass3; use base 'Test::Trap'; $Builder->test( pass => 'named', \&Test::More::pass ); }; like( $trap->die, qr/^\QUnrecognized identifier named in argspec at ${\__FILE__} line/, 'Bad definition: test argspec typo ("named" for "name")', ); } basic( \&D, \$D, 'Unmodified Test::Trap', qw( isno_A isno_B isno_AB ), ); basic( \&A, \$A, 'TT::A', qw( isan_A isno_B isno_AB ), ); basic( \&B, \$B, 'TT::B', qw( isno_A isa_B isno_AB ), ); basic( \&AB, \$AB, 'TT::AB', qw( isan_A isa_B isan_AB ), ); basic( \&A2, \$A2, 'TT::A2', qw( isan_A isno_B isno_AB ), ); exit 0; # compile this after the CORE::GLOBAL::exit has been set: my $argv_expected; my $ARGV_expected; sub isno_A { my ($func, $handle, $name) = @_; ok( !exists $$handle->{inargv}, "$name: no inargv internally" ); push @$ARGV_expected, $name; ok( !exists $$handle->{outargv}, "$name: no outargv internally" ); is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV modified" ); is_deeply( \@argv, $argv_expected, "$name: \@argv unmofied" ); ok( !$$handle->can('return_can'), "$name: no return_can method" ); ok( !$$handle->can('outargv'), "$name: no outargv method" ); ok( !$$handle->can('outargv_can'), "$name: no outargv_can method" ); ok( !$$handle->can('outargv_pass'), "$name: no outargv_pass method" ); } sub isan_A { my ($func, $handle, $name) = @_; is_deeply( $$handle->{inargv}, $argv_expected, "$name: inargv present internally" ); push @$argv_expected, $name; is_deeply( $$handle->{outargv}, $argv_expected, "$name: outargv present internally" ); is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV unmodified" ); is_deeply( \@argv, $argv_expected, "$name: \@argv modified" ); ok( $$handle->can('return_can'), "$name: return_can method present" ); () = trap { $$handle->outargv }; $trap->return_is_deeply( [$argv_expected], "$name: outargv method present and functional" ); ok( $$handle->can('outargv_can'), "$name: outargv_can method present" ); ok( $$handle->can('outargv_pass'), "$name: outargv_pass method present" ); } sub isa_B { my ($func, $handle, $name) = @_; () = trap { $$handle->leavewith }; $trap->return_is_deeply( [1], "$name: leavewith method present and functional" ); } sub isno_B { my ($func, $handle, $name) = @_; ok( !$$handle->can('leavewith'), "$name: no leavewith method" ); } sub isan_AB { my ($func, $handle, $name) = @_; ok( $$handle->can('stderr_fail'), "$name: stderr_fail method present" ); ok( $$handle->can('argv_fail'), "$name: argv_fail method present" ); ok( $$handle->can('leavewith_fail'), "$name: leavewith_fail method present" ); TODO: { local $TODO = 'Multiple inheritance still incomplete'; ok( $$handle->can('leavewith_can'), "$name: leavewith_fail method present" ); } } sub isno_AB { my ($func, $handle, $name) = @_; ok( !$$handle->can('stderr_fail'), "$name: no stderr_fail method" ); ok( !$$handle->can('argv_fail'), "$name: no argv_fail method" ); ok( !$$handle->can('leavewith_fail'), "$name: no leavewith_fail method" ); ok( !$$handle->can('leavewith_can'), "$name: no leavewith_can method" ); } sub basic { my ($func, $handle, $name) = @_; $argv_expected ||= ['A']; $ARGV_expected ||= []; $func->(sub { print "Hello"; warn "Hi!\n"; push @ARGV, $name; exit 1 }); local $Test::Builder::Level = $Test::Builder::Level + 1; is( $$handle->exit, 1, "$name: trapped exit" ); is( $$handle->stdout, "Hello", "$name: trapped stdout" ); is( $$handle->stderr, "Hi!\n", "$name: trapped stderr" ); is_deeply( $$handle->warn, ["Hi!\n"], "$name: trapped warnings" ); ok( $$handle->can('stdout_pass'), "$name: stdout_pass method present" ); $Test::Builder::Level++; no strict 'refs'; $_->(@_) for @_[3..$#_]; } Test-Trap-v0.3.2/t/02-reentrant.t000444001750001750 520712472732613 16137 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/02-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 1 + 6*5 + 3; use strict; use warnings; BEGIN { use_ok( 'Test::Trap' ); } # Inner and outer traps with different leaveby and context: my $x = trap { trap { exit }; die unless $trap->leaveby eq 'exit'; $trap; }; # outer trap is( $trap->leaveby, 'return', 'Expecting to return' ); ok( !$trap->list, 'Not list context' ); ok( $trap->scalar, 'Scalar context' ); ok( !$trap->void, 'Not void context' ); is_deeply( $trap->return, [$x], 'Returned the trapped() object' ); # inner trap is( $x->leaveby, 'exit', 'Inner: Exited' ); ok( !$x->list, 'Inner: Not list context' ); ok( !$x->scalar, 'Inner: Not scalar context' ); ok( $x->void, 'Inner: Void context' ); is_deeply( $x->return, undef, 'Inner: "Returned" ()' ); # An inner trap localizes $trap, then successfully calls a twice-inner # trap. After successful exit from the once-inner trap, $trap reverts # to its previous value: trap { trap { exit }; is( $trap->leaveby, 'exit', 'Expecting to exit' ); ok( !$trap->list, 'Not list context' ); ok( !$trap->scalar, 'Not scalar context' ); ok( $trap->void, 'Void context' ); is_deeply( $trap->return, undef, 'No return' ); { local $trap; trap { die }; # If the trap / local $trap breaks again, these method calls will # raise an exception, which we might as well catch: is( eval { $trap->leaveby }, 'die', 'Expecting to die' ); ok( eval { !$trap->list }, 'Not list context' ); ok( eval { !$trap->scalar }, 'Not scalar context' ); ok( eval { $trap->void }, 'Void context' ); is_deeply( eval { $trap->return }, undef, 'No return' ); } is( $trap->leaveby, 'exit', 'Revert: Expecting to exit' ); ok( !$trap->list, 'Revert: Not list context' ); ok( !$trap->scalar, 'Revert: Not scalar context' ); ok( $trap->void, 'Revert: Void context' ); is_deeply( $trap->return, undef, 'No return' ); }; is( $trap->leaveby, 'return', 'Expecting to return' ); ok( !$trap->list, 'Not list context' ); ok( !$trap->scalar, 'Not scalar context' ); ok( $trap->void, 'Void context' ); is_deeply( $trap->return, [], 'Void return' ); # exit compiled to CORE::GLOBAL::exit, which is undefined at runtime ... my $flag; trap { local *CORE::GLOBAL::exit; trap { exit }; is( $trap->leaveby, 'exit', 'Expecting to have exited' ); exit; # should die! $flag = 1; END { ok( !$flag, 'Code past (dying) exit should compile, but not run' ) } }; like( $trap->die, qr/^Undefined subroutine &CORE::GLOBAL::exit called at /, 'Dies: Undefined exit()' ); Test-Trap-v0.3.2/t/03-files-systemsafe.t000444001750001750 32012472732613 17370 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/03-*systemsafe.t" -*- use strict; use warnings; our $strategy; $strategy = 'SystemSafe'; use lib '.'; require 't/03-files.pl'; Test-Trap-v0.3.2/t/03-files.pl000444001750001750 1673312472732613 15436 0ustar00eirikeirik000000000000#!perl -T BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More; use IO::Handle; use File::Temp qw( tempfile ); use Data::Dump qw(dump); use strict; use warnings; our $strategy; # to be set in the requiring test script ... our $class; # may be set in the requiring test script, otherwise: BEGIN { $class ||= "Test::Trap::Builder::$strategy"; local $@; eval qq{ use $class }; if (exists &{"$class\::import"}) { plan tests => 1 + 6*10 + 5*3 + 17; # 10 runtests; 3 inner_tests; another bunch ... } else { plan skip_all => "$strategy strategy not supported; skipping"; } } # This is an ugly bunch of tests, but for regression's sake, I'll # leave it as-is. # One problem is that warn() (or rather, the default __WARN__ handler) # will print on the previous STDERR if the current STDERR is closed. # Another problem is that the __WARN__ handler has not always been # properly restored on exit from a trap. Ouch. BEGIN { use_ok( 'Test::Trap', '$T', lc ":flow:stdout($strategy):stderr($strategy):warn" ); } STDERR: { close STDERR; my ($errfh, $errname) = tempfile( UNLINK => 1 ); open STDERR, '>', $errname; STDERR->autoflush(1); print STDOUT ''; sub stderr () { local $/; no warnings 'io'; local *ERR; open ERR, '<', $errname or die; } END { close STDERR; close $errfh } } sub diagdie { my $msg = shift; diag $msg; die $msg; } my ($noise, $noisecounter) = ('', 0); sub runtests(&@) { # runs the trap and performs 6 tests my($code, $return, $warn, $stdout, $stderr, $desc) = @_; my $n = ++$noisecounter . $/; warn $n or diagdie "Cannot warn()!"; STDERR->flush or diagdie "Cannot flush STDERR!"; print STDERR $n or diagdie "Cannot print on STDERR!"; STDERR->flush or diagdie "Cannot flush STDERR!"; $noise .= "$n$n"; $warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ }; my @r = eval { &trap($code) }; # bypass prototype my $e = $@; SKIP: { ok( !$e, "$desc: No internal exception" ) or do { diag "Got internal exception: '$e'"; skip "$desc: Internal exception -- bad state", 5; }; is_deeply( $T->return, $return, "$desc: Return" ); like( join("`", @{$T->warn}), $warn, "$desc: Warnings" ); is( $T->stdout, $stdout, "$desc: STDOUT" ); like( $T->stderr, $stderr, "$desc: STDERR" ); is( stderr, $noise, ' -- no uncaptured STDERR -- ' ); } } my $inner_trap; sub inner_tests(@) { # performs 5 tests my($return, $warn, $stdout, $stderr, $desc) = @_; $warn = do { local $" = "[^`]*`"; qr/\A@$warn[^`]*\z/ }; SKIP: { ok(eval{$inner_trap->isa('Test::Trap')}, "$desc: The object" ) or skip 'No inner trap object!', 4; is_deeply( $inner_trap->return, $return, "$desc: Return" ); like( join("`", @{$inner_trap->warn}), $warn, "$desc: Warnings" ); is( $inner_trap->stdout, $stdout, "$desc: STDOUT" ); like( $inner_trap->stderr, $stderr, "$desc: STDERR" ); } undef $inner_trap; # catch those simple mistakes. } runtests { 5 } [5], [], '', qr/\A\z/, 'No output'; runtests { my $t; print "Test printing '$t'"; 2} [2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ], "Test printing ''", qr/^Use of uninitialized value.* in concatenation \Q(.) or string at /, 'Warning'; runtests { close STDERR; my $t; print "Test printing '$t'"; 2} [2], [ qr/^Use of uninitialized value.* in concatenation \Q(.) or string at / ], "Test printing ''", qr/\A\z/, 'Warning with closed STDERR'; runtests { warn "Testing stderr trapping\n"; 5 } [5], [ qr/^Testing stderr trapping$/ ], '', qr/^Testing stderr trapping$/, 'warn()'; runtests { close STDERR; warn "Testing stderr trapping\n"; 5 } [5], [ qr/^Testing stderr trapping$/ ], '', qr/\A\z/, 'warn() with closed STDERR'; runtests { warn "Outer 1st\n"; my @r = trap { warn "Testing stderr trapping\n"; 5 }; binmode(STDERR); # XXX: masks a real weakness -- we do not simply restore the original! $inner_trap = $T; warn "Outer 2nd\n"; @r } [5], [ qr/Outer 1st/, qr/Outer 2nd/ ], '', qr/^Outer 1st\nOuter 2nd$/, 'warn() in both traps'; inner_tests [5], [ qr/^Testing stderr trapping$/ ], '', qr/^Testing stderr trapping$/, ' -- the inner trap -- warn()'; runtests { print STDERR "Test printing"; 2} [2], [], '', qr/^Test printing\z/, 'print() on STDERR'; runtests { close STDOUT; print "Testing stdout trapping\n"; 6 } [6], [ qr/^print\Q() on closed filehandle STDOUT at / ], '', qr/^print\Q() on closed filehandle STDOUT at /, 'print() with closed STDOUT'; runtests { close STDOUT; my @r = trap { print "Testing stdout trapping\n"; (5,6) }; $inner_trap = $T; @r } [5, 6], [], '', qr/\A\z/, 'print() in inner trap with closed STDOUT'; inner_tests [5, 6], [ qr/^print\Q() on closed filehandle STDOUT at / ], '', qr/^print\Q() on closed filehandle STDOUT at /, ' -- the inner trap -- print() with closed STDOUT'; runtests { close STDERR; my @r = trap { warn "Testing stderr trapping\n"; 2 }; $inner_trap = $T; @r } [2], [], '', qr/\A\z/, 'warn() in inner trap with closed STDERR'; inner_tests [2], [ qr/^Testing stderr trapping$/ ], '', qr/\A\z/, ' -- the inner trap -- warn() with closed STDERR'; # regression test for the ', <$fh> line 1.' bug: trap { trap {}; warn "no newline"; }; unlike $T->stderr, qr/, \S+ line 1\./, 'No "<$f> line ..." stuff, please'; # regression test for preservation of PerlIO layers: SKIP: { skip 'Lacking PerlIO', 4 unless eval "use PerlIO; 1"; my @io = PerlIO::get_layers(*STDOUT); trap { binmode STDOUT, ':utf8' }; # or whatever, really is_deeply( [PerlIO::get_layers(*STDOUT)], \@io, 'STDOUT still has the original layers.') or diag(dump(\@io)); binmode STDOUT; my @raw = PerlIO::get_layers(*STDOUT); trap { binmode STDOUT, ':utf8' }; # or whatever, really is_deeply( [PerlIO::get_layers(*STDOUT)], \@raw, 'STDOUT is still binmoded.') or diag(dump([PerlIO::get_layers(*STDOUT)], \@raw)); binmode STDOUT, ':crlf'; my @crlf = PerlIO::get_layers(*STDOUT); trap { binmode STDOUT, ':utf8' }; # or whatever, really is_deeply( [PerlIO::get_layers(*STDOUT)], \@crlf, 'STDOUT still has the crlf layer(s).') or diag(dump([PerlIO::get_layers(*STDOUT)], \@crlf)); binmode STDOUT; my @tmp = @io; $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*STDOUT); binmode STDOUT, $_ for @tmp; is_deeply( [PerlIO::get_layers(*STDOUT)], \@io, 'Sanity check: STDOUT now again has the original layers.') or diag(dump([PerlIO::get_layers(*STDOUT)], \@io)); } # test the $! handling: my $errnum = 11; # "Resource temporarily unavailable" locally -- sounds good :-P my $errstring = do { local $! = $errnum; "$!" }; my $erros = do { local $! = $errnum; $^E }; my ($errsym) = do { local $! = $errnum; grep { $!{$_} } keys(%!) }; for my $case ([Bare => sub { return 42 }], [Dying => sub { die 42 }], [Exiting => sub { exit 42 }]) { local $! = $errnum; trap {}; my ($sym) = grep { $!{$_} } keys(%!); is $!+0, $errnum, "$strategy trap doesn't change errno (remains $errnum/$errstring)"; is $^E, $erros, "$strategy trap doesn't change extended OS error (remains $erros)"; is $sym, $errsym, "$strategy trap doesn't change the error symbol (remains $errsym)"; } { local $! = $errnum; trap { $! = 0; $^E = ''; }; my ($sym) = grep { $!{$_} } keys(%!); is $!+0, 0, "Errno-unsetting trap unsets errno (it's not localized)"; is $^E, '', "Errno-unsetting trap unsets extended OS error (it's not localized)"; is $sym, undef, "Errno-unsetting trap unsets the error symbol (it's not localized)"; } 1; Test-Trap-v0.3.2/t/03-files-tempfile-preserve.t000444001750001750 42212472732613 20646 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/03-*tempfile-preserve.t" -*- use strict; use warnings; our ($strategy, $class); $strategy = 'tempfile-preserve'; $class = 'Test::Trap::Builder::TempFile'; use lib '.'; require 't/03-files.pl'; Test-Trap-v0.3.2/t/09-array-accessor.t000444001750001750 103212472732613 17052 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/09-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 6; use strict; use warnings; BEGIN { use_ok( 'Test::Trap', 'trap', '$T' ); } my @r = trap { 10, 20, 30 }; is_deeply( $T->return, [10, 20, 30], 'Deeply' ); is_deeply( [ $T->return(0,2,1,1) ], [10, 30, 20, 20], 'Slice' ); is( $T->return(0), 10, 'Index 0' ); is( $T->return(1), 20, 'Index 1' ); is( $T->return(2), 30, 'Index 2' ); Test-Trap-v0.3.2/t/06-layers.t000444001750001750 2214012472732613 15453 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/06-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 4*15 + 4*5 + 3*6 + 5*13; # non-default standard layers + capture strategies + internal exceptions + exits use IO::Handle; use File::Temp qw( tempfile ); use Data::Dump qw( dump ); use strict; use warnings; use Test::Trap; # XXX: testing ourselves ... too early, I suppose? # The built-in non-default layers -- up against a standard. So far # just context manipulation: for my $case ( [ standard => [ ], context => undef, ], [ Void => [ ':void' ], void => undef, ], [ Scalar => [ ':scalar' ], scalar => '', ], [ List => [ ':list' ], list => 1, ], ) { my ($name, $layer, $context, $wantarray) = @$case; my $x = 0; eval sprintf <<'TEST', ($name) x 4 or diag "Error in eval $name: $@"; #line 1 (%s) BEGIN { my @L = @$layer; # be nice to perl562 trap { use_ok 'Test::Trap', '$T', $name, @L }; $trap->did_return(" ... importing $name"); $trap->quiet(' ... quietly'); } () = trap { my $x; () = %s { $x = wantarray }; $x }; if ($context eq 'context') { $trap->return_is_deeply( [1], ' ... list context propagated' ); $T->wantarray_is( 1, ' ... list context propagated' ); } else { $trap->return_is_deeply( [$wantarray], " ... forced $context context" ); $T->wantarray_is( $wantarray, " ... forced $context context" ); } $T->quiet( " ... with no output in the $name trap" ); $trap->quiet( " ... and no output from the $name trap itself" ); () = trap { my $x; scalar %s { $x = wantarray }; $x }; if ($context eq 'context') { $trap->return_is_deeply( [''], ' ... scalar context propagated' ); $T->wantarray_is( '', ' ... scalar context propagated' ); } else { $trap->return_is_deeply( [$wantarray], " ... forced $context context" ); $T->wantarray_is( $wantarray, " ... forced $context context" ); } $T->quiet( " ... with no output in the $name trap" ); $trap->quiet( " ... and no output from the $name trap itself" ); () = trap { my $x; %s { $x = wantarray }; $x }; if ($context eq 'context') { $trap->return_is_deeply( [undef], ' ... void context propagated' ); $T->wantarray_is( undef, ' ... void context propagated' ); } else { $trap->return_is_deeply( [$wantarray], " ... forced $context context" ); $T->wantarray_is( $wantarray, " ... forced $context context" ); } $T->quiet( " ... with no output in the $name trap" ); $trap->quiet( " ... and no output from the $name trap itself" ); 1; TEST } # The exceptions -- different layers that are supposed to raise an # internal exception are added (in two copies!) to a default setup. # Exceptions may be raised in the application of the layer, in the # teardown, or both. Exceptions in the application of the layer are # immediate (and terminate the trap), but exceptions in teardown are # delayed, and any number of teardown actions can raise an exception. for my $case ( [ exception1 => sub { die "going down\n" }, qr{^Rethrowing internal exception: going down\n at \(exception1\) line 7\.?\n\z}, 0, '(in layer, so user code not run)', ], [ exception2 => sub { my $self = shift; $self->Teardown(sub { die "going up\n" } ); $self->Next }, qr{^Rethrowing teardown exception: going up\n\nRethrowing teardown exception: going up\n at \(exception2\) line 7\.?\n\z}, 1, '(in teardown, so user code has been run)', ], [ exception3 => sub { my $self = shift; $self->Teardown(sub { die "going up\n" } ); die "going down\n" }, qr{^Rethrowing internal exception: going down\n\nRethrowing teardown exception: going up\n at \(exception3\) line 7\.?\n\z}, 0, '(in layer, so user code has not run)', ], ) { my ($name, $layer, $exception, $value, $test_name) = @$case; my $x = 0; eval sprintf <<'TEST', ($name) x 2, ( $value ? (teardown => 'run') : (layer => 'not run') ) or diag "Error in eval $name: $@"; #line 1 (%s) BEGIN { my $L = $layer; # be nice to perl562 trap { use_ok 'Test::Trap', '$T', $name, $L, $L }; $trap->did_return(" ... importing $name"); $trap->quiet(' ... quietly'); } trap { %s { ++$x } }; $trap->die_like( $exception, ' ... internal exceptions caught and rethrown' ); is( $x, $value, ' ... in %s, so user code %s' ); $trap->quiet; 1; TEST } # Test the new :output() layer: for my $case # layers strategies useable ( [ Tempfile => [ ':output(tempfile)' ], '"tempfile"', 1 ], [ Perlio => [ ':output(perlio)' ], '"perlio"', !!eval q{ use PerlIO 'scalar'; 1 } ], [ Mixed => [ ':output(nosuch;perlio)' ], '("nosuch", "perlio")', !!eval q{ use PerlIO 'scalar'; 1 } ], [ Badout => [ ':output(nosuch)' ], '"nosuch"', 0 ], ) { my ($name, $layer, $strategies, $usable) = @$case; eval sprintf <<'TEST', ($name) x 2 or diag "Error in $name eval: $@"; #line 1 (%s) BEGIN { my @L = @$layer; # be nice to perl562 trap { use_ok 'Test::Trap', '$T', $name, @L }; $trap->did_return(" ... importing $name"); $trap->quiet(' ... quietly'); } () = trap { %s { print "foo" }; $T->stdout }; if ($usable) { $trap->return_is_deeply( ['foo'], "Trapped the STDOUT with $name" ); } else { $trap->die_like( qr/^No capture strategy found for \Q$strategies/, "Died with $name" ); } $trap->warn_is_deeply( [], 'No warnings' ); 1; TEST $@ and die "Got $@"; } # Need some setup to test missing STDOUT/STDERR trapping layer: STDOUT: { close STDOUT; my ($outfh, $outname) = tempfile( UNLINK => 1 ); open STDOUT, '>', $outname; STDOUT->autoflush(1); print STDOUT ''; sub stdout () { local $/; local *OUT; open OUT, '<', $outname or die; } END { close STDOUT; close $outfh } } STDERR: { close STDERR; my ($errfh, $errname) = tempfile( UNLINK => 1 ); open STDERR, '>', $errname; STDERR->autoflush(1); print STDERR ''; sub stderr () { local $/; local *ERR; open ERR, '<', $errname or die; } END { close STDERR; close $errfh } } # More setup, to deal with the "special" argv-messing layer: local @ARGV; # in case some harness wants to mess with it ... my @argv = ('A'); my $special = sub { my $self = shift; local *ARGV = \@argv; $self->{inargv} = [@argv]; $self->Next; $self->{outargv} = [@argv]; }; # And then we apply varying combinations of layers, to test what is # trapped and what isn't: for my $case ( [ default => [ ':default' ], qw( stdout stderr warn ) ], [ raw => [ ':flow' ], qw( ) ], [ mixed => [ ':raw:warn:stderr:stdout:exit:die'], qw( stdout stderr warn ) ], [ special => [ ':default', $special ], qw( stdout stderr warn argv )], [ warntrap => [ ':flow:warn' ], qw( warn ) ], ) { my ($name, $layer, @active) = @$case; my %t = map { $_ => 1 } @active; my @a = @ARGV; my @a2 = @argv; my $out = stdout; my $err = stderr; eval sprintf <<'TEST', ($name) x 2 or diag "Error in eval $name: $@"; #line 1 (%s) BEGIN { my @L = @$layer; # be nice to perl562 trap { use_ok 'Test::Trap', '$T', $name, @L }; $trap->did_return(" ... importing $name"); $trap->quiet(' ... quietly'); } %s { print 'Hello'; warn "Hi!\n"; push @ARGV, $name; exit 1 }; is( $T->exit, 1, "&$name traps exit code 1" ); if ($t{stdout}) { is( $T->stdout, 'Hello', ' ... the stdout' ); is( stdout, $out, ' (preventing output on the previous STDOUT)' ); } else { is( $T->stdout, undef, ' ... no stdout' ); is( stdout, $out . 'Hello', ' (leaving the output going to the previous STDOUT)' ); } if ($t{stderr}) { is( $T->stderr, "Hi!\n", ' ... the stderr' ); is( stderr, $err, ' (preventing output on the previous STDERR)' ); } else { is( $T->stderr, undef, ' ... no stderr' ); is( stderr, $err . "Hi!\n", ' (leaving the output going to the previous STDERR)' ); } &is_deeply( scalar $T->warn, $t{warn} ? ( ["Hi!\n"], ' ... the warnings' ) : ( undef, ' ... no warnings' ), ); if ($t{argv}) { is_deeply( $T->{inargv}, \@a2, ' ... the in-@ARGV' ); is_deeply( $T->{outargv}, [@a2, $name], ' ... the out-@ARGV' ); is_deeply( \@ARGV, \@a, ' (keeping the real @ARGV unchanged)' ); is_deeply( \@argv, [@a2, $name], ' (instead modifying the lexical @argv)' ); } else { is_deeply( $T->{inargv}, undef, ' ... no in-@ARGV' ); is_deeply( $T->{outargv}, undef, ' ... no out-@ARGV' ); is_deeply( \@ARGV, [@a, $name], ' (so not preventing the modification of the real @ARGV)' ); is_deeply( \@argv, \@a2, ' (leaving the lexical @argv unchanged)' ); } 1; TEST } Test-Trap-v0.3.2/t/08-fork.PL000444001750001750 764312472732613 15162 0ustar00eirikeirik000000000000#!perl # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/08-*.t" -*- use strict; use warnings; use Config; my $code = ''; my $flags = ''; # Thank you, http://search.cpan.org/src/DAGOLDEN/Class-InsideOut-1.02/t/05_forking.t # If Win32, fork() is done with threads, so we need various things if ( $^O =~ /^(?:MSWin32|NetWare|WinCE)\z/ ) { $code .= <<'COVERAGE'; # don't run this at all under Devel::Cover if ( $ENV{HARNESS_PERL_SWITCHES} && $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { plan skip_all => 'Devel::Cover not compatible with Win32 pseudo-fork'; } COVERAGE # skip if threads not available for some reasons if ( ! $Config{useithreads} ) { $code .= < "Win32 fork() support requires threads"; NOTHREADS } # skip if perl < 5.8 if ( $] < 5.008 ) { $code .= < "Win32 fork() support requires perl 5.8"; NOTHREADS } } elsif (!$Config{d_fork}) { $code .= < 'Fork tests are irrelevant without fork()'; NOFORK } else { $flags = ' -T'; $code .= <', $file or die "Cannot open '$file': '$!'"; print $fh "#!perl$flags\n", <<'CODA', $code; # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/08-*.t" -*-; BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 15; use strict; use warnings; CODA print $fh ; exit 0; __DATA__ my $flag; BEGIN { *CORE::GLOBAL::exit = sub(;$) { if ($flag) { pass("The final test: The outer CORE::GLOBAL::exit is eventually called"); } else { fail("The outer CORE::GLOBAL::exit is called too soon!"); } CORE::exit(@_ ? shift : 0); }; } BEGIN { use_ok( 'Test::Trap' ); } # check that the setup works -- the exit is still trapped: trap { exit }; is( $trap->exit, 0, "Trapped the first exit"); # check that the exit from the forked-off process reverts to the inner # CORE::GLOBAL::exit, not the outer trap { *CORE::GLOBAL::exit = sub(;$) { pass("The inner CORE::GLOBAL::exit is called from the child"); CORE::exit(@_ ? shift : 0); }; trap { fork; exit; }; wait; # let the child finish first # Increment the counter correctly ... my $Test = Test::More->builder; $Test->current_test( $Test->current_test + 1 ); is( $trap->exit, 0, "Trapped the inner exit"); }; like( $trap->stderr, qr/^Subroutine (?:CORE::GLOBAL::)?exit \Qredefined at ${\__FILE__} line/, 'Override warning' ); trap { trap{ trap { fork; exit; }; wait; is( $trap->exit, 0, "Trapped the inner exit" ); } }; is( $trap->leaveby, 'return', 'Should return just once, okay?' ); # Output from forked-off processes? my $me; trap { $me = fork ? 'parent' : 'child'; print "\u$me print\n"; warn "\u$me warning\n"; wait, exit $$ if $me eq 'parent'; }; CORE::exit(0) if $me eq 'child'; is( $trap->exit, $$, "Trapped the parent exit" ); like( $trap->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' ); like( $trap->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' ); is_deeply( $trap->warn, ["Parent warning\n"], 'Warnings from the parent only' ); # STDERR from forked-off processes, with a closed STDIN & STDOUT? trap { close STDOUT; trap { my $me = fork ? 'parent' : 'child'; print "\u$me print\n"; warn "\u$me warning\n"; wait, exit $$ if $me eq 'parent'; CORE::exit(0); }; is( $trap->exit, $$, "Trapped the parent exit" ); is( $trap->stdout, '', 'STDOUT from both processes is nil -- the handle is closed!' ); like( $trap->stderr, qr/\A(?=.*^Parent warning$)(?=.*^Child warning$)/ms, 'STDERR from both processes!' ); }; $flag++; # the exit test will now pass -- in the forked-off processes it will fail! exit; Test-Trap-v0.3.2/t/15-tempfile-options.t000444001750001750 677312472732613 17450 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/15-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /}; # taint vs tempfile use Test::More; eval "use PerlIO ()"; plan skip_all => "PerlIO required for tempfile-preserve and other options" if $@; eval "use Encode::Byte ()"; plan skip_all => "Encode::Byte required to test at least Latin-2" if $@; } use Test::More tests => 3*2*5; use strict; use warnings; # For compatibility with perl <= 5.8.8, :crlf must be applied before :utf8. use Test::Trap::Builder::TempFile utf8 => { io_layers => ':crlf:utf8' }; use Test::Trap::Builder::TempFile both => { io_layers => ':crlf:utf8', preserve_io_layers => 1 }; use Test::Trap::Builder::TempFile latin2 => { io_layers => ':encoding(iso-8859-2)' }; use Test::Trap qw/ $basic basic :output(tempfile) /; use Test::Trap qw/ $preserve preserve :output(tempfile-preserve) /; use Test::Trap qw/ $utf8 utf8 :output(utf8) /; use Test::Trap qw/ $both both :output(both) /; use Test::Trap qw/ $latin2 latin2 :output(latin2) /; my @layers = qw(basic preserve utf8 both latin2); our($trap); sub trap(&); # For RT #102271: # The STDOUT may actually have a utf8 layer, from PERL_UNICODE or PERL5OPT or whatever. # So, check it: my $original_utf8 = grep { /utf8/ } PerlIO::get_layers(*STDOUT); # Test 1: ł (l stroke); no messing with STDOUT for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{142}" }; if ($glob =~ /utf8|both|latin2/ or $original_utf8 && $glob eq 'preserve') { # it should work $trap->stdout_is("\x{142}", "TempFile '$glob' strategy handles l stroke"); $trap->stderr_is('', "\t(no warning)"); } else { $trap->stdout_is("\xC5\x82", "TempFile '$glob' strategy doesn't handle l stroke"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } # Test 2: π (pi); STDOUT binmoded to utf8 binmode STDOUT, ':raw:utf8'; for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{3C0}" }; if ($glob =~ /utf8|preserve|both/) { # it should work $trap->stdout_is("\x{3C0}", "TempFile '$glob' strategy handles pi"); $trap->stderr_is('', "\t(no warning)"); } elsif ($glob eq 'latin2') { $trap->stdout_like(qr/^\\x\{0?3c0\}\z/, "TempFile '$glob' strategy doesn't handle pi; falls back to \\x notation"); $trap->stderr_like(qr/^"\\x\{0?3c0\}" does not map to iso-8859-2 .*$/, "\t(and warns)"); } else { $trap->stdout_is("\xCF\x80", "TempFile '$glob' strategy doesn't handle pi"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } # Test 3: ‰\n% (per mille, newline, per cent); STDOUT binmoded to latin2 binmode STDOUT, ':raw:encoding(iso-8859-2)'; for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{2030}\n%" }; if ($glob =~ /utf8/) { # it should work $trap->stdout_is("\x{2030}\n%", "TempFile '$glob' strategy handles per mille"); $trap->stderr_is('', "\t(no warning)"); } elsif ($glob =~ /preserve|both|latin2/) { $trap->stdout_is("\\x{2030}\n%", "TempFile '$glob' strategy doesn't handle per mille; falls back to \\x notation"); $trap->stderr_like(qr/^\Q"\x{2030}"\E does not map to iso-8859-2 .*$/, "\t(and warns)"); } else { $trap->stdout_is("\xE2\x80\xB0\n%", "TempFile '$glob' strategy doesn't handle per mille"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } Test-Trap-v0.3.2/t/03-files-perlio.t000444001750001750 31012472732613 16476 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/03-*perlio.t" -*- use strict; use warnings; our $strategy; $strategy = 'PerlIO'; use lib '.'; require 't/03-files.pl'; Test-Trap-v0.3.2/t/12-systemsafe-errors.t000444001750001750 1125712472732613 17655 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/12-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 10; use strict; use warnings; # A whole lot simpler testing -- we're now just checking that all the # error situations are caught and behave sensibly. Okay, it's not # that simple -- just simpler than the implementation ... my $errnum = 11; # "Resource temporarily unavailable" locally -- sounds good :-P my $errstring = do { local $! = $errnum; "$!" }; { my $fileno = fileno STDIN; die "STDIN not on fd 0" unless defined $fileno and $fileno == 0; }; our ($when_to_fail, $when_to_persist); my ($glob, $mode, @what); BEGIN { # make the open calls in SystemSafe.pm fail or just fdopen STDIN in # different situations: *Test::Trap::Builder::SystemSafe::open = # silence warnings *Test::Trap::Builder::SystemSafe::open = sub (*;$@) { ($glob, $mode, @what) = @_; unless (@what) { ($mode, @what) = $mode =~ /^([>&=]*)\s*(.*)/s; } if ($when_to_persist and $when_to_persist->()) { eval { open $_[0], '<&=STDIN' } or CORE::exit diag "Cannot fdopen STDIN; STDIN fd: ". fileno STDIN; for (fileno $_[0]) { defined or CORE::exit diag "fdopen STDIN gives undefined fd"; $_ == 0 or CORE::exit diag "fdopen STDIN gives fd $_"; } return 1; } if ($when_to_fail and $when_to_fail->()) { $! = $errnum; return; } my $return; if (@_ > 2) { $return = open $_[0], $_[1], @_[2..$#_]; } elsif (defined $_[0]){ $return = open $_[0], $_[1]; } else { $return = open my $fh, $_[1]; $_[0] = $fh; } return $return; }; } use Test::Trap::Builder::SystemSafe; use Test::Trap qw( trap $T :flow:stderr(systemsafe):stdout(systemsafe):warn ); use Test::Trap qw( protect $P ); SKIP: { skip 'These tests are broken on old perls', 3 if $] < 5.008; protect { # return fd 0 again and again on appending local $when_to_persist = sub { $mode eq '>>' }; eval { trap { 1 } }; like( $@, qr/^\QGetting several files opened on fileno 0 at ${\__FILE__}/, 'Persisting on STDIN' ); }; protect { # return fd 0 once(!) on appending my $count = 1; local $when_to_persist = sub { $mode eq '>>' and !--$count }; eval { trap { 1 } }; like( $@, qr/^Getting fileno \d+; \Qexpecting 0 at ${\__FILE__}/, "Mixed-up filenos" ); }; protect { # return fd 0 once(!) on appending -- then fail! my $count = 1; local $when_to_persist = sub { $mode eq '>>' and !--$count }; local $when_to_fail = sub { $mode eq '>>' and $count == -1 }; eval { trap { 1 } }; like( $@, qr/^Cannot open \S+ \Qfor stdout: '$errstring' at ${\__FILE__}/, 'Delayed append to tempfile' ); }; } protect { # fail on the first dup() -- stdout, coming in my $count = 1; local $when_to_fail = sub { $mode eq '>&' and !--$count }; eval { trap { 1 } }; like( $@, qr/^Cannot dup '\d+' \Qfor stdout: '$errstring' at ${\__FILE__}/, 'First dup() -- setting up STDOUT' ); }; protect { # fail on the second dup() -- stderr, coming in my $count = 2; local $when_to_fail = sub { $mode eq '>&' and !--$count }; # second dup() eval { trap { 1 } }; like( $@, qr/^Cannot dup '\d+' \Qfor stderr: '$errstring' at ${\__FILE__}/, 'Second dup() -- setting up STDERR' ); }; protect { # fail on the third dup() -- stderr, going out my $count = 3; local $when_to_fail = sub { $mode eq '>&' and !--$count }; eval { trap { 1 } }; like( $@, qr/^Cannot dup '\d+' \Qfor stderr: '$errstring' at ${\__FILE__}/, 'Third dup() -- restoring STDERR' ); }; protect { # fourth dup() -- stdout, going out my $count = 4; local $when_to_fail = sub { $mode eq '>&' and !--$count }; eval { trap { 1 } }; like( $@, qr/^Cannot dup '\d+' \Qfor stdout: '$errstring' at ${\__FILE__}/, 'Fourth dup() -- restoring STDOUT' ); }; protect { # fail on first opening the stderr tempfile for append my $count = 1; local $when_to_fail = sub { $mode eq '>>' and !--$count }; eval { trap { 1 } }; like( $@, qr/^Cannot open \S+ \Qfor stdout: '$errstring' at ${\__FILE__}/, 'First append to tempfile' ); }; SKIP: { protect { skip 'Need PerlIO', 1 unless eval 'use PerlIO; 1'; local *STDOUT; open STDOUT, '>', \ my $buffer; eval { trap { 1 } }; like( $@, qr/^\QSystemSafe only works with real file descriptors; aborting at ${\__FILE__}/, 'Negative fileno' ); }; } SKIP: { protect { skip 'Need IO::Scalar', 1 unless eval 'use IO::Scalar; 1'; local *STDOUT; tie *STDOUT, 'IO::Scalar', \my $s; eval { trap { 1 } }; like( $@, qr/^\QSystemSafe only works with real file descriptors; aborting at ${\__FILE__}/, 'Tied handle' ); }; } Test-Trap-v0.3.2/t/05-import.t000444001750001750 336112472732613 15451 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/05-*.t" -*- use Test::More tests => 8; use strict; use warnings; BEGIN { use_ok( 'Test::Trap' ); } eval { Test::Trap->import(qw( trap1 trap2 )) }; like( $@, qr/^\QThe Test::Trap module does not export more than one function at ${\__FILE__} line/, 'Export of two functions', ); eval { Test::Trap->import(qw( $trap1 $trap2 )) }; like( $@, qr/^\QThe Test::Trap module does not export more than one scalar at ${\__FILE__} line/, 'Export of two globs', ); eval { Test::Trap->import(qw( @bad )) }; like( $@, qr/^"\@bad"\Q is not exported by the Test::Trap module at ${\__FILE__} line/, 'Export of an array', ); eval { Test::Trap->import(qw( :no_such_layer )) }; like( $@, qr/^\QUnknown trap layer "no_such_layer" at ${\__FILE__} line/, 'Export of an unknown layer', ); my %got; $got{perlio} = eval q{ use PerlIO 'scalar'; 1 }; $got{tempfile} = eval q{ use File::Temp; 1 }; eval { Test::Trap->import(qw( test1 $T1 :stdout(perlio) )) }; like( $@, $got{perlio} ? qr/\A\z/ : qr/^\QNo capture strategy found for "perlio" at ${\__FILE__} line/, 'Export of capture strategy :stdout(perlio)', ); eval { Test::Trap->import(qw( test2 $T2 :stdout(nosuch;tempfile) )) }; like( $@, $got{tempfile} ? qr/\A\z/ : qr/^\QNo capture strategy found for ("nosuch", "tempfile") at ${\__FILE__} line/, 'Export of capture strategy :stdout(nosuch;tempfile)', ); eval { Test::Trap->import(qw( test2 $T2 :stdout(nosuch1;nosuch2) )) }; like( $@, qr/^\QNo capture strategy found for ("nosuch1", "nosuch2") at ${\__FILE__} line/, 'Export of capture strategy:stdout(nosuch1;nosuch2)', ); Test-Trap-v0.3.2/t/10-tester.t000444001750001750 1647612472732613 15474 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/10-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::Tester; use Test::More tests => 2 + 3 + 7*15 + 5*3; use strict; use warnings; use Test::Trap qw( trap $T ); use Test::Trap qw( diag_all $T :on_fail(diag_all) ); use Test::Trap qw( diag_all_once $T :on_fail(diag_all_once) ); # Trap with warning and return my ($prem, @t) = run_tests ( sub { my $t = trap { warn "A warning"; 5 }; $T->return_is_deeply( [5], '5 was returned' ); $T->warn_like( 0, qr/^A warning\b/, 'A warning was given' ); }, ); is( $prem, '' ); is( $#t, 1 ); is( $t[0]{ok}, 1, '->return_is_deeply [5]'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, '5 was returned' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); is( $t[1]{ok}, 1, '->warn_like'); is( $t[1]{actual_ok}, 1 ); is( $t[1]{name}, 'A warning was given' ); is( $t[1]{diag}, '' ); is( $t[1]{depth}, 1 ); # Trap with silent exit ($prem, @t) = run_tests ( sub { my $t = trap { exit }; $T->return_is_deeply( [5], '5 was returned' ); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 0, '->return_is_deeply [5]'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, '5 was returned' ); is( $t[0]{diag}, <<'EOE' ); Expecting to return(), but instead exit()ed with 0 EOE is( $t[0]{depth}, 1 ); # Trap with exception and diag_all ($prem, @t) = run_tests ( sub { my $t = diag_all { die "Argh\n" }; $T->return_nok(0, 'Return with (first) false value'); $T->exit_nok(q/Exit with (Perl's idea of a) false value/); }, ); is( $prem, '' ); is( $#t, 1 ); is( $t[0]{ok}, 0, '->return_nok'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'Return with (first) false value' ); is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) ); Expecting to return(), but instead die()ed with "Argh\n" %s EOE is( $t[0]{depth}, 1 ); is( $t[1]{ok}, 0, '->exit_nok'); is( $t[1]{actual_ok}, 0 ); is( $t[1]{name}, q/Exit with (Perl's idea of a) false value/ ); is( $t[1]{diag}, sprintf <<'EOE', Data::Dump::dump($T) ); Expecting to exit(), but instead die()ed with "Argh\n" %s EOE is( $t[1]{depth}, 1 ); # Trap with print, exit, and diag_all ($prem, @t) = run_tests ( sub { my $t = diag_all { print "Hello world"; exit }; $T->exit_nok('Exit with false value'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->exit_nok'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, 'Exit with false value' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # Capture some TB version dependent stuff: ($prem, @t) = run_tests sub { isnt 5, 5 }; my $diag5isnt5 = $t[0]{diag}; # Trap with print, and exit 5, and diag_all_once ($prem, @t) = run_tests ( sub { my $t = diag_all_once { print "Hello world"; exit 5 }; $T->exit_nok('Exit with false value'); $T->exit_isnt(5, 'Exit with non-5 value'); }, ); is( $prem, '' ); is( $#t, 1 ); is( $t[0]{ok}, 0, '->exit_nok'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'Exit with false value' ); is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) ); Expecting false value in exit(), but got 5 instead %s EOE is( $t[0]{depth}, 1 ); is( $t[1]{ok}, 0, '->exit_isnt'); is( $t[1]{actual_ok}, 0 ); is( $t[1]{name}, 'Exit with non-5 value' ); is( $t[1]{diag}, "$diag5isnt5(as above)\n" ); is( $t[1]{depth}, 1 ); # Trap with multiple return values and diag_all_once ($prem, @t) = run_tests ( sub { my ($t) = diag_all_once { return 3..7 }; $T->return_like( 1, qr/4/, 'return[1] matches /4/' ); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->return_like'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, 'return[1] matches /4/' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # Quiet trap, with no on-test-failure callback ($prem, @t) = run_tests ( sub { my ($t) = trap { return 3..7 }; $T->quiet; }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->quiet'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, '' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # Warning trap with diag_all_once ($prem, @t) = run_tests ( sub { my ($t) = diag_all_once { warn "Hello!\n" }; $T->quiet('In denial about STDERR'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 0, '->quiet'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'In denial about STDERR' ); is( $t[0]{diag}, sprintf <<'EOE', Data::Dump::dump($T) ); Expecting no STDERR, but got "Hello!\n" %s EOE is( $t[0]{depth}, 1 ); # Printing trap with no on-test-failure callback ($prem, @t) = run_tests ( sub { my ($t) = trap { print "Hello!\n" }; $T->quiet('In denial about STDOUT'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 0, '->quiet'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'In denial about STDOUT' ); is( $t[0]{diag}, <<'EOE' ); Expecting no STDOUT, but got "Hello!\n" EOE is( $t[0]{depth}, 1 ); # Noisy trap ($prem, @t) = run_tests ( sub { my ($t) = trap { warn "world!\n"; print "Hello!\n" }; $T->quiet('In denial about noise!'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 0, '->quiet'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'In denial about noise!' ); is( $t[0]{diag}, <<'EOE' ); Expecting no STDOUT, but got "Hello!\n" Expecting no STDERR, but got "world!\n" EOE is( $t[0]{depth}, 1 ); # Noisy trap ($prem, @t) = run_tests ( sub { my ($t) = trap { warn "world!\n"; print "Hello!\n" }; $T->did_return('Should return'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->did_return'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, 'Should return' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # Exiting trap ($prem, @t) = run_tests ( sub { my ($t) = trap { exit }; $T->did_exit('Should exit'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->did_exit'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, 'Should exit' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # Exiting trap ($prem, @t) = run_tests ( sub { my ($t) = trap { exit }; $T->did_die('In denial about death'); }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 0, '->did_die'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'In denial about death' ); is( $t[0]{diag}, <<'EOE' ); Expecting to die(), but instead exit()ed with 0 EOE is( $t[0]{depth}, 1 ); # Exiting TODO trap ($prem, @t) = run_tests ( sub { TODO: { local $TODO = 'Testing TODOs'; my ($t) = trap { exit }; $T->did_die('In denial about death'); } }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->did_die, TODO'); is( $t[0]{actual_ok}, 0 ); is( $t[0]{name}, 'In denial about death' ); is( $t[0]{diag}, <<'EOE' ); Expecting to die(), but instead exit()ed with 0 EOE is( $t[0]{depth}, 1 ); # extra 2: is( $t[0]{type}, 'todo', 'type = todo' ); is( $t[0]{reason}, 'Testing TODOs', 'reason' ); my $really_skipped = 1; # Exiting SKIPPED trap ($prem, @t) = run_tests ( sub { SKIP: { skip 'Testing SKIP', 1; undef $really_skipped; my ($t) = trap { exit }; $T->did_die('In denial about death'); } }, ); is( $prem, '' ); is( $#t, 0 ); is( $t[0]{ok}, 1, '->did_die, SKIPPED'); is( $t[0]{actual_ok}, 1 ); is( $t[0]{name}, '' ); is( $t[0]{diag}, '' ); is( $t[0]{depth}, 1 ); # extra 3: is( $t[0]{type}, 'skip', 'type = skip' ); is( $t[0]{reason}, 'Testing SKIP', 'reason' ); is( $really_skipped, 1, 'Asserting that SKIPPED code has not been run'); Test-Trap-v0.3.2/t/11-systemsafe-basic.PL000444001750001750 1404312472732613 17465 0ustar00eirikeirik000000000000#!perl # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/11-*.t" -*- use strict; use warnings; use Config; my $code = ''; my $flags = ''; # Thank you, http://search.cpan.org/src/DAGOLDEN/Class-InsideOut-1.02/t/05_forking.t # If Win32, fork() is done with threads, so we need various things if ( $^O =~ /^(?:MSWin32|NetWare|WinCE)\z/ ) { $code .= <<'COVERAGE'; # don't run this at all under Devel::Cover if ( $ENV{HARNESS_PERL_SWITCHES} && $ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) { plan skip_all => 'Devel::Cover not compatible with Win32 pseudo-fork'; } COVERAGE # skip if threads not available for some reasons if ( ! $Config{useithreads} ) { $code .= < "Win32 fork() support requires threads"; NOTHREADS } # skip if perl < 5.8 if ( $] < 5.008 ) { $code .= < "Win32 fork() support requires perl 5.8"; NOTHREADS } } elsif (!$Config{d_fork}) { $code .= < 'Fork tests are irrelevant without fork()'; NOFORK } else { $flags = ' -T'; $code .= <', $file or die "Cannot open '$file': '$!'"; print $fh "#!perl$flags\n", <<'CODA', $code; # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/11-*.t" -*-; BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More; use strict; use warnings; CODA print $fh ; exit 0; __DATA__ use File::Temp qw( tempfile ); use Test::Trap::Builder::SystemSafe; use Test::Trap qw( trap $T :flow:stderr(systemsafe):stdout(systemsafe):warn ); BEGIN { # silence some warnings that make coverage reports hard to get at if ($Storable::VERSION) { eval { eval { no warnings; Storable::retrieve('.') }; # silly, but hopefully safe ... my $_r = \&Storable::_retrieve; no warnings 'redefine'; *Storable::_retrieve = sub { no warnings; local $SIG{__WARN__} = sub {}; $_r->(@_); }; }; } if ($Devel::Cover::DB::Structure::VERSION) { eval { my $d = \&Devel::Cover::DB::Structure::digest; no warnings 'redefine'; *Devel::Cover::DB::Structure::digest = sub { no warnings; local $SIG{__WARN__} = sub {}; $d->(@_); }; }; } } # Protect against tainted PATH &c ... $ENV{PATH} = ''; $ENV{CDPATH} = ''; $ENV{ENV} = ''; $ENV{BASH_ENV} = ''; my ($PERL) = $^X =~ /^([\w.\/:\\~-]+)$/; if ($PERL) { plan tests => 3 + 6*6 + 4; } else { plan skip_all => "Odd perl path: $^X"; } my $desc = "fdopen()ed file handle"; SKIP: { skip 'These tests are irrelevant on old perls', 3 if $] < 5.008; open my $fh, '>&=STDOUT' or die "Cannot fdopen STDOUT: '$!'"; exit diag "Got fileno " . fileno($fh) unless fileno($fh)==1; # Basic error situation: STDOUT cannot be reopened on fd-1: eval { trap { system $PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)'; exit 1 } }; like( $@, qr/^\QCannot get the desired descriptor, '1' (could it be that it is fdopened and so still open?)/, "$desc: exception string" ); is( fileno STDOUT, undef, "$desc: STDOUT should be left closed by now") or exit diag "Got STDOUT with fd " . fileno(STDOUT); is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); unless (fileno(STDOUT) or open STDOUT, '>&=' . fileno $fh) { exit diag "Cannot fdopen fno ".fileno($fh).": '$!'"; } if (fileno $fh and !close $fh) { exit diag "Cannot close: '$!'"; } } $desc = "simple fork test"; trap { fork ? wait : do { warn "0123456789Warning\n"; print "Printing\n" }; exit 1; }; is( $T->exit, 1, "$desc: exit(1)" ); is( $T->stdout, "Printing\n", "$desc: system() STDOUT" ); is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" ); is( join("\n", @{$T->warn}), '', "$desc: No warnings" ); # Have the file handles been re-opened on the right descriptors? is( fileno STDOUT, 1, "$desc: STDOUT fileno should be unchanged"); is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); # Basic messing-up -- protect the handles with an outer trap: trap { for (1..5) { my $desc = "Take $_"; my $OUTFNO = 1; my $EXPECT = "Printing\n"; if ($_ > 2) { close STDIN; $desc .= ' - STDIN closed'; } if ($_ > 3) { close STDOUT; undef $OUTFNO; $EXPECT = ''; $desc .= ' - STDOUT closed'; } # Output from forked-off processes? trap { my @args = ($PERL, '-e', 'binmode STDOUT; binmode STDERR; warn qq(0123456789Warning\n); print qq(Printing\n)'); system @args and die "system @args failed with $?"; exit 1; }; is( $T->exit, 1, "$desc: exit(1)" ) or $T->diag_all; is( $T->stdout, $EXPECT, "$desc: system() STDOUT" ); is( $T->stderr, "0123456789Warning\n", "$desc: system() STDERR" ); is( join("\n", @{$T->warn}), '', "$desc: No warnings" ); # Have the file handles been re-opened on the right descriptors? is( fileno STDOUT, $OUTFNO, "$desc: STDOUT fileno should be unchanged"); is( fileno STDERR, 2, "$desc: STDERR fileno should be unchanged"); } }; SKIP: { use Config; unless ($Config{d_fork}) { skip 'Need a real fork()', 4; } # For coverage: Output from forked-off processes? my $me; trap { trap { $me = fork ? 'parent' : 'child'; print "\u$me print\n"; warn "\u$me warning\n"; trap { 1 }; wait, exit $$ if $me eq 'parent'; }; # On windows, in the child pseudo-process, this dies on leaving # the trap (fd 2 is not availible, because it is open in another # thread). I don't think anything can be done about it. CORE::exit(0) if $me eq 'child'; is( $T->exit, $$, "Trapped the parent exit" ); like( $T->stdout, qr/^(Parent print\nChild print\n|Child print\nParent print\n)/, 'STDOUT from both processes!' ); like( $T->stderr, qr/^(Parent warning\nChild warning\n|Child warning\nParent warning\n)/, 'STDERR from both processes!' ); is_deeply( $T->warn, ["Parent warning\n"], 'Warnings from the parent only' ); }; } exit; Test-Trap-v0.3.2/t/14-leaks.t000444001750001750 245312472732613 15237 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/14-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /}; # taint vs tempfile use Test::More; eval "use Test::Refcount (); use Scalar::Util ()"; plan skip_all => "Test::Refcount and Scalar::Util required to test refcount" if $@; } use Test::More tests => 3*5; use Test::Refcount; use strict; use warnings; use Test::Trap qw/ $tempfile tempfile :output(tempfile) /; use Test::Trap qw/ $systemsafe systemsafe :output(systemsafe) /; use Test::Trap qw/ $perlio perlio :output(perlio) /; our($trap); sub trap(&); for my $glob (qw(tempfile systemsafe perlio)) { no strict 'refs'; local *trap = *$glob; () = trap { 0 }; is_oneref($trap, "Basic check, with $glob: Our trap has one ref."); my $copy = $trap; my $prop = $trap->Prop; Scalar::Util::weaken($copy); Scalar::Util::weaken($prop); is_oneref($copy, "Sanity check, with $glob: Our trap has one ref now."); is_oneref($prop, "Sanity check, with $glob: Our trap's property collection has one ref now."); () = trap { 1 }; ok(!defined($copy), "Timely destruction, with $glob: Our trap has been collected now."); ok(!defined($prop), "Timely destruction, with $glob: Our trap's property collection has been collected now."); } Test-Trap-v0.3.2/t/16-systemsafe-options.t000444001750001750 703512472732613 20017 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/16-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /}; # taint vs tempfile use Test::More; eval "use PerlIO ()"; plan skip_all => "PerlIO required for systemsafe-preserve and other options" if $@; eval "use Encode::Byte ()"; plan skip_all => "Encode::Byte required to test at least Latin-2" if $@; } use Test::More tests => 3*2*5; use strict; use warnings; # For compatibility with perl <= 5.8.8, :crlf must be applied before :utf8. use Test::Trap::Builder::SystemSafe utf8 => { io_layers => ':crlf:utf8' }; use Test::Trap::Builder::SystemSafe both => { io_layers => ':crlf:utf8', preserve_io_layers => 1 }; use Test::Trap::Builder::SystemSafe latin2 => { io_layers => ':encoding(iso-8859-2)' }; use Test::Trap qw/ $basic basic :output(systemsafe) /; use Test::Trap qw/ $preserve preserve :output(systemsafe-preserve) /; use Test::Trap qw/ $utf8 utf8 :output(utf8) /; use Test::Trap qw/ $both both :output(both) /; use Test::Trap qw/ $latin2 latin2 :output(latin2) /; my @layers = qw(basic preserve utf8 both latin2); our($trap); sub trap(&); # For RT #102271: # The STDOUT may actually have a utf8 layer, from PERL_UNICODE or PERL5OPT or whatever. # So, check it: my $original_utf8 = grep { /utf8/ } PerlIO::get_layers(*STDOUT); # Test 1: ł (l stroke); no messing with STDOUT for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{142}" }; if ($glob =~ /utf8|both|latin2/ or $original_utf8 && $glob eq 'preserve') { # it should work $trap->stdout_is("\x{142}", "SystemSafe '$glob' strategy handles l stroke"); $trap->stderr_is('', "\t(no warning)"); } else { $trap->stdout_is("\xC5\x82", "SystemSafe '$glob' strategy doesn't handle l stroke"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } # Test 2: π (pi); STDOUT binmoded to utf8 binmode STDOUT, ':raw:utf8'; for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{3C0}" }; if ($glob =~ /utf8|preserve|both/) { # it should work $trap->stdout_is("\x{3C0}", "SystemSafe '$glob' strategy handles pi"); $trap->stderr_is('', "\t(no warning)"); } elsif ($glob eq 'latin2') { $trap->stdout_like(qr/^\\x\{0?3c0\}\z/, "SystemSafe '$glob' strategy doesn't handle pi; falls back to \\x notation"); $trap->stderr_like(qr/^"\\x\{0?3c0\}" does not map to iso-8859-2 .*$/, "\t(and warns)"); } else { $trap->stdout_is("\xCF\x80", "SystemSafe '$glob' strategy doesn't handle pi"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } # Test 3: ‰\n% (per mille, newline, per cent); STDOUT binmoded to latin2 binmode STDOUT, ':raw:encoding(iso-8859-2)'; for my $glob (@layers) { no strict 'refs'; local *trap = *$glob; trap { print "\x{2030}\n%" }; if ($glob =~ /utf8/) { # it should work $trap->stdout_is("\x{2030}\n%", "SystemSafe '$glob' strategy handles per mille"); $trap->stderr_is('', "\t(no warning)"); } elsif ($glob =~ /preserve|both|latin2/) { $trap->stdout_is("\\x{2030}\n%", "SystemSafe '$glob' strategy doesn't handle per mille; falls back to \\x notation"); $trap->stderr_like(qr/^\Q"\x{2030}"\E does not map to iso-8859-2 .*$/, "\t(and warns)"); } else { $trap->stdout_is("\xE2\x80\xB0\n%", "SystemSafe '$glob' strategy doesn't handle per mille"); $trap->stderr_like(qr/^Wide character in print.*$/, "\t(and warns)"); } } Test-Trap-v0.3.2/t/04-exit.t000444001750001750 277312472732613 15115 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/04-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 9; use strict; use warnings; my ($done_exit, $ready_for_exit); BEGIN { *CORE::GLOBAL::exit = sub(;$) { ok($ready_for_exit, "The outer CORE::GLOBAL::exit isn't called too early"); $done_exit++; CORE::exit(@_ ? shift : 0); }; } END{ ok($done_exit, "The final test: The outer CORE::GLOBAL::exit is eventually called"); } BEGIN { use_ok( 'Test::Trap' ); } # test the $! handling: my $errnum = 11; # "Resource temporarily unavailable" locally -- sounds good :-P my $errstring = do { local $! = $errnum; "$!" }; my $erros = do { local $! = $errnum; $^E }; my ($errsym) = do { local $! = $errnum; grep { $!{$_} } keys(%!) }; $! = $errnum; trap { exit }; is( $trap->exit, 0, "Trapped the first exit"); trap { *CORE::GLOBAL::exit = sub(;$) { fail("Should be overridden"); CORE::exit(@_ ? shift : 0); }; trap { exit }; is( $trap->exit, 0, "Trapped the inner exit"); }; like( $trap->stderr, qr/^Subroutine (?:CORE::GLOBAL::)?exit redefined at \Q${\__FILE__} line/, 'Override warning' ); my ($sym) = grep { $!{$_} } keys(%!); is $!+0, $errnum, "These traps don't change errno (remains $errnum/$errstring)"; is $^E, $erros, "These traps don't change extended OS error (remains $erros)"; is $sym, $errsym, "These traps don't change the error symbol (remains $errsym)"; $ready_for_exit++; exit; Test-Trap-v0.3.2/t/00-load.t000444001750001750 101512472732613 15043 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/00-*.t" -*- use Test::More tests => 5; BEGIN { use_ok( 'Test::Trap::Builder::TempFile' ); use_ok( 'Test::Trap::Builder::SystemSafe' ); SKIP: { skip 'Lacking PerlIO', 1 unless eval "use PerlIO; 1"; use_ok( 'Test::Trap::Builder::PerlIO' ); } use_ok( 'Test::Trap::Builder' ); use_ok( 'Test::Trap' ) or BAIL_OUT( "Nothing to test without the Test::Trap class" ); } diag( "Testing Test::Trap $Test::Trap::VERSION, Perl $], $^X" ); Test-Trap-v0.3.2/t/13-regressions.t000444001750001750 146712472732613 16506 0ustar00eirikeirik000000000000#!perl -T # -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/13-*.t" -*- BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile use Test::More tests => 7; use strict; use warnings; BEGIN { use_ok( 'Test::Trap' ); } () = trap { @_ }; is( $trap->leaveby, 'return', 'We may access @_' ); is_deeply( $trap->return, [], 'Empty @_ in the trap block, please' ); () = trap { $_[1] = 1; @_ }; is( $trap->leaveby, 'return', 'We may modify @_' ); is_deeply( $trap->return, [ undef, 1 ], 'Modified @_ in the trap block' ); TIMELY_DESTRUCTION: { my $destroyed=0; sub Foo::DESTROY { $destroyed++; } SCOPE: { my $foo = []; bless $foo, 'Foo'; trap { $foo }; is( $destroyed, 0, 'No Foo yet destroyed' ); } is( $destroyed, 1, 'One Foo destroyed' ); }