5 use vars qw( $AUTOLOAD $Debug $VERSION);
9 $Debug = 0 unless defined $Debug;
16 &_make_fatal($sym, $pkg);
23 &_make_fatal($cmd, (caller)[0]);
29 my ($n, $isref, @out, @out1, $seen_semi) = -1;
30 while ($proto =~ /\S/) {
32 push(@out1,[$n,@out]) if $seen_semi;
33 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
34 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
35 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
36 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
37 die "Unknown prototype letters: \"$proto\"";
39 push(@out1,[$n+1,@out]);
43 sub write_invocation {
44 my ($core, $call, $name, @argvs) = @_;
45 if (@argvs == 1) { # No optional arguments
46 my @argv = @{$argvs[0]};
48 return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
53 @argv = @{shift @argvs};
55 push @out, "$ {else}if (\@_ == $n) {\n";
58 "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
62 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
69 my ($core, $call, $name, @argv) = @_;
71 return qq{$call(@argv) || croak "Can't $name(\@_)} .
72 ($core ? ': $!' : ', \$! is \"$!\"') . '"';
77 my($name, $code, $sref, $real_proto, $proto, $core, $call);
80 $sub = "${pkg}::$sub" unless $sub =~ /::/;
82 $name =~ s/.*::// or $name =~ s/^&//;
83 print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
84 croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
85 if (defined(&$sub)) { # user subroutine
87 $proto = prototype $sref;
89 } elsif ($sub eq $ini) { # Stray user subroutine
90 die "$sub is not a Perl subroutine"
91 } else { # CORE subroutine
92 $proto = eval { prototype "CORE::$name" };
93 die "$name is neither a builtin, nor a Perl subroutine"
95 die "Cannot make a non-overridable builtin fatal"
96 if not defined $proto;
98 $call = "CORE::$name";
100 if (defined $proto) {
101 $real_proto = " ($proto)";
108 local(\$", \$!) = (', ', 0);
110 my @protos = fill_protos($proto);
111 $code .= write_invocation($core, $call, $name, @protos);
113 print $code if $Debug;
115 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
116 $code = eval("package $pkg; use Carp; $code");
118 local($^W) = 0; # to avoid: Subroutine foo redefined ...
129 Fatal - replace functions with equivalents which succeed or die
133 use Fatal qw(open close);
136 import Fatal 'juggle';
140 C<Fatal> provides a way to conveniently replace functions which normally
141 return a false value when they fail with equivalents which halt execution
142 if they are not successful. This lets you use these functions without
143 having to test their return values explicitly on each call. Errors are
144 reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
145 wish to take some action before the program exits.
147 The do-or-die equivalents are set up simply by calling Fatal's
148 C<import> routine, passing it the names of the functions to be
149 replaced. You may wrap both user-defined functions and overridable
150 CORE operators (except C<exec>, C<system> which cannot be expressed
151 via prototypes) in this way.
157 prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu