In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/35c0561a7bae0fd58527c372c899da0d87f75d37?hp=f3f2f486c173c975f5389913bb2b5b16f4ffd6cb>
- Log ----------------------------------------------------------------- commit 35c0561a7bae0fd58527c372c899da0d87f75d37 Author: Chris 'BinGOs' Williams <[email protected]> Date: Fri Jun 12 11:58:41 2015 +0100 Update autodie to CPAN version 2.27 [DELTA] 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. * 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) ----------------------------------------------------------------------- Summary of changes: MANIFEST | 2 +- Porting/Maintainers.pl | 2 +- cpan/autodie/lib/Fatal.pm | 185 ++++++-------------- cpan/autodie/lib/autodie.pm | 2 +- cpan/autodie/lib/autodie/Scope/Guard.pm | 2 +- cpan/autodie/lib/autodie/Scope/GuardStack.pm | 2 +- cpan/autodie/lib/autodie/ScopeUtil.pm | 80 --------- cpan/autodie/lib/autodie/Util.pm | 250 +++++++++++++++++++++++++++ cpan/autodie/lib/autodie/exception.pm | 112 ++++++++---- cpan/autodie/lib/autodie/exception/system.pm | 2 +- cpan/autodie/lib/autodie/hints.pm | 2 +- cpan/autodie/lib/autodie/skip.pm | 2 +- cpan/autodie/t/chmod.t | 9 +- cpan/autodie/t/dbmopen.t | 14 +- cpan/autodie/t/internal.t | 41 +++-- cpan/autodie/t/lib/my/pragma.pm | 1 + cpan/autodie/t/mkdir.t | 18 +- 17 files changed, 452 insertions(+), 274 deletions(-) delete mode 100644 cpan/autodie/lib/autodie/ScopeUtil.pm create mode 100644 cpan/autodie/lib/autodie/Util.pm diff --git a/MANIFEST b/MANIFEST index 90291f3..ab56808 100644 --- a/MANIFEST +++ b/MANIFEST @@ -47,8 +47,8 @@ cpan/autodie/lib/autodie/hints.pm Hinting interface for autodie cpan/autodie/lib/autodie.pm Functions succeed or die with lexical scope cpan/autodie/lib/autodie/Scope/Guard.pm cpan/autodie/lib/autodie/Scope/GuardStack.pm -cpan/autodie/lib/autodie/ScopeUtil.pm cpan/autodie/lib/autodie/skip.pm +cpan/autodie/lib/autodie/Util.pm cpan/autodie/lib/Fatal.pm Make errors in functions/builtins fatal cpan/autodie/t/00-load.t autodie - basic load cpan/autodie/t/args.t diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index c98bf8e..bf2d3b2 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -133,7 +133,7 @@ use File::Glob qw(:case); }, 'autodie' => { - 'DISTRIBUTION' => 'NTHYKIER/autodie-2.26.tar.gz', + 'DISTRIBUTION' => 'PJF/autodie-2.27.tar.gz', 'FILES' => q[cpan/autodie], 'EXCLUDED' => [ qr{benchmarks}, diff --git a/cpan/autodie/lib/Fatal.pm b/cpan/autodie/lib/Fatal.pm index 8fe7899..21064ee 100644 --- a/cpan/autodie/lib/Fatal.pm +++ b/cpan/autodie/lib/Fatal.pm @@ -10,7 +10,12 @@ use Tie::RefHash; # To cache subroutine refs use Config; use Scalar::Util qw(set_prototype); -use autodie::ScopeUtil qw(on_end_of_compile_scope); +use autodie::Util qw( + fill_protos + install_subs + make_core_trampoline + on_end_of_compile_scope +); use constant PERL510 => ( $] >= 5.010 ); @@ -50,7 +55,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; -our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg::Version +our $VERSION = '2.27'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -157,6 +162,7 @@ my %TAGS = ( ':2.24' => [qw(:v225)], ':2.25' => [qw(:v225)], ':2.26' => [qw(:default)], + ':2.27' => [qw(:default)], ); @@ -293,6 +299,8 @@ my %reusable_builtins; CORE::shmctl CORE::shmget CORE::shmread + CORE::exec + CORE::system )} = (); # Cached_fatalised_sub caches the various versions of our @@ -359,6 +367,41 @@ sub import { $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'. @@ -460,7 +503,7 @@ sub import { } } - $class->_install_subs($pkg, \%install_subs); + install_subs($pkg, \%install_subs); if ($lexical) { @@ -477,7 +520,7 @@ sub import { # scope. on_end_of_compile_scope(sub { - $class->_install_subs($pkg, \%unload_later); + install_subs($pkg, \%unload_later); }); # To allow others to determine when autodie was in scope, @@ -496,63 +539,6 @@ sub import { } -# 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 ($class, $pkg, $subs_to_reinstate) = @_; - - my $pkg_sym = "${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; -} - sub unimport { my $class = shift; @@ -597,9 +583,9 @@ sub unimport { } - $class->_install_subs($pkg, \%uninstall_subs); + install_subs($pkg, \%uninstall_subs); on_end_of_compile_scope(sub { - $class->_install_subs($pkg, \%reinstall_subs); + install_subs($pkg, \%reinstall_subs); }); return; @@ -755,32 +741,6 @@ sub _translate_import_args { } -# This code is from the original Fatal. It scares me. -# It is 100% compatible with the 5.10.0 Fatal module, right down -# to the scary 'XXXX' comment. ;) - -sub fill_protos { - my $proto = shift; - my ($n, $isref, @out, @out1, $seen_semi) = -1; - if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { - # prototype is entirely slurp - 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; -} - # This is a backwards compatible version of _write_invocation. It's # recommended you don't use it. @@ -1620,7 +1580,7 @@ sub _make_leak_guard { # As $orig_sub is "closed over", updating its value will # be "remembered" for the next call. - $orig_sub = _make_core_trampoline($call, $pkg, $proto); + $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 @@ -1643,51 +1603,6 @@ sub _make_leak_guard { return $leak_guard; } -# Create 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 use `goto &` on core builtins, we wouldn't need this. -sub _make_core_trampoline { - my ($call, $pkg, $proto_str) = @_; - my $trampoline_code = 'sub {'; - my $trampoline_sub; - my @protos = fill_protos($proto_str); - - # TODO: It may be possible to combine this with write_invocation(). - - 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< 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; -} - sub _compile_wrapper { my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; my $real_proto = ''; diff --git a/cpan/autodie/lib/autodie.pm b/cpan/autodie/lib/autodie.pm index 15d7134..b6db3af 100644 --- a/cpan/autodie/lib/autodie.pm +++ b/cpan/autodie/lib/autodie.pm @@ -9,7 +9,7 @@ our $VERSION; # ABSTRACT: Replace functions with ones that succeed or die with lexical scope BEGIN { - our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg::Version + our $VERSION = '2.27'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ diff --git a/cpan/autodie/lib/autodie/Scope/Guard.pm b/cpan/autodie/lib/autodie/Scope/Guard.pm index db38e36..6624c92 100644 --- a/cpan/autodie/lib/autodie/Scope/Guard.pm +++ b/cpan/autodie/lib/autodie/Scope/Guard.pm @@ -4,7 +4,7 @@ use strict; use warnings; # ABSTRACT: Wrapper class for calling subs at end of scope -our $VERSION = '2.26'; # VERSION +our $VERSION = '2.27'; # VERSION # This code schedules the cleanup of subroutines at the end of # scope. It's directly inspired by chocolateboy's excellent diff --git a/cpan/autodie/lib/autodie/Scope/GuardStack.pm b/cpan/autodie/lib/autodie/Scope/GuardStack.pm index 75300ff..d841fba 100644 --- a/cpan/autodie/lib/autodie/Scope/GuardStack.pm +++ b/cpan/autodie/lib/autodie/Scope/GuardStack.pm @@ -6,7 +6,7 @@ use warnings; use autodie::Scope::Guard; # ABSTRACT: Hook stack for managing scopes via %^H -our $VERSION = '2.26'; # VERSION +our $VERSION = '2.27'; # VERSION my $H_KEY_STEM = __PACKAGE__ . '/guard'; my $COUNTER = 0; diff --git a/cpan/autodie/lib/autodie/ScopeUtil.pm b/cpan/autodie/lib/autodie/ScopeUtil.pm deleted file mode 100644 index 2029209..0000000 --- a/cpan/autodie/lib/autodie/ScopeUtil.pm +++ /dev/null @@ -1,80 +0,0 @@ -package autodie::ScopeUtil; - -use strict; -use warnings; - -# Docs say that perl 5.8.3 has Exporter 5.57 and autodie requires -# 5.8.4, so this should "just work". -use Exporter 5.57 qw(import); - -use autodie::Scope::GuardStack; - -our @EXPORT_OK = qw(on_end_of_compile_scope); - -# ABSTRACT: Utilities for managing %^H scopes -our $VERSION = '2.26'; # VERSION - -# docs says we should pick __PACKAGE__ /<whatever> -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; -} - -1; - -=head1 NAME - -autodie::ScopeUtil - Utilities for managing %^H scopes - -=head1 SYNOPSIS - - use autodie::ScopeUtil qw(on_end_of_compile_scope); - on_end_of_compile_scope(sub { print "Hallo world\n"; }); - -=head1 DESCRIPTION - -Utilities for abstracting away the underlying magic of (ab)using -C<%^H> to call subs at the end of a (compile-time) scopes. - -Due to how C<%^H> works, 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>. This module is not a part of -autodie's public API. - -=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). - -=head1 AUTHOR - -Copyright 2013, Niels Thykier E<lt>[email protected]<gt> - -=head1 LICENSE - -This module is free software. You may distribute it under the -same terms as Perl itself. diff --git a/cpan/autodie/lib/autodie/Util.pm b/cpan/autodie/lib/autodie/Util.pm new file mode 100644 index 0000000..f2a8886 --- /dev/null +++ b/cpan/autodie/lib/autodie/Util.pm @@ -0,0 +1,250 @@ +package 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.27'; # VERSION: Generated by DZP::OurPkg:Version + +# ABSTRACT: Internal Utility subroutines for autodie and Fatal + +# docs says we should pick __PACKAGE__ /<whatever> +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<undef>), this subroutine will install said subroutines +on their given name in that module. If a name mapes to C<undef>, 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 E<lt>[email protected]<gt> + +=head1 LICENSE + +This module is free software. You may distribute it under the +same terms as Perl itself. diff --git a/cpan/autodie/lib/autodie/exception.pm b/cpan/autodie/lib/autodie/exception.pm index 15d0914..93806fa 100644 --- a/cpan/autodie/lib/autodie/exception.pm +++ b/cpan/autodie/lib/autodie/exception.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp qw(croak); -our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.27'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; @@ -292,8 +292,50 @@ my %formatter_of = ( '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. @@ -348,6 +390,40 @@ sub _format_flock { } +# 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) = @_; @@ -362,13 +438,7 @@ sub _format_dbmopen { my $mode = $args[-1]; my $file = $args[-2]; - # If we have a mask, then display it in octal, not decimal. - # We don't do this if it already looks octalish, or doesn't - # look like a number. - - if ($mode =~ /^[^\D0]\d+$/) { - $mode = sprintf("0%lo", $mode); - }; + $mode = $this->_octalize_number($mode); local $! = $this->errno; @@ -399,12 +469,9 @@ sub _format_close { # may contain binary data. sub _format_readwrite { my ($this) = @_; - my $call = $this->function; + my $call = $this->_trim_package_name($this->function); local $! = $this->errno; - # Trim package name off dying sub for error messages. - $call =~ s/.*:://; - # These subs receive the following arguments (in order): # # * FILEHANDLE @@ -619,29 +686,12 @@ messages are formatted. sub format_default { my ($this) = @_; - my $call = $this->function; + my $call = $this->_trim_package_name($this->function); local $! = $this->errno; - # 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. - $call =~ s/.*:://; - - # Walk through all our arguments, and... - # - # * Replace undef with the word 'undef' - # * Replace globs with the string '$fh' - # * Quote all other args. - my @args = @{ $this->args() }; - - foreach my $arg (@args) { - if (not defined($arg)) { $arg = 'undef' } - elsif (ref($arg) eq "GLOB") { $arg = '$fh' } - else { $arg = qq{'$arg'} } - } + @args = $this->_beautify_arguments(@args); # Format our beautiful error. diff --git a/cpan/autodie/lib/autodie/exception/system.pm b/cpan/autodie/lib/autodie/exception/system.pm index d63a607..081c998 100644 --- a/cpan/autodie/lib/autodie/exception/system.pm +++ b/cpan/autodie/lib/autodie/exception/system.pm @@ -5,7 +5,7 @@ use warnings; use parent 'autodie::exception'; use Carp qw(croak); -our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.27'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying system(). diff --git a/cpan/autodie/lib/autodie/hints.pm b/cpan/autodie/lib/autodie/hints.pm index 3c9d679..9db39b1 100644 --- a/cpan/autodie/lib/autodie/hints.pm +++ b/cpan/autodie/lib/autodie/hints.pm @@ -5,7 +5,7 @@ use warnings; use constant PERL58 => ( $] < 5.009 ); -our $VERSION = '2.26'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.27'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Provide hints about user subroutines to autodie diff --git a/cpan/autodie/lib/autodie/skip.pm b/cpan/autodie/lib/autodie/skip.pm index 1462acd..83f4721 100644 --- a/cpan/autodie/lib/autodie/skip.pm +++ b/cpan/autodie/lib/autodie/skip.pm @@ -2,7 +2,7 @@ package autodie::skip; use strict; use warnings; -our $VERSION = '2.26'; # VERSION +our $VERSION = '2.27'; # 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 diff --git a/cpan/autodie/t/chmod.t b/cpan/autodie/t/chmod.t index 9093b52..00715ae 100755 --- a/cpan/autodie/t/chmod.t +++ b/cpan/autodie/t/chmod.t @@ -1,13 +1,20 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 4; +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."); diff --git a/cpan/autodie/t/dbmopen.t b/cpan/autodie/t/dbmopen.t index 31698e6..5083f38 100644 --- a/cpan/autodie/t/dbmopen.t +++ b/cpan/autodie/t/dbmopen.t @@ -1,8 +1,9 @@ #!/usr/bin/perl -w use strict; -use Test::More qw(no_plan); +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"; @@ -27,6 +28,17 @@ 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); diff --git a/cpan/autodie/t/internal.t b/cpan/autodie/t/internal.t index 3853044..c4e5abc 100644 --- a/cpan/autodie/t/internal.t +++ b/cpan/autodie/t/internal.t @@ -1,32 +1,46 @@ -#!/usr/bin/perl -w +#!/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 => 9; +use Test::More tests => 7; + +use Fatal(); + +# Silence the warnings from using Fatal qw(:lexical) # Lexical tests using the internal interface. -eval { Fatal->import(qw(:lexical :void)) }; +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"); { - use Fatal qw(:lexical chdir); - + 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"); - TODO: { - local $TODO = 'Fatal should not (but does) throw autodie::exceptions'; - is(blessed($err), undef, - "Fatal does not throw autodie::exceptions"); - } - { no Fatal qw(:lexical chdir); eval { chdir(NO_SUCH_FILE); }; @@ -36,11 +50,6 @@ like($@, qr{:lexical must be used as first}, ":lexical must come first"); eval { chdir(NO_SUCH_FILE); }; $err = $@; like ($err, qr/^Can't chdir/, "Lexical fatal chdir returns"); - TODO: { - local $TODO = 'Fatal should not (but does) throw autodie::exceptions'; - is(blessed($err), undef, - "Fatal does not throw autodie::exceptions"); - } } eval { chdir(NO_SUCH_FILE); }; diff --git a/cpan/autodie/t/lib/my/pragma.pm b/cpan/autodie/t/lib/my/pragma.pm index 185d54f..3df2ced 100644 --- a/cpan/autodie/t/lib/my/pragma.pm +++ b/cpan/autodie/t/lib/my/pragma.pm @@ -1,5 +1,6 @@ package my::pragma; +require autodie; use Import::Into qw(into); sub import { diff --git a/cpan/autodie/t/mkdir.t b/cpan/autodie/t/mkdir.t index 7bd6529..a5586be 100644 --- a/cpan/autodie/t/mkdir.t +++ b/cpan/autodie/t/mkdir.t @@ -3,6 +3,8 @@ 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; @@ -25,7 +27,7 @@ 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 => 12; +plan tests => 18; # Create a directory (this should succeed) eval { @@ -40,12 +42,24 @@ ok(-d TMPDIR, "Successfully created test directory"); eval { use autodie; - mkdir TMPDIR; + 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 { -- Perl5 Master Repository
