From 2da5105ccab4b35342ec61d4e812fe7d1b17c40b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=C5=A0t=C4=9Bp=C3=A1n=20Kasal?= Date: Tue, 24 Mar 2009 14:57:25 +0000 Subject: [PATCH] - update module autodie --- perl-update-autodie.patch | 4211 +++++++++++++++++++++++++++++++++++++ perl.spec | 12 +- 2 files changed, 4221 insertions(+), 2 deletions(-) create mode 100644 perl-update-autodie.patch diff --git a/perl-update-autodie.patch b/perl-update-autodie.patch new file mode 100644 index 0000000..18e3f52 --- /dev/null +++ b/perl-update-autodie.patch @@ -0,0 +1,4211 @@ +autodie-1.999 + +diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST +--- perl-5.10.0.orig/MANIFEST 2009-02-20 18:22:32.000000000 +0100 ++++ perl-5.10.0/MANIFEST 2009-03-24 12:42:25.000000000 +0100 +@@ -1442,6 +1442,9 @@ + lib/Attribute/Handlers/t/linerep.t See if Attribute::Handlers works + lib/Attribute/Handlers/t/multi.t See if Attribute::Handlers works + lib/attributes.pm For "sub foo : attrlist" ++lib/autodie.pm Functions suceed or die with lexical scope ++lib/autodie/exception.pm Exception class for autodie ++lib/autodie/exception/system.pm Exception class for autodying system() + lib/AutoLoader.pm Autoloader base class + lib/AutoLoader.t See if AutoLoader works + lib/AutoSplit.pm Split up autoload functions +@@ -3439,6 +3442,45 @@ + t/io/utf8.t See if file seeking works + t/japh/abigail.t Obscure tests + t/lib/1_compile.t See if the various libraries and extensions compile ++t/lib/autodie/00-load.t autodie - basic load ++t/lib/autodie/autodie.t autodie - Basic functionality ++t/lib/autodie/autodie_test_module.pm autodie - test helper ++t/lib/autodie/backcompat.t autodie - More Fatal backcompat ++t/lib/autodie/basic_exceptions.t autodie - Basic exception tests ++t/lib/autodie/binmode.t autodie - Binmode testing ++t/lib/autodie/caller.t autodie - Caller diagnostics ++t/lib/autodie/context.t autodie - Context clobbering tests ++t/lib/autodie/context_lexical.t autodie - Context clobbering lexically ++t/lib/autodie/crickey.t autodie - Like an Australian ++t/lib/autodie/dbmopen.t autodie - dbm tests ++t/lib/autodie/exceptions.t autodie - 5.10 exception tests. ++t/lib/autodie/exception_class.t autodie - Exception class subclasses ++t/lib/autodie/exec.t autodie - exec tests. ++t/lib/autodie/Fatal.t autodie - Fatal backcompatibility ++t/lib/autodie/filehandles.t autodie - filehandle tests ++t/lib/autodie/fileno.t autodie - fileno tests ++t/lib/autodie/flock.t autodie - File locking tests ++t/lib/autodie/internal.t autodie - internal interface tests ++t/lib/autodie/lethal.t autodie - lethal is the one true name ++t/lib/autodie/lib/autodie/test/au.pm autodie - Austrlaian helper ++t/lib/autodie/lib/autodie/test/au/exception.pm autodie - Australian helper ++t/lib/autodie/lib/autodie/test/badname.pm autodie - Bad exception class ++t/lib/autodie/lib/autodie/test/missing.pm autodie - Missing exception class ++t/lib/autodie/lib/lethal.pm autodie - with a better name ++t/lib/autodie/lib/pujHa/ghach.pm autodie - Like a Klingon ++t/lib/autodie/lib/pujHa/ghach/Dotlh.pm autodie - With Klingon honour ++t/lib/autodie/mkdir.t autodie - filesystem tests ++t/lib/autodie/open.t autodie - Testing open ++t/lib/autodie/recv.t autodie - send/recv tests ++t/lib/autodie/repeat.t autodie - repeat autodie leak tests ++t/lib/autodie/scope_leak.t autodie - file scope leak tests ++t/lib/autodie/sysopen.t autodie - sysopen tests ++t/lib/autodie/truncate.t autodie - File truncation tests ++t/lib/autodie/unlink.t autodie - Unlink system tests. ++t/lib/autodie/user-context.t autodie - Context changes for usersubs ++t/lib/autodie/usersub.t autodie - user subroutine tests ++t/lib/autodie/version.t autodie - versioning tests ++t/lib/autodie/version_tag.t + t/lib/Cname.pm Test charnames in regexes (op/pat.t) + t/lib/common.pl Helper for lib/{warnings,feature}.t + t/lib/commonsense.t See if configuration meets basic needs +diff -urN perl-5.10.0.orig/Porting/Maintainers.pl perl-5.10.0/Porting/Maintainers.pl +--- perl-5.10.0.orig/Porting/Maintainers.pl 2007-12-18 11:47:07.000000000 +0100 ++++ perl-5.10.0/Porting/Maintainers.pl 2009-03-24 11:53:29.000000000 +0100 +@@ -57,6 +57,7 @@ + 'p5p' => 'perl5-porters ', + 'perlfaq' => 'perlfaq-workers ', + 'petdance' => 'Andy Lester ', ++ 'pjf' => 'Paul Fenwick ', + 'pmqs' => 'Paul Marquess ', + 'pvhp' => 'Peter Prymmer ', + 'rclamp' => 'Richard Clamp ', +@@ -113,6 +114,14 @@ + 'CPAN' => 1, + }, + ++ 'autodie' => ++ { ++ 'MAINTAINER' => 'pjf', ++ 'FILES' => q[lib/Fatal.pm lib/autodie.pm lib/autodie], ++ 'CPAN' => 1, ++ 'UPSTREAM' => 'cpan', ++ }, ++ + 'B::Concise' => + { + 'MAINTAINER' => 'smccam', +diff -urN perl-5.10.0.orig/installperl perl-5.10.0/installperl +--- perl-5.10.0.orig/installperl 2007-12-18 11:47:07.000000000 +0100 ++++ perl-5.10.0/installperl 2009-03-24 12:42:25.000000000 +0100 +@@ -827,7 +827,7 @@ + $name = "$dir/$name" if $dir ne ''; + + my $installlib = $installprivlib; +- if ($dir =~ /^auto/ || ++ if ($dir =~ /^auto\// || + ($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1}) || + ($name =~ /^(.*)\.(?:h|lib)$/i && ($Is_W32 || $Is_NetWare)) || + $name eq 'Config_heavy.pl' +diff -urN perl-5.10.0.orig/lib/Fatal.pm perl-5.10.0/lib/Fatal.pm +--- perl-5.10.0.orig/lib/Fatal.pm 2009-03-24 13:14:31.000000000 +0100 ++++ perl-5.10.0/lib/Fatal.pm 2009-03-24 13:15:35.000000000 +0100 +@@ -1,137 +1,1002 @@ + package Fatal; + +-use 5.006_001; ++use 5.008; # 5.8.x needed for autodie + use Carp; + use strict; +-our($AUTOLOAD, $Debug, $VERSION); ++use warnings; + +-$VERSION = 1.06; ++use constant LEXICAL_TAG => q{:lexical}; ++use constant VOID_TAG => q{:void}; + +-$Debug = 0 unless defined $Debug; ++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_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}; ++ ++# Older versions of IPC::System::Simple don't support all the ++# features we need. ++ ++use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; ++ ++# All the Fatal/autodie modules share the same version number. ++our $VERSION = '1.999'; ++ ++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, ++); ++ ++# 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 fileno binmode ++ ioctl truncate)], ++ ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir ++ symlink rmdir readlink umask)], ++ ':ipc' => [qw(:msg :semaphore :shm pipe)], ++ ':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? ++ # XXX - 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)], ++ ++ # Version specific tags. These allow someone to specify ++ # use autodie qw(:1.994) and know exactly what they'll get. ++ ++ ':1.994' => [qw(:default)], ++ ':1.995' => [qw(:default)], ++ ':1.996' => [qw(:default)], ++ ':1.997' => [qw(:default)], ++ ':1.998' => [qw(:default)], ++ ':1.999' => [qw(:default)], ++ ++); ++ ++$TAGS{':all'} = [ keys %TAGS ]; ++ ++# 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 ++)} = (); ++ ++# 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 = (); ++ ++# 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 $PACKAGE_GUARD = "guard $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 $self = shift(@_); +- my($sym, $pkg); +- my $void = 0; +- $pkg = (caller)[0]; +- foreach $sym (@_) { +- if ($sym eq ":void") { +- $void = 1; +- } +- else { +- &_make_fatal($sym, $pkg, $void); +- } +- } +-}; +- +-sub AUTOLOAD { +- my $cmd = $AUTOLOAD; +- $cmd =~ s/.*:://; +- &_make_fatal($cmd, (caller)[0]); +- goto &$AUTOLOAD; ++ my $class = shift(@_); ++ my $void = 0; ++ my $lexical = 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 @_; ++ ++ # 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 = @_; ++ ++ # Thiese subs will get unloaded at the end of lexical scope. ++ my %unload_later; ++ ++ # This hash helps us track if we've alredy done work. ++ my %done_this; ++ ++ # NB: we're using while/shift rather than foreach, since ++ # we'll be modifying the array as we walk through it. ++ ++ while (my $func = shift @fatalise_these) { ++ ++ if ($func eq VOID_TAG) { ++ ++ # When we see :void, set the void flag. ++ $void = 1; ++ ++ } elsif (exists $TAGS{$func}) { ++ ++ # When it's a tag, expand it. ++ push(@fatalise_these, @{ $TAGS{$func} }); ++ ++ } else { ++ ++ # Otherwise, fatalise it. ++ ++ # If we've already made something fatal this call, ++ # then don't do it twice. ++ ++ next if $done_this{$func}; ++ ++ # 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 ++ ); ++ ++ $done_this{$func}++; ++ ++ $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; ++ } ++ } ++ ++ 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. ++ ++ push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub { ++ $class->_install_subs($pkg, \%unload_later); ++ })); ++ ++ } ++ ++ return; ++ + } + ++# 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}::"; ++ ++ while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) { ++ ++ my $full_path = $pkg_sym.$sub_name; ++ ++ # Copy symbols across to temp area. ++ ++ no strict 'refs'; ## no critic ++ ++ local *__tmp = *{ $full_path }; ++ ++ # Nuke the old glob. ++ { no strict; delete $pkg_sym->{$sub_name}; } ## no critic ++ ++ # Copy innocent bystanders back. ++ ++ foreach my $slot (qw( SCALAR ARRAY HASH IO FORMAT ) ) { ++ next unless defined *__tmp{ $slot }; ++ *{ $full_path } = *__tmp{ $slot }; ++ } ++ ++ # Put back the old sub (if there was one). ++ ++ if ($sub_ref) { ++ ++ no strict; ## no critic ++ *{ $pkg_sym . $sub_name } = $sub_ref; ++ } ++ } ++ ++ 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'; ++ ++ while (my $symbol = shift @unimport_these) { ++ ++ if ($symbol =~ /^:/) { ++ ++ # Looks like a tag! Expand it! ++ push(@unimport_these, @{ $TAGS{$symbol} }); ++ ++ next; ++ } ++ ++ 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; ++ ++ if (my $original_sub = $Original_user_sub{$sub}) { ++ # Hey, we've got an original one of these, put it back. ++ $class->_install_subs($pkg, { $symbol => $original_sub }); ++ next; ++ } ++ ++ # We don't have an original copy of the sub, on the assumption ++ # it's core (or doesn't exist), we'll just nuke it. ++ ++ $class->_install_subs($pkg,{ $symbol => undef }); ++ ++ } ++ ++ return; ++ ++} ++ ++# TODO - This is rather terribly inefficient right now. ++ ++# NB: Perl::Critic's dump-autodie-tag-contents depends upon this ++# continuing to work. ++ ++{ ++ my %tag_cache; ++ ++ 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}}; ++ ++ my @taglist = (); ++ ++ while (my $item = shift @to_process) { ++ if ($item =~ /^:/) { ++ push(@to_process, @{$TAGS{$item}} ); ++ } else { ++ push(@taglist, "CORE::$item"); ++ } ++ } ++ ++ $tag_cache{$tag} = \@taglist; ++ ++ return \@taglist; ++ ++ } ++ ++} ++ ++# This code is from the original Fatal. It scares me. ++ + sub fill_protos { +- my $proto = shift; +- my ($n, $isref, @out, @out1, $seen_semi) = -1; +- 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 "Unknown prototype letters: \"$proto\""; +- } +- push(@out1,[$n+1,@out]); +- @out1; ++ my $proto = shift; ++ my ($n, $isref, @out, @out1, $seen_semi) = -1; ++ 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 generates the code that will become our fatalised subroutine. ++ + sub write_invocation { +- my ($core, $call, $name, $void, @argvs) = @_; +- if (@argvs == 1) { # No optional arguments +- my @argv = @{$argvs[0]}; +- shift @argv; +- return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n"; +- } else { +- my $else = "\t"; +- my (@out, @argv, $n); +- while (@argvs) { +- @argv = @{shift @argvs}; +- $n = shift @argv; +- push @out, "$ {else}if (\@_ == $n) {\n"; +- $else = "\t} els"; +- push @out, +- "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n"; +- } +- push @out, <one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv); ++ ++ } else { ++ my $else = "\t"; ++ my (@out, @argv, $n); ++ while (@argvs) { ++ @argv = @{shift @argvs}; ++ $n = shift @argv; ++ ++ push @out, "${else}if (\@_ == $n) {\n"; ++ $else = "\t} els"; ++ ++ push @out, $class->one_invocation($core,$call,$name,$void,$sub,! $lexical,@argv); ++ } ++ push @out, q[ ++ } ++ die "Internal error: $name(\@_): Do not expect to get ", scalar \@_, " arguments"; ++ ]; ++ ++ return join '', @out; ++ } + } + + sub one_invocation { +- my ($core, $call, $name, $void, @argv) = @_; +- local $" = ', '; +- if ($void) { +- return qq/(defined wantarray)?$call(@argv): +- $call(@argv) || croak "Can't $name(\@_)/ . +- ($core ? ': $!' : ', \$! is \"$!\"') . '"' +- } else { +- return qq{$call(@argv) || croak "Can't $name(\@_)} . +- ($core ? ': $!' : ', \$! is \"$!\"') . '"'; +- } ++ my ($class, $core, $call, $name, $void, $sub, $back_compat, @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) { ++ ++ # TODO - Use Fatal qw(system) is not yet supported. It should be! ++ ++ if ($call eq 'CORE::system') { ++ return q{ ++ croak("UNIMPLEMENTED: use Fatal qw(system) not yet supported."); ++ }; ++ } ++ ++ local $" = ', '; ++ ++ if ($void) { ++ return qq/return (defined wantarray)?$call(@argv): ++ $call(@argv) || croak "Can't $name(\@_)/ . ++ ($core ? ': $!' : ', \$! is \"$!\"') . '"' ++ } else { ++ return qq{return $call(@argv) || 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 actualling ++ # 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. ++ ++ # Unfortunately, none of this tells us the *ultimate* name. ++ # For example, if I export 'copy' from File::Copy, I'd like my ++ # ultimate name to be File::Copy::copy. ++ # ++ # TODO - Is there any way to find the ultimate name of a sub, as ++ # described above? ++ ++ my $true_sub_name = $core ? $call : $sub; ++ ++ 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 propogating ++ # upwards. ++ ++ return qq{ ++ my \$retval; ++ my \$E; ++ ++ ++ { ++ local \$@; ++ ++ eval { ++ \$retval = IPC::System::Simple::system(@argv); ++ }; ++ ++ \$E = \$@; ++ } ++ ++ if (\$E) { ++ ++ # XXX - 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; ++ }; ++ ++ } ++ ++ # Should we be testing to see if our result is defined, or ++ # just true? ++ my $use_defined_or = exists ( $Use_defined_or{$call} ); ++ ++ local $" = ', '; ++ ++ # If we're going to throw an exception, here's the code to use. ++ my $die = qq{ ++ die $class->throw( ++ function => q{$true_sub_name}, args => [ @argv ], ++ pragma => q{$class}, errno => \$!, ++ ) ++ }; ++ ++ 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."); ++ ++ require Fcntl; # For Fcntl::LOCK_NB ++ ++ return qq{ ++ ++ # 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 ) { ++ return \$retval; ++ } ++ ++ # Otherwise, we failed. Die noisily. ++ ++ $die; ++ ++ }; ++ } ++ ++ # 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. ++ ++ return qq{ ++ no warnings qw(unopened); ++ ++ if (wantarray) { ++ my \@results = $call(@argv); ++ # If we got back nothing, or we got back a single ++ # undef, we die. ++ if (! \@results or (\@results == 1 and ! defined \$results[0])) { ++ $die; ++ }; ++ return \@results; ++ } ++ ++ # Otherwise, we're in scalar context. ++ # We're never in a void context, since we have to look ++ # at the result. ++ ++ my \$result = $call(@argv); ++ ++ } . ( $use_defined_or ? qq{ ++ ++ $die if not defined \$result; ++ ++ return \$result; ++ ++ } : qq{ ++ ++ return \$result || $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. ++ + sub _make_fatal { +- my($sub, $pkg, $void) = @_; ++ my($class, $sub, $pkg, $void, $lexical, $filename) = @_; + my($name, $code, $sref, $real_proto, $proto, $core, $call); + my $ini = $sub; + + $sub = "${pkg}::$sub" unless $sub =~ /::/; ++ ++ # 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. ++ + $name = $sub; + $name =~ s/.*::// or $name =~ s/^&//; +- print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; +- croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/; +- if (defined(&$sub)) { # user subroutine +- $sref = \&$sub; +- $proto = prototype $sref; +- $call = '&$sref'; ++ ++ 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 ++ ++ # This could be something that we've fatalised that ++ # was in core. ++ ++ local $@; # Don't clobber anyone else's $@ ++ ++ if ( $Package_Fatal{$sub} and eval { prototype "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 = prototype $call; ++ ++ # We return our $sref from this subroutine later ++ # on, indicating this subroutine should be placed ++ # back when we're finished. ++ ++ $sref = \&$sub; ++ ++ } else { ++ ++ # A regular user sub, or a user sub wrapping a ++ # core sub. ++ ++ $sref = \&$sub; ++ $proto = prototype $sref; ++ $call = '&$sref'; ++ ++ } ++ + } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { +- # Stray user subroutine +- die "$sub is not a Perl subroutine" +- } else { # CORE subroutine ++ # Stray user subroutine ++ croak(sprintf(ERROR_NOTSUB,$sub)); ++ ++ } elsif ($name eq 'system') { ++ ++ # If we're fatalising system, then we need to load ++ # helper code. ++ ++ eval { ++ require IPC::System::Simple; # Only load it if we need it. ++ require autodie::exception::system; ++ }; ++ ++ if ($@) { 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'; ++ $name = '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" beaviour as expected. ++ ++ $call = 'CORE::exec'; ++ $name = 'exec'; ++ $core = 1; ++ ++ } else { # CORE subroutine + $proto = eval { prototype "CORE::$name" }; +- die "$name is neither a builtin, nor a Perl subroutine" +- if $@; +- die "Cannot make the non-overridable builtin $name fatal" +- if not defined $proto; +- $core = 1; +- $call = "CORE::$name"; ++ croak(sprintf(ERROR_NOT_BUILT,$name)) if $@; ++ croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; ++ $core = 1; ++ $call = "CORE::$name"; + } ++ + if (defined $proto) { +- $real_proto = " ($proto)"; ++ $real_proto = " ($proto)"; + } else { +- $real_proto = ''; +- $proto = '@'; ++ $real_proto = ''; ++ $proto = '@'; + } +- $code = <_install_subs($pkg, { $name => $subref }); ++ return $sref; ++ } ++ ++ $code = qq[ ++ sub$real_proto { ++ local(\$", \$!) = (', ', 0); # TODO - Why do we do this? ++ ]; ++ ++ # 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"; ++ + my @protos = fill_protos($proto); +- $code .= write_invocation($core, $call, $name, $void, @protos); ++ $code .= $class->write_invocation($core, $call, $name, $void, $lexical, $sub, @protos); + $code .= "}\n"; +- print $code if $Debug; ++ 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). ++ # ++ # There is potential to more aggressively cache core subs ++ # that we know will never want to interact with package variables ++ # and filehandles. ++ + { +- no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... +- $code = eval("package $pkg; use Carp; $code"); +- die if $@; +- no warnings; # to avoid: Subroutine foo redefined ... +- *{$sub} = $code; ++ local $@; ++ no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... ++ $code = eval("package $pkg; use Carp; $code"); ## no critic ++ if (not $code) { ++ ++ # For some reason, using a die, croak, or confess in here ++ # results in the error being completely surpressed. As such, ++ # we need to do our own reporting. ++ # ++ # TODO: Fix the above. ++ ++ _autocroak("Internal error in autodie/Fatal processing $true_name: $@"); ++ ++ } + } ++ ++ # 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 $leak_guard; ++ ++ if ($lexical) { ++ ++ $leak_guard = qq< ++ package $pkg; ++ ++ sub$real_proto { ++ ++ # If we're inside a string eval, we can end up with a ++ # whacky filename. The following code allows autodie ++ # to propagate correctly into string evals. ++ ++ my \$caller_level = 0; ++ ++ while ( (caller \$caller_level)[1] =~ m{^\\(eval \\d+\\)\$} ) { ++ \$caller_level++; ++ } ++ ++ # If we're called from the correct file, then use the ++ # autodying code. ++ goto &\$code if ((caller \$caller_level)[1] eq \$filename); ++ ++ # Oh bother, we've leaked into another file. Call the ++ # original code. Note that \$sref may actually be a ++ # reference to a Fatalised version of a core built-in. ++ # That's okay, because Fatal *always* leaks between files. ++ ++ goto &\$sref if \$sref; ++ >; ++ ++ ++ # If we're here, it must have been a core subroutine called. ++ # Warning: The following code may disturb some viewers. ++ ++ # TODO: It should be possible to combine this with ++ # write_invocation(). ++ ++ foreach my $proto (@protos) { ++ local $" = ", "; # So @args is formatted correctly. ++ my ($count, @args) = @$proto; ++ $leak_guard .= qq< ++ if (\@_ == $count) { ++ return $call(@args); ++ } ++ >; ++ } ++ ++ $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >; ++ ++ # warn "$leak_guard\n"; ++ ++ local $@; ++ ++ $leak_guard = eval $leak_guard; ## no critic ++ ++ die "Internal error in $class: Leak-guard installation failure: $@" if $@; ++ } ++ ++ $class->_install_subs($pkg, { $name => $leak_guard || $code }); ++ ++ $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $leak_guard || $code; ++ ++ 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! ++ eval "require $exception_class"; ## no critic ++ $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); ++ } ++} ++ ++# 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 vegence. 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! ++} ++ ++package autodie::Scope::Guard; ++ ++# 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; +@@ -140,54 +1005,129 @@ + + =head1 NAME + +-Fatal - replace functions with equivalents which succeed or die ++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 { . . . } +- import Fatal '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. ++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 which cannot be expressed +-via prototypes) in this way. ++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/; ++ 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. + +- # properly checked, so no exception raised on error +- if(open(FH, "< /bogotic") { +- warn "bogo file, dude: $!"; +- } ++=head1 DIAGNOSTICS + +- # not checked, so error raises an exception +- close FH; ++=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 + +-You should not fatalize functions that are called in list context, because this +-module tests whether a function has failed by testing the boolean truth of its +-return value in scalar context. ++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 + +-Lionel Cons (CERN). ++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. ++ + =cut +diff -urN perl-5.10.0.orig/lib/autodie/exception/system.pm perl-5.10.0/lib/autodie/exception/system.pm +--- perl-5.10.0.orig/lib/autodie/exception/system.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/lib/autodie/exception/system.pm 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,81 @@ ++package autodie::exception::system; ++use 5.008; ++use strict; ++use warnings; ++use base 'autodie::exception'; ++use Carp qw(croak); ++ ++our $VERSION = '1.999'; ++ ++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 +diff -urN perl-5.10.0.orig/lib/autodie/exception.pm perl-5.10.0/lib/autodie/exception.pm +--- perl-5.10.0.orig/lib/autodie/exception.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/lib/autodie/exception.pm 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,687 @@ ++package autodie::exception; ++use 5.008; ++use strict; ++use warnings; ++use Carp qw(croak); ++ ++our $DEBUG = 0; ++ ++use overload ++ q{""} => "stringify" ++; ++ ++# Overload smart-match only if we're using 5.10 ++ ++use if ($] >= 5.010), overload => '~~' => "matches"; ++ ++our $VERSION = '1.999'; ++ ++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 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 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 futher information. ++ ++=back ++ ++=cut ++ ++{ ++ my (%cache); ++ ++ sub matches { ++ my ($this, $that) = @_; ++ ++ # XXX - 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, ++); ++ ++# 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::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]; ++ ++ # 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); ++ }; ++ ++ 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::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'; } ++ ++ 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; ++ ++ # Have a funny mode? Use the default format. ++ return $this->format_default if not defined $mode; ++ ++ # Localising $! means perl make make 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; ++ ++ 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} ) { ++ return $sub->($this) . $this->add_file_and_line; ++ } ++ ++ return $this->format_default; ++ ++} ++ ++=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->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'} } ++ } ++ ++ # Format our beautiful error. ++ ++ return "Can't $call(". join(q{, }, @args) . "): $!" . ++ $this->add_file_and_line; ++ ++ # TODO - Handle user-defined errors from hash. ++ ++ # TODO - Handle default error messages. ++ ++} ++ ++=head3 new ++ ++ my $error = autodie::exception->new( ++ args => \@_, ++ function => "CORE::open", ++ errno => $!, ++ ); ++ ++ ++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__); ++ 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 thetop 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; ++ $this->{$PACKAGE}{package} = $package; ++ ++ $this->{$PACKAGE}{errno} = $args{errno} || 0; ++ ++ $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 +diff -urN perl-5.10.0.orig/lib/autodie.pm perl-5.10.0/lib/autodie.pm +--- perl-5.10.0.orig/lib/autodie.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/lib/autodie.pm 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,360 @@ ++package autodie; ++use 5.008; ++use strict; ++use warnings; ++ ++use Fatal (); ++our @ISA = qw(Fatal); ++our $VERSION; ++ ++BEGIN { ++ $VERSION = "1.999"; ++} ++ ++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 ($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(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 ++ } ++ ++=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, C and C. ++ ++The categories are currently: ++ ++ :all ++ :default ++ :io ++ read ++ seek ++ sysread ++ sysseek ++ syswrite ++ :dbm ++ dbmclose ++ dbmopen ++ :file ++ binmode ++ close ++ fcntl ++ fileno ++ flock ++ ioctl ++ open ++ sysopen ++ truncate ++ :filesys ++ chdir ++ closedir ++ opendir ++ link ++ mkdir ++ readlink ++ rename ++ rmdir ++ symlink ++ unlink ++ :ipc ++ 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 surity ++that no behavorial changes will occur if the C module is ++upgraded. ++ ++=head1 FUNCTION SPECIFIC NOTES ++ ++=head2 flock ++ ++It is not considered an error for C to return false if it fails ++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 ++ ++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. ++ ++=head1 DIAGNOSTICS ++ ++=over 4 ++ ++=item :void cannot be used with lexical scope ++ ++The C<:void> option is supported in L, but not ++C. However you can explicitly disable autodie ++end the end of the current block with C. ++To disable autodie for only a single function (eg, open) ++use or C. ++ ++=back ++ ++See also L. ++ ++=head1 BUGS ++ ++"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. ++ ++Under Perl 5.8 only, C I propagate into string C ++statements, although it can be explicitly enabled inside a string ++C. This bug does not affect block C statements in ++any version of Perl. ++ ++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 ue C or C on other user subroutines will ++result in a compile-time error. ++ ++=head2 REPORTING BUGS ++ ++Please report bugs 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, 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 ++ ++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 +diff -urN perl-5.10.0.orig/pod/perlmodlib.pod perl-5.10.0/pod/perlmodlib.pod +--- perl-5.10.0.orig/pod/perlmodlib.pod 2007-12-18 11:47:08.000000000 +0100 ++++ perl-5.10.0/pod/perlmodlib.pod 2009-03-24 11:53:29.000000000 +0100 +@@ -55,6 +55,10 @@ + + Set/get attributes of a subroutine (deprecated) + ++=item autodie ++ ++Replace functions with ones that succeed or die with lexical scope ++ + =item autouse + + Postpone load of modules until a function is used +diff -urN perl-5.10.0.orig/t/lib/autodie/00-load.t perl-5.10.0/t/lib/autodie/00-load.t +--- perl-5.10.0.orig/t/lib/autodie/00-load.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/00-load.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,9 @@ ++#!perl -T ++ ++use Test::More tests => 1; ++ ++BEGIN { ++ use_ok( 'Fatal' ); ++} ++ ++# diag( "Testing Fatal $Fatal::VERSION, Perl $], $^X" ); +diff -urN perl-5.10.0.orig/t/lib/autodie/Fatal.t perl-5.10.0/t/lib/autodie/Fatal.t +--- perl-5.10.0.orig/t/lib/autodie/Fatal.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/Fatal.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,36 @@ ++#!/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(open close :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" ++); +diff -urN perl-5.10.0.orig/t/lib/autodie/autodie.t perl-5.10.0/t/lib/autodie/autodie.t +--- perl-5.10.0.orig/t/lib/autodie/autodie.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/autodie.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,103 @@ ++#!/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."); ++} ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/autodie_test_module.pm perl-5.10.0/t/lib/autodie/autodie_test_module.pm +--- perl-5.10.0.orig/t/lib/autodie/autodie_test_module.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/autodie_test_module.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,18 @@ ++package main; ++use strict; ++use warnings; ++ ++# Calls open, while still in the main package. This shouldn't ++# be autodying. ++sub leak_test { ++ return open(my $fh, '<', $_[0]); ++} ++ ++package autodie_test_module; ++ ++# This should be calling CORE::open ++sub your_open { ++ return open(my $fh, '<', $_[0]); ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/backcompat.t perl-5.10.0/t/lib/autodie/backcompat.t +--- perl-5.10.0.orig/t/lib/autodie/backcompat.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/backcompat.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,14 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/basic_exceptions.t perl-5.10.0/t/lib/autodie/basic_exceptions.t +--- perl-5.10.0.orig/t/lib/autodie/basic_exceptions.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/basic_exceptions.t 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,46 @@ ++#!/usr/bin/perl -w ++use strict; ++ ++use Test::More tests => 17; ++ ++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'); ++ ++# 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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/binmode.t perl-5.10.0/t/lib/autodie/binmode.t +--- perl-5.10.0.orig/t/lib/autodie/binmode.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/binmode.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,33 @@ ++#!/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."); +diff -urN perl-5.10.0.orig/t/lib/autodie/caller.t perl-5.10.0/t/lib/autodie/caller.t +--- perl-5.10.0.orig/t/lib/autodie/caller.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/caller.t 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,34 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/context.t perl-5.10.0/t/lib/autodie/context.t +--- perl-5.10.0.orig/t/lib/autodie/context.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/context.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,66 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/context_lexical.t perl-5.10.0/t/lib/autodie/context_lexical.t +--- perl-5.10.0.orig/t/lib/autodie/context_lexical.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/context_lexical.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,80 @@ ++#!/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. ++ ++sub list_mirror { ++ return undef if (@_ == 1 and not defined $_[0]); ++ 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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/crickey.t perl-5.10.0/t/lib/autodie/crickey.t +--- perl-5.10.0.orig/t/lib/autodie/crickey.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/crickey.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,27 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/dbmopen.t perl-5.10.0/t/lib/autodie/dbmopen.t +--- perl-5.10.0.orig/t/lib/autodie/dbmopen.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/dbmopen.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,36 @@ ++#!/usr/bin/perl -w ++use strict; ++use Test::More qw(no_plan); ++ ++use constant ERROR_REGEXP => qr{Can't dbmopen\(%hash, 'foo/bar/baz', 0666\):}; ++ ++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; ++ ++ my %bar = ( foo => 1, bar => 2 ); ++ ++ dbmopen(%bar, "foo/bar/baz", 0666); ++}; ++ ++like($@, ERROR_REGEXP, "Correct formatting even with non-empty dbmopen hash"); ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/exception_class.t perl-5.10.0/t/lib/autodie/exception_class.t +--- perl-5.10.0.orig/t/lib/autodie/exception_class.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/exception_class.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,57 @@ ++#!/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'); +diff -urN perl-5.10.0.orig/t/lib/autodie/exceptions.t perl-5.10.0/t/lib/autodie/exceptions.t +--- perl-5.10.0.orig/t/lib/autodie/exceptions.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/exceptions.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,45 @@ ++#!/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'; ++ ++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" ); ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/exec.t perl-5.10.0/t/lib/autodie/exec.t +--- perl-5.10.0.orig/t/lib/autodie/exec.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/exec.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,12 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/filehandles.t perl-5.10.0/t/lib/autodie/filehandles.t +--- perl-5.10.0.orig/t/lib/autodie/filehandles.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/filehandles.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,60 @@ ++#!/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}); +diff -urN perl-5.10.0.orig/t/lib/autodie/fileno.t perl-5.10.0/t/lib/autodie/fileno.t +--- perl-5.10.0.orig/t/lib/autodie/fileno.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/fileno.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,35 @@ ++#!/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'); +diff -urN perl-5.10.0.orig/t/lib/autodie/flock.t perl-5.10.0/t/lib/autodie/flock.t +--- perl-5.10.0.orig/t/lib/autodie/flock.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/flock.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,90 @@ ++#!/usr/bin/perl -w ++use strict; ++use Test::More; ++use Fcntl qw(:flock); ++use POSIX qw(EWOULDBLOCK); ++ ++require Fatal; ++ ++my $EWOULDBLOCK = eval { EWOULDBLOCK() } ++ || $Fatal::_EWOULDBLOCK{$^O} ++ || plan skip_all => "EWOULDBLOCK not defined on this system"; ++ ++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 = 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); ++}; ++ ++is($!+0, $EWOULDBLOCK, "Double-flocking should be EWOULDBLOCK"); ++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."); +diff -urN perl-5.10.0.orig/t/lib/autodie/internal.t perl-5.10.0/t/lib/autodie/internal.t +--- perl-5.10.0.orig/t/lib/autodie/internal.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/internal.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,33 @@ ++#!/usr/bin/perl -w ++use strict; ++ ++use constant NO_SUCH_FILE => "this_file_or_dir_had_better_not_exist_XYZZY"; ++ ++use Test::More tests => 6; ++ ++# Lexical tests using the internal interface. ++ ++eval { Fatal->import(qw(:lexical :void)) }; ++like($@, qr{:void cannot be used with lexical}, ":void can't be used with :lexical"); ++ ++eval { Fatal->import(qw(open close :lexical)) }; ++like($@, qr{:lexical must be used as first}, ":lexical must come first"); ++ ++{ ++ use Fatal qw(:lexical chdir); ++ ++ eval { chdir(NO_SUCH_FILE); }; ++ like ($@, 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); }; ++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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/lethal.t perl-5.10.0/t/lib/autodie/lethal.t +--- perl-5.10.0.orig/t/lib/autodie/lethal.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lethal.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,17 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/Caller_helper.pm perl-5.10.0/t/lib/autodie/lib/Caller_helper.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/Caller_helper.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/Caller_helper.pm 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,13 @@ ++package Caller_helper; ++ ++our $line; ++ ++sub foo { ++ use autodie; ++ ++ $line = __LINE__; open(my $fh, '<', "no_such_file_here"); ++ ++ return; ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/au/exception.pm perl-5.10.0/t/lib/autodie/lib/autodie/test/au/exception.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/au/exception.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/autodie/test/au/exception.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,19 @@ ++package autodie::test::au::exception; ++use strict; ++use warnings; ++ ++use base 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; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/au.pm perl-5.10.0/t/lib/autodie/lib/autodie/test/au.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/au.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/autodie/test/au.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,14 @@ ++package autodie::test::au; ++use strict; ++use warnings; ++ ++use base qw(autodie); ++ ++use autodie::test::au::exception; ++ ++sub throw { ++ my ($this, @args) = @_; ++ return autodie::test::au::exception->new(@args); ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/badname.pm perl-5.10.0/t/lib/autodie/lib/autodie/test/badname.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/badname.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/autodie/test/badname.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,8 @@ ++package autodie::test::badname; ++use base qw(autodie); ++ ++sub exception_class { ++ return 'autodie::test::badname::$@#%'; # Doesn't exist! ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/missing.pm perl-5.10.0/t/lib/autodie/lib/autodie/test/missing.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/autodie/test/missing.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/autodie/test/missing.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,8 @@ ++package autodie::test::missing; ++use base qw(autodie); ++ ++sub exception_class { ++ return "autodie::test::missing::exception"; # Doesn't exist! ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/lethal.pm perl-5.10.0/t/lib/autodie/lib/lethal.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/lethal.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/lethal.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,8 @@ ++package lethal; ++ ++# A dummy package showing how we can trivially subclass autodie ++# to our tastes. ++ ++use base qw(autodie); ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/pujHa/ghach/Dotlh.pm perl-5.10.0/t/lib/autodie/lib/pujHa/ghach/Dotlh.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/pujHa/ghach/Dotlh.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/pujHa/ghach/Dotlh.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,59 @@ ++package 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 base 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; ++ ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/lib/pujHa/ghach.pm perl-5.10.0/t/lib/autodie/lib/pujHa/ghach.pm +--- perl-5.10.0.orig/t/lib/autodie/lib/pujHa/ghach.pm 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/lib/pujHa/ghach.pm 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,26 @@ ++package 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 base qw(autodie); ++ ++sub exception_class { ++ return "pujHa'ghach::Dotlh"; # Dotlh - status ++} ++ ++1; +diff -urN perl-5.10.0.orig/t/lib/autodie/mkdir.t perl-5.10.0/t/lib/autodie/mkdir.t +--- perl-5.10.0.orig/t/lib/autodie/mkdir.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/mkdir.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,69 @@ ++#!/usr/bin/perl -w ++use strict; ++use Test::More; ++use FindBin qw($Bin); ++use constant TMPDIR => "$Bin/mkdir_test_delete_me"; ++ ++# 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 => 12; ++ ++# 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; ++}; ++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"); ++ ++# 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"); ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/open.t perl-5.10.0/t/lib/autodie/open.t +--- perl-5.10.0.orig/t/lib/autodie/open.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/open.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,18 @@ ++#!/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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/recv.t perl-5.10.0/t/lib/autodie/recv.t +--- perl-5.10.0.orig/t/lib/autodie/recv.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/recv.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,60 @@ ++#!/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 { ++ # STDIN isn't a socket, so this should fail. ++ recv(STDIN,$buffer,1,0); ++}; ++ ++ok($@,'recv dies on returning undef'); ++isa_ok($@,'autodie::exception'); ++ ++$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'); +diff -urN perl-5.10.0.orig/t/lib/autodie/repeat.t perl-5.10.0/t/lib/autodie/repeat.t +--- perl-5.10.0.orig/t/lib/autodie/repeat.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/repeat.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,19 @@ ++#!/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"); ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/scope_leak.t perl-5.10.0/t/lib/autodie/scope_leak.t +--- perl-5.10.0.orig/t/lib/autodie/scope_leak.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/scope_leak.t 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,78 @@ ++#!/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 autodie qw(open); ++ ++eval { ++ open(my $fh, '<', NO_SUCH_FILE); ++}; ++ ++ok($@, "basic autodie test"); ++ ++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"); ++ ++# 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'); +diff -urN perl-5.10.0.orig/t/lib/autodie/sysopen.t perl-5.10.0/t/lib/autodie/sysopen.t +--- perl-5.10.0.orig/t/lib/autodie/sysopen.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/sysopen.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,23 @@ ++#!/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'); +diff -urN perl-5.10.0.orig/t/lib/autodie/truncate.t perl-5.10.0/t/lib/autodie/truncate.t +--- perl-5.10.0.orig/t/lib/autodie/truncate.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/truncate.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,53 @@ ++#!/usr/bin/perl -w ++use strict; ++ ++use Test::More; ++use File::Temp qw(tempfile); ++use IO::Handle; ++ ++my $tmpfh = tempfile(); ++my $truncate_status; ++ ++eval { ++ $truncate_status = truncate($tmpfh, 0); ++}; ++ ++if ($@ || !defined($truncate_status)) { ++ plan skip_all => 'Truncate not implemented or not working on this system'; ++} ++ ++plan tests => 3; ++ ++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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/unlink.t perl-5.10.0/t/lib/autodie/unlink.t +--- perl-5.10.0.orig/t/lib/autodie/unlink.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/unlink.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,52 @@ ++#!/usr/bin/perl -w ++use strict; ++use Test::More; ++use FindBin qw($Bin); ++use constant TMPFILE => "$Bin/unlink_test_delete_me"; ++ ++# Create a file to practice unlinking ++open(my $fh, ">", TMPFILE) ++ or plan skip_all => "Unable to create test file: $!"; ++print {$fh} "Test\n"; ++close $fh; ++ ++# 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 ++open(my $fh2, ">", TMPFILE) ++ or plan skip_all => "Unable to create test file: $!"; ++print {$fh2} "Test\n"; ++close $fh2; ++ ++# Check that file now exists ++-e TMPFILE or plan skip_all => "Failed to create test file"; ++ ++plan tests => 6; ++ ++# Try to delete directory (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"); ++ +diff -urN perl-5.10.0.orig/t/lib/autodie/user-context.t perl-5.10.0/t/lib/autodie/user-context.t +--- perl-5.10.0.orig/t/lib/autodie/user-context.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/user-context.t 2009-03-24 12:42:25.000000000 +0100 +@@ -0,0 +1,59 @@ ++#!/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'); ++}; ++ ++TODO: { ++ local $TODO = "Fixed in 'hints' branch"; ++ ++ 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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/usersub.t perl-5.10.0/t/lib/autodie/usersub.t +--- perl-5.10.0.orig/t/lib/autodie/usersub.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/usersub.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,64 @@ ++#!/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"); ++ ++$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"); +diff -urN perl-5.10.0.orig/t/lib/autodie/version.t perl-5.10.0/t/lib/autodie/version.t +--- perl-5.10.0.orig/t/lib/autodie/version.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/version.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,17 @@ ++#!/usr/bin/perl -w ++use strict; ++use Test::More tests => 3; ++ ++# 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::exception; ++require autodie::exception::system; ++ ++is($Fatal::VERSION, $autodie::VERSION); ++is($autodie::VERSION, $autodie::exception::VERSION); ++is($autodie::exception::VERSION, $autodie::exception::system::VERSION); +diff -urN perl-5.10.0.orig/t/lib/autodie/version_tag.t perl-5.10.0/t/lib/autodie/version_tag.t +--- perl-5.10.0.orig/t/lib/autodie/version_tag.t 1970-01-01 01:00:00.000000000 +0100 ++++ perl-5.10.0/t/lib/autodie/version_tag.t 2009-03-24 11:53:29.000000000 +0100 +@@ -0,0 +1,26 @@ ++#!/usr/bin/perl -w ++use strict; ++use warnings; ++use Test::More tests => 3; ++ ++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; ++ ++# Expanding our current version should work! ++eval { my $foo = autodie->_expand_tag(":$version"); }; ++ ++is($@,"","Expanding :$version should succeed"); ++ diff --git a/perl.spec b/perl.spec index e0dd983..e25de54 100644 --- a/perl.spec +++ b/perl.spec @@ -7,7 +7,7 @@ Name: perl Version: %{perl_version} -Release: 63%{?dist} +Release: 64%{?dist} Epoch: %{perl_epoch} Summary: Practical Extraction and Report Language Group: Development/Languages @@ -216,6 +216,9 @@ Patch116: perl-update-Time-HiRes.patch %define Time_HiRes_version 1.9719 Patch117: perl-update-Digest-SHA.patch %define Digest_SHA_version 5.47 +# includes Fatal.pm +Patch118: perl-update-autodie.patch +%define autodie_version 1.999 # Fedora uses links instead of lynx # patches File-Fetch and CPAN @@ -988,6 +991,7 @@ upstream tarball from perl.org. %patch115 -p1 %patch116 -p1 %patch117 -p1 +%patch118 -p1 %patch201 -p1 # @@ -1230,7 +1234,7 @@ perl -x patchlevel.h \ 'Fedora Patch55: File::Path::rmtree no longer allows creating of setuid files.' \ 'Fedora Patch56: Fix $? when dumping core' \ '34209 Fix a memory leak with Scalar::Util::weaken()' \ - 'Fedora Patch100: Update constant to %{constant_version}' \ + 'Fedora Patch100: Update module constant to %{constant_version}' \ 'Fedora Patch101: Update Archive::Extract to %{Archive_Extract_version}' \ 'Fedora Patch102: Update Archive::Tar to %{Archive_Tar_version}' \ 'Fedora Patch103: Update CGI to %{CGI_version}' \ @@ -1248,6 +1252,7 @@ perl -x patchlevel.h \ 'Fedora Patch115: Update Test::Simple to %{Test_Simple_version}' \ 'Fedora Patch116: Update Time::HiRes to %{Time_HiRes_version}' \ 'Fedora Patch117: Update Digest::SHA to %{Digest_SHA_version}' \ + 'Fedora Patch117: Update module autodie to %{autodie_version}' \ 'Fedora Patch201: Fedora uses links instead of lynx' \ %{nil} @@ -1870,6 +1875,9 @@ TMPDIR="$PWD/tmp" make test # Old changelog entries are preserved in CVS. %changelog +* Tue Mar 24 2009 Stepan Kasal - 4:5.10.0-64 +- update module autodie + * Mon Mar 23 2009 Stepan Kasal - 4:5.10.0-63 - update Digest::SHA (fixes 489221)