1package Fatal; 2 3use 5.006_001; 4use Carp; 5use strict; 6our($AUTOLOAD, $Debug, $VERSION); 7 8$VERSION = 1.03; 9 10$Debug = 0 unless defined $Debug; 11 12sub import { 13 my $self = shift(@_); 14 my($sym, $pkg); 15 my $void = 0; 16 $pkg = (caller)[0]; 17 foreach $sym (@_) { 18 if ($sym eq ":void") { 19 $void = 1; 20 } 21 else { 22 &_make_fatal($sym, $pkg, $void); 23 } 24 } 25}; 26 27sub AUTOLOAD { 28 my $cmd = $AUTOLOAD; 29 $cmd =~ s/.*:://; 30 &_make_fatal($cmd, (caller)[0]); 31 goto &$AUTOLOAD; 32} 33 34sub fill_protos { 35 my $proto = shift; 36 my ($n, $isref, @out, @out1, $seen_semi) = -1; 37 while ($proto =~ /\S/) { 38 $n++; 39 push(@out1,[$n,@out]) if $seen_semi; 40 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; 41 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//; 42 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; 43 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? 44 die "Unknown prototype letters: \"$proto\""; 45 } 46 push(@out1,[$n+1,@out]); 47 @out1; 48} 49 50sub write_invocation { 51 my ($core, $call, $name, $void, @argvs) = @_; 52 if (@argvs == 1) { # No optional arguments 53 my @argv = @{$argvs[0]}; 54 shift @argv; 55 return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 56 } else { 57 my $else = "\t"; 58 my (@out, @argv, $n); 59 while (@argvs) { 60 @argv = @{shift @argvs}; 61 $n = shift @argv; 62 push @out, "$ {else}if (\@_ == $n) {\n"; 63 $else = "\t} els"; 64 push @out, 65 "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 66 } 67 push @out, <<EOC; 68 } 69 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments"; 70EOC 71 return join '', @out; 72 } 73} 74 75sub one_invocation { 76 my ($core, $call, $name, $void, @argv) = @_; 77 local $" = ', '; 78 if ($void) { 79 return qq/(defined wantarray)?$call(@argv): 80 $call(@argv) || croak "Can't $name(\@_)/ . 81 ($core ? ': $!' : ', \$! is \"$!\"') . '"' 82 } else { 83 return qq{$call(@argv) || croak "Can't $name(\@_)} . 84 ($core ? ': $!' : ', \$! is \"$!\"') . '"'; 85 } 86} 87 88sub _make_fatal { 89 my($sub, $pkg, $void) = @_; 90 my($name, $code, $sref, $real_proto, $proto, $core, $call); 91 my $ini = $sub; 92 93 $sub = "${pkg}::$sub" unless $sub =~ /::/; 94 $name = $sub; 95 $name =~ s/.*::// or $name =~ s/^&//; 96 print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; 97 croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/; 98 if (defined(&$sub)) { # user subroutine 99 $sref = \&$sub; 100 $proto = prototype $sref; 101 $call = '&$sref'; 102 } elsif ($sub eq $ini) { # Stray user subroutine 103 die "$sub is not a Perl subroutine" 104 } else { # CORE subroutine 105 $proto = eval { prototype "CORE::$name" }; 106 die "$name is neither a builtin, nor a Perl subroutine" 107 if $@; 108 die "Cannot make a non-overridable builtin fatal" 109 if not defined $proto; 110 $core = 1; 111 $call = "CORE::$name"; 112 } 113 if (defined $proto) { 114 $real_proto = " ($proto)"; 115 } else { 116 $real_proto = ''; 117 $proto = '@'; 118 } 119 $code = <<EOS; 120sub$real_proto { 121 local(\$", \$!) = (', ', 0); 122EOS 123 my @protos = fill_protos($proto); 124 $code .= write_invocation($core, $call, $name, $void, @protos); 125 $code .= "}\n"; 126 print $code if $Debug; 127 { 128 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... 129 $code = eval("package $pkg; use Carp; $code"); 130 die if $@; 131 no warnings; # to avoid: Subroutine foo redefined ... 132 *{$sub} = $code; 133 } 134} 135 1361; 137 138__END__ 139 140=head1 NAME 141 142Fatal - replace functions with equivalents which succeed or die 143 144=head1 SYNOPSIS 145 146 use Fatal qw(open close); 147 148 sub juggle { . . . } 149 import Fatal 'juggle'; 150 151=head1 DESCRIPTION 152 153C<Fatal> provides a way to conveniently replace functions which normally 154return a false value when they fail with equivalents which raise exceptions 155if they are not successful. This lets you use these functions without 156having to test their return values explicitly on each call. Exceptions 157can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details. 158 159The do-or-die equivalents are set up simply by calling Fatal's 160C<import> routine, passing it the names of the functions to be 161replaced. You may wrap both user-defined functions and overridable 162CORE operators (except C<exec>, C<system> which cannot be expressed 163via prototypes) in this way. 164 165If the symbol C<:void> appears in the import list, then functions 166named later in that import list raise an exception only when 167these are called in void context--that is, when their return 168values are ignored. For example 169 170 use Fatal qw/:void open close/; 171 172 # properly checked, so no exception raised on error 173 if(open(FH, "< /bogotic") { 174 warn "bogo file, dude: $!"; 175 } 176 177 # not checked, so error raises an exception 178 close FH; 179 180=head1 AUTHOR 181 182Lionel.Cons@cern.ch 183 184prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu 185 186=cut 187