autodie-2.29000755001750001750 012547417731 11634 5ustar00pjfpjf000000000000AUTHORS100644001750001750 1004012547417731 13000 0ustar00pjfpjf000000000000autodie-2.29Fatal and autodie would not be possible if it were not for the contributions of the wonderful people below. Lionel Cons - Original module Ilya Zakharevich - Prototype updates Paul Fenwick - autodie, autodie::exception, Fatal overhaul BrowserUk - Suggesting the name 'lethal', which the module was called during much of development. Juerd Waalboer - Suggesting the name 'autodie' Aristotle Pagaltzis - Suggestions and sanity checking on design and interface Mark Reed and Rolan Giersig - Klingon Translators Matt Trout - Suggesting I look at namespace::clean as a pragma that works under 5.8 and which is able to precisely delete subroutines from globs. Robert 'phaylon' Sedlacek - Writing namespace::clean, which I twisted to my dark will to provide a faster, 5.8 clean autodie with less side-effects. Stephen 'Stennie' Steneker - Spelling corrections. Chocolateboy - Advice on $^H, %^H, and other dark and terrible magicks. - Being a wonderful sounding board for when I had too many ideas and not enough implementation. ikegami - Resolving the most frustrating issue of user-subroutine replacement under Perl 5.8, - Enlightening me as to the correct way to reference globs. - Reminding me that 'use' really does happen first, regardless of how it's been dressed. Matt Kraai - Formatting fixes in diagnostics. Darren Duncan - Spotting omissions in user documentation. Damian Conway - Extremely detailed and inspirational input into how autodie::hints should work, as opposed to my original and rather stunted proposal. Jacinta Richardson - Documentation, proof-reading, code review, and a huge amount of sound-boarding. In particular most of the autodie::hints documentation would not exist without Jacinta's efforts. Ben Morrow - Providing an excellent and compelling argument as to how roles should be handled. - Spotting that autodie can clobber package scalars when formats are copied between blogs. Glenn Fowler - Documentation review and improvement when I had spent so long looking at the autodie::hints documentation I wasn't sure if they made sense anymore. ;) Toby Corkindale - Documentation copyediting and improvements. Vincent Pit - Additional test cases. - Help in tracking down string eval weirdness. - Code review and sanity support. Florian Ragwitz - Help in tracking down string eval weirdness. - Letting me cargo-cult code from B::Hooks::EndOfScope. Elliot Shank - Integration into Perl::Critic Michael Schwern - Finding a more-than-a-decade old bug in Fatal that caused it to leak carp functions. - Improvements to generated error messages. - Safer loading of exception classes. - Support for working with the open pragma. David Taylor - Documentation fixes. Nick Cleaton - Support for multi-arg open. Craig A. Berry - VMS support. Jonathan Yu - chmod support. - Prevention of author tests failing if Sub::Identify not installed. Jerry D. Hedden - Better test output, particularly when running as part of the Perl core. Curtis Jewell - Improvements to File::Copy tests under Windows. Olivier Mengué - Compatibility fixes with Carp. Todd Rinaldo - Avoided possible test failures when STDIN was a socket. RsrchBoy - chmod support and tests. David Steinbrunner - Spelling and documentation corrections. Niels Thykier - Identification and caching of reuseable subroutines. - Significant reductions in the number of string evals(). - Refactoring and restructing to make autodie's guts more sane. - General all round speed improvements. - Niels Thykier is a hero of the free people. Autodie loads *much* faster due to his efforts! - Fixes around leak guards and slurpy core subroutines. Changes100640001750001750 11661612547417731 13257 0ustar00pjfpjf000000000000autodie-2.29Revision history for autodie 2.29 2015-07-09 17:16:38+10:00 Australia/Melbourne * BUGFIX: Apply patch from Karen Etheridge to install autodie and Fatal into 'perl' rather than 'site' for older perls (RT#85801, GH#68) 2.28 2015-06-22 16:20:35+10:00 Australia/Melbourne * TEST BUG: Properly skip the Import::Into test if the version of Import::Into is insufficent. Thanks to Olivier Mengué. (GH#67) * DOC: Document change in 2.27 that was omitted from the Changes-file by mistake. 2.27 2015-06-10 19:19:49+10:00 Australia/Melbourne * DEPRECATION: Deprecate the use of "Fatal qw(:lexcial)". It is an implementation detail of autodie and is about to change. * BUG: Use "octal" numbers in error messages for CORE subroutines taking a "mode" parameter (e.g. mkdir and chmod). Thanks to "Bugdebugger". (GH#65 and GH#66) * SPEED: Allow wrappers for CORE::exec and CORE::system to be reused as they are not dependent on the calling package. * TEST: Avoid hard-coded directory separator in t/system.t. Thanks to A. Sinan Unur for reporting it and providing a patch. (GH#62) * TEST: Add missing "require autodie" in import-into test and ensure Import::Into remains an optional test dependency. * TEST / INTERNAL / TRAVIS: Set "sudo: false" to gain access to the Travis container based infrastructure. * TEST: Bump version of Import::Into to 1.002004 as older versions are insufficient for our test. Thanks to Olivier Mengué for reporting it. (RT#101377) 2.26 2014-12-26 16:27:23+00:00 UTC * BUGFIX / INCOMPAT: Remove "fileno" and "umask" from the list of CORE subs protected by autodie and Fatal. When they return undef, it is not a failure. * BUGFIX: Fixed an error that could occur during global destruction of the form "(in cleanup) Can't use an undefined value as an ARRAY reference at .../autodie/Scope/GuardStack.pm line 48 during global destruction" (Thanks to Dave Rolsky). * BUGFIX: The open-pragma is now properly ignored when open is given an explicit layer. This brings autodie protected open in sync with open. Thanks to Gregory Oschwald and Graham Knop for the report + test case and the patch. (GH#52 + GH#53) * BUGFIX: Hide the "SCALAR" (buffer) argument in the string representation of autodie::exception for the read, sysread and syswrite CORE subs. This is to avoid a dump of binary data to the screen/log when a (sys)read or syswrite fails. * FEATURE: Let autodie::exception work in equality tests and string comparison via "overload fallback". (Thanks to Michael G. Schwern) * DOC: Mention that "kill" is in the ":ipc" category. It has been there since autodie v2.14. (Thanks to Felipe Gasper for reporting it, RT#97320). * INTERNAL: Use "parent" instead of "base" for inheritance. Also avoid some @ISA relationships that were redundant. Either truly redundant ones or by importing "import" from Exporter v5.57. - This change implies that perl 5.8 users must now also fetch "parent" from cpan. (Thanks to Olivier Mengué, GH#59) * DEVEL / TEST: The autodie module now accepts an undefined Fatal version, assuming it to be development version. Test cases that require versions are now either skipped or considered "release" test. * TEST / INTERNAL: Enabled travis-ci for Perl 5.20 * TEST: Close temp file before re-opening in t/truncate.t. (Thanks to Craig A. Berry, RT#96609) * TEST: Pass O_TRUNC with O_CREAT to sysopen in t/utf8_open.t. (Thanks to Craig A. Berry, RT#87237) * TEST: Clean up temp file in t/truncate.t. (Thanks to Dave Mitchell, RT#100688) 2.25 2014-04-03 09:43:15EST+1100 Australia/Melbourne * DOCS: Spelling fixes in autodie::ScopeUtil (Courtesy Salvatore Bonaccorso) 2.24 2014-03-30 19:30:10EST+1100 Australia/Melbourne * FEATURE: Provide a stack backtrace when `Carp::Always` is enabled. Note that sometimes this is not as pretty as it could be, patches welcome. (Thanks to Niels Thykier, GH #35) * BUGFIX: Fix situations where `no autodie` doesn't respect lexical scope. (Thanks to Niels Thykier, GH #41, RT #72053, RT #86396) * INTERNAL: Remove now unused variables in code (Niels Thykier). * DOCS: Make it extra-clear autodie doesn't check `print`. (Dave Rolsky, GH #39) * TEST: Removed obsolete boilerplate.t * TEST / INTERNAL: Enabled travis-ci for Perl 5.8 * TEST: Stopped some Pod::Coverage tests failing under Perl 5.8 * BUILD: Better support for building in a read-only directory (courtesy Andrew Fresh, GH #46) 2.23 2014-01-27 13:50:55EST+1100 Australia/Melbourne * TEST / BUGFIX: Improved testing support on Android and Blackberry devices. (GH #44, thanks to Hugmeir.) * TEST / INTERNAL / TRAVIS: Various non-code tweaks to make travis-ci more happy with testing autodie. * BUGFIX: autodie no longer weakens strict by allowing undeclared variables with the same name as built-ins. (RT #74246, thanks to Neils Thykier and Father Chrysostomos.) * BUGFIX: `use autodie qw( foo ! foo);` now correctly insists that we have hints for foo. (Thanks Niels Thykier) * INTERNAL: Improved benchmarking code, thanks to Niels Thykier. 2.22 2013-09-21 11:37:14 Asia/Tokyo * TEST / INTERNAL: Restore timestamps on touched testing files to avoid git flagging files having changed in git. (RT #88444, courtesy shay@cpan) 2.21 2013-09-12 13:17:23 Australia/Melbourne Many more improvements from Niels Thykier, great hero of the free people. Plus a compatibility patch from Zefram, keeper of Carp. * SPEED / INTERNAL : Through the magic of globally reuseable core leak trampolines, autodie is even faster when used across multiple pacakages. * SPEED / INTERNAL : Caches used for keeping track of fatalised subroutines are faster and leaner. * SPEED / INTERNAL : Core subroutine wrappers are now lazily compiled. * SPEED / INTERNAL : Using autodie while autodie is already in effect is now faster and more efficient. * INTERNAL : $" and $! are no longer arbitrarily messed with for no reason via autodie. (They're still messed with when using Fatal.) * SPEED / INTERNAL : The ':all' tag hierachy is expanded immediately, in an efficient fashion. * INTERNAL : Numerous minor clean-ups. Dead variables removed. Typos fixed. * SPEED / INTERNAL : import() and _make_fatal() cache more aggressively, reducing CPU overhead. * TEST: Compatibility with Carp 1.32 (thanks to Zefram). RT #88076. 2.20 2013-06-23 16:08:41 PST8PDT Many improvements from Niels Thykier, hero of the free people. From GH #25: * SPEED / INTERNAL: Less time is spent computing prototypes * SPEED / INTERNAL: Leak guards are more efficient. * SPEED : Expanding tags (eg: qw(:all)) is now faster. This also improves the speed of checking autodying code with Perl::Critic. * INTERNAL: Expanding of tags is faster and preserves order. 2.19 2013-05-13 10:02:15 Australia/Melbourne * BUGFIX: Loading a file that does not change packages while autodie in effect no longer causes weird behaviour when slurpy built-ins (like open() and unlink()) are called. GH #22 Thanks to Niels Thykier. * TEST: Tests for leak guard failures for slurpy core functions. 2.18 2013-05-12 18:12:14 Australia/Melbourne * TEST: More testing in scope_leak.t. * TEST: More testing around packages in truncate.t. * SPEED / INTERNAL: Significant improvements in load time, especially when autodie is used across multiple files, by caching reuseable subroutines and reducing calls to eval "". Huge thanks to Niels Thykier, who is a hero of the free people, and completely and utterly awesome. (RT #46984) * DOCUMENTATION: Spelling and correction fixes, courtesy David Steinbrunner. * DEVEL: Faster and more robust testing with travis-ci. * DEVEL: Some simple benchmarks bundled in the benchmarks/ directory. 2.17 2013-04-29 01:03:50 Australia/Melbourne * DOCS: Spelling fixes thanks to dsteinbrunner! (RT #84897) * DOCS: Fixed github links to point to 'pjf' rather than 'pfenwick' (GH #18, thanks to Lx!) * INTERNAL: Silence warnings about experimental smart-match on 5.17.11+ (via Brian Fraser and p5p) * TEST / BUILD: Generate .travis.yml files for CI testing via dzil. 2.16 2013-02-23 01:49:16 Australia/Melbourne * BUGFIX: Fix breakages under 5.8.x related to the new autodie::skip feature. * BUILD / BUGFIX: Remove dependency on parent.pm. 2.15 2013-02-22 23:55:22 Australia/Melbourne * BUILD / BUGFIX: Correct meta-info that wanted at least Perl v5.8.40, rather than v5.8.4. Giant thanks to Paul Howarth for spotting this! 2.14 2013-02-22 15:43:33 Australia/Melbourne * FEATURE: Classes which claim they ->DOES('autodie::skip') are now skipped when generating exceptions. This is mainly of use to utility classes. See `perldoc autodie::skip` for more details. (GH Issue #15) * FEATURE / BUGFIX / INCOMPAT: 'chmod' is now in the ':filesys' category (was in ':file'). * BUGFIX: Added support for 'chown' and 'utime', that was previously overlooked. Mad props to RsrchBoy for spotting this. These are all in the ':filesys' category. (GH Pull #13) * BUGFIX: Added support for 'kill'. This is part of the ':ipc' category. * BUGFIX: Fixed bug whereby chmod, chown, kill, unlink and utime would not throw an exception when they didn't change all their files or signal all their processes. * TEST: truncate.t is now skipped on systems that don't have a working File::Temp. * TEST: open.t has a few more tests for exotic modes. * TEST: chown() tests are skipped on Win32, as chown on Windows is a no-op. (Thanks to Mithaldu for spotting this!) * TEST: Author tests now look for the AUTHOR_TESTING env variable (for dzil compliance). * TEST: Better testing for chown, chmod, and unlink. * TEST: Better testing for utime. * TEST: kwalitee.t is now only run when $ENV{RELEASE_TESTING} is set. * BUGFIX: Removed executable bits from some bundled text files. * BUILD: We now use dzil to manage autodie. * BUILD: Only Perl 5.8.4 and above is supported by autodie. Please upgrade your Perl distro if you're using 5.8.3 or below. 2.13 Thu Nov 8 14:22:03 EST 2012 * TEST: Deterministic tests in hints_pod_examples.t . (RT #80412, thanks to demerphq) * INTERNAL: subroutine installs are now done in a deterministic order. (RT #80414, thanks to demerphq) 2.12 Tue Jun 26 14:55:04 PDT 2012 * BUGFIX: autodie now plays nicely with the 'open' pragma (RT #54777, thanks to Schwern). * BUILD: Updated to Module::Install 1.06 * BUILD: Makefile.PL is less redundant. * TEST: t/pod-coverage.t no longer thinks LEXICAL_TAG is a user-visible subroutine. 2.11 Sat Mar 24 01:50:56 AUSEST 2012 * DOCS: Explicitly documented that autodie is context unaware. (Thanks to chromatic.) * TEST: Multi-arg open tests are skipped on VMS. (Thanks to Craig A. Berry.) * TEST BUGFIX recv.t shouldn't assume STDIN is a file handle. (Thanks to Todd Rinaldo) * TEST: Fixed compatibility with Carp 1.25. (Thanks to Olivier Mengué.) * INTERNAL: Exception classes are loaded more safely. (Thanks to Schwern) 2.10 Sat Feb 27 14:01:18 AUSEST 2010 * BUGFIX: Fatal and autodie no longer leak Carp functions into the caller's namespace. Thanks to Schwern. * TEST: Multi-arg open tests are really really skipped under Windows now. * DOCUMENTATION: Many more people are properly attributed in the 'AUTHORS' file. 2.09 Tue Feb 23 00:33:09 AUSEST 2010 * DOCS: Fixed documentation typo. RT #48575 Thanks to David Taylor. * TEST: Tests involved multi-arg open are skipped on Windows (where multi-arg pipe is not implemented). 2.08 Mon Feb 8 14:24:26 AUSEST 2010 * BUGFIX: Addeds support for chmod. Many thanks to Jonathan Yu for reporting this (RT #50423). * BUGFIX: Multi-arg open is now supported by open. Many thanks to Nick Cleaton for finding and fix this bug. (RT #52427) * BUILD: Updated to Module::Install 0.93 2.07 Fri Jul 31 16:35:40 BST 2009 * FEATURE: Added ->eval_error to autodie::exception, which stores the contents of $@ at the time autodie throws its own exception. This is useful when dealing with modules such as Text::Balanced which set (but do not throw) $@ on error. * TEST: Checking for flock() support no longer causes test failures on older VMS sysstems. (RT #47812) Thanks to Craig A. Berry for supplying a patch. * TEST: hints.t tests should no longer cause bogus failures relating to File::Copy on VMS and Windows systems prior to Perl 5.10.2. 2.06 Tue Jul 7 00:01:37 AUSEST 2009 * BUG: Explicitly documented that autodie does NOT play nicely with string evals, especially under Perl 5.10.x. Please avoid using string evals while autodie is in scope. * TEST: Check for autodie leaking out of scope in the presence of string evals. (string-eval-leak.t) Thanks to Florian Ragwitz and Vincent Pit for identifying this. * BUGFIX: autodie once again correctly works when used inside a string eval. (This was accidently broken somewhere around 1.997-1.998). 2.05 Sat Jul 4 16:33:01 AUSEST 2009 * BUGFIX: format_default() in autodie::exception no longer returns a string with file and line attached. This would cause the file and line information to appear twice when format handlers would choose to fall back to the defaults. The file and line information is now always added by stringify(). (RT #47520, thanks to Michael Schwern) * BUGFIX: Exceptions thrown by 2-argument open() are more likely to specify the mode as 'for reading' when no explicit mode was given. (RT #47520, thanks to Michael Schwern) 2.04 Thu Jul 2 18:56:57 AUSEST 2009 * TEST: Removed spurious warning about insufficient credit. * TEST: hints.t produces less debugging output when testing the Perl core. (Thanks to Jerry D. Hedden) * TEST: hints.t no longer spuriously fails when checking the return values from File::Copy under Windows before Perl 5.10.1. (Thanks to Curtis Jewell) 2.03 Wed Jul 1 15:39:16 AUSEST 2009 * BUGFIX: Stopped blog_hints.t from booching under Perl 5.8.x. because parent.pm is not installed. 2.02 Wed Jul 1 15:06:21 AUSEST 2009 * FEATURE: autodie::exception now supports ->context() to discover the context of the failing subroutine, and ->return() to get a list of what it returned. * BUGFIX: ->function from autodie::exception now returns the original name of the dying sub, rather than its imported name. For example, 'File::Copy::copy' rather than 'main::copy'. Core functions continue to always return 'CORE::whatever'. * TEST: blog_hints.t tests new hinting features against examples in my blog at http://pjf.id.au/blog/ 2.01 Wed Jul 1 01:31:24 AUSEST 2009 * DOCUMENTATION: General copyediting and tidy-up (Thanks to Toby Corkindale) * BUGFIX: Warnings are no longer emitted when undefined values are compared by hinting routines. * BUGFIX: Hints for File::Copy now operate correctly under Perl 5.10.1. * BUGFIX: Inheritance is now considered sufficient to declare allegiance to the hints provider role under Perl 5.8.x. (Thanks to Glenn Fowler) * TEST: hints.t no longer throws failures under Perl 5.10.1. * TEST: pod-coverage.t (author test) no longer fails if Sub::Identify is not installed. (Thanks to Jonathan Yu. RT #47437) 2.00 Mon Jun 29 01:24:49 AUSEST 2009 * FEATURE: autodie can now accept hints regarding how user and module subroutines should be handled. See autodie::hints for more information. * INTERFACE: The calls to the internal subroutines one_invocation() and write_invocation() have changed. An additional argument (the user subroutine reference) is passed as the second-last argument. This may break code that previously tried to call these subroutines directly. * BUGFIX: Calls to subroutines to File::Copy should now correctly throw exceptions when called in a list context. * BUGFIX: An internal error where autodie could potentially fail to correctly report a dying function's name has been fixed. * BUGFIX: autodie will no longer clobber package scalars when a format has the same name as an autodying function. (Thanks to Ben Morrow) * INTERFACE: The internal interfaces for fill_protos(), one_invocation(), write_invocation() are now once again backward compatible with legacy versions of Fatal. It is still strongly recommended these interfaces are NOT called directly. The _make_fatal() subroutine is not backwards compatible. * TEST: Added internal-backcompat.t to test backwards compatibility of internal interfaces. * DOCUMENTATION: Expanded documentation regarding how autodie changes calls to system(), and how this must be explicitly enabled. * BUILD: Upgraded to Module::Install 0.91 * BUGFIX: A situation where certain compile-time diagnostics and errors from autodie would not be displayed has been fixed. 1.999 Sat Feb 28 18:36:55 AUSEDT 2009 * BUGFIX: Autodie now correctly propagates into string evals under 5.10+. Autodie completely fails to propagate into string evals under 5.8. No fix for 5.8 is known. * BUGFIX: The caller() method on autodie::exception objects should now always report the correct caller. While it would always get the line, file, and package correct, previously it would sometimes report less-than-helpful callers like '__ANON__' or '(eval)'. * BUGFIX: autodie was treating system() as a user-sub, not a built-in. This could tigger extra (unnecessary) work inside autodie, but otherwise had no user impact. * DOCUMENTATION: The synopsis for autodie::exception::system previously implied system() was made autodying by default. This was not the case. It must still be enabled with use autodie qw(system). * DOCUMENTATION: Noted the 5.8 string eval bug in autodie/BUGS. * TEST: Added test for correct caller output on autodie::exception objects. Thanks to Piers Harding for spotting this bug at KiwiFoo. * TEST: Added tests for user-defined autodying functions changing behaviour depending upon context. This was reported in http://perlmonks.org/?node_id=744246 . * TEST: Tests for autodie propagating into string eval. * TEST: Expanded tests to ensure autodie::exception returns the correct line number and caller. * TEST: Expanded tests to ensure autodie::exception returns correct information when calling subroutines in external files. 1.998 Sat Jan 3 11:19:53 AUSEDT 2009 * BUILD: Removed Module::AutoInstall, which previously was loaded but not used, but currently doesn't actually do what we want. * TEST: We manually stringify $@ for one test in exception_class.t to avoid a bug involving overloaded classes containing apostrophies. * TEST: unlink.t and mkdir.t avoid changing directories, which could cause spurious failures when @INC includes paths relative to the current working directory. * DOCUMENTATION: Spurious "used only once" messages are documented in Fatal's documentation (as well as autodie's). * TEST: truncate.t has been updated to avoid incorrect test failures on VMS machines. Many thanks to Craig A Berry for the bug report and fix. (RT #42110) 1.997 Thu Dec 4 15:14:00 AUSEDT 2008 * TEST: Test::More 0.86 (and possibly 0.85) appears to dislike package names that contain the apostrophe character (these occur in some tests for Klingon localisation). We now skip these tests on systems with Test::More >= 0.85 installed. 1.996 Thu Dec 4 09:07:39 AUSEDT 2008 * FEATURE: Child classes can now provide an exception_class() method that returns the desired exception class, rather than over-riding the whole throw() method. Existing classes that over-ride throw() will still work as before. * BUGFIX: Fixed a bug where multiple autodie-derived classes would share the same subroutine cache. This could result in excptions from the wrong class being thrown. This bug did not affect programs which used only autodie, or a single autodie-derived class. * BUGFIX: Missing 1.995 version tag added to export list. * TEST: Make sure that we always have a working version tag for our current version. 1.995 Sun Nov 30 17:30:16 AUSEDT 2008 * FEATURE: Errors from 2-argument open now have more human friendly error messages for reading, writing, and appending. * FEATURE: autodie will never print unsightly references to GLOB(0x...) structures in error messages; instead it uses the placeholder '$fh'. * BUILD: Bundled Module::AutoInstall makes it clear to users they need to install IPC::System::Simple for autodying system() support. * TEST: truncate.t provides more diagnostics on failure. * TEST: Tests for better formatted reports from connect(). * TEST: New 'open.t' contains specific tests for well-formatted messages from open(). 1.994 Thu Sep 25 16:18:56 AUSEST 2008 * BUGFIX: flock(), ioctl() and truncate() are now part of the :file tag. * BUGFIX: link(), mkdir(), rmdir(), symlink() and umask() are now part of the :filesys tag. * BUGFIX: The new :msg tag contains msgctl(), msgget(), msgrcv(), and msgsnd(). * BUGFIX: The new :semaphore tag contains semctl(), semget() and semop(). * BUGFIX: The new :shm tag contains shmget(), shmread() and shmctl(). * BUGFIX: The new :ipc tag contains :msg, :semaphore, :shm and pipe(). * BUGFIX: The read(), seek(), sysread(), syswrite() and sysseek() methods have been added to :io. * BUGFIX: autodie produces more detailed messages on internal faults, and is more aggressive about stopping code compilation. * FEATURE: flock will not die on failure when called with the LOCK_NB option and would return false due to an EWOULDBLOCK. See function specific notes in autodie documentation for more details. * FEATURE: Stringified exceptions from flock() are significantly nicer to read. * FEATURE: use autodie qw(:1.994) can be used to specify the :default tag from a particular version. * DOCUMENTATION: flock() is documented as being in the :file tag. * DOCUMENTATION: Added function-specific notes in autodie.pm * TEST: New tests for rmdir(), mkdir(), and unlink(), thanks to Jacinta Richardson. * TEST: Added author-only perlcritic tests. * META: META.yml has more correct author information. 1.993 Sun Sep 14 11:15:36 AUSEST 2008 * DOCUMENTATION: The :dbm tag is now correctly documented in autodie/CATEGORIES. Thanks to Darren Duncan for spotting this. (RT #39172) * DOCUMENTATION: The README file has been updated to reflect current minimum Perl versions (5.8.0) and current resources. * DOCUMENTATION: The closedir() function is properly documented as being included in the :filesys tag. * DOCUMENTATION: Feedback section added to the autodie documentation. If you find the module useful, consider saying so on cpanratings.perl.org, or dropping me a note. * BUILD: Upgrade to Module::Intstall 0.77 1.992 Sun Sep 7 15:51:32 AUSEST 2008 * BUGFIX: unlink(), rename(), chdir() and closedir() functions are now included in the :filesys tag. * BUGFIX: binmode() is now checked for failure as part of the :file tag. * BUGFIX: Using an unopened filehandle in an autodying built-in no longer triggers a spurious warning. * BUGFIX: RT #38845, corrected a missing space in the error produced by autodie when called with the ':void' switch. Many thanks to Matt Kraai for the patch! * FEATURE: The dbmopen() and dbmclose() functions are now supported in their own :dbm tag. This is part of :io (and hence :default). * FEATURE: The dbmopen() built-in has its own formatter, which ensures errors always display the mask in octal, not decimal. * DOCUMENTATION: The :filesys tag is properly documented. * DOCUMENTATION: Added link to Perl tip on autodie. * TEST: RT #38845, t/internal.t updated to detect malformed error messages involving the mixing of ':void' and autodie. 1.991 Fri Aug 22 23:57:24 AUSEST 2008 * BUGFIX: RT #38614, stringified autodie::exceptions objects now always end with a newline. Thanks to Offer Kaye for the report. * BUGFIX: Makefile.PL is no longer executable. * BUGFIX: 'chdir' added to defaults, and the :filesys group. * BUGFIX: RT #38598, the errno attribute on autodie::exception objects is now correctly set. * BUGFIX: RT #38066, exceptions from system() now report the correct line number. * TEST: Internal tests changes to ease integration with core. * TEST: Checks added for empty 'errno' string in basic_exceptions.t * TEST: Errors should end with a newline. * TEST: fork tests should no longer mysteriously fail on Solaris. * TEST: backcompat.t should no longer give strange failures on old versions of 5.8.3 or earlier. * TEST: system.t ensures the correct file is reported. * BUILD: Upgrade to Module::Install 0.75 1.99 Mon Jul 21 02:25:23 PDT 2008 * RELEASE CODENAME: "jarich", in thanks for her giving up pretty much a whole week of her life to do nothing but help me work on my talks for OSCON. * BUGFIX: autodie will now check open() for returning undef, not merely false, as open() can legimiately return zero for open(my $fh, '-|') || exec(...) style calls. * TEST: Added t/lethal.t, a test for basic subclassing. * TEST: Added t/usersub.t, a test for correct handling of user subroutines. * DOCUMENTATION: Noted in autodie.pm that user subs can only be made Fatal/autodying if they've been declared first. * FEATURE: Conflicts between 'no autodie' and 'use Fatal' re-enabled. * FEATURE: Added sysopen() and fcntl() to :file, and exec() and system to :system. exec() doesn't yet work due to its prototype; * FEATURE: Vanilla 'use autodie' now implies 'use autodie qw(:default)'. This excludes system(), which depends upon an optional module, and exec(), which breaks its exotic form. * TEST: Internal tests moved from Fatal.t to internal.t * FEATURE: Added support for fileno. * FEATURE: Addded support for exec (although this breaks the exotic form while autodie is in scope). * BUGFIX: 'no autodie' now plays nicely with user subs. * DOCUMENTATION: Added a brief mention of the category system that autodie provides. 1.11_01 Fri Jul 4 12:53:11 AEST 2008 * RELEASE CODENAME: "Aristotle", in thanks for the many long and detailed discussions about the autodie interface and how it should interact with Fatal. Aristotle was instrumental in ensuring autodie has the clean and simple interface that it does now. * FEATURE: 5.8 now has the ability to differentiate between calls that return false to indicate failure, and those that only return undef to indicate failure. CORE::send and CORE::recv are examples of these. * FEATURE: You can now 'use autodie qw(fork)' to make sure your forks are successful (they must return defined). * TEST: t/todo.t removed. We have passing tests (recv.t) for the reminder I had stuffed into here. * TEST: t/fork.t added, for testing autodying fork. * INTERNAL: The internal subroutine _remove_lexical_subs has been renamed to a much less misleading name of _install_subs, since that's what it actually does now. * BUGFIX: Found and fixed a nasty bug where autodie's internal subroutine cache was being too agressive. This could result in handles from the incorrect package being used. Scalar filehandles have never been affected by this bug. * BUGFIX: Autodying subroutines will no longer leak into other files if they are used/required/done in the same lexical scope. * BUILD: Fatal and autodie now install themselves with a INSTALLDIRS=perl target, meaning they will now correctly override (and possibly overwrite) your installed Fatal.pm on 'make install'. * DOCUMENTATION: Documented the 'used only once' bug when using Fatal/autodie with package filehandles. This has always existed in Fatal, and as far as I know it incurable (but harmless). * FEATURE: autodie and its exceptions can now be subclassed! * TEST: Added t/crickey.t as an example of using fair dinkum subclasses of autodie. Mate, I reckon it's time for a beer. * INTERNAL: Moved exception architecture from inside-out objects (which need lots of extra work under 5.8) to regular hashes (which don't need extra work). * INTERNAL: Inlined relevant portions of Scope::Guard, meaning autodie can be installed with no dependencies. (It still recommends IPC::System::Simple.) 1.10_07 Sun Jun 29 15:54:26 AEST 2008 * RELEASE CODENAME: "ikegami", in thanks for solving the problem of getting lexical replacement of subroutines working for real under Perl 5.8. As this works better than my 5.10 implemenation, it forms the foundation for this release. * Removed inappropriate diagnostics about :lexical from Fatal.pm * Moved can't mix lexical and void diagnostics to autodie.pm * Added some basic tests for sysopen() * Removed the 5.10 only way of tracking lexical hints with %^H. Our code now exclusively uses the more portable 5.8 code that employs Scope::Guard (and has less side-effects). * Exotic system is no longer clobbered under 5.10 outside of autodie's scope. * autodie::exception::match is better exercised in the 5.8 test suite. * Re-enabled 'use autodie' vanilla tests. * t/backcompat.t no longer fails under Devel::Cover * Repeating function names in arguments to autodie no longer causes those functions to become 'stuck' in autodying mode. * Wrong-version of Fatal.pm support added, along with basic hints on how to get it working. * Expanded documentation on autodie, particularly for exception handling under Perl 5.8. * Less warnings from t/exceptions.t when running under 5.10. * All releases now really depend upon Scope::Guard, not just 5.8. 1.10_06 Sun Jun 22 21:50:39 AEST 2008 * RELEASE CODENAME: "Chocolateboy", in thanks for his wonderful insights, and for letting me sound off way too many ideas about how things may be done. * Fixed speeling errors in context.t, thanks to Stennie. * Fixed minor pod errors and omissions. * Fixed bug in recv.t which resulted in an incorrect number of skipped tests on systems using socketpair emulation. * Fixed a bug that would cause unwanted interactions between autodie and autobox. Thanks to chocolateboy. (5.8) * Wrote a (failing) test case demonstrating that the autodie pragma could leak across files. Many thanks to chocolateboy for bringing this to my attention. * t/system.t checks to see if exotic system has been injured in the same package as 'use qutodie qw(system)' * Calling filename reliably reported in 5.8 error messages and error objects. * User subs can be made autodying under 5.8, but they leak over the entire package (which is very bad!) * Context-checking tests split into package-scope tests and lexical scope tests. * Lexical user-subs are disabled under Perl 5.8. They were leaking everywhere and not being lexical at all. Attempting to use a lexical user-sub under 5.8 now causes an error. * Bugs found in interaction between autodie and Fatal in 5.8. When used together, we can't reliably replace a Fatalised sub with an autodying one, and then switch it back again at the end of block. * Bugs described above fixed, thanks to ikegami! * Overhauled _remove_lexical_subs, based on ikegami's input. This routine would now be better named "_install_lexical_subs", since it can now both install and remove. * Surpressed some warnings under 5.8 about uninitialised hints hashes. * Added support for backwards compatible Fatal calls in 5.8. These are currently a little *too* backwards compatible, possessing the same bugs as the old Fatal (clobbering context). * Improved caching of pre-generated subroutines. We now cache the compiled subroutine, rather than the uncompiled code. * Added more tests to ensure Fatal throws backcompat strings, whereas autodie throws exception objects. * Support for lexical user-subs enabled, tested, and working in 5.8! * Added resources to Makefile.PL / META.yml 1.10_05 Sun Jun 15 15:46:38 AEST 2008 * Kludgy support for Perl 5.8 using Scope::Guard and dark and terrible magicks taken from namespace::clean. * Rudimentary caching of generated code, to avoid having to regenerate the same code every single time Fatal/autodie is used on the same function. * Nuking subroutines at end of lexical scope moved into own subroutine. * Perl 5.8 support working! Backcompat mode not yet supported, nor is autodie with user defined subs. The 5.8 support that is there is rather kludgy, and still needs a lot of work. * Perl 5.8 code no longer gets executed under 5.10 when executing write_invocation(). * lex58.t tells the user that we'll get warnings under Win32, and these are to be ignored. This is due to a Perl behaviour where it always calls the shell under Win32, even when multi-arg system is used. * lex58.t no longer fails to compile on Perl 5.10 which is still clobbering exotic open. Perl 5.8 does not clobber the exotic form. * Backcompat tests are all marked as TODO under perl 5.8 * Makefile.PL moved back to saying autodie works under 5.8 * Context/user-sub tests skipped under 5.8, which does not yet support autodying of user subs. * lex58 tests now skipped if IPC::System::Simple not installed. * Squished a spurious warning from lex58.t 1.10_04 Sat Jun 14 15:02:17 AEST 2008 * Made all $VERSION numbers more friendly to static code analysis tools (including CPAN). * Added a test to make sure all version numbers are incremented in lock-step. * Started 5.8 support * Removed dependencies on 5.10 'use feature'. * Removed dependencies on 5.10 fieldhashes. * a::e::match no longer uses smart-match or // * %^H init doesn't use // anymore. * 5.8 won't try to use // in fatalised subs (kludge) * recv.t corrected to use a custom socket (closed for writing) and to ignore SIGPIPEs. 1.10_03 Fri Jun 13 11:04:17 AEST 2008 * Updated backwards compatibility tests to work on non-Enligh systems. 1.10_02 Fri Jun 13 10:55:00 AEST 2008 * Tweaked boilerplate test to remove windows-only paths. 1.10_01 Thu Jun 12 17:19:13 AEST 2008 * First beta release of module. 1.09 UNRELEASED * Many changes not documented here. * Fatal is now fully backwaards compatible again. * system() can be fatalised/autodying if IPC::System::Simple is installed. * Rationlisation of autodie::exception API. * autodie::exception->function() now always returns the full function name as best we can find it, and not what may be getting replaced (eg, CORE::open instead of main::open). 1.08 Sat Mar 29 10:54:20 AEDT 2008 Dual-lifed module internally from work I was doing on p5p. t000755001750001750 012547417731 12020 5ustar00pjfpjf000000000000autodie-2.29pod.t100755001750001750 44312547417731 13113 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; if (not $ENV{AUTHOR_TESTING}) { plan( skip_all => 'Author test. Set $ENV{AUTHOR_TESTING} to true to run.'); } eval "use Test::Pod 1.00"; ## no critic plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); LICENSE100644001750001750 4400712547417731 12747 0ustar00pjfpjf000000000000autodie-2.29This software is copyright (c) 2015 by Paul Fenwick and others (see AUTHORS file). This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015 by Paul Fenwick and others (see AUTHORS file). This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015 by Paul Fenwick and others (see AUTHORS file). This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End dist.ini100640001750001750 307312547417731 13360 0ustar00pjfpjf000000000000autodie-2.29name = autodie author = Paul Fenwick license = Perl_5 copyright_holder = Paul Fenwick and others (see AUTHORS file) [Git::NextVersion] [NextRelease] [MetaJSON] [MetaResources] repository.url = git://github.com/pjf/autodie repository.web = https://github.com/pjf/autodie repository.type = git bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie [DualLife] ; autodie.pm entered in 5.010001, but we need to handle Fatal.pm as well entered_core = 5.00307 [Test::Perl::Critic] [PodCoverageTests] [PodSyntaxTests] ; DIY Basic, because we don't want the Readme plugin. [GatherDir] [PruneCruft] [ManifestSkip] [MetaYAML] [License] [ExtraTests] [ExecDir] [ShareDir] [MakeMaker] [Manifest] [TestRelease] [ConfirmRelease] [UploadToCPAN] [AutoPrereqs] ; Skip Klingon testing pre-reqs. They're included in the test dir. skip = ^pujHa ; Skip optional testing modules skip = ^(?:BSD::Resource|Test::Kwalitee|Test::Perl::Critic|Import::Into)$ ; Some modules are nice to have, but not required. skip = ^(?:IPC::System::Simple|Sub::Identify)$ ; We'll specify our own minimum version of Perl, thanks! skip = ^perl$ [Prereqs] ; I'm really sorry, if you're using something older than 5.8.4, you ; really want to upgrade your Perl distro. perl = 5.008004 [Prereqs / TestRecommends] perl = 5.010 BSD::Resource = 0 Test::Kwalitee = 0 Test::Perl::Critic = 0 Import::Into = 1.002004 ; release-pod-coverage.t likes this Pod::Coverage::TrustPod = 0 [Prereqs / RuntimeRecommends] perl = 5.010 IPC::System::Simple = 0.12 Sub::Identify = 0 [OurPkgVersion] [CPANFile] [@Git] args.t100755001750001750 251212547417731 13304 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 7; require Fatal; my @default = expand(':default'); my @threads = expand(':threads'); my @io = expand(':io'); my %io_hash = map { $_ => 1 } @io; my @default_minus_io = grep { !exists($io_hash{$_}) } @default; is_deeply(translate('!a', 'a'), ['!a'], 'Keeps insist variant'); is_deeply(translate(':default'), \@default, 'translate and expand agrees'); is_deeply(translate(':default', ':void', ':io'), [@default_minus_io, ':void', @io], ':void position is respected'); is_deeply(translate(':default', ':void', ':io', ':void', ':threads'), [':void', @io, ':void', @threads], ':void (twice) position are respected'); is_deeply(translate(':default', '!', ':io'), [@default_minus_io, '!', @io], '! position is respected'); is_deeply(translate(':default', '!', ':io', '!', ':threads'), ['!', @io, '!', @threads], '! (twice) positions are respected'); is_deeply(translate(':default', '!open', '!', ':io'), [@default_minus_io, '!open', '!', grep { $_ ne 'open' } @io], '!open ! :io works as well'); sub expand { # substr is to strip "CORE::" without modifying $_ return map { substr($_, 6) } @{Fatal->_expand_tag(@_)}; } sub translate { return [Fatal->_translate_import_args(@_)]; } exec.t100755001750001750 50412547417731 13253 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 3; eval { use autodie qw(exec); exec("this_command_had_better_not_exist", 1); }; isa_ok($@,"autodie::exception", "failed execs should die"); ok($@->matches('exec'), "exception should match exec"); ok($@->matches(':system'), "exception should match :system"); fork.t100755001750001750 215412547417731 13313 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use constant TESTS => 3; BEGIN { eval { require BSD::Resource; BSD::Resource->import() }; if ($@) { plan skip_all => "BSD::Resource required to test fork()"; } } plan tests => TESTS; # This should prevent our process from being allowed to have # any children. my $rlimit_success = eval { setrlimit(RLIMIT_NPROC, 0, 0); }; SKIP: { skip("setrlimit does not allow child limiting",TESTS) if not $rlimit_success; # This should return undef quietly, as well as testing that # fork is failing. my $retval = fork(); # If our fork was successful, we had better skip out! if (defined $retval) { $retval or exit(0); # The child process should just exit. skip("fork() still creates children after setrlimit",TESTS); } eval { use autodie qw(fork); fork(); # Should die. }; if ($@) { ok(1, "autodying fork throws an exception"); isa_ok($@, 'autodie::exception', '... with the correct class'); ok($@->matches('fork'), '... which matches fork()'); } } kill.t100755001750001750 121212547417731 13277 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use autodie; use constant SYSINIT => 1; if (not CORE::kill(0,$$)) { plan skip_all => "Can't send signals to own process on this system."; } if (CORE::kill(0, SYSINIT)) { plan skip_all => "Can unexpectedly signal process 1. Won't run as root."; } plan tests => 4; eval { kill(0, $$); }; is($@, '', "Signalling self is fine"); eval { kill(0, SYSINIT ) }; isa_ok($@, 'autodie::exception', "Signalling init is not allowed."); eval { kill(0, $$, SYSINIT) }; isa_ok($@, 'autodie::exception', 'kill exception on single failure.'); is($@->return, 1, "kill fails correctly on a 'true' failure."); open.t100755001750001750 503212547417731 13311 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; use autodie; eval { open(my $fh, '<', NO_SUCH_FILE); }; ok($@, "3-arg opening non-existent file fails"); like($@, qr/for reading/, "Well-formatted 3-arg open failure"); eval { open(my $fh, "< ".NO_SUCH_FILE) }; ok($@, "2-arg opening non-existent file fails"); like($@, qr/for reading/, "Well-formatted 2-arg open failure"); unlike($@, qr/GLOB\(0x/, "No ugly globs in 2-arg open messsage"); # RT 47520. 2-argument open without mode would repeat the file # and line number. eval { use autodie; open(my $fh, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception'); like( $@, qr/at \S+ line \d+/, "At least one mention"); unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); # RT 47520-ish. 2-argument open without a mode should be marked # as 'for reading'. like($@, qr/for reading/, "Well formatted 2-arg open without mode"); # We also shouldn't get repeated messages, even if the default mode # was used. Single-arg open always falls through to the default # formatter. eval { use autodie; open( NO_SUCH_FILE . "" ); }; isa_ok($@, 'autodie::exception'); like( $@, qr/at \S+ line \d+/, "At least one mention"); unlike($@, qr/at \S+ line \d+\s+at \S+ line \d+/, "...but not too mentions"); # RT 52427. Piped open can have any many args. # Sniff to see if we can run 'true' on this system. Changes we can't # on non-Unix systems. use Config; my @true = ($^O =~ /android/ || ($Config{usecrosscompile} && $^O eq 'nto' )) ? ('sh', '-c', 'true $@', '--') : 'true'; eval { use autodie; die "Windows and VMS do not support multi-arg pipe" if $^O eq "MSWin32" or $^O eq 'VMS'; open(my $fh, '-|', @true); }; SKIP: { skip('true command or list pipe not available on this system', 1) if $@; eval { use autodie; my $fh; open $fh, "-|", @true; open $fh, "-|", @true, "foo"; open $fh, "-|", @true, "foo", "bar"; open $fh, "-|", @true, "foo", "bar", "baz"; }; is $@, '', "multi arg piped open does not fail"; } # Github 6 # Non-vanilla modes (such as <:utf8) would cause the formatter in # autodie::exception to fail. eval { use autodie; open(my $fh, '<:utf8', NO_SUCH_FILE); }; ok( $@, "Error thrown."); unlike($@, qr/Don't know how to format mode/, "No error on exotic open."); like( $@, qr/Can't open .*? with mode '<:utf8'/, "Nicer looking error."); recv.t100755001750001750 303412547417731 13307 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 8; use Socket; use autodie qw(socketpair); # All of this code is based around recv returning an empty # string when it gets data from a local machine (using AF_UNIX), # but returning an undefined value on error. Fatal/autodie # should be able to tell the difference. $SIG{PIPE} = 'IGNORE'; my ($sock1, $sock2); socketpair($sock1, $sock2, AF_UNIX, SOCK_STREAM, PF_UNSPEC); my $buffer; send($sock1, "xyz", 0); my $ret = recv($sock2, $buffer, 2, 0); use autodie qw(recv); SKIP: { skip('recv() never returns empty string with socketpair emulation',4) if ($ret); is($buffer,'xy',"recv() operational without autodie"); # Read the last byte from the socket. eval { $ret = recv($sock2, $buffer, 1, 0); }; is($@, "", "recv should not die on returning an emtpy string."); is($buffer,"z","recv() operational with autodie"); is($ret,"","recv returns undying empty string for local sockets"); } eval { my $string = "now is the time..."; open(my $fh, '<', \$string) or die("Can't open \$string for read"); # $fh isn't a socket, so this should fail. recv($fh,$buffer,1,0); }; ok($@,'recv dies on returning undef'); isa_ok($@,'autodie::exception') or diag("$@"); $buffer = "# Not an empty string\n"; # Terminate writing for $sock1 shutdown($sock1, 1); eval { use autodie qw(send); # Writing to a socket terminated for writing should fail. send($sock1,$buffer,0); }; ok($@,'send dies on returning undef'); isa_ok($@,'autodie::exception'); skip.t100644001750001750 116712547417731 13320 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use warnings; use Test::More tests => 6; use FindBin qw($Bin); use lib $Bin; use autodie_skippy; eval { autodie_skippy->fail_open() }; ok($@, "autodie_skippy throws exceptions."); isa_ok($@, 'autodie::exception', 'Autodie exceptions correct class'); is($@->package, 'main', 'Skippy classes are skipped.'); eval { autodie_unskippy->fail_open() }; ok($@, "autodie_skippy throws exceptions."); isa_ok($@, 'autodie::exception', 'Autodie exceptions correct class'); is($@->package, 'autodie_unskippy','Unskippy classes are not skipped.'); read.t100640001750001750 60712547417731 13237 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use warnings; use autodie; use Test::More tests => 2; my $buffer = 'should-not-appear'; eval { read('BOFH', $buffer, 1024); }; like($@, qr/Can't read\(BOFH, , 1024\)/, 'read should not show the buffer'); eval { read('BOFH', $buffer, 1024, 5); }; like($@, qr/Can't read\(BOFH, , 1024, 5\)/, 'read should not show the buffer'); META.yml100644001750001750 162212547417731 13167 0ustar00pjfpjf000000000000autodie-2.29--- abstract: 'Replace functions with ones that succeed or die with lexical scope' author: - 'Paul Fenwick ' build_requires: File::Copy: 0 File::Spec: 0 File::Temp: 0 FindBin: 0 IO::Handle: 0 Socket: 0 Test::More: 0 if: 0 lib: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 0 generated_by: 'Dist::Zilla version 5.037, 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: autodie recommends: IPC::System::Simple: 0.12 Sub::Identify: 0 perl: 5.010 requires: B: 0 Carp: 0 Exporter: 5.57 Fcntl: 0 POSIX: 0 Scalar::Util: 0 Tie::RefHash: 0 constant: 0 overload: 0 parent: 0 perl: 5.008004 strict: 0 warnings: 0 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie repository: git://github.com/pjf/autodie version: 2.29 MANIFEST100644001750001750 363312547417731 13053 0ustar00pjfpjf000000000000autodie-2.29# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.037. AUTHORS Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL README.md benchmarks/Fatal_Leaky_Benchmark.pm benchmarks/benchmark.pl benchmarks/call.pl benchmarks/leak.pl benchmarks/raw-call.pl cpanfile dist.ini lib/Fatal.pm lib/autodie.pm lib/autodie/Scope/Guard.pm lib/autodie/Scope/GuardStack.pm lib/autodie/Util.pm lib/autodie/exception.pm lib/autodie/exception/system.pm lib/autodie/hints.pm lib/autodie/skip.pm t/00-load.t t/Fatal.t t/args.t t/author-critic.t t/autodie.t t/autodie_skippy.pm t/autodie_test_module.pm t/backcompat.t t/basic_exceptions.t t/binmode.t t/blog_hints.t t/caller.t t/chmod.t t/chown.t t/context.t t/context_lexical.t t/core-trampoline-slurp.t t/crickey.t t/critic.t t/dbmopen.t t/eval_error.t t/exception_class.t t/exceptions.t t/exec.t t/filehandles.t t/fileno.t t/flock.t t/fork.t t/format-clobber.t t/hints.t t/hints_insist.t t/hints_pod_examples.t t/hints_provider_does.t t/hints_provider_easy_does_it.t t/hints_provider_isa.t t/import-into.t t/internal-backcompat.t t/internal.t t/kill.t t/kwalitee.t t/lethal.t t/lex58.t t/lib/Caller_helper.pm t/lib/Hints_pod_examples.pm t/lib/Hints_provider_does.pm t/lib/Hints_provider_easy_does_it.pm t/lib/Hints_provider_isa.pm t/lib/Hints_test.pm t/lib/OtherTypes.pm t/lib/Some/Module.pm t/lib/autodie/test/au.pm t/lib/autodie/test/au/exception.pm t/lib/autodie/test/badname.pm t/lib/autodie/test/missing.pm t/lib/lethal.pm t/lib/my/autodie.pm t/lib/my/pragma.pm t/lib/pujHa/ghach.pm t/lib/pujHa/ghach/Dotlh.pm t/mkdir.t t/no_carp.t t/open.t t/pod-coverage.t t/pod.t t/read.t t/recv.t t/release-pod-coverage.t t/release-pod-syntax.t t/repeat.t t/rt-74246.t t/scope_leak.t t/skip.t t/socket.t t/string-eval-basic.t t/string-eval-leak.t t/sysopen.t t/system.t t/touch_me t/truncate.t t/unlink.t t/user-context.t t/usersub.t t/utf8_open.t t/utime.t t/version.t t/version_tag.t cpanfile100644001750001750 232312547417731 13421 0ustar00pjfpjf000000000000autodie-2.29requires "B" => "0"; requires "Carp" => "0"; requires "Exporter" => "5.57"; requires "Fcntl" => "0"; requires "POSIX" => "0"; requires "Scalar::Util" => "0"; requires "Tie::RefHash" => "0"; requires "constant" => "0"; requires "overload" => "0"; requires "parent" => "0"; requires "perl" => "5.008004"; requires "strict" => "0"; requires "warnings" => "0"; recommends "IPC::System::Simple" => "0.12"; recommends "Sub::Identify" => "0"; recommends "perl" => "5.010"; on 'test' => sub { requires "File::Copy" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "FindBin" => "0"; requires "IO::Handle" => "0"; requires "Socket" => "0"; requires "Test::More" => "0"; requires "if" => "0"; requires "lib" => "0"; }; on 'test' => sub { recommends "BSD::Resource" => "0"; recommends "Import::Into" => "1.002004"; recommends "Pod::Coverage::TrustPod" => "0"; recommends "Test::Kwalitee" => "0"; recommends "Test::Perl::Critic" => "0"; recommends "perl" => "5.010"; }; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; }; on 'develop' => sub { requires "Pod::Coverage::TrustPod" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; }; META.json100644001750001750 433212547417731 13340 0ustar00pjfpjf000000000000autodie-2.29{ "abstract" : "Replace functions with ones that succeed or die with lexical scope", "author" : [ "Paul Fenwick " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.037, CPAN::Meta::Converter version 2.142060", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "autodie", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08" } }, "runtime" : { "recommends" : { "IPC::System::Simple" : "0.12", "Sub::Identify" : "0", "perl" : "5.010" }, "requires" : { "B" : "0", "Carp" : "0", "Exporter" : "5.57", "Fcntl" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Tie::RefHash" : "0", "constant" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008004", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "BSD::Resource" : "0", "Import::Into" : "1.002004", "Pod::Coverage::TrustPod" : "0", "Test::Kwalitee" : "0", "Test::Perl::Critic" : "0", "perl" : "5.010" }, "requires" : { "File::Copy" : "0", "File::Spec" : "0", "File::Temp" : "0", "FindBin" : "0", "IO::Handle" : "0", "Socket" : "0", "Test::More" : "0", "if" : "0", "lib" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie" }, "repository" : { "type" : "git", "url" : "git://github.com/pjf/autodie", "web" : "https://github.com/pjf/autodie" } }, "version" : "2.29" } README.md100644001750001750 206512547417731 13177 0ustar00pjfpjf000000000000autodie-2.29 # Fatal and autodie This distribution provides 'autodie', a lexical equivalent of 'Fatal'. This distribution REQUIRES Perl 5.8 or later to run. ## INSTALLATION As of Perl 5.10.1, autodie is bundled with Perl. To install the latest stable release, use your favourite CPAN installer: $ cpanm autodie ## DEVELOPMENT [![Build Status](https://travis-ci.org/pjf/autodie.png?branch=master)](https://travis-ci.org/pjf/autodie) autodie is hosted [on github](https://github.com/pjf/autodie). You can track and contribute to its development there. ## SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc autodie ## COPYRIGHT AND LICENCE Original module by Lionel Cons (CERN) Prototype updates by Ilya Zakharevich Lexical support and other modifications Copyright 2008-2014 by Paul Fenwick See the AUTHORS file for a complete list of authors. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Fatal.t100755001750001750 166612547417731 13410 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; use Test::More tests => 17; use Fatal qw(:io :void opendir); eval { open FOO, "<".NO_SUCH_FILE }; # Two arg open like($@, qr/^Can't open/, q{Package Fatal::open}); is(ref $@, "", "Regular fatal throws a string"); my $foo = 'FOO'; for ('$foo', "'$foo'", "*$foo", "\\*$foo") { eval qq{ open $_, '<$0' }; is($@,"", "Open using filehandle named - $_"); like(scalar(<$foo>), qr{^#!.*/perl}, "File contents using - $_"); eval qq{ close FOO }; is($@,"", "Close filehandle using - $_"); } eval { opendir FOO, NO_SUCH_FILE }; like($@, qr{^Can't open}, "Package :void Fatal::opendir"); eval { my $a = opendir FOO, NO_SUCH_FILE }; is($@, "", "Package :void Fatal::opendir in scalar context"); eval { Fatal->import(qw(print)) }; like( $@, qr{Cannot make the non-overridable builtin print fatal}, "Can't override print" ); chown.t100755001750001750 137412547417731 13473 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; use autodie; if ($^O eq 'MSWin32') { plan skip_all => 'chown() seems to always succeed on Windows'; } plan tests => 4; eval { chown(1234, 1234, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'exception thrown for chown'); # Chown returns the number of files that we chowned. So really we # should die if the return value is not equal to the number of arguments # minus two. eval { chown($<, -1, $0); }; ok(! $@, "Can chown ourselves just fine."); eval { chown($<, -1, $0, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', "Exception if ANY file changemode fails"); is($@->return, 1, "Confirm we're dying on a 'true' chown failure."); flock.t100755001750001750 527712547417731 13461 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use Fcntl qw(:flock); use POSIX qw(EWOULDBLOCK EAGAIN); use Config; require Fatal; my $EWOULDBLOCK = eval { EWOULDBLOCK() } || $Fatal::_EWOULDBLOCK{$^O} || plan skip_all => "EWOULDBLOCK not defined on this system"; my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; my $EAGAIN = eval { EAGAIN() }; my ($self_fh, $self_fh2); eval { use autodie; open($self_fh, '<', $0); open($self_fh2, '<', $0); open(SELF, '<', $0); }; if ($@) { plan skip_all => "Cannot lock this test on this system."; } my $flock_return = eval { flock($self_fh, LOCK_EX | LOCK_NB); }; if (not $flock_return) { plan skip_all => "flock on my own test not supported on this system."; } my $flock_return2 = flock($self_fh2, LOCK_EX | LOCK_NB); if ($flock_return2) { plan skip_all => "this test requires locking a file twice with ". "different filehandles to fail"; } $flock_return = flock($self_fh, LOCK_UN); if (not $flock_return) { plan skip_all => "Odd, I can't unlock a file with flock on this system."; } # If we're here, then we can lock and unlock our own file. plan 'no_plan'; ok( flock($self_fh, LOCK_EX | LOCK_NB), "Test file locked"); my $return; eval { use autodie qw(flock); $return = flock($self_fh2, LOCK_EX | LOCK_NB); }; if (!$try_EAGAIN) { is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); } else { ok($!+0 == $EWOULDBLOCK || $!+0 == $EAGAIN, "Double-flocking should be EWOULDBLOCK or EAGAIN"); } ok(!$return, "flocking a file twice should fail"); is($@, "", "Non-blocking flock should not fail on EWOULDBLOCK"); __END__ # These are old tests which I'd love to resurrect, but they need # a reliable way of getting flock to throw exceptions but with # minimal blocking. They may turn into author tests. eval { use autodie; flock($self_fh2, LOCK_EX | LOCK_NB); }; ok($@, "Locking a file twice throws an exception with vanilla autodie"); isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); unlike($@, qr/GLOB/ , "error doesn't include ugly GLOB mention"); eval { use autodie; flock(SELF, LOCK_EX | LOCK_NB); }; ok($@, "Locking a package filehanlde twice throws exception with vanilla autodie"); isa_ok($@, "autodie::exception", "Exception is from autodie::exception"); like($@, qr/LOCK_EX/, "error message contains LOCK_EX switch"); like($@, qr/LOCK_NB/, "error message contains LOCK_NB switch"); like($@, qr/SELF/ , "error mentions actual filehandle name."); hints.t100755001750001750 755412547417731 13510 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie::hints; use FindBin; use lib "$FindBin::Bin/lib"; use File::Copy qw(copy move cp mv); use Test::More 'no_plan'; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; use constant NO_SUCH_FILE2 => "this_file_had_better_not_exist_xyzzy"; use constant PERL510 => ( $] >= 5.0100 ); use constant PERL5101 => ( $] >= 5.0101 ); use constant PERL5102 => ( $] >= 5.0102 ); # File::Copy states that all subroutines return '0' on failure. # However both Windows and VMS may return other false values # (notably empty-string) on failure. This constant indicates # whether we should skip some tests because the return values # from File::Copy may not be what's in the documentation. use constant WEIRDO_FILE_COPY => ( ! PERL5102 and ( $^O eq "MSWin32" or $^O eq "VMS" )); use Hints_test qw( fail_on_empty fail_on_false fail_on_undef ); use autodie qw(fail_on_empty fail_on_false fail_on_undef); diag("Sub::Identify ", exists( $INC{'Sub/Identify.pm'} ) ? "is" : "is not", " loaded") if (! $ENV{PERL_CORE}); my $hints = "autodie::hints"; # Basic hinting tests is( $hints->sub_fullname(\©), 'File::Copy::copy' , "Id: copy" ); is( $hints->sub_fullname(\&cp), PERL5101 ? 'File::Copy::cp' : 'File::Copy::copy' , "Id: cp" ); is( $hints->sub_fullname(\&move), 'File::Copy::move' , "Id: move" ); is( $hints->sub_fullname(\&mv), PERL5101 ? 'File::Copy::mv' : 'File::Copy::move' , "Id: mv" ); if (PERL510) { ok( $hints->get_hints_for(\©)->{scalar}->(0) , "copy() hints should fail on 0 for scalars." ); ok( $hints->get_hints_for(\©)->{list}->(0) , "copy() hints should fail on 0 for lists." ); } # Scalar context test eval { use autodie qw(copy); my $scalar_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2); }; isnt("$@", "", "Copying in scalar context should throw an error."); isa_ok($@, "autodie::exception"); is($@->function, "File::Copy::copy", "Function should be original name"); SKIP: { skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) if WEIRDO_FILE_COPY; is($@->return, 0, "File::Copy returns zero on failure"); } is($@->context, "scalar", "File::Copy called in scalar context"); # List context test. eval { use autodie qw(copy); my @list_context = copy(NO_SUCH_FILE, NO_SUCH_FILE2); }; isnt("$@", "", "Copying in list context should throw an error."); isa_ok($@, "autodie::exception"); is($@->function, "File::Copy::copy", "Function should be original name"); SKIP: { skip("File::Copy is weird on Win32/VMS before 5.10.1", 1) if WEIRDO_FILE_COPY; is_deeply($@->return, [0], "File::Copy returns zero on failure"); } is($@->context, "list", "File::Copy called in list context"); # Tests on loaded funcs. my %tests = ( # Test code # Exception expected? 'fail_on_empty()' => 1, 'fail_on_empty(0)' => 0, 'fail_on_empty(undef)' => 0, 'fail_on_empty(1)' => 0, 'fail_on_false()' => 1, 'fail_on_false(0)' => 1, 'fail_on_false(undef)' => 1, 'fail_on_false(1)' => 0, 'fail_on_undef()' => 1, 'fail_on_undef(0)' => 0, 'fail_on_undef(undef)' => 1, 'fail_on_undef(1)' => 0, ); # On Perl 5.8, autodie doesn't correctly propagate into string evals. # The following snippet forces the use of autodie inside the eval if # we really really have to. For 5.10+, we don't want to include this # fix, because the tests will act as a canary if we screw up string # eval propagation. my $perl58_fix = ( $] >= 5.010 ? "" : "use autodie qw(fail_on_empty fail_on_false fail_on_undef); " ); while (my ($test, $exception_expected) = each %tests) { eval " $perl58_fix my \@array = $test; "; if ($exception_expected) { isnt("$@", "", $test); } else { is($@, "", $test); } } 1; lex58.t100755001750001750 267612547417731 13330 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use warnings; use Test::More; # We name our non-existant file in such a way that Win32 users know # it's okay that we get a warning due to Perl's "call the shell # anyway" bug. use constant NO_SUCH_FILE => "this_warning_can_be_safely_ignored"; BEGIN { eval "use IPC::System::Simple"; plan skip_all => "IPC::System::Simple required" if $@; plan skip_all => "IPC::System::Simple 0.12 required" if $IPC::System::Simple::VERSION < 0.12; } plan 'no_plan'; # These tests are designed to test very basic support for # autodie under perl 5.8. They now work, but are left in # useful simple tests. eval { use autodie qw(open); open(my $fh, '<', NO_SUCH_FILE); }; ok($@); eval { open(my $fh, '<', NO_SUCH_FILE); }; ok(! $@); eval { use autodie qw(system); system(NO_SUCH_FILE,1); }; ok($@); eval { # Because Perl *always* calls the shell under Win32, even # though mutli-arg system shouldn't, we always get a warning # (from the shell, not perl) for the line below. # # IPC::System::Simple and autodie's system() never call the # shell when called with multiple arguments. warn "\nPlease ignore the following warning, it is expected\n" if $^O eq "MSWin32"; no warnings; system(NO_SUCH_FILE,1); }; ok(! $@); { no warnings; # Disables "can't exec..." warning. # Test exotic system. eval " system { NO_SUCH_FILE } 1; "; ok(! $@); } utime.t100755001750001750 151012547417731 13470 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 4; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; use FindBin qw($Bin); use File::Spec; use constant TOUCH_ME => File::Spec->catfile($Bin, 'touch_me'); use autodie; eval { utime(undef, undef, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'exception thrown for utime'); my($atime, $mtime) = (stat TOUCH_ME)[8, 9]; eval { utime(undef, undef, TOUCH_ME); }; ok(! $@, "We can utime a file just fine.") or diag $@; eval { utime(undef, undef, NO_SUCH_FILE, TOUCH_ME); }; isa_ok($@, 'autodie::exception', 'utime exception on single failure.'); is($@->return, 1, "utime fails correctly on a 'true' failure."); # Reset timestamps so that Git doesn't think the file has changed when # running the test in the core perl distribution. utime($atime, $mtime, TOUCH_ME); chmod.t100750001750001750 170212547417731 13435 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 7; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; use constant ERROR_REGEXP => qr{Can't chmod\(0755, '${\(NO_SUCH_FILE)}'\):}; use constant SINGLE_DIGIT_ERROR_REGEXP => qr{Can't chmod\(0010, '${\(NO_SUCH_FILE)}'\):}; use autodie; # This tests RT #50423, Debian #550462 eval { chmod(0755, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'exception thrown for chmod'); like($@, ERROR_REGEXP, "Message should include numeric mode in octal form"); eval { chmod(8, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'exception thrown for chmod'); like($@, SINGLE_DIGIT_ERROR_REGEXP, "Message should include numeric mode in octal form"); eval { chmod(0755, $0); }; ok(! $@, "We can chmod ourselves just fine."); eval { chmod(0755, $0, NO_SUCH_FILE) }; isa_ok($@, 'autodie::exception', 'chmod exception on any file failure.'); is($@->return,1,"Confirm autodie on a 'true' chown failure."); mkdir.t100750001750001750 465712547417731 13465 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use FindBin qw($Bin); use constant TMPDIR => "$Bin/mkdir_test_delete_me"; use constant ERROR_REGEXP => qr{Can't mkdir\('${\(TMPDIR)}', 0777\):}; use constant SINGLE_DIGIT_ERROR_REGEXP => qr{Can't mkdir\('${\(TMPDIR)}', 0010\):}; # Delete our directory if it's there rmdir TMPDIR; # See if we can create directories and remove them mkdir TMPDIR or plan skip_all => "Failed to make test directory"; # Test the directory was created -d TMPDIR or plan skip_all => "Failed to make test directory"; # Try making it a second time (this should fail) if(mkdir TMPDIR) { plan skip_all => "Attempt to remake a directory succeeded";} # See if we can remove the directory rmdir TMPDIR or plan skip_all => "Failed to remove directory"; # Check that the directory was removed if(-d TMPDIR) { plan skip_all => "Failed to delete test directory"; } # Try to delete second time if(rmdir TMPDIR) { plan skip_all => "Able to rmdir directory twice"; } plan tests => 18; # Create a directory (this should succeed) eval { use autodie; mkdir TMPDIR; }; is($@, "", "mkdir returned success"); ok(-d TMPDIR, "Successfully created test directory"); # Try to create it again (this should fail) eval { use autodie; mkdir TMPDIR, 0777; }; ok($@, "Re-creating directory causes failure."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); ok($@->matches("mkdir"), "... it's also a mkdir object"); ok($@->matches(":filesys"), "... and a filesys object"); like($@, ERROR_REGEXP, "Message should include numeric mask in octal form"); eval { use autodie; mkdir TMPDIR, 8; }; ok($@, "Re-creating directory causes failure."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); ok($@->matches("mkdir"), "... it's also a mkdir object"); ok($@->matches(":filesys"), "... and a filesys object"); like($@, SINGLE_DIGIT_ERROR_REGEXP, "Message should include numeric mask in octal form"); # Try to delete directory (this should succeed) eval { use autodie; rmdir TMPDIR; }; is($@, "", "rmdir returned success"); ok(! -d TMPDIR, "Successfully removed test directory"); # Try to delete directory again (this should fail) eval { use autodie; rmdir TMPDIR; }; ok($@, "Re-deleting directory causes failure."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); ok($@->matches("rmdir"), "... it's also a rmdir object"); ok($@->matches(":filesys"), "... and a filesys object"); caller.t100755001750001750 134712547417731 13617 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie; use Test::More 'no_plan'; use FindBin qw($Bin); use lib "$Bin/lib"; use Caller_helper; use constant NO_SUCH_FILE => "kiwifoo_is_so_much_fun"; eval { foo(); }; isa_ok($@, 'autodie::exception'); is($@->caller, 'main::foo', "Caller should be main::foo"); sub foo { use autodie; open(my $fh, '<', NO_SUCH_FILE); } eval { Caller_helper::foo(); }; isa_ok($@, 'autodie::exception'); is($@->line, $Caller_helper::line, "External line number check"); is($@->file, $INC{"Caller_helper.pm"}, "External filename check"); is($@->package, "Caller_helper", "External package check"); is($@->caller, "Caller_helper::foo", "External subname check"); critic.t100755001750001750 52712547417731 13611 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use File::Spec; if (not $ENV{AUTHOR_TESTING}) { plan( skip_all => 'Author test. Set $ENV{AUTHOR_TESTING} to true to run.'); } eval { require Test::Perl::Critic; }; if ($@) { plan( skip_all => 'Test::Perl::Critic required for test.'); } Test::Perl::Critic->import(); all_critic_ok(); fileno.t100755001750001750 134412547417731 13626 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 8; # Basic sanity tests. is(fileno(STDIN), 0, "STDIN fileno looks sane"); is(fileno(STDOUT),1, "STDOUT looks sane"); my $dummy = "foo"; ok(!defined(fileno($dummy)), "Non-filehandles shouldn't be defined."); my $fileno = eval { use autodie qw(fileno); fileno(STDIN); }; is($@,"","fileno(STDIN) shouldn't die"); is($fileno,0,"autodying fileno(STDIN) should be 0"); $fileno = eval { use autodie qw(fileno); fileno(STDOUT); }; is($@,"","fileno(STDOUT) shouldn't die"); is($fileno,1,"autodying fileno(STDOUT) should be 1"); $fileno = eval { use autodie qw(fileno); fileno($dummy); }; isa_ok($@,"autodie::exception", 'autodying fileno($dummy) should die'); lethal.t100755001750001750 72212547417731 13602 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use FindBin; use Test::More tests => 4; use lib "$FindBin::Bin/lib"; use lethal qw(open); use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; eval { open(my $fh, '<', NO_SUCH_FILE); }; ok($@, "lethal throws an exception"); isa_ok($@, 'autodie::exception','...which is the correct class'); ok($@->matches('open'), "...which matches open"); is($@->file,__FILE__, "...which reports the correct file"); repeat.t100755001750001750 57612547417731 13620 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; eval { use autodie qw(open open open); open(my $fh, '<', NO_SUCH_FILE); }; isa_ok($@,q{autodie::exception}); ok($@->matches('open'),"Exception from open"); eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"","Repeated autodie should not leak"); socket.t100755001750001750 137612547417731 13647 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; if (not $ENV{AUTHOR_TESTING}) { plan( skip_all => 'Author test. Set $ENV{AUTHOR_TESTING} to true to run.'); } plan tests => 4; use Socket; use autodie; TODO: { local $TODO = "getprotobyname not implemented by autodie"; eval { my $x = getprotobyname('totally bogus') }; ok($@, "getprotobyname() should die when protocol look-up fails"); } my $tcp = getprotobyname('tcp'); eval { socket(my $socket, PF_INET, SOCK_STREAM, $tcp); my $bogus_address = "This isn't even formatted properly"; connect($socket, $bogus_address); }; isa_ok($@, 'autodie::exception'); ok($@->matches('connect'), "connect threw an exception"); unlike($@, qr/GLOB/, "We shouldn't show ugly GLOB(...)s ever"); touch_me100644001750001750 7112547417731 13644 0ustar00pjfpjf000000000000autodie-2.29/tFor testing utime. Contents of this file are irrelevant. unlink.t100755001750001750 321412547417731 13650 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use FindBin qw($Bin); use constant TMPFILE => "$Bin/unlink_test_delete_me"; use constant NO_SUCH_FILE => 'this_file_had_better_not_be_here_at_all'; make_file(TMPFILE); # Check that file now exists -e TMPFILE or plan skip_all => "Failed to create test file"; # Check we can unlink unlink TMPFILE; # Check it's gone if(-e TMPFILE) {plan skip_all => "Failed to delete test file: $!";} # Re-create file make_file(TMPFILE); # Check that file now exists -e TMPFILE or plan skip_all => "Failed to create test file"; plan tests => 10; # Try to delete file (this should succeed) eval { use autodie; unlink TMPFILE; }; is($@, "", "Unlink appears to have been successful"); ok(! -e TMPFILE, "File does not exist"); # Try to delete file again (this should fail) eval { use autodie; unlink TMPFILE; }; ok($@, "Re-unlinking file causes failure."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); ok($@->matches("unlink"), "... it's also a unlink object"); ok($@->matches(":filesys"), "... and a filesys object"); # Autodie should throw if we delete a LIST of files, but can only # delete some of them. make_file(TMPFILE); ok(-e TMPFILE, "Sanity: file exists"); eval { use autodie; unlink TMPFILE, NO_SUCH_FILE; }; ok($@, "Failure when trying to delete missing file in list."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); is($@->return,1, "Failure on deleting missing file but true return value"); sub make_file { open(my $fh, ">", $_[0]) or plan skip_all => "Unable to create test file $_[0]: $!"; print {$fh} "Test\n"; close $fh; } system.t100750001750001750 214612547417731 13672 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use constant NO_SUCH_FILE => 'this_file_had_so_better_not_be_here'; use Test::More; BEGIN { require Fatal; eval { require IPC::System::Simple; }; plan skip_all => 'IPC::System::Simple not installed' if ($@); if ($IPC::System::Simple::VERSION < Fatal::MIN_IPC_SYS_SIMPLE_VER()) { plan skip_all => 'IPC::System::Simple version is too low'; } } plan tests => 9; eval { use autodie qw(system); system($^X,'-e1'); }; ok($? == 0, "system completed successfully"); ok(!$@,"system returning 0 is considered fine.") or diag $@; eval { use autodie qw(system); system(NO_SUCH_FILE, "foo"); }; ok($@, "Exception thrown"); isa_ok($@, "autodie::exception") or diag $@; like($@,qr{failed to start}, "Reason for failure given"); like($@,qr{@{[NO_SUCH_FILE]}},"Failed command given"); # The error should report *this* file. See RT #38066 like($@,qr{at \Q$0\E line \d}); eval "system { \$^X} 'perl', '-e1'"; is($@,"","Exotic system in same package not harmed"); package Bar; system { $^X } 'perl','-e1'; ::ok(1,"Exotic system in other package not harmed"); 00-load.t100755001750001750 17712547417731 13471 0ustar00pjfpjf000000000000autodie-2.29/t#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Fatal' ); } # diag( "Testing Fatal $Fatal::VERSION, Perl $], $^X" ); autodie.t100755001750001750 501412547417731 14002 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use constant NO_SUCH_FILE => 'this_file_had_so_better_not_be_here'; use Test::More tests => 19; { use autodie qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@,qr{Can't open},"autodie qw(open) in lexical scope"); no autodie qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"","no autodie qw(open) in lexical scope"); use autodie qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@,qr{Can't open},"autodie qw(open) in lexical scope 2"); no autodie; # Should turn off all autodying subs eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"","no autodie in lexical scope 2"); # Turn our pragma on one last time, so we can verify that # falling out of this block reverts it back to previous # behaviour. use autodie qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@,qr{Can't open},"autodie qw(open) in lexical scope 3"); } eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"","autodie open outside of lexical scope"); eval { use autodie; # Should turn on everything open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr{Can't open}, "vanilla use autodie turns on everything."); eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"","vanilla autodie cleans up"); { use autodie qw(:io); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@,qr{Can't open},"autodie q(:io) makes autodying open"); no autodie qw(:io); eval { open(my $fh, '<', NO_SUCH_FILE); }; is($@,"", "no autodie qw(:io) disabled autodying open"); } { package Testing_autodie; use Test::More; use constant NO_SUCH_FILE => ::NO_SUCH_FILE(); use Fatal qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr{Can't open}, "Package fatal working"); is(ref $@,"","Old Fatal throws strings"); { use autodie qw(open); ok(1,"use autodie allowed with Fatal"); eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr{Can't open}, "autodie and Fatal works"); isa_ok($@, "autodie::exception"); # autodie throws real exceptions } eval { open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr{Can't open}, "Package fatal working after autodie"); is(ref $@,"","Old Fatal throws strings after autodie"); eval " no autodie qw(open); "; ok($@,"no autodie on Fataled sub an error."); eval " no autodie qw(close); use Fatal 'close'; "; like($@, qr{not allowed}, "Using fatal after autodie is an error."); } binmode.t100755001750001750 125212547417731 13765 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; # These are a bunch of general tests for working with files and # filehandles. my $r = "default"; eval { no warnings; $r = binmode(FOO); }; is($@,"","Sanity: binmode(FOO) doesn't usually throw exceptions"); is($r,undef,"Sanity: binmode(FOO) returns undef"); eval { use autodie qw(binmode); no warnings; binmode(FOO); }; ok($@, "autodie qw(binmode) should cause failing binmode to die."); isa_ok($@,"autodie::exception", "binmode exceptions are in autodie::exception"); eval { use autodie; no warnings; binmode(FOO); }; ok($@, "autodie (default) should cause failing binmode to die."); context.t100755001750001750 247212547417731 14041 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; plan 'no_plan'; sub list_return { return if @_; return qw(foo bar baz); } sub list_return2 { return if @_; return qw(foo bar baz); } # Returns a list presented to it, but also returns a single # undef if given a list of a single undef. This mimics the # behaviour of many user-defined subs and built-ins (eg: open) that # always return undef regardless of context. sub list_mirror { return undef if (@_ == 1 and not defined $_[0]); return @_; } use Fatal qw(list_return); use Fatal qw(:void list_return2); TODO: { # Clobbering context was documented as a bug in the original # Fatal, so we'll still consider it a bug here. local $TODO = "Fatal clobbers context, just like it always has."; my @list = list_return(); is_deeply(\@list,[qw(foo bar baz)],'fatal sub works in list context'); } eval { my @line = list_return(1); # Should die }; ok($@,"List return fatalised"); ### Tests where we've fatalised our function with :void ### my @list2 = list_return2(); is_deeply(\@list2,[qw(foo bar baz)],'fatal sub works in list context'); eval { my @line = list_return2(1); # Shouldn't die }; ok(! $@,"void List return fatalised survives when non-void"); eval { list_return2(1); }; ok($@,"void List return fatalised"); crickey.t100755001750001750 123312547417731 14000 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use FindBin; use Test::More 'no_plan'; use lib "$FindBin::Bin/lib"; use constant NO_SUCH_FILE => "crickey_mate_this_file_isnt_here_either"; use autodie::test::au qw(open); eval { open(my $fh, '<', NO_SUCH_FILE); }; ok(my $e = $@, 'Strewth! autodie::test::au should throw an exception on failure'); isa_ok($e, 'autodie::test::au::exception', 'Yeah mate, that should be our test exception.'); like($e, qr/time for a beer/, "Time for a beer mate?"); like( eval { $e->time_for_a_beer; }, qr/time for a beer/, "It's always a good time for a beer." ); ok($e->matches('open'), "Should be a fair dinkum error from open"); no_carp.t100755001750001750 30312547417731 13745 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w # Test that autodie doesn't pollute the caller with carp and croak. use strict; use Test::More tests => 2; use autodie; ok !defined &main::carp; ok !defined &main::croak; sysopen.t100755001750001750 70212547417731 14027 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; use Fcntl; use autodie qw(sysopen); use constant NO_SUCH_FILE => "this_file_had_better_not_be_here_at_all"; my $fh; eval { sysopen($fh, $0, O_RDONLY); }; is($@, "", "sysopen can open files that exist"); like(scalar( <$fh> ), qr/perl/, "Data in file read"); eval { sysopen(my $fh2, NO_SUCH_FILE, O_RDONLY); }; isa_ok($@, 'autodie::exception', 'Opening a bad file fails with sysopen'); usersub.t100755001750001750 244112547417731 14041 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; sub mytest { return $_[0]; } is(mytest(q{foo}),q{foo},"Mytest returns input"); my $return = eval { mytest(undef); }; ok(!defined($return), "mytest returns undef without autodie"); is($@,"","Mytest doesn't throw an exception without autodie"); $return = eval { use autodie qw(mytest); mytest('foo'); }; is($return,'foo',"Mytest returns input with autodie"); is($@,"","No error should be thrown"); $return = eval { use autodie qw(mytest); mytest(undef); }; isa_ok($@,'autodie::exception',"autodie mytest/undef throws exception"); # We set initial values here because we're expecting $data to be # changed to undef later on. Having it as undef to begin with means # we can't see mytest(undef) working correctly. my ($data, $data2) = (1,1); eval { use autodie qw(mytest); { no autodie qw(mytest); $data = mytest(undef); $data2 = mytest('foo'); } }; is($@,"","no autodie can counter use autodie for user subs"); ok(!defined($data), "mytest(undef) should return undef"); is($data2, "foo", "mytest(foo) should return foo"); eval { mytest(undef); }; is($@,"","No lingering failure effects"); $return = eval { mytest("bar"); }; is($return,"bar","No lingering return effects"); version.t100755001750001750 176312547417731 14044 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; if (not $ENV{RELEASE_TESTING}) { plan( skip_all => 'Release test. Set $ENV{RELEASE_TESTING} to true to run.'); } plan tests => 8; # For the moment, we'd like all our versions to be the same. # In order to play nicely with some code scanners, they need to be # hard-coded into the files, rather than just nicking the version # from autodie::exception at run-time. require Fatal; require autodie; require autodie::hints; require autodie::exception; require autodie::exception::system; ok(defined($autodie::VERSION), 'autodie has a version'); ok(defined($autodie::exception::VERSION), 'autodie::exception has a version'); ok(defined($autodie::hints::VERSION), 'autodie::hints has a version'); ok(defined($Fatal::VERSION), 'Fatal has a version'); is($Fatal::VERSION, $autodie::VERSION); is($autodie::VERSION, $autodie::exception::VERSION); is($autodie::exception::VERSION, $autodie::exception::system::VERSION); is($Fatal::VERSION, $autodie::hints::VERSION); dbmopen.t100750001750001750 226312547417731 13772 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 9; use constant ERROR_REGEXP => qr{Can't dbmopen\(%hash, 'foo/bar/baz', 0666\):}; use constant SINGLE_DIGIT_ERROR_REGEXP => qr{Can't dbmopen\(%hash, 'foo/bar/baz', 0010\):}; my $return = "default"; eval { $return = dbmopen(my %foo, "foo/bar/baz", 0666); }; ok(!$return, "Sanity: dbmopen usually returns false on failure"); ok(!$@, "Sanity: dbmopen doesn't usually throw exceptions"); eval { use autodie; dbmopen(my %foo, "foo/bar/baz", 0666); }; ok($@, "autodie allows dbmopen to throw errors."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); like($@, ERROR_REGEXP, "Message should include number in octal, not decimal"); eval { use autodie; dbmopen(my %foo, "foo/bar/baz", 8); }; ok($@, "autodie allows dbmopen to throw errors."); isa_ok($@, "autodie::exception", "... errors are of the correct type"); like($@, SINGLE_DIGIT_ERROR_REGEXP, "Message should include number in octal, not decimal"); eval { use autodie; my %bar = ( foo => 1, bar => 2 ); dbmopen(%bar, "foo/bar/baz", 0666); }; like($@, ERROR_REGEXP, "Correct formatting even with non-empty dbmopen hash"); Makefile.PL100644001750001750 357612547417731 13702 0ustar00pjfpjf000000000000autodie-2.29# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.037. use strict; use warnings; use 5.008004; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Replace functions with ones that succeed or die with lexical scope", "AUTHOR" => "Paul Fenwick ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "autodie", "EXE_FILES" => [], "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008004", "NAME" => "autodie", "PREREQ_PM" => { "B" => 0, "Carp" => 0, "Exporter" => "5.57", "Fcntl" => 0, "POSIX" => 0, "Scalar::Util" => 0, "Tie::RefHash" => 0, "constant" => 0, "overload" => 0, "parent" => 0, "strict" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "File::Copy" => 0, "File::Spec" => 0, "File::Temp" => 0, "FindBin" => 0, "IO::Handle" => 0, "Socket" => 0, "Test::More" => 0, "if" => 0, "lib" => 0 }, "VERSION" => "2.29", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "B" => 0, "Carp" => 0, "Exporter" => "5.57", "ExtUtils::MakeMaker" => 0, "Fcntl" => 0, "File::Copy" => 0, "File::Spec" => 0, "File::Temp" => 0, "FindBin" => 0, "IO::Handle" => 0, "POSIX" => 0, "Scalar::Util" => 0, "Socket" => 0, "Test::More" => 0, "Tie::RefHash" => 0, "constant" => 0, "if" => 0, "lib" => 0, "overload" => 0, "parent" => 0, "strict" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{INSTALLDIRS} = 'perl' if $] >= 5.00307 && $] <= 5.011000; WriteMakefile(%WriteMakefileArgs); lib000755001750001750 012547417731 12323 5ustar00pjfpjf000000000000autodie-2.29Fatal.pm100640001750001750 16150012547417731 14107 0ustar00pjfpjf000000000000autodie-2.29/libpackage Fatal; # ABSTRACT: Replace functions with equivalents which succeed or die use 5.008; # 5.8.x needed for autodie use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs use Config; use Scalar::Util qw(set_prototype); use autodie::Util qw( fill_protos install_subs make_core_trampoline on_end_of_compile_scope ); use constant PERL510 => ( $] >= 5.010 ); use constant LEXICAL_TAG => q{:lexical}; use constant VOID_TAG => q{:void}; use constant INSIST_TAG => q{!}; # Keys for %Cached_fatalised_sub (used in 3rd level) use constant CACHE_AUTODIE_LEAK_GUARD => 0; use constant CACHE_FATAL_WRAPPER => 1; use constant CACHE_FATAL_VOID => 2; use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; use constant ERROR_NOHINTS => "No user hints defined for %s"; use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; # Older versions of IPC::System::Simple don't support all the # features we need. use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; # EWOULDBLOCK values for systems that don't supply their own. # Even though this is defined with our, that's to help our # test code. Please don't rely upon this variable existing in # the future. our %_EWOULDBLOCK = ( MSWin32 => 33, ); $Carp::CarpInternal{'Fatal'} = 1; $Carp::CarpInternal{'autodie'} = 1; $Carp::CarpInternal{'autodie::exception'} = 1; # the linux parisc port has separate EAGAIN and EWOULDBLOCK, # and the kernel returns EAGAIN my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; # We have some tags that can be passed in for use with import. # These are all assumed to be CORE:: my %TAGS = ( ':io' => [qw(:dbm :file :filesys :ipc :socket read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl binmode ioctl truncate)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir symlink rmdir readlink chmod chown utime)], ':ipc' => [qw(:msg :semaphore :shm pipe kill)], ':msg' => [qw(msgctl msgget msgrcv msgsnd)], ':threads' => [qw(fork)], ':semaphore'=>[qw(semctl semget semop)], ':shm' => [qw(shmctl shmget shmread)], ':system' => [qw(system exec)], # Can we use qw(getpeername getsockname)? What do they do on failure? # TODO - Can socket return false? ':socket' => [qw(accept bind connect getsockopt listen recv send setsockopt shutdown socketpair)], # Our defaults don't include system(), because it depends upon # an optional module, and it breaks the exotic form. # # This *may* change in the future. I'd love IPC::System::Simple # to be a dependency rather than a recommendation, and hence for # system() to be autodying by default. ':default' => [qw(:io :threads)], # Everything in v2.07 and before. This was :default less chmod and chown ':v207' => [qw(:threads :dbm :socket read seek sysread syswrite sysseek open close flock sysopen fcntl fileno binmode ioctl truncate opendir closedir chdir link unlink rename mkdir symlink rmdir readlink umask :msg :semaphore :shm pipe)], # Chmod was added in 2.13 ':v213' => [qw(:v207 chmod)], # chown, utime, kill were added in 2.14 ':v214' => [qw(:v213 chown utime kill)], # umask was removed in 2.26 ':v225' => [qw(:io :threads umask fileno)], # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. ':1.994' => [qw(:v207)], ':1.995' => [qw(:v207)], ':1.996' => [qw(:v207)], ':1.997' => [qw(:v207)], ':1.998' => [qw(:v207)], ':1.999' => [qw(:v207)], ':1.999_01' => [qw(:v207)], ':2.00' => [qw(:v207)], ':2.01' => [qw(:v207)], ':2.02' => [qw(:v207)], ':2.03' => [qw(:v207)], ':2.04' => [qw(:v207)], ':2.05' => [qw(:v207)], ':2.06' => [qw(:v207)], ':2.06_01' => [qw(:v207)], ':2.07' => [qw(:v207)], # Last release without chmod ':2.08' => [qw(:v213)], ':2.09' => [qw(:v213)], ':2.10' => [qw(:v213)], ':2.11' => [qw(:v213)], ':2.12' => [qw(:v213)], ':2.13' => [qw(:v213)], # Last release without chown ':2.14' => [qw(:v225)], ':2.15' => [qw(:v225)], ':2.16' => [qw(:v225)], ':2.17' => [qw(:v225)], ':2.18' => [qw(:v225)], ':2.19' => [qw(:v225)], ':2.20' => [qw(:v225)], ':2.21' => [qw(:v225)], ':2.22' => [qw(:v225)], ':2.23' => [qw(:v225)], ':2.24' => [qw(:v225)], ':2.25' => [qw(:v225)], ':2.26' => [qw(:default)], ':2.27' => [qw(:default)], ':2.28' => [qw(:default)], ':2.29' => [qw(:default)], ); { # Expand :all immediately by expanding and flattening all tags. # _expand_tag is not really optimised for expanding the ":all" # case (i.e. keys %TAGS, or values %TAGS for that matter), so we # just do it here. # # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being # pre-expanded. my %seen; my @all = grep { !/^:/ && !$seen{$_}++ } map { @{$_} } values %TAGS; $TAGS{':all'} = \@all; } # This hash contains subroutines for which we should # subroutine() // die() rather than subroutine() || die() my %Use_defined_or; # CORE::open returns undef on failure. It can legitimately return # 0 on success, eg: open(my $fh, '-|') || exec(...); @Use_defined_or{qw( CORE::fork CORE::recv CORE::send CORE::open CORE::fileno CORE::read CORE::readlink CORE::sysread CORE::syswrite CORE::sysseek CORE::umask )} = (); # Some functions can return true because they changed *some* things, but # not all of them. This is a list of offending functions, and how many # items to subtract from @_ to determine the "success" value they return. my %Returns_num_things_changed = ( 'CORE::chmod' => 1, 'CORE::chown' => 2, 'CORE::kill' => 1, # TODO: Could this return anything on negative args? 'CORE::unlink' => 0, 'CORE::utime' => 2, ); # Optional actions to take on the return value before returning it. my %Retval_action = ( "CORE::open" => q{ # apply the open pragma from our caller if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { # Get the caller's hint hash my $hints = (caller 0)[10]; # Decide if we're reading or writing and apply the appropriate encoding # These keys are undocumented. # Match what PerlIO_context_layers() does. Read gets the read layer, # everything else gets the write layer. my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; # Apply the encoding, if any. if( $encoding ) { binmode $_[0], $encoding; } } }, "CORE::sysopen" => q{ # apply the open pragma from our caller if( defined $retval ) { # Get the caller's hint hash my $hints = (caller 0)[10]; require Fcntl; # Decide if we're reading or writing and apply the appropriate encoding. # Match what PerlIO_context_layers() does. Read gets the read layer, # everything else gets the write layer. my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; # Apply the encoding, if any. if( $encoding ) { binmode $_[0], $encoding; } } }, ); my %reusable_builtins; # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can # take file and directory handles, which are package depedent." # # You would be correct, except that prototype() returns signatures which don't # allow for passing of globs, and nobody's complained about that. You can # still use \*FILEHANDLE, but that results in a reference coming through, # and it's already pointing to the filehandle in the caller's packge, so # it's all okay. @reusable_builtins{qw( CORE::fork CORE::kill CORE::truncate CORE::chdir CORE::link CORE::unlink CORE::rename CORE::mkdir CORE::symlink CORE::rmdir CORE::readlink CORE::umask CORE::chmod CORE::chown CORE::utime CORE::msgctl CORE::msgget CORE::msgrcv CORE::msgsnd CORE::semctl CORE::semget CORE::semop CORE::shmctl CORE::shmget CORE::shmread CORE::exec CORE::system )} = (); # Cached_fatalised_sub caches the various versions of our # fatalised subs as they're produced. This means we don't # have to build our own replacement of CORE::open and friends # for every single package that wants to use them. my %Cached_fatalised_sub = (); # Every time we're called with package scope, we record the subroutine # (including package or CORE::) in %Package_Fatal. This allows us # to detect illegal combinations of autodie and Fatal, and makes sure # we don't accidently make a Fatal function autodying (which isn't # very useful). my %Package_Fatal = (); # The first time we're called with a user-sub, we cache it here. # In the case of a "no autodie ..." we put back the cached copy. my %Original_user_sub = (); # Is_fatalised_sub simply records a big map of fatalised subroutine # refs. It means we can avoid repeating work, or fatalising something # we've already processed. my %Is_fatalised_sub = (); tie %Is_fatalised_sub, 'Tie::RefHash'; # Our trampoline cache allows us to cache trampolines which are used to # bounce leaked wrapped core subroutines to their actual core counterparts. my %Trampoline_cache; # A cache mapping "CORE::" to their prototype. Turns out that if # you "use autodie;" enough times, this pays off. my %CORE_prototype_cache; # We use our package in a few hash-keys. Having it in a scalar is # convenient. The "guard $PACKAGE" string is used as a key when # setting up lexical guards. my $PACKAGE = __PACKAGE__; my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' # Here's where all the magic happens when someone write 'use Fatal' # or 'use autodie'. sub import { my $class = shift(@_); my @original_args = @_; my $void = 0; my $lexical = 0; my $insist_hints = 0; my ($pkg, $filename) = caller(); @_ or return; # 'use Fatal' is a no-op. # If we see the :lexical flag, then _all_ arguments are # changed lexically if ($_[0] eq LEXICAL_TAG) { $lexical = 1; shift @_; # It is currently an implementation detail that autodie is # implemented as "use Fatal qw(:lexical ...)". For backwards # compatibility, we allow it - but not without a warning. # NB: Optimise for autodie as it is quite possibly the most # freq. consumer of this case. if ($class ne 'autodie' and not $class->isa('autodie')) { if ($class eq 'Fatal') { warnings::warnif( 'deprecated', '[deprecated] The "use Fatal qw(:lexical ...)" ' . 'should be replaced by "use autodie qw(...)". ' . 'Seen' # warnif appends " at <...>" ); } else { warnings::warnif( 'deprecated', "[deprecated] The class/Package $class is a " . 'subclass of Fatal and used the :lexical. ' . 'If $class provides lexical error checking ' . 'it should extend autodie instead of using :lexical. ' . 'Seen' # warnif appends " at <...>" ); } # "Promote" the call to autodie from here on. This is # already mostly the case (e.g. use Fatal qw(:lexical ...) # would throw autodie::exceptions on error rather than the # Fatal errors. $class = 'autodie'; # This requires that autodie is in fact loaded; otherwise # the "$class->X()" method calls below will explode. require autodie; # TODO, when autodie and Fatal are cleanly separated, we # should go a "goto &autodie::import" here instead. } # If we see no arguments and :lexical, we assume they # wanted ':default'. if (@_ == 0) { push(@_, ':default'); } # Don't allow :lexical with :void, it's needlessly confusing. if ( grep { $_ eq VOID_TAG } @_ ) { croak(ERROR_VOID_LEX); } } if ( grep { $_ eq LEXICAL_TAG } @_ ) { # If we see the lexical tag as the non-first argument, complain. croak(ERROR_LEX_FIRST); } my @fatalise_these = @_; # These subs will get unloaded at the end of lexical scope. my %unload_later; # These subs are to be installed into callers namespace. my %install_subs; # Use _translate_import_args to expand tags for us. It will # pass-through unknown tags (i.e. we have to manually handle # VOID_TAG). # # NB: _translate_import_args re-orders everything for us, so # we don't have to worry about stuff like: # # :default :void :io # # That will (correctly) translated into # # expand(:defaults-without-io) :void :io # # by _translate_import_args. for my $func ($class->_translate_import_args(@fatalise_these)) { if ($func eq VOID_TAG) { # When we see :void, set the void flag. $void = 1; } elsif ($func eq INSIST_TAG) { $insist_hints = 1; } else { # Otherwise, fatalise it. # Check to see if there's an insist flag at the front. # If so, remove it, and insist we have hints for this sub. my $insist_this = $insist_hints; if (substr($func, 0, 1) eq '!') { $func = substr($func, 1); $insist_this = 1; } # We're going to make a subroutine fatalistic. # However if we're being invoked with 'use Fatal qw(x)' # and we've already been called with 'no autodie qw(x)' # in the same scope, we consider this to be an error. # Mixing Fatal and autodie effects was considered to be # needlessly confusing on p5p. my $sub = $func; $sub = "${pkg}::$sub" unless $sub =~ /::/; # If we're being called as Fatal, and we've previously # had a 'no X' in scope for the subroutine, then complain # bitterly. if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); } # We're not being used in a confusing way, so make # the sub fatal. Note that _make_fatal returns the # old (original) version of the sub, or undef for # built-ins. my $sub_ref = $class->_make_fatal( $func, $pkg, $void, $lexical, $filename, $insist_this, \%install_subs, ); $Original_user_sub{$sub} ||= $sub_ref; # If we're making lexical changes, we need to arrange # for them to be cleaned at the end of our scope, so # record them here. $unload_later{$func} = $sub_ref if $lexical; } } install_subs($pkg, \%install_subs); if ($lexical) { # Dark magic to have autodie work under 5.8 # Copied from namespace::clean, that copied it from # autobox, that found it on an ancient scroll written # in blood. # This magic bit causes %^H to be lexically scoped. $^H |= 0x020000; # Our package guard gets invoked when we leave our lexical # scope. on_end_of_compile_scope(sub { install_subs($pkg, \%unload_later); }); # To allow others to determine when autodie was in scope, # and with what arguments, we also set a %^H hint which # is how we were called. # This feature should be considered EXPERIMENTAL, and # may change without notice. Please e-mail pjf@cpan.org # if you're actually using it. $^H{autodie} = "$PACKAGE @original_args"; } return; } sub unimport { my $class = shift; # Calling "no Fatal" must start with ":lexical" if ($_[0] ne LEXICAL_TAG) { croak(sprintf(ERROR_NO_LEX,$class)); } shift @_; # Remove :lexical my $pkg = (caller)[0]; # If we've been called with arguments, then the developer # has explicitly stated 'no autodie qw(blah)', # in which case, we disable Fatalistic behaviour for 'blah'. my @unimport_these = @_ ? @_ : ':all'; my (%uninstall_subs, %reinstall_subs); for my $symbol ($class->_translate_import_args(@unimport_these)) { my $sub = $symbol; $sub = "${pkg}::$sub" unless $sub =~ /::/; # If 'blah' was already enabled with Fatal (which has package # scope) then, this is considered an error. if (exists $Package_Fatal{$sub}) { croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); } # Record 'no autodie qw($sub)' as being in effect. # This is to catch conflicting semantics elsewhere # (eg, mixing Fatal with no autodie) $^H{$NO_PACKAGE}{$sub} = 1; # Record the current sub to be reinstalled at end of scope # and then restore the original (can be undef for "CORE::" # subs) $reinstall_subs{$symbol} = \&$sub; $uninstall_subs{$symbol} = $Original_user_sub{$sub}; } install_subs($pkg, \%uninstall_subs); on_end_of_compile_scope(sub { install_subs($pkg, \%reinstall_subs); }); return; } sub _translate_import_args { my ($class, @args) = @_; my @result; my %seen; if (@args < 2) { # Optimize for this case, as it is fairly common. (e.g. use # autodie; or use autodie qw(:all); both trigger this). return unless @args; # Not a (known) tag, pass through. return @args unless exists($TAGS{$args[0]}); # Strip "CORE::" from all elements in the list as import and # unimport does not handle the "CORE::" prefix too well. # # NB: we use substr as it is faster than s/^CORE::// and # it does not change the elements. return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; } # We want to translate # # :default :void :io # # into (pseudo-ish): # # expanded(:threads) :void expanded(:io) # # We accomplish this by "reverse, expand + filter, reverse". for my $a (reverse(@args)) { if (exists $TAGS{$a}) { my $expanded = $class->_expand_tag($a); push(@result, # Remove duplicates after ... grep { !$seen{$_}++ } # we have stripped CORE:: (see above) map { substr($_, 6) } # We take the elements in reverse order # (as @result be reversed later). reverse(@{$expanded})); } else { # pass through - no filtering here for tags. # # The reason for not filtering tags cases like: # # ":default :void :io :void :threads" # # As we have reversed args, we see this as: # # ":threads :void :io :void* :default*" # # (Entries marked with "*" will be filtered out completely). When # reversed again, this will be: # # ":io :void :threads" # # But we would rather want it to be: # # ":void :io :threads" or ":void :io :void :threads" # my $letter = substr($a, 0, 1); if ($letter ne ':' && $a ne INSIST_TAG) { next if $seen{$a}++; if ($letter eq '!' and $seen{substr($a, 1)}++) { my $name = substr($a, 1); # People are being silly and doing: # # use autodie qw(!a a); # # Enjoy this little O(n) clean up... @result = grep { $_ ne $name } @result; } } push @result, $a; } } # Reverse the result to restore the input order return reverse(@result); } # NB: Perl::Critic's dump-autodie-tag-contents depends upon this # continuing to work. { # We assume that $TAGS{':all'} is pre-expanded and just fill it in # from the beginning. my %tag_cache = ( 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], ); # Expand a given tag (e.g. ":default") into a listref containing # all sub names covered by that tag. Each sub is returned as # "CORE::" (i.e. "CORE::open" rather than "open"). # # NB: the listref must not be modified. sub _expand_tag { my ($class, $tag) = @_; if (my $cached = $tag_cache{$tag}) { return $cached; } if (not exists $TAGS{$tag}) { croak "Invalid exception class $tag"; } my @to_process = @{$TAGS{$tag}}; # If the tag is basically an alias of another tag (like e.g. ":2.11"), # then just share the resulting reference with the original content (so # we only pay for an extra reference for the alias memory-wise). if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { # We could do this for "non-tags" as well, but that only occurs # once at the time of writing (":threads" => ["fork"]), so # probably not worth it. my $expanded = $class->_expand_tag($to_process[0]); $tag_cache{$tag} = $expanded; return $expanded; } my %seen = (); my @taglist = (); for my $item (@to_process) { # substr is more efficient than m/^:/ for stuff like this, # at the price of being a bit more verbose/low-level. if (substr($item, 0, 1) eq ':') { # Use recursion here to ensure we expand a tag at most once. my $expanded = $class->_expand_tag($item); push @taglist, grep { !$seen{$_}++ } @{$expanded}; } else { my $subname = "CORE::$item"; push @taglist, $subname unless $seen{$subname}++; } } $tag_cache{$tag} = \@taglist; return \@taglist; } } # This is a backwards compatible version of _write_invocation. It's # recommended you don't use it. sub write_invocation { my ($core, $call, $name, $void, @args) = @_; return Fatal->_write_invocation( $core, $call, $name, $void, 0, # Lexical flag undef, # Sub, unused in legacy mode undef, # Subref, unused in legacy mode. @args ); } # This version of _write_invocation is used internally. It's not # recommended you call it from external code, as the interface WILL # change in the future. sub _write_invocation { my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; if (@argvs == 1) { # No optional arguments my @argv = @{$argvs[0]}; shift @argv; return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); } else { my $else = "\t"; my (@out, @argv, $n); while (@argvs) { @argv = @{shift @argvs}; $n = shift @argv; my $condition = "\@_ == $n"; if (@argv and $argv[-1] =~ /[#@]_/) { # This argv ends with '@' in the prototype, so it matches # any number of args >= the number of expressions in the # argv. $condition = "\@_ >= $n"; } push @out, "${else}if ($condition) {\n"; $else = "\t} els"; push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); } push @out, qq[ } die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; ]; return join '', @out; } } # This is a slim interface to ensure backward compatibility with # anyone doing very foolish things with old versions of Fatal. sub one_invocation { my ($core, $call, $name, $void, @argv) = @_; return Fatal->_one_invocation( $core, $call, $name, $void, undef, # Sub. Unused in back-compat mode. 1, # Back-compat flag undef, # Subref, unused in back-compat mode. @argv ); } # This is the internal interface that generates code. # NOTE: This interface WILL change in the future. Please do not # call this subroutine directly. # TODO: Whatever's calling this code has already looked up hints. Pass # them in, rather than look them up a second time. sub _one_invocation { my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; # If someone is calling us directly (a child class perhaps?) then # they could try to mix void without enabling backwards # compatibility. We just don't support this at all, so we gripe # about it rather than doing something unwise. if ($void and not $back_compat) { Carp::confess("Internal error: :void mode not supported with $class"); } # @argv only contains the results of the in-built prototype # function, and is therefore safe to interpolate in the # code generators below. # TODO - The following clobbers context, but that's what the # old Fatal did. Do we care? if ($back_compat) { # Use Fatal qw(system) will never be supported. It generated # a compile-time error with legacy Fatal, and there's no reason # to support it when autodie does a better job. if ($call eq 'CORE::system') { return q{ croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); }; } local $" = ', '; if ($void) { return qq/return (defined wantarray)?$call(@argv): $call(@argv) || Carp::croak("Can't $name(\@_)/ . ($core ? ': $!' : ', \$! is \"$!\"') . '")' } else { return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . ($core ? ': $!' : ', \$! is \"$!\"') . '")'; } } # The name of our original function is: # $call if the function is CORE # $sub if our function is non-CORE # The reason for this is that $call is what we're actually # calling. For our core functions, this is always # CORE::something. However for user-defined subs, we're about to # replace whatever it is that we're calling; as such, we actually # calling a subroutine ref. my $human_sub_name = $core ? $call : $sub; # Should we be testing to see if our result is defined, or # just true? my $use_defined_or; my $hints; # All user-sub hints, including list hints. if ( $core ) { # Core hints are built into autodie. $use_defined_or = exists ( $Use_defined_or{$call} ); } else { # User sub hints are looked up using autodie::hints, # since users may wish to add their own hints. require autodie::hints; $hints = autodie::hints->get_hints_for( $sref ); # We'll look up the sub's fullname. This means we # get better reports of where it came from in our # error messages, rather than what imported it. $human_sub_name = autodie::hints->sub_fullname( $sref ); } # Checks for special core subs. if ($call eq 'CORE::system') { # Leverage IPC::System::Simple if we're making an autodying # system. local $" = ", "; # We need to stash $@ into $E, rather than using # local $@ for the whole sub. If we don't then # any exceptions from internal errors in autodie/Fatal # will mysteriously disappear before propagating # upwards. return qq{ my \$retval; my \$E; { local \$@; eval { \$retval = IPC::System::Simple::system(@argv); }; \$E = \$@; } if (\$E) { # TODO - This can't be overridden in child # classes! die autodie::exception::system->new( function => q{CORE::system}, args => [ @argv ], message => "\$E", errno => \$!, ); } return \$retval; }; } local $" = ', '; # If we're going to throw an exception, here's the code to use. my $die = qq{ die $class->throw( function => q{$human_sub_name}, args => [ @argv ], pragma => q{$class}, errno => \$!, context => \$context, return => \$retval, eval_error => \$@ ) }; if ($call eq 'CORE::flock') { # flock needs special treatment. When it fails with # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just # means we couldn't get the lock right now. require POSIX; # For POSIX::EWOULDBLOCK local $@; # Don't blat anyone else's $@. # Ensure that our vendor supports EWOULDBLOCK. If they # don't (eg, Windows), then we use known values for its # equivalent on other systems. my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } || $_EWOULDBLOCK{$^O} || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); my $EAGAIN = $EWOULDBLOCK; if ($try_EAGAIN) { $EAGAIN = eval { POSIX::EAGAIN(); } || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); } require Fcntl; # For Fcntl::LOCK_NB return qq{ my \$context = wantarray() ? "list" : "scalar"; # Try to flock. If successful, return it immediately. my \$retval = $call(@argv); return \$retval if \$retval; # If we failed, but we're using LOCK_NB and # returned EWOULDBLOCK, it's not a real error. if (\$_[1] & Fcntl::LOCK_NB() and (\$! == $EWOULDBLOCK or ($try_EAGAIN and \$! == $EAGAIN ))) { return \$retval; } # Otherwise, we failed. Die noisily. $die; }; } if (exists $Returns_num_things_changed{$call}) { # Some things return the number of things changed (like # chown, kill, chmod, etc). We only consider these successful # if *all* the things are changed. return qq[ my \$num_things = \@_ - $Returns_num_things_changed{$call}; my \$retval = $call(@argv); if (\$retval != \$num_things) { # We need \$context to throw an exception. # It's *always* set to scalar, because that's how # autodie calls chown() above. my \$context = "scalar"; $die; } return \$retval; ]; } # AFAIK everything that can be given an unopned filehandle # will fail if it tries to use it, so we don't really need # the 'unopened' warning class here. Especially since they # then report the wrong line number. # Other warnings are disabled because they produce excessive # complaints from smart-match hints under 5.10.1. my $code = qq[ no warnings qw(unopened uninitialized numeric); no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; if (wantarray) { my \@results = $call(@argv); my \$retval = \\\@results; my \$context = "list"; ]; my $retval_action = $Retval_action{$call} || ''; if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { # NB: Subroutine hints are passed as a full list. # This differs from the 5.10.0 smart-match behaviour, # but means that context unaware subroutines can use # the same hints in both list and scalar context. $code .= qq{ if ( \$hints->{list}->(\@results) ) { $die }; }; } elsif ( PERL510 and $hints ) { $code .= qq{ if ( \@results ~~ \$hints->{list} ) { $die }; }; } elsif ( $hints ) { croak sprintf(ERROR_58_HINTS, 'list', $sub); } else { $code .= qq{ # An empty list, or a single undef is failure if (! \@results or (\@results == 1 and ! defined \$results[0])) { $die; } } } # Tidy up the end of our wantarray call. $code .= qq[ return \@results; } ]; # Otherwise, we're in scalar context. # We're never in a void context, since we have to look # at the result. $code .= qq{ my \$retval = $call(@argv); my \$context = "scalar"; }; if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { # We always call code refs directly, since that always # works in 5.8.x, and always works in 5.10.1 return $code .= qq{ if ( \$hints->{scalar}->(\$retval) ) { $die }; $retval_action return \$retval; }; } elsif (PERL510 and $hints) { return $code . qq{ if ( \$retval ~~ \$hints->{scalar} ) { $die }; $retval_action return \$retval; }; } elsif ( $hints ) { croak sprintf(ERROR_58_HINTS, 'scalar', $sub); } return $code . ( $use_defined_or ? qq{ $die if not defined \$retval; $retval_action return \$retval; } : qq{ $retval_action return \$retval || $die; } ) ; } # This returns the old copy of the sub, so we can # put it back at end of scope. # TODO : Check to make sure prototypes are restored correctly. # TODO: Taking a huge list of arguments is awful. Rewriting to # take a hash would be lovely. # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 sub _make_fatal { my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); my $ini = $sub; my $name = $sub; if (index($sub, '::') == -1) { $sub = "${pkg}::$sub"; if (substr($name, 0, 1) eq '&') { $name = substr($name, 1); } } else { $name =~ s/.*:://; } # Figure if we're using lexical or package semantics and # twiddle the appropriate bits. if (not $lexical) { $Package_Fatal{$sub} = 1; } # TODO - We *should* be able to do skipping, since we know when # we've lexicalised / unlexicalised a subroutine. warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; if (defined(&$sub)) { # user subroutine # NOTE: Previously we would localise $@ at this point, so # the following calls to eval {} wouldn't interfere with anything # that's already in $@. Unfortunately, it would also stop # any of our croaks from triggering(!), which is even worse. # This could be something that we've fatalised that # was in core. # Store the current sub in case we need to restore it. $sref = \&$sub; if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { # Something we previously made Fatal that was core. # This is safe to replace with an autodying to core # version. $core = 1; $call = "CORE::$name"; $proto = $CORE_prototype_cache{$call}; # We return our $sref from this subroutine later # on, indicating this subroutine should be placed # back when we're finished. } else { # If this is something we've already fatalised or played with, # then look-up the name of the original sub for the rest of # our processing. if (exists($Is_fatalised_sub{$sref})) { # $sub is one of our wrappers around a CORE sub or a # user sub. Instead of wrapping our wrapper, lets just # generate a new wrapper for the original sub. # - NB: the current wrapper might be for a different class # than the one we are generating now (e.g. some limited # mixing between use Fatal + use autodie can occur). # - Even for nested autodie, we need this as the leak guards # differ. my $s = $Is_fatalised_sub{$sref}; if (defined($s)) { # It is a wrapper for a user sub $sub = $s; } else { # It is a wrapper for a CORE:: sub $core = 1; $call = "CORE::$name"; $proto = $CORE_prototype_cache{$call}; } } # A regular user sub, or a user sub wrapping a # core sub. if (!$core) { # A non-CORE sub might have hints and such... $proto = prototype($sref); $call = '&$sref'; require autodie::hints; $hints = autodie::hints->get_hints_for( $sref ); # If we've insisted on hints, but don't have them, then # bail out! if ($insist and not $hints) { croak(sprintf(ERROR_NOHINTS, $name)); } # Otherwise, use the default hints if we don't have # any. $hints ||= autodie::hints::DEFAULT_HINTS(); } } } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { # Stray user subroutine croak(sprintf(ERROR_NOTSUB,$sub)); } elsif ($name eq 'system') { # If we're fatalising system, then we need to load # helper code. # The business with $E is to avoid clobbering our caller's # $@, and to avoid $@ being localised when we croak. my $E; { local $@; eval { require IPC::System::Simple; # Only load it if we need it. require autodie::exception::system; }; $E = $@; } if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } # Make sure we're using a recent version of ISS that actually # support fatalised system. if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { croak sprintf( ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, $IPC::System::Simple::VERSION ); } $call = 'CORE::system'; $core = 1; } elsif ($name eq 'exec') { # Exec doesn't have a prototype. We don't care. This # breaks the exotic form with lexical scope, and gives # the regular form a "do or die" behavior as expected. $call = 'CORE::exec'; $core = 1; } else { # CORE subroutine $call = "CORE::$name"; if (exists($CORE_prototype_cache{$call})) { $proto = $CORE_prototype_cache{$call}; } else { my $E; { local $@; $proto = eval { prototype $call }; $E = $@; } croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; $CORE_prototype_cache{$call} = $proto; } $core = 1; } # TODO: This caching works, but I don't like using $void and # $lexical as keys. In particular, I suspect our code may end up # wrapping already wrapped code when autodie and Fatal are used # together. # NB: We must use '$sub' (the name plus package) and not # just '$name' (the short name) here. Failing to do so # results code that's in the wrong package, and hence has # access to the wrong package filehandles. $cache = $Cached_fatalised_sub{$class}{$sub}; if ($lexical) { $cache_type = CACHE_AUTODIE_LEAK_GUARD; } else { $cache_type = CACHE_FATAL_WRAPPER; $cache_type = CACHE_FATAL_VOID if $void; } if (my $subref = $cache->{$cache_type}) { $install_subs->{$name} = $subref; return $sref; } # If our subroutine is reusable (ie, not package depdendent), # then check to see if we've got a cached copy, and use that. # See RT #46984. (Thanks to Niels Thykier for being awesome!) if ($core && exists $reusable_builtins{$call}) { # For non-lexical subs, we can just use this cache directly # - for lexical variants, we need a leak guard as well. $code = $reusable_builtins{$call}{$lexical}; if (!$lexical && defined($code)) { $install_subs->{$name} = $code; return $sref; } } if (!($lexical && $core) && !defined($code)) { # No code available, generate it now. my $wrapper_pkg = $pkg; $wrapper_pkg = undef if (exists($reusable_builtins{$call})); $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto); if (!defined($wrapper_pkg)) { # cache it so we don't recompile this part again $reusable_builtins{$call}{$lexical} = $code; } } # Now we need to wrap our fatalised sub inside an itty bitty # closure, which can detect if we've leaked into another file. # Luckily, we only need to do this for lexical (autodie) # subs. Fatal subs can leak all they want, it's considered # a "feature" (or at least backwards compatible). # TODO: Cache our leak guards! # TODO: This is pretty hairy code. A lot more tests would # be really nice for this. my $installed_sub = $code; if ($lexical) { $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, $pkg, $proto); } $cache->{$cache_type} = $code; $install_subs->{$name} = $installed_sub; # Cache that we've now overridden this sub. If we get called # again, we may need to find that find subroutine again (eg, for hints). $Is_fatalised_sub{$installed_sub} = $sref; return $sref; } # This subroutine exists primarily so that child classes can override # it to point to their own exception class. Doing this is significantly # less complex than overriding throw() sub exception_class { return "autodie::exception" }; { my %exception_class_for; my %class_loaded; sub throw { my ($class, @args) = @_; # Find our exception class if we need it. my $exception_class = $exception_class_for{$class} ||= $class->exception_class; if (not $class_loaded{$exception_class}) { if ($exception_class =~ /[^\w:']/) { confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons."; } # Alas, Perl does turn barewords into modules unless they're # actually barewords. As such, we're left doing a string eval # to make sure we load our file correctly. my $E; { local $@; # We can't clobber $@, it's wrong! my $pm_file = $exception_class . ".pm"; $pm_file =~ s{ (?: :: | ' ) }{/}gx; eval { require $pm_file }; $E = $@; # Save $E despite ending our local. } # We need quotes around $@ to make sure it's stringified # while still in scope. Without them, we run the risk of # $@ having been cleared by us exiting the local() block. confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E; $class_loaded{$exception_class}++; } return $exception_class->new(@args); } } # Creates and returns a leak guard (with prototype if needed). sub _make_leak_guard { my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; # The leak guard is rather lengthly (in fact it makes up the most # of _make_leak_guard). It is possible to split it into a large # "generic" part and a small wrapper with call-specific # information. This was done in v2.19 and profiling suggested # that we ended up using a substantial amount of runtime in "goto" # between the leak guard(s) and the final sub. Therefore, the two # parts were merged into one to reduce the runtime overhead. my $leak_guard = sub { my $caller_level = 0; my $caller; while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { # If our filename is actually an eval, and we # reach it, then go to our autodying code immediatately. last if ($caller eq $filename); $caller_level++; } # We're now out of the eval stack. if ($caller eq $filename) { # No leak, call the wrapper. NB: In this case, it doesn't # matter if it is a CORE sub or not. if (!defined($wrapped_sub)) { # CORE sub that we were too lazy to compile when we # created this leak guard. die "$call is not CORE::" if substr($call, 0, 6) ne 'CORE::'; my $name = substr($call, 6); my $sub = $name; my $lexical = 1; my $wrapper_pkg = $pkg; my $code; if (exists($reusable_builtins{$call})) { $code = $reusable_builtins{$call}{$lexical}; $wrapper_pkg = undef; } if (!defined($code)) { $code = $class->_compile_wrapper($wrapper_pkg, 1, # core $call, $name, 0, # void $lexical, $sub, undef, # subref (not used for core) undef, # hints (not used for core) $proto); if (!defined($wrapper_pkg)) { # cache it so we don't recompile this part again $reusable_builtins{$call}{$lexical} = $code; } } # As $wrapped_sub is "closed over", updating its value will # be "remembered" for the next call. $wrapped_sub = $code; } goto $wrapped_sub; } # We leaked, time to call the original function. # - for non-core functions that will be $orig_sub # - for CORE functions, $orig_sub may be a trampoline goto $orig_sub if defined($orig_sub); # We are wrapping a CORE sub and we do not have a trampoline # yet. # # If we've cached a trampoline, then use it. Usually only # resuable subs will have cache hits, but non-reusuably ones # can get it as well in (very) rare cases. It is mostly in # cases where a package uses autodie multiple times and leaks # from multiple places. Possibly something like: # # package Pkg::With::LeakyCode; # sub a { # use autodie; # code_that_leaks(); # } # # sub b { # use autodie; # more_leaky_code(); # } # # Note that we use "Fatal" as package name for reusable subs # because A) that allows us to trivially re-use the # trampolines as well and B) because the reusable sub is # compiled into "package Fatal" as well. $pkg = 'Fatal' if exists $reusable_builtins{$call}; $orig_sub = $Trampoline_cache{$pkg}{$call}; if (not $orig_sub) { # If we don't have a trampoline, we need to build it. # # We only generate trampolines when we need them, and # we can cache them by subroutine + package. # # As $orig_sub is "closed over", updating its value will # be "remembered" for the next call. $orig_sub = make_core_trampoline($call, $pkg, $proto); # We still cache it despite remembering it in $orig_sub as # well. In particularly, we rely on this to avoid # re-compiling the reusable trampolines. $Trampoline_cache{$pkg}{$call} = $orig_sub; } # Bounce to our trampoline, which takes us to our core sub. goto $orig_sub; }; # <-- end of leak guard # If there is a prototype on the original sub, copy it to the leak # guard. if (defined $proto) { # The "\&" may appear to be redundant but set_prototype # croaks when it is removed. set_prototype(\&$leak_guard, $proto); } return $leak_guard; } sub _compile_wrapper { my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; my $real_proto = ''; my @protos; my $code; if (defined $proto) { $real_proto = " ($proto)"; } else { $proto = '@'; } @protos = fill_protos($proto); $code = qq[ sub$real_proto { ]; if (!$lexical) { $code .= q[ local($", $!) = (', ', 0); ]; } # Don't have perl whine if exec fails, since we'll be handling # the exception now. $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos); $code .= "}\n"; warn $code if $Debug; # I thought that changing package was a monumental waste of # time for CORE subs, since they'll always be the same. However # that's not the case, since they may refer to package-based # filehandles (eg, with open). # # The %reusable_builtins hash defines ones we can aggressively # cache as they never depend upon package-based symbols. my $E; { no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... local $@; if (defined($wrapper_pkg)) { $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic } else { $code = eval("require Carp; $code"); ## no critic } $E = $@; } if (not $code) { my $true_name = $core ? $call : $sub; croak("Internal error in autodie/Fatal processing $true_name: $E"); } return $code; } # For some reason, dying while replacing our subs doesn't # kill our calling program. It simply stops the loading of # autodie and keeps going with everything else. The _autocroak # sub allows us to die with a vengeance. It should *only* ever be # used for serious internal errors, since the results of it can't # be captured. sub _autocroak { warn Carp::longmess(@_); exit(255); # Ugh! } 1; __END__ =head1 NAME Fatal - Replace functions with equivalents which succeed or die =head1 SYNOPSIS use Fatal qw(open close); open(my $fh, "<", $filename); # No need to check errors! use File::Copy qw(move); use Fatal qw(move); move($file1, $file2); # No need to check errors! sub juggle { . . . } Fatal->import('juggle'); =head1 BEST PRACTICE B pragma.> Please use L in preference to C. L supports lexical scoping, throws real exception objects, and provides much nicer error messages. The use of C<:void> with Fatal is discouraged. =head1 DESCRIPTION C provides a way to conveniently replace functions which normally return a false value when they fail with equivalents which raise exceptions if they are not successful. This lets you use these functions without having to test their return values explicitly on each call. Exceptions can be caught using C. See L and L for details. The do-or-die equivalents are set up simply by calling Fatal's C routine, passing it the names of the functions to be replaced. You may wrap both user-defined functions and overridable CORE operators (except C, C, C, or any other built-in that cannot be expressed via prototypes) in this way. If the symbol C<:void> appears in the import list, then functions named later in that import list raise an exception only when these are called in void context--that is, when their return values are ignored. For example use Fatal qw/:void open close/; # properly checked, so no exception raised on error if (not open(my $fh, '<', '/bogotic') { warn "Can't open /bogotic: $!"; } # not checked, so error raises an exception close FH; The use of C<:void> is discouraged, as it can result in exceptions not being thrown if you I call a method without void context. Use L instead if you need to be able to disable autodying/Fatal behaviour for a small block of code. =head1 DIAGNOSTICS =over 4 =item Bad subroutine name for Fatal: %s You've called C with an argument that doesn't look like a subroutine name, nor a switch that this version of Fatal understands. =item %s is not a Perl subroutine You've asked C to try and replace a subroutine which does not exist, or has not yet been defined. =item %s is neither a builtin, nor a Perl subroutine You've asked C to replace a subroutine, but it's not a Perl built-in, and C couldn't find it as a regular subroutine. It either doesn't exist or has not yet been defined. =item Cannot make the non-overridable %s fatal You've tried to use C on a Perl built-in that can't be overridden, such as C or C, which means that C can't help you, although some other modules might. See the L section of this documentation. =item Internal error: %s You've found a bug in C. Please report it using the C command. =back =head1 BUGS C clobbers the context in which a function is called and always makes it a scalar context, except when the C<:void> tag is used. This problem does not exist in L. "Used only once" warnings can be generated when C or C is used with package filehandles (eg, C). It's strongly recommended you use scalar filehandles instead. =head1 AUTHOR Original module by Lionel Cons (CERN). Prototype updates by Ilya Zakharevich . L support, bugfixes, extended diagnostics, C support, and major overhauling by Paul Fenwick =head1 LICENSE This module is free software, you may distribute it under the same terms as Perl itself. =head1 SEE ALSO L for a nicer way to use lexical Fatal. L for a similar idea for calls to C and backticks. =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG =cut kwalitee.t100755001750001750 44612547417731 14141 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; if (not $ENV{RELEASE_TESTING}) { plan( skip_all => 'Author test. Set $ENV{RELEASE_TESTING} to true to run.'); } eval { require Test::Kwalitee; Test::Kwalitee->import() }; plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; rt-74246.t100644001750001750 45512547417731 13442 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 1; eval q{ use strict; no warnings; # Suppress a "helpful" warning on STDERR use autodie qw(open); $open = 1; }; like($@, qr/Global symbol "\$open" requires explicit package name/, 'autodie does not break "use strict;"'); truncate.t100750001750001750 651412547417731 14176 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; use File::Temp qw(tempfile); use IO::Handle; use File::Spec; use FindBin qw($Bin); my ($truncate_status, $tmpfh, $tmpfile); # Some systems have a screwy tempfile. We don't run our tests there. eval { ($tmpfh, $tmpfile) = tempfile(UNLINK => 1); }; if ($@ or !defined $tmpfh) { plan skip_all => 'tempfile() not happy on this system.'; } eval { $truncate_status = truncate($tmpfh, 0); }; if ($@ || !defined($truncate_status)) { plan skip_all => 'Truncate not implemented or not working on this system'; } plan tests => 12; SKIP: { my $can_truncate_stdout = truncate(\*STDOUT,0); if ($can_truncate_stdout) { skip("This system thinks we can truncate STDOUT. Suuure!", 1); } eval { use autodie; truncate(\*STDOUT,0); }; isa_ok($@, 'autodie::exception', "Truncating STDOUT should throw an exception"); } eval { use autodie; no warnings 'once'; truncate(\*FOO, 0); }; isa_ok($@, 'autodie::exception', "Truncating an unopened file is wrong."); $tmpfh->print("Hello World"); $tmpfh->flush; eval { use autodie; truncate($tmpfh, 0); }; is($@, "", "Truncating a normal file should be fine"); $tmpfh->close; # Time to test truncating via globs. # Firstly, truncating a closed filehandle should fail. # I know we tested this above, but we'll do a full dance of # opening and closing TRUNCATE_FH here. eval { use autodie qw(truncate); truncate(\*TRUNCATE_FH, 0); }; isa_ok($@, 'autodie::exception', "Truncating unopened file (TRUNCATE_FH)"); # Now open the file. If this throws an exception, there's something # wrong with our tests, or autodie... { use autodie qw(open); open(TRUNCATE_FH, '+<', $tmpfile); } # Now try truncating the filehandle. This should succeed. eval { use autodie qw(truncate); truncate(\*TRUNCATE_FH,0); }; is($@, "", 'Truncating an opened glob (\*TRUNCATE_FH)'); eval { use autodie qw(truncate); truncate(*TRUNCATE_FH,0); }; is($@, "", 'Truncating an opened glob (*TRUNCATE_FH)'); # Now let's change packages, since globs are package dependent eval { package Fatal::Test; no warnings 'once'; use autodie qw(truncate); truncate(\*TRUNCATE_FH,0); # Should die, as now unopened }; isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (\*TRUNCATE_FH)'); eval { package Fatal::Test; no warnings 'once'; use autodie qw(truncate); truncate(*TRUNCATE_FH,0); # Should die, as now unopened }; isa_ok($@, 'autodie::exception', 'Truncating unopened file in different package (*TRUNCATE_FH)'); # Now back to our previous test, just to make sure it hasn't changed # the original file. eval { use autodie qw(truncate); truncate(\*TRUNCATE_FH,0); }; is($@, "", 'Truncating an opened glob #2 (\*TRUNCATE_FH)'); eval { use autodie qw(truncate); truncate(*TRUNCATE_FH,0); }; is($@, "", 'Truncating an opened glob #2 (*TRUNCATE_FH)'); # Now to close the file and retry. { use autodie qw(close); close(TRUNCATE_FH); } eval { use autodie qw(truncate); truncate(\*TRUNCATE_FH,0); }; isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (\*TRUNCATE_FH)'); eval { use autodie qw(truncate); truncate(*TRUNCATE_FH,0); }; isa_ok($@, 'autodie::exception', 'Truncating freshly closed glob (*TRUNCATE_FH)'); internal.t100750001750001750 315512547417731 14163 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use Scalar::Util qw(blessed); use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; use Test::More tests => 7; use Fatal(); # Silence the warnings from using Fatal qw(:lexical) # Lexical tests using the internal interface. my @warnings; eval { # Filter out deprecation warning (no warnings qw(deprecated) does # not seem to work for some reason) local $SIG{'__WARN__'} = sub { push(@warnings, @_) unless $_[0] =~ m/Fatal qw\(:lexical/; }; Fatal->import(qw(:lexical :void)) }; like($@, qr{:void cannot be used with lexical}, ":void can't be used with :lexical"); warn($_) while shift @warnings; eval { Fatal->import(qw(open close :lexical)) }; like($@, qr{:lexical must be used as first}, ":lexical must come first"); { BEGIN { # Filter out deprecation warning (no warnings qw(deprecated) does # not seem to work for some reason) local $SIG{'__WARN__'} = sub { push(@warnings, @_) unless $_[0] =~ m/Fatal qw\(:lexical/; }; import Fatal qw(:lexical chdir); }; warn($_) while shift @warnings; eval { chdir(NO_SUCH_FILE); }; my $err = $@; like ($err, qr/^Can't chdir/, "Lexical fatal chdir"); { no Fatal qw(:lexical chdir); eval { chdir(NO_SUCH_FILE); }; is ($@, "", "No lexical fatal chdir"); } eval { chdir(NO_SUCH_FILE); }; $err = $@; like ($err, qr/^Can't chdir/, "Lexical fatal chdir returns"); } eval { chdir(NO_SUCH_FILE); }; is($@, "", "Lexical chdir becomes non-fatal out of scope."); eval { Fatal->import('2+2'); }; like($@,qr{Bad subroutine name},"Can't use fatal with invalid sub names"); MANIFEST.SKIP100644001750001750 40312547417731 13570 0ustar00pjfpjf000000000000autodie-2.29.git .gitignore .prove .proverc pm_to_lib MANIFEST.bak MANIFEST.skip blib .*.pm~$ Makefile$ Makefile.old examples/ autodie-.*.tar.gz autodie-.*.tar cover_db merge-core.pl doc/perl-tip.pod .*\.swp$ doc/tpr.pod ^autodie-\d+\.\d+ \.patch$ TODO Debian_CPANTS.txt utf8_open.t100755001750001750 641712547417731 14267 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w # Test that open still honors the open pragma. use strict; use warnings; use autodie; use Fcntl; use File::Temp; use Test::More; if( $] < '5.01000' ) { plan skip_all => "autodie does not honor the open pragma before 5.10"; } else { plan "no_plan"; } # Test with an open pragma on { use open IN => ':encoding(utf8)', OUT => ':utf8'; # Test the standard handles and all newly opened handles are utf8 my $file = File::Temp->new; my $txt = "autodie is MËTÁŁ"; # open for writing { open my $fh, ">", $file; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'utf8' } @layers), "open write honors open pragma" ) or diag join ", ", @layers; print $fh $txt; close $fh; } # open for reading, explicit { open my $fh, "<", $file; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open read honors open pragma" ) or diag join ", ", @layers; is join("\n", <$fh>), $txt; } # open for reading, implicit { open my($fh), $file; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; is join("\n", <$fh>), $txt; } # open for read/write { open my $fh, "+>", $file; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'utf8' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; } # open for append { open my $fh, ">>", $file; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'utf8' } @layers), "open implicit read honors open pragma" ) or diag join ", ", @layers; } # raw { open my $fh, ">:raw", $file; my @layers = PerlIO::get_layers($fh); ok( !(grep { $_ eq 'utf8' } @layers), 'open pragma is not used if raw is specified' ) or diag join ", ", @layers; } } # Test without open pragma { my $file = File::Temp->new; open my $fh, ">", $file; my @layers = PerlIO::get_layers($fh); ok( grep(!/utf8/, @layers), "open pragma remains lexical" ) or diag join ", ", @layers; } # sysopen { use open IN => ':encoding(utf8)', OUT => ':utf8'; # Test the standard handles and all newly opened handles are utf8 my $file = File::Temp->new; my $txt = "autodie is MËTÁŁ"; # open for writing only { sysopen my $fh, $file, O_CREAT|O_TRUNC|O_WRONLY; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'utf8' } @layers), "open write honors open pragma" ) or diag join ", ", @layers; print $fh $txt; close $fh; } # open for reading only { sysopen my $fh, $file, O_RDONLY; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'encoding(utf8)' } @layers), "open read honors open pragma" ) or diag join ", ", @layers; is join("\n", <$fh>), $txt; } # open for reading and writing { sysopen my $fh, $file, O_RDWR; my @layers = PerlIO::get_layers($fh); ok( (grep { $_ eq 'utf8' } @layers), "open read/write honors open write pragma" ) or diag join ", ", @layers; is join("\n", <$fh>), $txt; } } autodie.pm100640001750001750 3112612547417731 14472 0ustar00pjfpjf000000000000autodie-2.29/libpackage autodie; use 5.008; use strict; use warnings; use parent qw(Fatal); our $VERSION; # ABSTRACT: Replace functions with ones that succeed or die with lexical scope BEGIN { our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ Incorrect version of Fatal.pm loaded by autodie. The autodie pragma uses an updated version of Fatal to do its heavy lifting. We seem to have loaded Fatal version %s, which is probably the version that came with your version of Perl. However autodie needs version %s, which would have come bundled with autodie. You may be able to solve this problem by adding the following line of code to your main program, before any use of Fatal or autodie. use lib "%s"; }; # We have to check we've got the right version of Fatal before we # try to compile the rest of our code, lest we use a constant # that doesn't exist. BEGIN { # If we have the wrong Fatal, then we've probably loaded the system # one, not our own. Complain, and give a useful hint. ;) if (defined($Fatal::VERSION) and defined($VERSION) and $Fatal::VERSION ne $VERSION) { my $autodie_path = $INC{'autodie.pm'}; $autodie_path =~ s/autodie\.pm//; require Carp; Carp::croak sprintf( ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path ); } } # When passing args to Fatal we want to keep the first arg # (our package) in place. Hence the splice. sub import { splice(@_,1,0,Fatal::LEXICAL_TAG); goto &Fatal::import; } sub unimport { splice(@_,1,0,Fatal::LEXICAL_TAG); goto &Fatal::unimport; } 1; __END__ =head1 NAME autodie - Replace functions with ones that succeed or die with lexical scope =head1 SYNOPSIS use autodie; # Recommended: implies 'use autodie qw(:default)' use autodie qw(:all); # Recommended more: defaults and system/exec. use autodie qw(open close); # open/close succeed or die open(my $fh, "<", $filename); # No need to check! { no autodie qw(open); # open failures won't die open(my $fh, "<", $filename); # Could fail silently! no autodie; # disable all autodies } print "Hello World" or die $!; # autodie DOESN'T check print! =head1 DESCRIPTION bIlujDI' yIchegh()Qo'; yIHegh()! It is better to die() than to return() in failure. -- Klingon programming proverb. The C pragma provides a convenient way to replace functions that normally return false on failure with equivalents that throw an exception on failure. The C pragma has I, meaning that functions and subroutines altered with C will only change their behaviour until the end of the enclosing block, file, or C. If C is specified as an argument to C, then it uses L to do the heavy lifting. See the description of that module for more information. =head1 EXCEPTIONS Exceptions produced by the C pragma are members of the L class. The preferred way to work with these exceptions under Perl 5.10 is as follows: use feature qw(switch); eval { use autodie; open(my $fh, '<', $some_file); my @records = <$fh>; # Do things with @records... close($fh); }; given ($@) { when (undef) { say "No error"; } when ('open') { say "Error from open"; } when (':io') { say "Non-open, IO error."; } when (':all') { say "All other autodie errors." } default { say "Not an autodie error at all." } } Under Perl 5.8, the C structure is not available, so the following structure may be used: eval { use autodie; open(my $fh, '<', $some_file); my @records = <$fh>; # Do things with @records... close($fh); }; if ($@ and $@->isa('autodie::exception')) { if ($@->matches('open')) { print "Error from open\n"; } if ($@->matches(':io' )) { print "Non-open, IO error."; } } elsif ($@) { # A non-autodie exception. } See L for further information on interrogating exceptions. =head1 CATEGORIES Autodie uses a simple set of categories to group together similar built-ins. Requesting a category type (starting with a colon) will enable autodie for all built-ins beneath that category. For example, requesting C<:file> will enable autodie for C, C, C and C. The categories are currently: :all :default :io read seek sysread sysseek syswrite :dbm dbmclose dbmopen :file binmode close chmod chown fcntl flock ioctl open sysopen truncate :filesys chdir closedir opendir link mkdir readlink rename rmdir symlink unlink :ipc kill pipe :msg msgctl msgget msgrcv msgsnd :semaphore semctl semget semop :shm shmctl shmget shmread :socket accept bind connect getsockopt listen recv send setsockopt shutdown socketpair :threads fork :system system exec Note that while the above category system is presently a strict hierarchy, this should not be assumed. A plain C implies C. Note that C and C are not enabled by default. C requires the optional L module to be installed, and enabling C or C will invalidate their exotic forms. See L below for more details. The syntax: use autodie qw(:1.994); allows the C<:default> list from a particular version to be used. This provides the convenience of using the default methods, but the surety that no behavioral changes will occur if the C module is upgraded. C can be enabled for all of Perl's built-ins, including C and C with: use autodie qw(:all); =head1 FUNCTION SPECIFIC NOTES =head2 print The autodie pragma B<>>. =head2 flock It is not considered an error for C to return false if it fails due to an C (or equivalent) condition. This means one can still use the common convention of testing the return value of C when called with the C option: use autodie; if ( flock($fh, LOCK_EX | LOCK_NB) ) { # We have a lock } Autodying C will generate an exception if C returns false with any other error. =head2 system/exec The C built-in is considered to have failed in the following circumstances: =over 4 =item * The command does not start. =item * The command is killed by a signal. =item * The command returns a non-zero exit value (but see below). =back On success, the autodying form of C returns the I rather than the contents of C<$?>. Additional allowable exit values can be supplied as an optional first argument to autodying C: system( [ 0, 1, 2 ], $cmd, @args); # 0,1,2 are good exit values C uses the L module to change C. See its documentation for further information. Applying C to C or C causes the exotic forms C or C to be considered a syntax error until the end of the lexical scope. If you really need to use the exotic form, you can call C or C instead, or use C before calling the exotic form. =head1 GOTCHAS Functions called in list context are assumed to have failed if they return an empty list, or a list consisting only of a single undef element. Some builtins (e.g. C or C) has a call signature that cannot completely be representated with a Perl prototype. This means that some valid Perl code will be invalid under autodie. As an example: chdir(BAREWORD); Without autodie (and assuming BAREWORD is an open filehandle/dirhandle) this is a valid call to chdir. But under autodie, C will behave like it had the prototype ";$" and thus BAREWORD will be a syntax error (under "use strict". Without strict, it will interpreted as a filename). =head1 DIAGNOSTICS =over 4 =item :void cannot be used with lexical scope The C<:void> option is supported in L, but not C. To workaround this, C may be explicitly disabled until the end of the current block with C. To disable autodie for only a single function (eg, open) use C. C performs no checking of called context to determine whether to throw an exception; the explicitness of error handling with C is a deliberate feature. =item No user hints defined for %s You've insisted on hints for user-subroutines, either by pre-pending a C to the subroutine name itself, or earlier in the list of arguments to C. However the subroutine in question does not have any hints available. =back See also L. =head1 BUGS "Used only once" warnings can be generated when C or C is used with package filehandles (eg, C). Scalar filehandles are strongly recommended instead. When using C or C with user subroutines, the declaration of those subroutines must appear before the first use of C or C, or have been exported from a module. Attempting to use C or C on other user subroutines will result in a compile-time error. Due to a bug in Perl, C may "lose" any format which has the same name as an autodying built-in or function. C may not work correctly if used inside a file with a name that looks like a string eval, such as F. =head2 autodie and string eval Due to the current implementation of C, unexpected results may be seen when used near or with the string version of eval. I. Under Perl 5.8 only, C I propagate into string C statements, although it can be explicitly enabled inside a string C. Under Perl 5.10 only, using a string eval when C is in effect can cause the autodie behaviour to leak into the surrounding scope. This can be worked around by using a C at the end of the scope to explicitly remove autodie's effects, or by avoiding the use of string eval. I. The use of C with block eval is considered good practice. =head2 REPORTING BUGS Please report bugs via the GitHub Issue Tracker at L or via the CPAN Request Tracker at L. =head1 FEEDBACK If you find this module useful, please consider rating it on the CPAN Ratings service at L . The module author loves to hear how C has made your life better (or worse). Feedback can be sent to Epjf@perltraining.com.auE. =head1 AUTHOR Copyright 2008-2009, Paul Fenwick Epjf@perltraining.com.auE =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L I at L =head1 ACKNOWLEDGEMENTS Mark Reed and Roland Giersig -- Klingon translators. See the F file for full credits. The latest version of this file can be found at L . =cut backcompat.t100755001750001750 111012547417731 14445 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Fatal qw(open); use Test::More tests => 2; use constant NO_SUCH_FILE => "xyzzy_this_file_is_not_here"; eval { open(my $fh, '<', NO_SUCH_FILE); }; my $old_msg = qr{Can't open\(GLOB\(0x[0-9a-f]+\), <, xyzzy_this_file_is_not_here\): .* at \(eval \d+\)(?:\[.*?\])? line \d+\.?\s+main::__ANON__\('?GLOB\(0x[0-9a-f]+\)'?,\s*['"]<['"],\s*['"]xyzzy_this_file_is_not_here['"]\) called at \S+ line \d+\s+eval \Q{...}\E called at \S+ line \d+}; like($@,$old_msg,"Backwards compat ugly messages"); is(ref($@),"", "Exception is a string, not an object"); blog_hints.t100755001750001750 130312547417731 14475 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use FindBin; use lib "$FindBin::Bin/lib"; use Some::Module qw(some_sub); use my::autodie qw(! some_sub); eval { some_sub() }; isnt("$@", "", "some_sub should die in void/scalar context"); isa_ok($@, 'autodie::exception'); is($@->context, 'scalar'); is($@->function, 'Some::Module::some_sub'); like("$@", qr/can't be called in scalar context/); my @returns = eval { some_sub(0); }; is($@, "", "Good call to some_sub"); is_deeply(\@returns, [1,2,3], "Returns unmolested"); @returns = eval { some_sub(1) }; isnt("$@",""); is($@->return->[0], undef); is($@->return->[1], 'Insufficient credit'); like("$@", qr/Insufficient credit/); eval_error.t100755001750001750 104312547417731 14506 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use autodie; use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; use constant MAGIC_STRING => 'xyzzy'; # Opening an eval clears $@, so it's important that we set it # inside the eval block to see if it's successfully captured. eval { $@ = MAGIC_STRING; is($@, MAGIC_STRING, 'Sanity check on start conditions'); open(my $fh, '<', NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception'); is($@->eval_error, MAGIC_STRING, 'Previous $@ should be captured'); scope_leak.t100755001750001750 504212547417731 14456 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use FindBin; # Check for %^H leaking across file boundries. Many thanks # to chocolateboy for pointing out this can be a problem. use lib $FindBin::Bin; use Test::More 'no_plan'; use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; use constant NO_SUCH_FILE2 => 'this_file_had_better_not_exist_either'; use autodie qw(open rename); eval { open(my $fh, '<', NO_SUCH_FILE); }; ok($@, "basic autodie test - open"); eval { rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; ok($@, "basic autodie test - rename"); use autodie_test_module; # If things don't work as they should, then the file we've # just loaded will still have an autodying main::open (although # its own open should be unaffected). eval { leak_test(NO_SUCH_FILE); }; is($@,"","autodying main::open should not leak to other files"); eval { autodie_test_module::your_open(NO_SUCH_FILE); }; is($@,"","Other package open should be unaffected"); # The same should apply for rename (which is different, because # it doesn't depend upon packages, and could be cached more # aggressively.) eval { leak_test_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; is($@,"","autodying main::rename should not leak to other files"); eval { autodie_test_module::your_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; is($@,"","Other package rename should be unaffected"); # Dying rename in the other package should still die. eval { autodie_test_module::your_dying_rename(NO_SUCH_FILE, NO_SUCH_FILE2); }; ok($@, "rename in loaded module should remain autodying."); # Due to odd filenames reported when doing string evals, # older versions of autodie would not propogate into string evals. eval q{ open(my $fh, '<', NO_SUCH_FILE); }; TODO: { local $TODO = "No known way of propagating into string eval in 5.8" if $] < 5.010; ok($@, "Failing-open string eval should throw an exception"); isa_ok($@, 'autodie::exception'); } eval q{ no autodie; open(my $fh, '<', NO_SUCH_FILE); }; is("$@","","disabling autodie in string context should work"); eval { open(my $fh, '<', NO_SUCH_FILE); }; ok($@,"...but shouldn't disable it for the calling code."); isa_ok($@, 'autodie::exception'); eval q{ no autodie; use autodie qw(open); open(my $fh, '<', NO_SUCH_FILE); }; ok($@,"Wacky flipping of autodie in string eval should work too!"); isa_ok($@, 'autodie::exception'); eval q{ # RT#72053 use autodie; { no autodie; } open(my $fh, '<', NO_SUCH_FILE); }; ok($@,"Wacky flipping of autodie in string eval should work too!"); isa_ok($@, 'autodie::exception'); exceptions.t100750001750001750 264512547417731 14533 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; BEGIN { plan skip_all => "Perl 5.10 only tests" if $] < 5.010; } # These are tests that depend upon 5.10 (eg, smart-match). # Basic tests should go in basic_exceptions.t use 5.010; use constant NO_SUCH_FILE => 'this_file_had_better_not_exist_xyzzy'; no if $] >= 5.017011, warnings => "experimental::smartmatch"; plan 'no_plan'; eval { use autodie ':io'; open(my $fh, '<', NO_SUCH_FILE); }; ok($@, "Exception thrown" ); ok($@ ~~ 'open', "Exception from open" ); ok($@ ~~ ':file', "Exception from open / class :file" ); ok($@ ~~ ':io', "Exception from open / class :io" ); ok($@ ~~ ':all', "Exception from open / class :all" ); eval { no warnings 'once'; # To prevent the following close from complaining. close(THIS_FILEHANDLE_AINT_OPEN); }; ok(! $@, "Close without autodie should fail silent"); eval { use autodie ':io'; close(THIS_FILEHANDLE_AINT_OPEN); }; like($@, qr{Can't close filehandle 'THIS_FILEHANDLE_AINT_OPEN'},"Nice msg from close"); ok($@, "Exception thrown" ); ok($@ ~~ 'close', "Exception from close" ); ok($@ ~~ ':file', "Exception from close / class :file" ); ok($@ ~~ ':io', "Exception from close / class :io" ); ok($@ ~~ ':all', "Exception from close / class :all" ); ok $@ eq $@.'', "string overloading is complete (eq)"; ok( ($@ cmp $@.'') == 0, "string overloading is complete (cmp)" ); filehandles.t100755001750001750 211612547417731 14626 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w package main; use strict; use Test::More; # We may see failures with package filehandles if Fatal/autodie # incorrectly pulls out a cached subroutine from a different package. # We're using Fatal because package filehandles are likely to # see more use with Fatal than autodie. use Fatal qw(open); eval { open(FILE, '<', $0); }; if ($@) { # Holy smokes! We couldn't even open our own file, bail out... plan skip_all => q{Can't open $0 for filehandle tests} } plan tests => 4; my $line = ; like($line, qr{perl}, 'Looks like we opened $0 correctly'); close(FILE); package autodie::test; use Test::More; use Fatal qw(open); eval { open(FILE2, '<', $0); }; is($@,"",'Opened $0 in autodie::test'); my $line2 = ; like($line2, qr{perl}, '...and we can read from $0 fine'); close(FILE2); package main; # This shouldn't read anything, because FILE2 should be inside # autodie::test no warnings; # Otherwise we see problems with FILE2 my $wrong_line = ; ok(! defined($wrong_line),q{Filehandles shouldn't leak between packages}); version_tag.t100755001750001750 413312547417731 14671 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 10; use constant NO_SUCH_FILE => 'THIS_FILE_HAD_BETTER_NOT_EXIST'; eval { use autodie qw(:1.994); open(my $fh, '<', 'this_file_had_better_not_exist.txt'); }; isa_ok($@, 'autodie::exception', "Basic version tags work"); # Expanding :1.00 should fail, there was no autodie :1.00 eval { my $foo = autodie->_expand_tag(":1.00"); }; isnt($@,"","Expanding :1.00 should fail"); my $version = $autodie::VERSION; SKIP: { if (not defined($version) or $version =~ /_/) { skip "Tag test skipped on dev release", 1; } # Expanding our current version should work! eval { my $foo = autodie->_expand_tag(":$version"); }; is($@,"","Expanding :$version should succeed"); } eval { use autodie qw(:2.07); # 2.07 didn't support chmod. This shouldn't throw an # exception. chmod(0644,NO_SUCH_FILE); }; is($@,"","chmod wasn't supported in 2.07"); eval { use autodie; chmod(0644,NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'Our current version supports chmod'); eval { use autodie qw(:2.13); # 2.13 didn't support chown. This shouldn't throw an # exception. chown(12345, 12345, NO_SUCH_FILE); }; is($@,"","chown wasn't supported in 2.13"); SKIP: { if ($^O eq "MSWin32") { skip("chown() on Windows always succeeds.", 1) } eval { use autodie; chown(12345, 12345, NO_SUCH_FILE); }; isa_ok($@, 'autodie::exception', 'Our current version supports chown'); } # The patch in RT 46984 would have utime being set even if an # older version of autodie semantics was requested. Let's see if # it's coming from outside the eval context below. eval { utime undef, undef, NO_SUCH_FILE; }; is($@,"","utime is not autodying outside of any autodie context."); # Now do our regular versioning checks for utime. eval { use autodie qw(:2.13); utime undef, undef, NO_SUCH_FILE; }; is($@,"","utime wasn't supported in 2.13"); eval { use autodie; utime undef, undef, NO_SUCH_FILE; }; isa_ok($@, 'autodie::exception', 'Our current version supports utime'); import-into.t100640001750001750 57412547417731 14610 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval 'use Import::Into 1.002004'; plan skip_all => 'Test needs Import::Into >= 1.002004' if $@; } use FindBin; use lib "$FindBin::Bin/lib"; use my::pragma qw(open); plan tests => 1; my::pragma->dont_die(); eval { open(my $fd, '<', 'random-file'); }; ok($@, 'my::pragma can use import::into'); lib000755001750001750 012547417731 12566 5ustar00pjfpjf000000000000autodie-2.29/tlethal.pm100640001750001750 17712547417731 14516 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage lethal; # A dummy package showing how we can trivially subclass autodie # to our tastes. use parent qw(autodie); 1; hints_insist.t100755001750001750 120312547417731 15062 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie; use Test::More tests => 5; use FindBin qw($Bin); use lib "$Bin/lib"; use Hints_provider_does qw(always_pass always_fail no_hints); eval "use autodie qw( ! always_pass always_fail); "; is("$@", "", "Insisting on good hints (distributed insist)"); is(always_pass(), "foo", "Always_pass() should still work"); is(always_fail(), "foo", "Always_pass() should still work"); eval "use autodie qw(!always_pass !always_fail); "; is("$@", "", "Insisting on good hints (individual insist)"); my $ret = eval "use autodie qw(!no_hints); 1;"; isnt("$@", "", "Asking for non-existent hints"); pod-coverage.t100755001750001750 223312547417731 14723 0ustar00pjfpjf000000000000autodie-2.29/tuse strict; use warnings; use Test::More; if (not $ENV{AUTHOR_TESTING}) { plan( skip_all => 'Author test. Set $ENV{AUTHOR_TESTING} to true to run.'); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok({ also_private => [ qr{^ (?: ERROR_\w+ |unimport |fill_protos |one_invocation |write_invocation |throw |exception_class |AUTODIE_HINTS |LEXICAL_TAG |get_hints_for |load_hints |normalise_hints |sub_fullname |get_code_info |DOES )$ }x ], }); user-context.t100755001750001750 242212547417731 15010 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use File::Copy; use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; use constant EXCEPTION => 'autodie::exception'; # http://perlmonks.org/?node_id=744246 describes a situation where # using autodie on user-defined functions can fail, depending upon # their context. These tests attempt to detect this bug. eval { use autodie qw(copy); copy(NO_SUCH_FILE, 'xyzzy'); }; isa_ok($@,EXCEPTION,"Copying a non-existent file should throw an error"); eval { use autodie qw(copy); my $x = copy(NO_SUCH_FILE, 'xyzzy'); }; isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); eval { use autodie qw(copy); my @x = copy(NO_SUCH_FILE, 'xyzzy'); }; isa_ok($@,EXCEPTION,"This shouldn't change with array context"); # For good measure, test with built-ins. eval { use autodie qw(open); open(my $fh, '<', 'xyzzy'); }; isa_ok($@,EXCEPTION,"Opening a non-existent file should throw an error"); eval { use autodie qw(open); my $x = open(my $fh, '<', 'xyzzy'); }; isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); eval { use autodie qw(open); my @x = open(my $fh, '<', 'xyzzy'); }; isa_ok($@,EXCEPTION,"This shouldn't change with array context"); author-critic.t100644001750001750 66612547417731 15112 0ustar00pjfpjf000000000000autodie-2.29/t#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for testing by the author'); } } use strict; use warnings; use Test::More; use English qw(-no_match_vars); eval "use Test::Perl::Critic"; plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; all_critic_ok(); benchmarks000755001750001750 012547417731 13672 5ustar00pjfpjf000000000000autodie-2.29call.pl100755001750001750 45512547417731 15271 0ustar00pjfpjf000000000000autodie-2.29/benchmarks#!/usr/bin/perl -w use 5.010; use strict; use warnings; use autodie qw(binmode); use constant N => 1000000; # Run an autodie wrapped sub many times in what's essentially a no-op. # This should give us an idea of autodie's overhead. sub run { for (1..N) { binmode(STDOUT); } } run(); leak.pl100755001750001750 21312547417731 15262 0ustar00pjfpjf000000000000autodie-2.29/benchmarks#!/usr/bin/perl -w use 5.010; use strict; use warnings; use autodie; use Fatal_Leaky_Benchmark; run(); # Loaded from my leaky benchmark format-clobber.t100755001750001750 375212547417731 15255 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/env perl use warnings; use strict; use FindBin; use lib "$FindBin::Bin/lib"; use Test::More tests => 21; our ($pvio, $pvfm); use_ok('OtherTypes'); # Since we use use_ok, this is effectively 'compile time'. ok( defined *OtherTypes::foo{SCALAR}, "SCALAR slot intact at compile time" ); ok( defined *OtherTypes::foo{ARRAY}, "ARRAY slot intact at compile time" ); ok( defined *OtherTypes::foo{HASH}, "HASH slot intact at compile time" ); ok( defined *OtherTypes::foo{IO}, "IO slot intact at compile time" ); ok( defined *OtherTypes::foo{FORMAT}, "FORMAT slot intact at compile time" ); is( $OtherTypes::foo, 23, "SCALAR slot correct at compile time" ); is( $OtherTypes::foo[0], "bar", "ARRAY slot correct at compile time" ); is( $OtherTypes::foo{mouse}, "trap", "HASH slot correct at compile time" ); is( *OtherTypes::foo{IO}, $pvio, "IO slot correct at compile time" ); is( *OtherTypes::foo{FORMAT}, $pvfm, "FORMAT slot correct at compile time" ); eval q{ ok( defined *OtherTypes::foo{SCALAR}, "SCALAR slot intact at run time" ); ok( defined *OtherTypes::foo{ARRAY}, "ARRAY slot intact at run time" ); ok( defined *OtherTypes::foo{HASH}, "HASH slot intact at run time" ); ok( defined *OtherTypes::foo{IO}, "IO slot intact at run time" ); TODO: { local $TODO = "Copying formats fails due to a bug in Perl."; ok( defined *OtherTypes::foo{FORMAT}, "FORMAT slot intact at run time" ); } is( $OtherTypes::foo, 23, "SCALAR slot correct at run time" ); is( $OtherTypes::foo[0], "bar", "ARRAY slot correct at run time" ); is( $OtherTypes::foo{mouse}, "trap", "HASH slot correct at run time" ); is( *OtherTypes::foo{IO}, $pvio, "IO slot correct at run time" ); TODO: { local $TODO = "Copying formats fails due to a bug in Perl."; is( *OtherTypes::foo{FORMAT}, $pvfm, "FORMAT slot correct at run time" ); } }; my000755001750001750 012547417731 13213 5ustar00pjfpjf000000000000autodie-2.29/t/libpragma.pm100640001750001750 33212547417731 15132 0ustar00pjfpjf000000000000autodie-2.29/t/lib/mypackage my::pragma; require autodie; use Import::Into qw(into); sub import { shift(@_); autodie->import::into(1, @_); return; } sub dont_die { open(my $fd, '<', 'random-file'); return $fd; } 1; autodie000755001750001750 012547417731 13755 5ustar00pjfpjf000000000000autodie-2.29/libskip.pm100644001750001750 227712547417731 15431 0ustar00pjfpjf000000000000autodie-2.29/lib/autodiepackage autodie::skip; use strict; use warnings; our $VERSION = '2.29'; # VERSION # This package exists purely so people can inherit from it, # which isn't at all how roles are supposed to work, but it's # how people will use them anyway. if ($] < 5.010) { # Older Perls don't have a native ->DOES. Let's provide a cheap # imitation here. *DOES = sub { return shift->isa(@_); }; } 1; __END__ =head1 NAME autodie::skip - Skip a package when throwing autodie exceptions =head1 SYNPOSIS use parent qw(autodie::skip); =head1 DESCRIPTION This dummy class exists to signal that the class inheriting it should be skipped when reporting exceptions from autodie. This is useful for utility classes like L that wish to report the location of where they were called on failure. If your class has a better way of doing roles, then you should not load this class and instead simply say that your class I C instead. =head1 AUTHOR Copyright 2013, Paul Fenwick =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. =head1 SEE ALSO L, L =for Pod::Coverage DOES =cut Util.pm100640001750001750 1707712547417731 15420 0ustar00pjfpjf000000000000autodie-2.29/lib/autodiepackage autodie::Util; use strict; use warnings; use Exporter 5.57 qw(import); use autodie::Scope::GuardStack; our @EXPORT_OK = qw( fill_protos install_subs make_core_trampoline on_end_of_compile_scope ); our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Internal Utility subroutines for autodie and Fatal # docs says we should pick __PACKAGE__ / my $H_STACK_KEY = __PACKAGE__ . '/stack'; sub on_end_of_compile_scope { my ($hook) = @_; # Dark magic to have autodie work under 5.8 # Copied from namespace::clean, that copied it from # autobox, that found it on an ancient scroll written # in blood. # This magic bit causes %^H to be lexically scoped. $^H |= 0x020000; my $stack = $^H{$H_STACK_KEY}; if (not defined($stack)) { $stack = autodie::Scope::GuardStack->new; $^H{$H_STACK_KEY} = $stack; } $stack->push_hook($hook); return; } # This code is based on code from the original Fatal. The "XXXX" # remark is from the original code and its meaning is (sadly) unknown. sub fill_protos { my ($proto) = @_; my ($n, $isref, @out, @out1, $seen_semi) = -1; if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { # prototype is entirely slurply - special case that does not # require any handling. return ([0, '@_']); } while ($proto =~ /\S/) { $n++; push(@out1,[$n,@out]) if $seen_semi; push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//; push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? die "Internal error: Unknown prototype letters: \"$proto\""; } push(@out1,[$n+1,@out]); return @out1; } sub make_core_trampoline { my ($call, $pkg, $proto_str) = @_; my $trampoline_code = 'sub {'; my $trampoline_sub; my @protos = fill_protos($proto_str); foreach my $proto (@protos) { local $" = ", "; # So @args is formatted correctly. my ($count, @args) = @$proto; if (@args && $args[-1] =~ m/[@#]_/) { $trampoline_code .= qq/ if (\@_ >= $count) { return $call(@args); } /; } else { $trampoline_code .= qq< if (\@_ == $count) { return $call(@args); } >; } } $trampoline_code .= qq< require Carp; Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; my $E; { local $@; $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic $E = $@; } die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" if $E; return $trampoline_sub; } # The code here is originally lifted from namespace::clean, # by Robert "phaylon" Sedlacek. # # It's been redesigned after feedback from ikegami on perlmonks. # See http://perlmonks.org/?node_id=693338 . Ikegami rocks. # # Given a package, and hash of (subname => subref) pairs, # we install the given subroutines into the package. If # a subref is undef, the subroutine is removed. Otherwise # it replaces any existing subs which were already there. sub install_subs { my ($target_pkg, $subs_to_reinstate) = @_; my $pkg_sym = "${target_pkg}::"; # It does not hurt to do this in a predictable order, and might help debugging. foreach my $sub_name (sort keys(%{$subs_to_reinstate})) { # We will repeatedly mess with stuff that strict "refs" does # not like. So lets just disable it once for this entire # scope. no strict qw(refs); ## no critic my $sub_ref = $subs_to_reinstate->{$sub_name}; my $full_path = ${pkg_sym}.${sub_name}; my $oldglob = *$full_path; # Nuke the old glob. delete($pkg_sym->{$sub_name}); # For some reason this local *alias = *$full_path triggers an # "only used once" warning. Not entirely sure why, but at # least it is easy to silence. no warnings qw(once); local *alias = *$full_path; use warnings qw(once); # Copy innocent bystanders back. Note that we lose # formats; it seems that Perl versions up to 5.10.0 # have a bug which causes copying formats to end up in # the scalar slot. Thanks to Ben Morrow for spotting this. foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { next unless defined(*$oldglob{$slot}); *alias = *$oldglob{$slot}; } if ($sub_ref) { *$full_path = $sub_ref; } } return; } 1; __END__ =head1 NAME autodie::Util - Internal Utility subroutines for autodie and Fatal =head1 SYNOPSIS # INTERNAL API for autodie and Fatal only! use autodie::Util qw(on_end_of_compile_scope); on_end_of_compile_scope(sub { print "Hallo world\n"; }); =head1 DESCRIPTION Interal Utilities for autodie and Fatal! This module is not a part of autodie's public API. This module contains utility subroutines for abstracting away the underlying magic of autodie and (ab)uses of C<%^H> to call subs at the end of a (compile-time) scopes. Note that due to how C<%^H> works, some of these utilities are only useful during the compilation phase of a perl module and relies on the internals of how perl handles references in C<%^H>. =head2 Methods =head3 on_end_of_compile_scope on_end_of_compile_scope(sub { print "Hallo world\n"; }); Will invoke a sub at the end of a (compile-time) scope. The sub is called once with no arguments. Can be called multiple times (even in the same "compile-time" scope) to install multiple subs. Subs are called in a "first-in-last-out"-order (FILO or "stack"-order). =head3 fill_protos fill_protos('*$$;$@') Given a Perl subroutine prototype, return a list of invocation specifications. Each specification is a listref, where the first member is the (minimum) number of arguments for this invocation specification. The remaining arguments are a string representation of how to pass the arguments correctly to a sub with the given prototype, when called with the given number of arguments. The specifications are returned in increasing order of arguments starting at 0 (e.g. ';$') or 1 (e.g. '$@'). Note that if the prototype is "slurpy" (e.g. ends with a "@"), the number of arguments for the last specification is a "minimum" number rather than an exact number. This can be detected by the last member of the last specification matching m/[@#]_/. =head3 make_core_trampoline make_core_trampoline('CORE::open', 'main', prototype('CORE::open')) Creates a trampoline for calling a core sub. Essentially, a tiny sub that figures out how we should be calling our core sub, puts in the arguments in the right way, and bounces our control over to it. If we could reliably use `goto &` on core builtins, we wouldn't need this subroutine. =head3 install_subs install_subs('My::Module', { 'read' => sub { die("Hallo\n"), ... }}) Given a package name and a hashref mapping names to a subroutine reference (or C), this subroutine will install said subroutines on their given name in that module. If a name mapes to C, any subroutine with that name in the target module will be remove (possibly "unshadowing" a CORE sub of same name). =head1 AUTHOR Copyright 2013-2014, Niels Thykier Eniels@thykier.netE =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. context_lexical.t100755001750001750 315612547417731 15542 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More; plan 'no_plan'; # Returns a list presented to it, but also returns a single # undef if given a list of a single undef. This mimics the # behaviour of many user-defined subs and built-ins (eg: open) that # always return undef regardless of context. # # We also do an 'empty return' if no arguments are passed. This # mimics the PBP guideline for returning nothing. sub list_mirror { return undef if (@_ == 1 and not defined $_[0]); return if not @_; return @_; } ### autodie clobbering tests ### eval { list_mirror(); }; is($@, "", "No autodie, no fatality"); eval { use autodie qw(list_mirror); list_mirror(); }; ok($@, "Autodie fatality for empty return in void context"); eval { list_mirror(); }; is($@, "", "No autodie, no fatality (after autodie used)"); eval { use autodie qw(list_mirror); list_mirror(undef); }; ok($@, "Autodie fatality for undef return in void context"); eval { use autodie qw(list_mirror); my @list = list_mirror(); }; ok($@,"Autodie fatality for empty list return"); eval { use autodie qw(list_mirror); my @list = list_mirror(undef); }; ok($@,"Autodie fatality for undef list return"); eval { use autodie qw(list_mirror); my @list = list_mirror("tada"); }; ok(! $@,"No Autodie fatality for defined list return"); eval { use autodie qw(list_mirror); my $single = list_mirror("tada"); }; ok(! $@,"No Autodie fatality for defined scalar return"); eval { use autodie qw(list_mirror); my $single = list_mirror(undef); }; ok($@,"Autodie fatality for undefined scalar return"); exception_class.t100755001750001750 255312547417731 15540 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use FindBin; use Test::More 'no_plan'; use lib "$FindBin::Bin/lib"; use constant NO_SUCH_FILE => "this_file_had_better_not_exist_xyzzy"; ### Tests with non-existent exception class. my $open_success = eval { use autodie::test::missing qw(open); # Uses non-existent exceptions open(my $fh, '<', NO_SUCH_FILE); 1; }; is($open_success,undef,"Open should fail"); isnt($@,"",'$@ should not be empty'); is(ref($@),"",'$@ should not be a reference or object'); like($@, qr/Failed to load/, '$@ should contain bad exception class msg'); #### Tests with malformed exception class. my $open_success2 = eval { use autodie::test::badname qw(open); open(my $fh, '<', NO_SUCH_FILE); 1; }; is($open_success2,undef,"Open should fail"); isnt($@,"",'$@ should not be empty'); is(ref($@),"",'$@ should not be a reference or object'); like($@, qr/Bad exception class/, '$@ should contain bad exception class msg'); ### Tests with well-formed exception class (in Klingon) my $open_success3 = eval { use pujHa'ghach qw(open); #' <-- this makes my editor happy open(my $fh, '<', NO_SUCH_FILE); 1; }; is($open_success3,undef,"Open should fail"); isnt("$@","",'$@ should not be empty'); isa_ok($@, "pujHa'ghach::Dotlh", '$@ should be a Klingon exception'); like($@, qr/lujqu'/, '$@ should contain Klingon text'); autodie_skippy.pm100640001750001750 55512547417731 15530 0ustar00pjfpjf000000000000autodie-2.29/tpackage autodie_skippy; use strict; use warnings; use autodie; use parent qw(autodie::skip); # This should skip upwards to the caller. sub fail_open { open(my $fh, '<', 'this_file_had_better_not_exist'); } package autodie_unskippy; use autodie; # This should not skip upwards. sub fail_open { open(my $fh, '<', 'this_file_had_better_not_exist'); } 1; OtherTypes.pm100644001750001750 36612547417731 15357 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage OtherTypes; no warnings; our $foo = 23; our @foo = "bar"; our %foo = (mouse => "trap"); open foo, "<", $0; format foo = foo . BEGIN { $main::pvio = *foo{IO}; $main::pvfm = *foo{FORMAT}; } sub foo { 1 } use autodie 'foo'; 1; Hints_test.pm100640001750001750 155312547417731 15410 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Hints_test; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw( fail_on_empty fail_on_false fail_on_undef ); use autodie::hints; # Create some dummy subs that just return their arguments. sub fail_on_empty { return @_; } sub fail_on_false { return @_; } sub fail_on_undef { return @_; } # Set them to different failure modes when used with autodie. autodie::hints->set_hints_for( \&fail_on_empty, { list => autodie::hints::EMPTY_ONLY , scalar => autodie::hints::EMPTY_ONLY } ); autodie::hints->set_hints_for( \&fail_on_false, { list => autodie::hints::EMPTY_OR_FALSE , scalar => autodie::hints::EMPTY_OR_FALSE } ); autodie::hints->set_hints_for( \&fail_on_undef, { list => autodie::hints::EMPTY_OR_UNDEF , scalar => autodie::hints::EMPTY_OR_UNDEF } ); 1; autodie.pm100640001750001750 116012547417731 15335 0ustar00pjfpjf000000000000autodie-2.29/t/lib/mypackage my::autodie; use strict; use warnings; use parent qw(autodie); use autodie::exception; use autodie::hints; autodie::hints->set_hints_for( 'Some::Module::some_sub' => { scalar => sub { 1 }, # No calling in scalar/void context list => sub { @_ == 2 and not defined $_[0] } }, ); autodie::exception->register( 'Some::Module::some_sub' => sub { my ($E) = @_; if ($E->context eq "scalar") { return "some_sub() can't be called in scalar context"; } my $error = $E->return->[1]; return "some_sub() failed: $error"; } ); 1; hints.pm100640001750001750 4053612547417731 15624 0ustar00pjfpjf000000000000autodie-2.29/lib/autodiepackage autodie::hints; use strict; use warnings; use constant PERL58 => ( $] < 5.009 ); our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Provide hints about user subroutines to autodie =head1 NAME autodie::hints - Provide hints about user subroutines to autodie =head1 SYNOPSIS package Your::Module; our %DOES = ( 'autodie::hints::provider' => 1 ); sub AUTODIE_HINTS { return { foo => { scalar => HINTS, list => SOME_HINTS }, bar => { scalar => HINTS, list => MORE_HINTS }, } } # Later, in your main program... use Your::Module qw(foo bar); use autodie qw(:default foo bar); foo(); # succeeds or dies based on scalar hints # Alternatively, hints can be set on subroutines we've # imported. use autodie::hints; use Some::Module qw(think_positive); BEGIN { autodie::hints->set_hints_for( \&think_positive, { fail => sub { $_[0] <= 0 } } ) } use autodie qw(think_positive); think_positive(...); # Returns positive or dies. =head1 DESCRIPTION =head2 Introduction The L pragma is very smart when it comes to working with Perl's built-in functions. The behaviour for these functions are fixed, and C knows exactly how they try to signal failure. But what about user-defined subroutines from modules? If you use C on a user-defined subroutine then it assumes the following behaviour to demonstrate failure: =over =item * A false value, in scalar context =item * An empty list, in list context =item * A list containing a single undef, in list context =back All other return values (including the list of the single zero, and the list containing a single empty string) are considered successful. However, real-world code isn't always that easy. Perhaps the code you're working with returns a string containing the word "FAIL" upon failure, or a two element list containing C<(undef, "human error message")>. To make autodie work with these sorts of subroutines, we have the I. The hinting interface allows I to be provided to C on how it should detect failure from user-defined subroutines. While these I be provided by the end-user of C, they are ideally written into the module itself, or into a helper module or sub-class of C itself. =head2 What are hints? A I is a subroutine or value that is checked against the return value of an autodying subroutine. If the match returns true, C considers the subroutine to have failed. If the hint provided is a subroutine, then C will pass the complete return value to that subroutine. If the hint is any other value, then C will smart-match against the value provided. In Perl 5.8.x there is no smart-match operator, and as such only subroutine hints are supported in these versions. Hints can be provided for both scalar and list contexts. Note that an autodying subroutine will never see a void context, as C always needs to capture the return value for examination. Autodying subroutines called in void context act as if they're called in a scalar context, but their return value is discarded after it has been checked. =head2 Example hints Hints may consist of scalars, array references, regular expressions and subroutine references. You can specify different hints for how failure should be identified in scalar and list contexts. These examples apply for use in the C subroutine and when calling Cset_hints_for()>. The most common context-specific hints are: # Scalar failures always return undef: { scalar => undef } # Scalar failures return any false value [default expectation]: { scalar => sub { ! $_[0] } } # Scalar failures always return zero explicitly: { scalar => '0' } # List failures always return an empty list: { list => [] } # List failures return () or (undef) [default expectation]: { list => sub { ! @_ || @_ == 1 && !defined $_[0] } } # List failures return () or a single false value: { list => sub { ! @_ || @_ == 1 && !$_[0] } } # List failures return (undef, "some string") { list => sub { @_ == 2 && !defined $_[0] } } # Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context, # returns (-1) in list context... autodie::hints->set_hints_for( \&foo, { scalar => qr/^ _? FAIL $/xms, list => [-1], } ); # Unsuccessful foo() returns 0 in all contexts... autodie::hints->set_hints_for( \&foo, { scalar => 0, list => [0], } ); This "in all contexts" construction is very common, and can be abbreviated, using the 'fail' key. This sets both the C and C hints to the same value: # Unsuccessful foo() returns 0 in all contexts... autodie::hints->set_hints_for( \&foo, { fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 } } ); # Unsuccessful think_positive() returns negative number on failure... autodie::hints->set_hints_for( \&think_positive, { fail => sub { $_[0] < 0 } } ); # Unsuccessful my_system() returns non-zero on failure... autodie::hints->set_hints_for( \&my_system, { fail => sub { $_[0] != 0 } } ); =head1 Manually setting hints from within your program If you are using a module which returns something special on failure, then you can manually create hints for each of the desired subroutines. Once the hints are specified, they are available for all files and modules loaded thereafter, thus you can move this work into a module and it will still work. use Some::Module qw(foo bar); use autodie::hints; autodie::hints->set_hints_for( \&foo, { scalar => SCALAR_HINT, list => LIST_HINT, } ); autodie::hints->set_hints_for( \&bar, { fail => SOME_HINT, } ); It is possible to pass either a subroutine reference (recommended) or a fully qualified subroutine name as the first argument. This means you can set hints on modules that I get loaded: use autodie::hints; autodie::hints->set_hints_for( 'Some::Module:bar', { fail => SCALAR_HINT, } ); This technique is most useful when you have a project that uses a lot of third-party modules. You can define all your possible hints in one-place. This can even be in a sub-class of autodie. For example: package my::autodie; use parent qw(autodie); use autodie::hints; autodie::hints->set_hints_for(...); 1; You can now C, which will work just like the standard C, but is now aware of any hints that you've set. =head1 Adding hints to your module C provides a passive interface to allow you to declare hints for your module. These hints will be found and used by C if it is loaded, but otherwise have no effect (or dependencies) without autodie. To set these, your module needs to declare that it I the C role. This can be done by writing your own C method, using a system such as C to handle the heavy-lifting for you, or declaring a C<%DOES> package variable with a C key and a corresponding true value. Note that checking for a C<%DOES> hash is an C-only short-cut. Other modules do not use this mechanism for checking roles, although you can use the C module from the CPAN to allow it. In addition, you must define a C subroutine that returns a hash-reference containing the hints for your subroutines: package Your::Module; # We can use the Class::DOES from the CPAN to declare adherence # to a role. use Class::DOES 'autodie::hints::provider' => 1; # Alternatively, we can declare the role in %DOES. Note that # this is an autodie specific optimisation, although Class::DOES # can be used to promote this to a true role declaration. our %DOES = ( 'autodie::hints::provider' => 1 ); # Finally, we must define the hints themselves. sub AUTODIE_HINTS { return { foo => { scalar => HINTS, list => SOME_HINTS }, bar => { scalar => HINTS, list => MORE_HINTS }, baz => { fail => HINTS }, } } This allows your code to set hints without relying on C and C being loaded, or even installed. In this way your code can do the right thing when C is installed, but does not need to depend upon it to function. =head1 Insisting on hints When a user-defined subroutine is wrapped by C, it will use hints if they are available, and otherwise reverts to the I described in the introduction of this document. This can be problematic if we expect a hint to exist, but (for whatever reason) it has not been loaded. We can ask autodie to I that a hint be used by prefixing an exclamation mark to the start of the subroutine name. A lone exclamation mark indicates that I subroutines after it must have hints declared. # foo() and bar() must have their hints defined use autodie qw( !foo !bar baz ); # Everything must have hints (recommended). use autodie qw( ! foo bar baz ); # bar() and baz() must have their hints defined use autodie qw( foo ! bar baz ); # Enable autodie for all of Perl's supported built-ins, # as well as for foo(), bar() and baz(). Everything must # have hints. use autodie qw( ! :all foo bar baz ); If hints are not available for the specified subroutines, this will cause a compile-time error. Insisting on hints for Perl's built-in functions (eg, C and C) is always successful. Insisting on hints is I recommended. =cut # TODO: implement regular expression hints use constant UNDEF_ONLY => sub { not defined $_[0] }; use constant EMPTY_OR_UNDEF => sub { ! @_ or @_==1 && !defined $_[0] }; use constant EMPTY_ONLY => sub { @_ == 0 }; use constant EMPTY_OR_FALSE => sub { ! @_ or @_==1 && !$_[0] }; use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] }; use constant DEFAULT_HINTS => { scalar => UNDEF_ONLY, list => EMPTY_OR_UNDEF, }; use constant HINTS_PROVIDER => 'autodie::hints::provider'; our $DEBUG = 0; # Only ( undef ) is a strange but possible situation for very # badly written code. It's not supported yet. my %Hints = ( 'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, 'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, 'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, 'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, ); # Start by using Sub::Identify if it exists on this system. eval { require Sub::Identify; Sub::Identify->import('get_code_info'); }; # If it doesn't exist, we'll define our own. This code is directly # taken from Rafael Garcia's Sub::Identify 0.04, used under the same # license as Perl itself. if ($@) { require B; no warnings 'once'; *get_code_info = sub ($) { my ($coderef) = @_; ref $coderef or return; my $cv = B::svref_2object($coderef); $cv->isa('B::CV') or return; # bail out if GV is undefined $cv->GV->isa('B::SPECIAL') and return; return ($cv->GV->STASH->NAME, $cv->GV->NAME); }; } sub sub_fullname { return join( '::', get_code_info( $_[1] ) ); } my %Hints_loaded = (); sub load_hints { my ($class, $sub) = @_; my ($package) = ( $sub =~ /(.*)::/ ); if (not defined $package) { require Carp; Carp::croak( "Internal error in autodie::hints::load_hints - no package found. "); } # Do nothing if we've already tried to load hints for # this package. return if $Hints_loaded{$package}++; my $hints_available = 0; { no strict 'refs'; ## no critic if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) { $hints_available = 1; } elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) { $hints_available = 1; } elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) { $hints_available = 1; } } return if not $hints_available; my %package_hints = %{ $package->AUTODIE_HINTS }; foreach my $sub (keys %package_hints) { my $hint = $package_hints{$sub}; # Ensure we have a package name. $sub = "${package}::$sub" if $sub !~ /::/; # TODO - Currently we don't check for conflicts, should we? $Hints{$sub} = $hint; $class->normalise_hints(\%Hints, $sub); } return; } sub normalise_hints { my ($class, $hints, $sub) = @_; if ( exists $hints->{$sub}->{fail} ) { if ( exists $hints->{$sub}->{scalar} or exists $hints->{$sub}->{list} ) { # TODO: Turn into a proper diagnostic. require Carp; local $Carp::CarpLevel = 1; Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub"); } # Set our scalar and list hints. $hints->{$sub}->{scalar} = $hints->{$sub}->{list} = delete $hints->{$sub}->{fail}; return; } # Check to make sure all our hints exist. foreach my $hint (qw(scalar list)) { if ( not exists $hints->{$sub}->{$hint} ) { # TODO: Turn into a proper diagnostic. require Carp; local $Carp::CarpLevel = 1; Carp::croak("$hint hint missing for $sub"); } } return; } sub get_hints_for { my ($class, $sub) = @_; my $subname = $class->sub_fullname( $sub ); # If we have hints loaded for a sub, then return them. if ( exists $Hints{ $subname } ) { return $Hints{ $subname }; } # If not, we try to load them... $class->load_hints( $subname ); # ...and try again! if ( exists $Hints{ $subname } ) { return $Hints{ $subname }; } # It's the caller's responsibility to use defaults if desired. # This allows on autodie to insist on hints if needed. return; } sub set_hints_for { my ($class, $sub, $hints) = @_; if (ref $sub) { $sub = $class->sub_fullname( $sub ); require Carp; $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine"); } if ($DEBUG) { warn "autodie::hints: Setting $sub to hints: $hints\n"; } $Hints{ $sub } = $hints; $class->normalise_hints(\%Hints, $sub); return; } 1; __END__ =head1 Diagnostics =over 4 =item Attempts to set_hints_for unidentifiable subroutine You've called C<< autodie::hints->set_hints_for() >> using a subroutine reference, but that reference could not be resolved back to a subroutine name. It may be an anonymous subroutine (which can't be made autodying), or may lack a name for other reasons. If you receive this error with a subroutine that has a real name, then you may have found a bug in autodie. See L for how to report this. =item fail hints cannot be provided with either scalar or list hints for %s When defining hints, you can either supply both C and C keywords, I you can provide a single C keyword. You can't mix and match them. =item %s hint missing for %s You've provided either a C hint without supplying a C hint, or vice-versa. You I supply both C and C hints, I a single C hint. =back =head1 ACKNOWLEDGEMENTS =over =item * Dr Damian Conway for suggesting the hinting interface and providing the example usage. =item * Jacinta Richardson for translating much of my ideas into this documentation. =back =head1 AUTHOR Copyright 2009, Paul Fenwick Epjf@perltraining.com.auE =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. =head1 SEE ALSO L, L =for Pod::Coverage get_hints_for load_hints normalise_hints sub_fullname get_code_info =cut basic_exceptions.t100755001750001750 263412547417731 15677 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use Test::More tests => 19; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; my $line; eval { use autodie ':io'; $line = __LINE__; open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr/Can't open '\w+' for reading: /, "Prety printed open msg"); like($@, qr{\Q$0\E}, "Our file mention in error message"); like($@, qr{for reading: '.+'}, "Error should be in single-quotes"); like($@->errno,qr/./, "Errno should not be empty"); like($@, qr{\n$}, "Errors should end with a newline"); is($@->file, $0, "Correct file"); is($@->function, 'CORE::open', "Correct dying sub"); is($@->package, __PACKAGE__, "Correct package"); is($@->caller,__PACKAGE__."::__ANON__", "Correct caller"); is($@->line, $line, "Correct line"); is($@->args->[1], '<', 'Correct mode arg'); is($@->args->[2], NO_SUCH_FILE, 'Correct filename arg'); ok($@->matches('open'), 'Looks like an error from open'); ok($@->matches(':io'), 'Looks like an error from :io'); is($@->context, 'scalar', 'Open called in scalar/void context'); is($@->return,undef,'Open should return undef on failure'); # Testing of caller info with a real subroutine. my $line2; sub xyzzy { use autodie ':io'; $line2 = __LINE__; open(my $fh, '<', NO_SUCH_FILE); return; }; eval { xyzzy(); }; isa_ok($@, 'autodie::exception'); is($@->caller, __PACKAGE__."::xyzzy", "Subroutine caller test"); is($@->line, $line2, "Subroutine line test"); string-eval-leak.t100755001750001750 146412547417731 15522 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 2; # Under Perl 5.10.x, a string eval can cause a copy to be taken of # %^H, which delays stringification of our scope guard objects, # which in turn causes autodie to leak. These tests check to see # if we've successfully worked around this issue. eval { { use autodie; eval "1"; } open(my $fh, '<', 'this_file_had_better_not_exist'); }; TODO: { local $TODO; if ( $] >= 5.010 ) { $TODO = "Autodie can leak near string evals in 5.10.x"; } is("$@","","Autodie should not leak out of scope"); } # However, we can plug the leak with 'no autodie'. no autodie; eval { open(my $fh, '<', 'this_file_had_better_not_exist'); }; is("$@","",'no autodie should be able to workaround this bug'); Some000755001750001750 012547417731 13471 5ustar00pjfpjf000000000000autodie-2.29/t/libModule.pm100640001750001750 50712547417731 15372 0ustar00pjfpjf000000000000autodie-2.29/t/lib/Somepackage Some::Module; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(some_sub); # This is an example of a subroutine that returns (undef, $msg) # to signal failure. sub some_sub { my ($arg) = @_; if ($arg) { return (undef, "Insufficient credit"); } return (1,2,3); } 1; pujHa000755001750001750 012547417731 13635 5ustar00pjfpjf000000000000autodie-2.29/t/libghach.pm100640001750001750 123612547417731 15403 0ustar00pjfpjf000000000000autodie-2.29/t/lib/pujHapackage pujHa'ghach; # Translator notes: reH Hegh is Kligon for "always dying". # It was the original name for this testing pragma, but # it lacked an apostrophe, which better shows how Perl is # useful in Klingon naming schemes. # The new name is pujHa'ghach is "thing which is not weak". # puj -> be weak (verb) # -Ha' -> not # ghach -> normalise -Ha' verb into noun. # # I'm not use if -wI' should be used here. pujwI' is "thing which # is weak". One could conceivably use "pujHa'wI'" for "thing which # is not weak". use strict; use warnings; use parent qw(autodie); sub exception_class { return "pujHa'ghach::Dotlh"; # Dotlh - status } 1; string-eval-basic.t100755001750001750 116012547417731 15660 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 3; use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; # Keep this test alone in its file as it can be hidden by using autodie outside # the eval. # Just to make sure we're absolutely not encountering any weird $@ clobbering # events, we'll capture a result from our string eval. my $result = eval q{ use autodie "open"; open(my $fh, '<', NO_SUCH_FILE); 1; }; ok( ! $result, "Eval should fail with autodie/no such file"); ok($@, "enabling autodie in string eval should throw an exception"); isa_ok($@, 'autodie::exception'); release-pod-syntax.t100644001750001750 45612547417731 16056 0ustar00pjfpjf000000000000autodie-2.29/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use Test::More; use Test::Pod 1.41; all_pod_files_ok(); raw-call.pl100755001750001750 37112547417731 16055 0ustar00pjfpjf000000000000autodie-2.29/benchmarks#!/usr/bin/perl -w use 5.010; use strict; use warnings; use constant N => 1000000; # Essentially run a no-op many times - This is useful for comparison # with leak.pl or call.pl sub run { for (1..N) { binmode(STDOUT); } } run(); hints_pod_examples.t100755001750001750 1245412547417731 16263 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie::hints; use Test::More; use constant PERL510 => ( $] >= 5.010 ); BEGIN { if (not PERL510) { plan skip_all => "Only subroutine hints supported in 5.8.x"; } else { plan 'no_plan'; } } use FindBin; use lib "$FindBin::Bin/lib"; use Hints_pod_examples qw( undef_scalar false_scalar zero_scalar empty_list default_list empty_or_false_list undef_n_error_list foo re_fail bar think_positive my_system ); use autodie qw( ! undef_scalar false_scalar zero_scalar empty_list default_list empty_or_false_list undef_n_error_list foo re_fail bar think_positive my_system ); my %scalar_tests = ( # Test code # Exception expected? 'undef_scalar()' => 1, 'undef_scalar(1)', => 0, 'undef_scalar(0)', => 0, 'undef_scalar("")', => 0, 'false_scalar(0)', => 1, 'false_scalar()', => 1, 'false_scalar(undef)', => 1, 'false_scalar("")', => 1, 'false_scalar(1)', => 0, 'false_scalar("1")', => 0, 'zero_scalar("0")', => 1, 'zero_scalar(0)', => 1, 'zero_scalar(1)', => 0, 'zero_scalar(undef)', => 0, 'zero_scalar("")', => 0, 'foo(0)', => 1, 'foo(undef)', => 0, 'foo(1)', => 0, 'bar(0)', => 1, 'bar(undef)', => 0, 'bar(1)', => 0, 're_fail(-1)', => 0, 're_fail("FAIL")', => 1, 're_fail("_FAIL")', => 1, 're_fail("_fail")', => 0, 're_fail("fail")', => 0, 'think_positive(-1)' => 1, 'think_positive(-2)' => 1, 'think_positive(0)' => 0, 'think_positive(1)' => 0, 'think_positive(2)' => 0, 'my_system(1)' => 1, 'my_system(2)' => 1, 'my_system(0)' => 0, ); my %list_tests = ( 'empty_list()', => 1, 'empty_list(())', => 1, 'empty_list([])', => 0, 'empty_list(0)', => 0, 'empty_list("")', => 0, 'empty_list(undef)', => 0, 'default_list()', => 1, 'default_list(0)', => 0, 'default_list("")', => 0, 'default_list(undef)', => 1, 'default_list(1)', => 0, 'default_list("str")', => 0, 'default_list(1, 2)', => 0, 'empty_or_false_list()', => 1, 'empty_or_false_list(())', => 1, 'empty_or_false_list(0)', => 1, 'empty_or_false_list(undef)',=> 1, 'empty_or_false_list("")', => 1, 'empty_or_false_list("0")', => 1, 'empty_or_false_list(1,2)', => 0, 'empty_or_false_list("a")', => 0, 'undef_n_error_list(undef, 1)' => 1, 'undef_n_error_list(undef, "a")' => 1, 'undef_n_error_list()' => 0, 'undef_n_error_list(0, 1)' => 0, 'undef_n_error_list("", 1)' => 0, 'undef_n_error_list(1)' => 0, 'foo(0)', => 1, 'foo(undef)', => 0, 'foo(1)', => 0, 'bar(0)', => 1, 'bar(undef)', => 0, 'bar(1)', => 0, 're_fail(-1)', => 1, 're_fail("FAIL")', => 0, 're_fail("_FAIL")', => 0, 're_fail("_fail")', => 0, 're_fail("fail")', => 0, 'think_positive(-1)' => 1, 'think_positive(-2)' => 1, 'think_positive(0)' => 0, 'think_positive(1)' => 0, 'think_positive(2)' => 0, 'my_system(1)' => 1, 'my_system(2)' => 1, 'my_system(0)' => 0, ); # On Perl 5.8, autodie doesn't correctly propagate into string evals. # The following snippet forces the use of autodie inside the eval if # we really really have to. For 5.10+, we don't want to include this # fix, because the tests will act as a canary if we screw up string # eval propagation. my $perl58_fix = ( PERL510 ? q{} : q{use autodie qw( undef_scalar false_scalar zero_scalar empty_list default_list empty_or_false_list undef_n_error_list foo re_fail bar think_positive my_system bizarro_system );} ); # Some of the tests provide different hints for scalar or list context # NOTE: these tests are sensitive to order (not sure why) therefore # this loop must use a sorted list of keys . Otherwise there is an occasional # failure like this: # # Failed test 'scalar test - zero_scalar("")' # at cpan/autodie/t/hints_pod_examples.t line 168. # got: 'Can't zero_scalar(''): at cpan/autodie/t/hints_pod_examples.t line 157 # ' # expected: '' # # # my $scalar = zero_scalar(""); # 1; foreach my $test (sort keys %scalar_tests) { my $exception_expected= $scalar_tests{$test}; my $ok= eval(my $code= " $perl58_fix my \$scalar = $test; 1; "); if ($exception_expected) { isnt($ok ? "" : "$@", "", "scalar test - $test") or diag($code); } else { is($ok ? "" : "$@", "", "scalar test - $test") or diag($code); } } # this set of test is not *known* to be order dependent however we sort it anyway out caution foreach my $test (sort keys %list_tests) { my $exception_expected= $list_tests{$test}; eval " $perl58_fix my \@array = $test; "; if ($exception_expected) { isnt("$@", "", "array test - $test"); } else { is($@, "", "array test - $test"); } } 1; hints_provider_isa.t100755001750001750 103612547417731 16243 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie; use Test::More 'no_plan'; use FindBin qw($Bin); use lib "$Bin/lib"; use Hints_provider_isa qw(always_pass always_fail); use autodie qw(always_pass always_fail); eval { my $x = always_pass() }; is("$@", "", "always_pass in scalar context"); eval { my @x = always_pass() }; is("$@", "", "always_pass in list context"); eval { my $x = always_fail() }; isnt("$@", "", "always_fail in scalar context"); eval { my @x = always_fail() }; isnt("$@", "", "always_fail in list context"); Caller_helper.pm100644001750001750 22112547417731 16000 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Caller_helper; our $line; sub foo { use autodie; $line = __LINE__; open(my $fh, '<', "no_such_file_here"); return; } 1; benchmark.pl100755001750001750 42212547417731 16302 0ustar00pjfpjf000000000000autodie-2.29/benchmarks#!/usr/bin/perl use strict; use warnings; use autodie; # Load time benchmark. Courtesy Niels Thykier use constant N => 1000; # Pretend we are a project with a N modules that all use autodie. my $str = join("\n", map { "package A$_;\nuse autodie;\n" } (1..N)); eval $str; hints_provider_does.t100755001750001750 103712547417731 16422 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie; use Test::More 'no_plan'; use FindBin qw($Bin); use lib "$Bin/lib"; use Hints_provider_does qw(always_pass always_fail); use autodie qw(always_pass always_fail); eval { my $x = always_pass() }; is("$@", "", "always_pass in scalar context"); eval { my @x = always_pass() }; is("$@", "", "always_pass in list context"); eval { my $x = always_fail() }; isnt("$@", "", "always_fail in scalar context"); eval { my @x = always_fail() }; isnt("$@", "", "always_fail in list context"); internal-backcompat.t100755001750001750 546012547417731 16273 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use Fatal; use Test::More 'no_plan'; # Tests to determine if Fatal's internal interfaces remain backwards # compatible. # # WARNING: This file contains a lot of very ugly code, hard-coded # strings, and nasty API calls. It may frighten small children. # Viewer discretion is advised. # fill_protos. This hasn't been changed since the original Fatal, # and so should always be the same. my %protos = ( '$' => [ [ 1, '$_[0]' ] ], '$$' => [ [ 2, '$_[0]', '$_[1]' ] ], '$$@' => [ [ 3, '$_[0]', '$_[1]', '@_[2..$#_]' ] ], '\$' => [ [ 1, '${$_[0]}' ] ], '\%' => [ [ 1, '%{$_[0]}' ] ], '\%;$*' => [ [ 1, '%{$_[0]}' ], [ 2, '%{$_[0]}', '$_[1]' ], [ 3, '%{$_[0]}', '$_[1]', '$_[2]' ] ], ); while (my ($proto, $code) = each %protos) { is_deeply( [ Fatal::fill_protos($proto) ], $code, $proto); } # write_invocation tests no warnings 'qw'; # Technically the outputted code varies from the classical Fatal. # However the changes are mostly whitespace. Those that aren't are # improvements to error messages or bug fixes. my @write_invocation_calls = ( [ # Core # Call # Name # Void # Args [ 1, 'CORE::open', 'open', 0, [ 1, qw($_[0]) ], [ 2, qw($_[0] $_[1]) ], [ 3, qw($_[0] $_[1] @_[2..$#_])] ], q{ if (@_ == 1) { return CORE::open($_[0]) || Carp::croak("Can't open(@_): $!") } elsif (@_ == 2) { return CORE::open($_[0], $_[1]) || Carp::croak("Can't open(@_): $!") } elsif (@_ >= 3) { return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!") } die "Internal error: open(@_): Do not expect to get ", scalar(@_), " arguments"; } ] ); foreach my $test (@write_invocation_calls) { is(Fatal::write_invocation( @{ $test->[0] } ), $test->[1], 'write_inovcation'); } # one_invocation tests. my @one_invocation_calls = ( # Core # Call # Name # Void # Args [ [ 1, 'CORE::open', 'open', 0, qw($_[0] $_[1] @_[2..$#_]) ], q{return CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")}, ], [ [ 1, 'CORE::open', 'open', 1, qw($_[0] $_[1] @_[2..$#_]) ], q{return (defined wantarray)?CORE::open($_[0], $_[1], @_[2..$#_]): CORE::open($_[0], $_[1], @_[2..$#_]) || Carp::croak("Can't open(@_): $!")}, ], ); foreach my $test (@one_invocation_calls) { is(Fatal::one_invocation( @{ $test->[0] } ), $test->[1], 'one_inovcation'); } # TODO: _make_fatal # Since this subroutine has always started with an underscore, # I think it's pretty clear that it's internal-only. I'm not # testing it here, and it doesn't yet have backcompat. release-pod-coverage.t100644001750001750 57212547417731 16322 0ustar00pjfpjf000000000000autodie-2.29/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } # This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. use Test::Pod::Coverage 1.08; use Pod::Coverage::TrustPod; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); exception.pm100640001750001750 5233012547417731 16470 0ustar00pjfpjf000000000000autodie-2.29/lib/autodiepackage autodie::exception; use 5.008; use strict; use warnings; use Carp qw(croak); our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; use overload q{""} => "stringify", # Overload smart-match only if we're using 5.10 or up ($] >= 5.010 ? ('~~' => "matches") : ()), fallback => 1 ; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. =head1 NAME autodie::exception - Exceptions from autodying functions. =head1 SYNOPSIS eval { use autodie; open(my $fh, '<', 'some_file.txt'); ... }; if (my $E = $@) { say "Ooops! ",$E->caller," had problems: $@"; } =head1 DESCRIPTION When an L enabled function fails, it generates an C object. This can be interrogated to determine further information about the error that occurred. This document is broken into two sections; those methods that are most useful to the end-developer, and those methods for anyone wishing to subclass or get very familiar with C. =head2 Common Methods These methods are intended to be used in the everyday dealing of exceptions. The following assume that the error has been copied into a separate scalar: if ($E = $@) { ... } This is not required, but is recommended in case any code is called which may reset or alter C<$@>. =cut =head3 args my $array_ref = $E->args; Provides a reference to the arguments passed to the subroutine that died. =cut sub args { return $_[0]->{$PACKAGE}{args}; } =head3 function my $sub = $E->function; The subroutine (including package) that threw the exception. =cut sub function { return $_[0]->{$PACKAGE}{function}; } =head3 file my $file = $E->file; The file in which the error occurred (eg, C or C). =cut sub file { return $_[0]->{$PACKAGE}{file}; } =head3 package my $package = $E->package; The package from which the exceptional subroutine was called. =cut sub package { return $_[0]->{$PACKAGE}{package}; } =head3 caller my $caller = $E->caller; The subroutine that I the exceptional code. =cut sub caller { return $_[0]->{$PACKAGE}{caller}; } =head3 line my $line = $E->line; The line in C<< $E->file >> where the exceptional code was called. =cut sub line { return $_[0]->{$PACKAGE}{line}; } =head3 context my $context = $E->context; The context in which the subroutine was called by autodie; usually the same as the context in which you called the autodying subroutine. This can be 'list', 'scalar', or undefined (unknown). It will never be 'void', as C always captures the return value in one way or another. For some core functions that always return a scalar value regardless of their context (eg, C), this may be 'scalar', even if you used a list context. =cut # TODO: The comments above say this can be undefined. Is that actually # the case? (With 'system', perhaps?) sub context { return $_[0]->{$PACKAGE}{context} } =head3 return my $return_value = $E->return; The value(s) returned by the failed subroutine. When the subroutine was called in a list context, this will always be a reference to an array containing the results. When the subroutine was called in a scalar context, this will be the actual scalar returned. =cut sub return { return $_[0]->{$PACKAGE}{return} } =head3 errno my $errno = $E->errno; The value of C<$!> at the time when the exception occurred. B: This method will leave the main C class and become part of a role in the future. You should only call C for exceptions where C<$!> would reasonably have been set on failure. =cut # TODO: Make errno part of a role. It doesn't make sense for # everything. sub errno { return $_[0]->{$PACKAGE}{errno}; } =head3 eval_error my $old_eval_error = $E->eval_error; The contents of C<$@> immediately after autodie triggered an exception. This may be useful when dealing with modules such as L that set (but do not throw) C<$@> on error. =cut sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } =head3 matches if ( $e->matches('open') ) { ... } if ( $e ~~ 'open' ) { ... } C is used to determine whether a given exception matches a particular role. On Perl 5.10, using smart-match (C<~~>) with an C object will use C underneath. An exception is considered to match a string if: =over 4 =item * For a string not starting with a colon, the string exactly matches the package and subroutine that threw the exception. For example, C. If the string does not contain a package name, C is assumed. =item * For a string that does start with a colon, if the subroutine throwing the exception I that behaviour. For example, the C subroutine does C<:file>, C<:io> and C<:all>. See L for further information. =back =cut { my (%cache); sub matches { my ($this, $that) = @_; # TODO - Handle references croak "UNIMPLEMENTED" if ref $that; my $sub = $this->function; if ($DEBUG) { my $sub2 = $this->function; warn "Smart-matching $that against $sub / $sub2\n"; } # Direct subname match. return 1 if $that eq $sub; return 1 if $that !~ /:/ and "CORE::$that" eq $sub; return 0 if $that !~ /^:/; # Cached match / check tags. require Fatal; if (exists $cache{$sub}{$that}) { return $cache{$sub}{$that}; } # This rather awful looking line checks to see if our sub is in the # list of expanded tags, caches it, and returns the result. return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; } } # This exists primarily so that child classes can override or # augment it if they wish. sub _expand_tag { my ($this, @args) = @_; return Fatal->_expand_tag(@args); } =head2 Advanced methods The following methods, while usable from anywhere, are primarily intended for developers wishing to subclass C, write code that registers custom error messages, or otherwise work closely with the C model. =cut # The table below records customer formatters. # TODO - Should this be a package var instead? # TODO - Should these be in a completely different file, or # perhaps loaded on demand? Most formatters will never # get used in most programs. my %formatter_of = ( 'CORE::close' => \&_format_close, 'CORE::open' => \&_format_open, 'CORE::dbmopen' => \&_format_dbmopen, 'CORE::flock' => \&_format_flock, 'CORE::read' => \&_format_readwrite, 'CORE::sysread' => \&_format_readwrite, 'CORE::syswrite' => \&_format_readwrite, 'CORE::chmod' => \&_format_chmod, 'CORE::mkdir' => \&_format_mkdir, ); sub _beautify_arguments { shift @_; # Walk through all our arguments, and... # # * Replace undef with the word 'undef' # * Replace globs with the string '$fh' # * Quote all other args. foreach my $arg (@_) { if (not defined($arg)) { $arg = 'undef' } elsif (ref($arg) eq "GLOB") { $arg = '$fh' } else { $arg = qq{'$arg'} } } return @_; } sub _trim_package_name { # Info: The following is done since 05/2008 (which is before v1.10) # TODO: This is probably a good idea for CORE, is it # a good idea for other subs? # Trim package name off dying sub for error messages (my $name = $_[1]) =~ s/.*:://; return $name; } # Returns the parameter formatted as octal number sub _octalize_number { my $number = $_[1]; # Only reformat if it looks like a whole number if ($number =~ /^\d+$/) { $number = sprintf("%#04lo", $number); } return $number; } # TODO: Our tests only check LOCK_EX | LOCK_NB is properly # formatted. Try other combinations and ensure they work # correctly. sub _format_flock { my ($this) = @_; require Fcntl; my $filehandle = $this->args->[0]; my $raw_mode = $this->args->[1]; my $mode_type; my $lock_unlock; if ($raw_mode & Fcntl::LOCK_EX() ) { $lock_unlock = "lock"; $mode_type = "for exclusive access"; } elsif ($raw_mode & Fcntl::LOCK_SH() ) { $lock_unlock = "lock"; $mode_type = "for shared access"; } elsif ($raw_mode & Fcntl::LOCK_UN() ) { $lock_unlock = "unlock"; $mode_type = ""; } else { # I've got no idea what they're trying to do. $lock_unlock = "lock"; $mode_type = "with mode $raw_mode"; } my $cooked_filehandle; if ($filehandle and not ref $filehandle) { # A package filehandle with a name! $cooked_filehandle = " $filehandle"; } else { # Otherwise we have a scalar filehandle. $cooked_filehandle = ''; } local $! = $this->errno; return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; } # Default formatter for CORE::chmod sub _format_chmod { my ($this) = @_; my @args = @{$this->args}; my $mode = shift @args; local $! = $this->errno; $mode = $this->_octalize_number($mode); @args = $this->_beautify_arguments(@args); return "Can't chmod($mode, ". join(q{, }, @args) ."): $!"; } # Default formatter for CORE::mkdir sub _format_mkdir { my ($this) = @_; my @args = @{$this->args}; # If no mask is specified use default formatter if (@args < 2) { return $this->format_default; } my $file = $args[0]; my $mask = $args[1]; local $! = $this->errno; $mask = $this->_octalize_number($mask); return "Can't mkdir('$file', $mask): '$!'"; } # Default formatter for CORE::dbmopen sub _format_dbmopen { my ($this) = @_; my @args = @{$this->args}; # TODO: Presently, $args flattens out the (usually empty) hash # which is passed as the first argument to dbmopen. This is # a bug in our args handling code (taking a reference to it would # be better), but for the moment we'll just examine the end of # our arguments list for message formatting. my $mode = $args[-1]; my $file = $args[-2]; $mode = $this->_octalize_number($mode); local $! = $this->errno; return "Can't dbmopen(%hash, '$file', $mode): '$!'"; } # Default formatter for CORE::close sub _format_close { my ($this) = @_; my $close_arg = $this->args->[0]; local $! = $this->errno; # If we've got an old-style filehandle, mention it. if ($close_arg and not ref $close_arg) { return "Can't close filehandle '$close_arg': '$!'"; } # TODO - This will probably produce an ugly error. Test and fix. return "Can't close($close_arg) filehandle: '$!'"; } # Default formatter for CORE::read, CORE::sysread and CORE::syswrite # # Similar to default formatter with the buffer filtered out as it # may contain binary data. sub _format_readwrite { my ($this) = @_; my $call = $this->_trim_package_name($this->function); local $! = $this->errno; # These subs receive the following arguments (in order): # # * FILEHANDLE # * SCALAR (buffer, we do not want to write this) # * LENGTH (optional for syswrite) # * OFFSET (optional for all) my (@args) = @{$this->args}; my $arg_name = $args[1]; if (defined($arg_name)) { if (ref($arg_name)) { my $name = blessed($arg_name) || ref($arg_name); $arg_name = "<${name}>"; } else { $arg_name = ''; } } else { $arg_name = ''; } $args[1] = $arg_name; return "Can't $call(" . join(q{, }, @args) . "): $!"; } # Default formatter for CORE::open use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; sub _format_open_with_mode { my ($this, $mode, $file, $error) = @_; my $wordy_mode; if ($mode eq '<') { $wordy_mode = 'reading'; } elsif ($mode eq '>') { $wordy_mode = 'writing'; } elsif ($mode eq '>>') { $wordy_mode = 'appending'; } $file = '' if not defined $file; return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); } sub _format_open { my ($this) = @_; my @open_args = @{$this->args}; # Use the default formatter for single-arg and many-arg open if (@open_args <= 1 or @open_args >= 4) { return $this->format_default; } # For two arg open, we have to extract the mode if (@open_args == 2) { my ($fh, $file) = @open_args; if (ref($fh) eq "GLOB") { $fh = '$fh'; } my ($mode) = $file =~ m{ ^\s* # Spaces before mode ( (?> # Non-backtracking subexp. < # Reading |>>? # Writing/appending ) ) [^&] # Not an ampersand (which means a dup) }x; if (not $mode) { # Maybe it's a 2-arg open without any mode at all? # Detect the most simple case for this, where our # file consists only of word characters. if ( $file =~ m{^\s*\w+\s*$} ) { $mode = '<' } else { # Otherwise, we've got no idea what's going on. # Use the default. return $this->format_default; } } # Localising $! means perl makes it a pretty error for us. local $! = $this->errno; return $this->_format_open_with_mode($mode, $file, $!); } # Here we must be using three arg open. my $file = $open_args[2]; local $! = $this->errno; my $mode = $open_args[1]; local $@; my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; return $msg if $msg; # Default message (for pipes and odd things) return "Can't open '$file' with mode '$open_args[1]': '$!'"; } =head3 register autodie::exception->register( 'CORE::open' => \&mysub ); The C method allows for the registration of a message handler for a given subroutine. The full subroutine name including the package should be used. Registered message handlers will receive the C object as the first parameter. =cut sub register { my ($class, $symbol, $handler) = @_; croak "Incorrect call to autodie::register" if @_ != 3; $formatter_of{$symbol} = $handler; } =head3 add_file_and_line say "Problem occurred",$@->add_file_and_line; Returns the string C< at %s line %d>, where C<%s> is replaced with the filename, and C<%d> is replaced with the line number. Primarily intended for use by format handlers. =cut # Simply produces the file and line number; intended to be added # to the end of error messages. sub add_file_and_line { my ($this) = @_; return sprintf(" at %s line %d\n", $this->file, $this->line); } =head3 stringify say "The error was: ",$@->stringify; Formats the error as a human readable string. Usually there's no reason to call this directly, as it is used automatically if an C object is ever used as a string. Child classes can override this method to change how they're stringified. =cut sub stringify { my ($this) = @_; my $call = $this->function; my $msg; if ($DEBUG) { my $dying_pkg = $this->package; my $sub = $this->function; my $caller = $this->caller; warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; } # TODO - This isn't using inheritance. Should it? if ( my $sub = $formatter_of{$call} ) { $msg = $sub->($this) . $this->add_file_and_line; } else { $msg = $this->format_default . $this->add_file_and_line; } $msg .= $this->{$PACKAGE}{_stack_trace} if $Carp::Verbose; return $msg; } =head3 format_default my $error_string = $E->format_default; This produces the default error string for the given exception, I. It is primarily intended to be called from a message handler when they have been passed an exception they don't want to format. Child classes can override this method to change how default messages are formatted. =cut # TODO: This produces ugly errors. Is there any way we can # dig around to find the actual variable names? I know perl 5.10 # does some dark and terrible magicks to find them for undef warnings. sub format_default { my ($this) = @_; my $call = $this->_trim_package_name($this->function); local $! = $this->errno; my @args = @{ $this->args() }; @args = $this->_beautify_arguments(@args); # Format our beautiful error. return "Can't $call(". join(q{, }, @args) . "): $!" ; # TODO - Handle user-defined errors from hash. # TODO - Handle default error messages. } =head3 new my $error = autodie::exception->new( args => \@_, function => "CORE::open", errno => $!, context => 'scalar', return => undef, ); Creates a new C object. Normally called directly from an autodying function. The C argument is required, its the function we were trying to call that generated the exception. The C parameter is optional. The C value is optional. In versions of C 1.99 and earlier the code would try to automatically use the current value of C<$!>, but this was unreliable and is no longer supported. Atrributes such as package, file, and caller are determined automatically, and cannot be specified. =cut sub new { my ($class, @args) = @_; my $this = {}; bless($this,$class); # I'd love to use EVERY here, but it causes our code to die # because it wants to stringify our objects before they're # initialised, causing everything to explode. $this->_init(@args); return $this; } sub _init { my ($this, %args) = @_; # Capturing errno here is not necessarily reliable. my $original_errno = $!; our $init_called = 1; my $class = ref $this; # We're going to walk up our call stack, looking for the # first thing that doesn't look like our exception # code, autodie/Fatal, or some whacky eval. my ($package, $file, $line, $sub); my $depth = 0; while (1) { $depth++; ($package, $file, $line, $sub) = CORE::caller($depth); # Skip up the call stack until we find something outside # of the Fatal/autodie/eval space. next if $package->isa('Fatal'); next if $package->isa($class); next if $package->isa(__PACKAGE__); # Anything with the 'autodie::skip' role wants us to skip it. # https://github.com/pjf/autodie/issues/15 next if ($package->can('DOES') and $package->DOES('autodie::skip')); next if $file =~ /^\(eval\s\d+\)$/; last; } # We now have everything correct, *except* for our subroutine # name. If it's __ANON__ or (eval), then we need to keep on # digging deeper into our stack to find the real name. However we # don't update our other information, since that will be correct # for our current exception. my $first_guess_subroutine = $sub; while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { $depth++; $sub = (CORE::caller($depth))[3]; } # If we end up falling out the bottom of our stack, then our # __ANON__ guess is the best we can get. This includes situations # where we were called from the top level of a program. if (not defined $sub) { $sub = $first_guess_subroutine; } $this->{$PACKAGE}{package} = $package; $this->{$PACKAGE}{file} = $file; $this->{$PACKAGE}{line} = $line; $this->{$PACKAGE}{caller} = $sub; # Tranks to %Carp::CarpInternal all Fatal, autodie and # autodie::exception stack frames are filtered already, but our # nameless wrapper is still present, so strip that. my $trace = Carp::longmess(); $trace =~ s/^\s*at \(eval[^\n]+\n//; # And if we see an __ANON__, then we'll replace that with the actual # name of our autodying function. my $short_func = $args{function}; $short_func =~ s/^CORE:://; $trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/; # And now we just fill in all our attributes. $this->{$PACKAGE}{_stack_trace} = $trace; $this->{$PACKAGE}{errno} = $args{errno} || 0; $this->{$PACKAGE}{context} = $args{context}; $this->{$PACKAGE}{return} = $args{return}; $this->{$PACKAGE}{eval_error} = $args{eval_error}; $this->{$PACKAGE}{args} = $args{args} || []; $this->{$PACKAGE}{function}= $args{function} or croak("$class->new() called without function arg"); return $this; } 1; __END__ =head1 SEE ALSO L, L =head1 LICENSE Copyright (C)2008 Paul Fenwick This is free software. You may modify and/or redistribute this code under the same terms as Perl 5.10 itself, or, at your option, any later version of Perl 5. =head1 AUTHOR Paul Fenwick Epjf@perltraining.com.auE autodie_test_module.pm100644001750001750 155712547417731 16564 0ustar00pjfpjf000000000000autodie-2.29/tpackage main; use strict; use warnings; use constant NOFILE1 => 'this_file_had_better_not_exist'; use constant NOFILE2 => NOFILE1 . '2'; use constant NOFILE3 => NOFILE1 . '3'; # Calls open, while still in the main package. This shouldn't # be autodying. sub leak_test { return open(my $fh, '<', $_[0]); } # This rename shouldn't be autodying, either. sub leak_test_rename { return rename($_[0], $_[1]); } # These are used by core-trampoline-slurp.t sub slurp_leak_unlink { unlink(NOFILE1, NOFILE2, NOFILE3); } sub slurp_leak_open { open(1,2,3,4,5); } package autodie_test_module; # This should be calling CORE::open sub your_open { return open(my $fh, '<', $_[0]); } # This should be calling CORE::rename sub your_rename { return rename($_[0], $_[1]); } sub your_dying_rename { use autodie qw(rename); return rename($_[0], $_[1]); } 1; test000755001750001750 012547417731 15177 5ustar00pjfpjf000000000000autodie-2.29/t/lib/autodieau.pm100640001750001750 32512547417731 16256 0ustar00pjfpjf000000000000autodie-2.29/t/lib/autodie/testpackage autodie::test::au; use strict; use warnings; use parent qw(autodie); use autodie::test::au::exception; sub throw { my ($this, @args) = @_; return autodie::test::au::exception->new(@args); } 1; core-trampoline-slurp.t100644001750001750 121212547417731 16604 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; # Tests for GH #22 # # Slurpy calls (like open, unlink, chown, etc) could not be # interpreted properly if they leak into another file which # doesn't have autodie enabled. use autodie; use FindBin qw($Bin); use lib $Bin; use autodie_test_module; # This will throw an error, but it shouldn't throw a leak-guard # failure. eval { slurp_leak_open(); }; unlike($@,qr/Leak-guard failure/, "Leak guard failure (open)"); eval { slurp_leak_unlink(); }; is($@,"","No error should be thrown by leaked guards (unlink)"); unlike($@,qr/Leak-guard failure/, "Leak guard failure (unlink)"); Scope000755001750001750 012547417731 15026 5ustar00pjfpjf000000000000autodie-2.29/lib/autodieGuard.pm100644001750001750 256412547417731 16575 0ustar00pjfpjf000000000000autodie-2.29/lib/autodie/Scopepackage autodie::Scope::Guard; use strict; use warnings; # ABSTRACT: Wrapper class for calling subs at end of scope our $VERSION = '2.29'; # VERSION # This code schedules the cleanup of subroutines at the end of # scope. It's directly inspired by chocolateboy's excellent # Scope::Guard module. sub new { my ($class, $handler) = @_; return bless($handler, $class); } sub DESTROY { my ($self) = @_; $self->(); } 1; __END__ =head1 NAME autodie::Scope::Guard - Wrapper class for calling subs at end of scope =head1 SYNOPSIS use autodie::Scope::Guard; $^H{'my-key'} = autodie::Scope::Guard->new(sub { print "Hallo world\n"; }); =head1 DESCRIPTION This class is used to bless perl subs so that they are invoked when they are destroyed. This is mostly useful for ensuring the code is invoked at end of scope. This module is not a part of autodie's public API. This module is directly inspired by chocolateboy's excellent Scope::Guard module. =head2 Methods =head3 new my $hook = autodie::Scope::Guard->new(sub {}); Creates a new C, which will invoke the given sub once it goes out of scope (i.e. its DESTROY handler is called). =head1 AUTHOR Copyright 2008-2009, Paul Fenwick Epjf@perltraining.com.auE =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. ghach000755001750001750 012547417731 14707 5ustar00pjfpjf000000000000autodie-2.29/t/lib/pujHaDotlh.pm100640001750001750 220612547417731 16453 0ustar00pjfpjf000000000000autodie-2.29/t/lib/pujHa/ghachpackage pujHa'ghach::Dotlh; # Translator notes: Dotlh = status # Ideally this should be le'wI' - Thing that is exceptional. ;) # Unfortunately that results in a file called .pm, which may cause # problems on some filesystems. use strict; use warnings; use parent qw(autodie::exception); sub stringify { my ($this) = @_; my $error = $this->SUPER::stringify; return "QaghHommeyHeylIjmo':\n" . # Due to your apparent minor errors "$error\n" . "lujqu'"; # Epic fail } 1; __END__ # The following was a really neat idea, but currently autodie # always pushes values in $! to format them, which loses the # Klingon translation. use Errno qw(:POSIX); use Scalar::Util qw(dualvar); my %translation_for = ( EPERM() => q{Dachaw'be'}, # You do not have permission ENOENT() => q{De' vItu'laHbe'}, # I cannot find this information. ); sub errno { my ($this) = @_; my $errno = int $this->SUPER::errno; warn "In tlhIngan errno - $errno\n"; if ( my $tlhIngan = $translation_for{ $errno } ) { return dualvar( $errno, $tlhIngan ); } return $!; } 1; Hints_pod_examples.pm100640001750001750 550712547417731 17114 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Hints_pod_examples; use strict; use warnings; use Exporter 5.57 'import'; our %DOES = ( 'autodie::hints::provider' => 1 ); our @EXPORT_OK = qw( undef_scalar false_scalar zero_scalar empty_list default_list empty_or_false_list undef_n_error_list foo re_fail bar think_positive my_system bizarro_system ); use autodie::hints; sub AUTODIE_HINTS { return { # Scalar failures always return undef: undef_scalar => { fail => undef }, # Scalar failures return any false value [default behaviour]: false_scalar => { fail => sub { return ! $_[0] } }, # Scalar failures always return zero explicitly: zero_scalar => { fail => '0' }, # List failures always return empty list: # We never want these called in a scalar context empty_list => { scalar => sub { 1 }, list => [] }, # List failures return C<()> or C<(undef)> [default expectation]: default_list => { fail => sub { ! @_ || @_ == 1 && !defined $_[0] } }, # List failures return C<()> or a single false value: empty_or_false_list => { fail => sub { ! @_ || @_ == 1 && !$_[0] } }, # List failures return (undef, "some string") undef_n_error_list => { fail => sub { @_ == 2 && !defined $_[0] } }, }; } # Define some subs that all just return their arguments sub undef_scalar { return wantarray ? @_ : $_[0] } sub false_scalar { return wantarray ? @_ : $_[0] } sub zero_scalar { return wantarray ? @_ : $_[0] } sub empty_list { return wantarray ? @_ : $_[0] } sub default_list { return wantarray ? @_ : $_[0] } sub empty_or_false_list { return wantarray ? @_ : $_[0] } sub undef_n_error_list { return wantarray ? @_ : $_[0] } # Unsuccessful foo() returns 0 in all contexts... autodie::hints->set_hints_for( \&foo, { scalar => 0, list => [0], } ); sub foo { return wantarray ? @_ : $_[0] } # Unsuccessful re_fail() returns 'FAIL' or '_FAIL' in scalar context, # returns (-1) in list context... autodie::hints->set_hints_for( \&re_fail, { scalar => qr/^ _? FAIL $/xms, list => [-1], } ); sub re_fail { return wantarray ? @_ : $_[0] } # Unsuccessful bar() returns 0 in all contexts... autodie::hints->set_hints_for( \&bar, { scalar => 0, list => [0], } ); sub bar { return wantarray ? @_ : $_[0] } # Unsuccessful think_positive() returns negative number on failure... autodie::hints->set_hints_for( \&think_positive, { scalar => sub { $_[0] < 0 }, list => sub { $_[0] < 0 }, } ); sub think_positive { return wantarray ? @_ : $_[0] } # Unsuccessful my_system() returns non-zero on failure... autodie::hints->set_hints_for( \&my_system, { scalar => sub { $_[0] != 0 }, list => sub { $_[0] != 0 }, } ); sub my_system { return wantarray ? @_ : $_[0] }; 1; Hints_provider_isa.pm100640001750001750 102612547417731 17112 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Hints_provider_isa; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(always_fail always_pass no_hints); { package autodie::hints::provider; } push(our @ISA, 'autodie::hints::provider'); my $package = __PACKAGE__; sub AUTODIE_HINTS { return { always_fail => { list => sub { 1 }, scalar => sub { 1 } }, always_pass => { list => sub { 0 }, scalar => sub { 0 } }, }; } sub always_fail { return "foo" }; sub always_pass { return "foo" }; sub no_hints { return "foo" }; 1; Hints_provider_does.pm100640001750001750 120612547417731 17270 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Hints_provider_does; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(always_fail always_pass no_hints); sub DOES { my ($class, $arg) = @_; return 1 if ($arg eq 'autodie::hints::provider'); return $class->SUPER::DOES($arg) if $class->SUPER::can('DOES'); return $class->isa($arg); } my $package = __PACKAGE__; sub AUTODIE_HINTS { return { always_fail => { list => sub { 1 }, scalar => sub { 1 } }, always_pass => { list => sub { 0 }, scalar => sub { 0 } }, }; } sub always_fail { return "foo" }; sub always_pass { return "foo" }; sub no_hints { return "foo" }; 1; badname.pm100640001750001750 22212547417731 17234 0ustar00pjfpjf000000000000autodie-2.29/t/lib/autodie/testpackage autodie::test::badname; use parent qw(autodie); sub exception_class { return 'autodie::test::badname::$@#%'; # Doesn't exist! } 1; missing.pm100640001750001750 22712547417731 17323 0ustar00pjfpjf000000000000autodie-2.29/t/lib/autodie/testpackage autodie::test::missing; use parent qw(autodie); sub exception_class { return "autodie::test::missing::exception"; # Doesn't exist! } 1; GuardStack.pm100640001750001750 654012547417731 17555 0ustar00pjfpjf000000000000autodie-2.29/lib/autodie/Scopepackage autodie::Scope::GuardStack; use strict; use warnings; use autodie::Scope::Guard; # ABSTRACT: Hook stack for managing scopes via %^H our $VERSION = '2.29'; # VERSION my $H_KEY_STEM = __PACKAGE__ . '/guard'; my $COUNTER = 0; # This code schedules the cleanup of subroutines at the end of # scope. It's directly inspired by chocolateboy's excellent # Scope::Guard module. sub new { my ($class) = @_; return bless([], $class); } sub push_hook { my ($self, $hook) = @_; my $h_key = $H_KEY_STEM . ($COUNTER++); my $size = @{$self}; $^H{$h_key} = autodie::Scope::Guard->new(sub { # Pop the stack until we reach the right size # - this may seem weird, but it is to avoid relying # on "destruction order" of keys in %^H. # # Example: # { # use autodie; # hook 1 # no autodie; # hook 2 # use autodie; # hook 3 # } # # Here we want call hook 3, then hook 2 and finally hook 1. # Any other order could have undesired consequences. # # Suppose hook 2 is destroyed first, it will pop hook 3 and # then hook 2. hook 3 will then be destroyed, but do nothing # since its "frame" was already popped and finally hook 1 # will be popped and take its own frame with it. # # We need to check that $self still exists since things can get weird # during global destruction. $self->_pop_hook while $self && @{$self} > $size; }); push(@{$self}, [$hook, $h_key]); return; } sub _pop_hook { my ($self) = @_; my ($hook, $key) = @{ pop(@{$self}) }; my $ref = delete($^H{$key}); $hook->(); return; } sub DESTROY { my ($self) = @_; # To be honest, I suspect @{$self} will always be empty here due # to the subs in %^H having references to the stack (which would # keep the stack alive until those have been destroyed). Anyhow, # it never hurt to be careful. $self->_pop_hook while @{$self}; return; } 1; __END__ =head1 NAME autodie::Scope::GuardStack - Hook stack for managing scopes via %^H =head1 SYNOPSIS use autodie::Scope::GuardStack; my $stack = autodie::Scope::GuardStack->new $^H{'my-key'} = $stack; $stack->push_hook(sub {}); =head1 DESCRIPTION This class is a stack of hooks to be called in the right order as scopes go away. The stack is only useful when inserted into C<%^H> and will pop hooks as their "scope" is popped. This is useful for uninstalling or reinstalling subs in a namespace as a pragma goes out of scope. Due to how C<%^H> works, this class is only useful during the compilation phase of a perl module and relies on the internals of how perl handles references in C<%^H>. This module is not a part of autodie's public API. =head2 Methods =head3 new my $stack = autodie::Scope::GuardStack->new; Creates a new C. The stack is initially empty and must be inserted into C<%^H> by the creator. =head3 push_hook $stack->push_hook(sub {}); Add a sub to the stack. The sub will be called once the current compile-time "scope" is left. Multiple hooks can be added per scope =head1 AUTHOR Copyright 2013, Niels Thykier Eniels@thykier.netE =head1 LICENSE This module is free software. You may distribute it under the same terms as Perl itself. exception000755001750001750 012547417731 15753 5ustar00pjfpjf000000000000autodie-2.29/lib/autodiesystem.pm100640001750001750 313712547417731 17775 0ustar00pjfpjf000000000000autodie-2.29/lib/autodie/exceptionpackage autodie::exception::system; use 5.008; use strict; use warnings; use parent 'autodie::exception'; use Carp qw(croak); our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying system(). my $PACKAGE = __PACKAGE__; =head1 NAME autodie::exception::system - Exceptions from autodying system(). =head1 SYNOPSIS eval { use autodie qw(system); system($cmd, @args); }; if (my $E = $@) { say "Ooops! ",$E->caller," had problems: $@"; } =head1 DESCRIPTION This is a L class for failures from the C command. Presently there is no way to interrogate an C object for the command, exit status, and other information you'd expect such an object to hold. The interface will be expanded to accommodate this in the future. =cut sub _init { my ($this, %args) = @_; $this->{$PACKAGE}{message} = $args{message} || croak "'message' arg not supplied to autodie::exception::system->new"; return $this->SUPER::_init(%args); } =head2 stringify When stringified, C objects currently use the message generated by L. =cut sub stringify { my ($this) = @_; return $this->{$PACKAGE}{message} . $this->add_file_and_line; } 1; __END__ =head1 LICENSE Copyright (C)2008 Paul Fenwick This is free software. You may modify and/or redistribute this code under the same terms as Perl 5.10 itself, or, at your option, any later version of Perl 5. =head1 AUTHOR Paul Fenwick Epjf@perltraining.com.auE hints_provider_easy_does_it.t100755001750001750 104712547417731 20140 0ustar00pjfpjf000000000000autodie-2.29/t#!/usr/bin/perl -w use strict; use warnings; use autodie; use Test::More 'no_plan'; use FindBin qw($Bin); use lib "$Bin/lib"; use Hints_provider_easy_does_it qw(always_pass always_fail); use autodie qw(always_pass always_fail); eval { my $x = always_pass() }; is("$@", "", "always_pass in scalar context"); eval { my @x = always_pass() }; is("$@", "", "always_pass in list context"); eval { my $x = always_fail() }; isnt("$@", "", "always_fail in scalar context"); eval { my @x = always_fail() }; isnt("$@", "", "always_fail in list context"); au000755001750001750 012547417731 15604 5ustar00pjfpjf000000000000autodie-2.29/t/lib/autodie/testexception.pm100640001750001750 46612547417731 20262 0ustar00pjfpjf000000000000autodie-2.29/t/lib/autodie/test/aupackage autodie::test::au::exception; use strict; use warnings; use parent qw(autodie::exception); sub time_for_a_beer { return "Now's a good time for a beer."; } sub stringify { my ($this) = @_; my $base_str = $this->SUPER::stringify; return "$base_str\n" . $this->time_for_a_beer; } 1; Fatal_Leaky_Benchmark.pm100644001750001750 56212547417731 20501 0ustar00pjfpjf000000000000autodie-2.29/benchmarksuse strict; use warnings; # But *don't* use autodie # And *don't* use a package. # Either of those will stop autodie leaking into this file. use constant N => 1000000; # Essentially run a no-op many times. With a high leak overhead, # this is expensive. With a low leak overhead, this should be cheap. sub run { for (1..N) { binmode(STDOUT); } } 1; Hints_provider_easy_does_it.pm100640001750001750 77512547417731 20777 0ustar00pjfpjf000000000000autodie-2.29/t/libpackage Hints_provider_easy_does_it; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT_OK = qw(always_fail always_pass no_hints); our %DOES = ( 'autodie::hints::provider' => 1 ); my $package = __PACKAGE__; sub AUTODIE_HINTS { return { always_fail => { list => sub { 1 }, scalar => sub { 1 } }, always_pass => { list => sub { 0 }, scalar => sub { 0 } }, }; } sub always_fail { return "foo" }; sub always_pass { return "foo" }; sub no_hints { return "foo" }; 1;