Commit | Line | Data |
e92e55da |
1 | package Fatal; |
2 | |
3 | use Carp; |
4 | use strict; |
5 | use vars qw( $AUTOLOAD $Debug $VERSION); |
6 | |
7 | $VERSION = 1.02; |
8 | |
9 | $Debug = 0 unless defined $Debug; |
10 | |
11 | sub import { |
12 | my $self = shift(@_); |
13 | my($sym, $pkg); |
14 | $pkg = (caller)[0]; |
15 | foreach $sym (@_) { |
16 | &_make_fatal($sym, $pkg); |
17 | } |
18 | }; |
19 | |
20 | sub AUTOLOAD { |
21 | my $cmd = $AUTOLOAD; |
22 | $cmd =~ s/.*:://; |
23 | &_make_fatal($cmd, (caller)[0]); |
24 | goto &$AUTOLOAD; |
25 | } |
26 | |
27 | sub fill_protos { |
28 | my $proto = shift; |
29 | my ($n, $isref, @out, @out1, $seen_semi) = -1; |
30 | while ($proto =~ /\S/) { |
31 | $n++; |
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\""; |
38 | } |
39 | push(@out1,[$n+1,@out]); |
40 | @out1; |
41 | } |
42 | |
43 | sub write_invocation { |
44 | my ($core, $call, $name, @argvs) = @_; |
45 | if (@argvs == 1) { # No optional arguments |
46 | my @argv = @{$argvs[0]}; |
47 | shift @argv; |
48 | return "\t" . one_invocation($core, $call, $name, @argv) . ";\n"; |
49 | } else { |
50 | my $else = "\t"; |
51 | my (@out, @argv, $n); |
52 | while (@argvs) { |
53 | @argv = @{shift @argvs}; |
54 | $n = shift @argv; |
55 | push @out, "$ {else}if (\@_ == $n) {\n"; |
56 | $else = "\t} els"; |
57 | push @out, |
58 | "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n"; |
59 | } |
60 | push @out, <<EOC; |
61 | } |
62 | die "$name(\@_): Do not expect to get ", scalar \@_, " arguments"; |
63 | EOC |
64 | return join '', @out; |
65 | } |
66 | } |
67 | |
68 | sub one_invocation { |
69 | my ($core, $call, $name, @argv) = @_; |
70 | local $" = ', '; |
71 | return qq{$call(@argv) || croak "Can't $name(\@_)} . |
72 | ($core ? ': $!' : ', \$! is \"$!\"') . '"'; |
73 | } |
74 | |
75 | sub _make_fatal { |
76 | my($sub, $pkg) = @_; |
77 | my($name, $code, $sref, $real_proto, $proto, $core, $call); |
78 | my $ini = $sub; |
79 | |
80 | $sub = "${pkg}::$sub" unless $sub =~ /::/; |
81 | $name = $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 |
86 | $sref = \&$sub; |
87 | $proto = prototype $sref; |
88 | $call = '&$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" |
94 | if $@; |
95 | die "Cannot make a non-overridable builtin fatal" |
96 | if not defined $proto; |
97 | $core = 1; |
98 | $call = "CORE::$name"; |
99 | } |
100 | if (defined $proto) { |
101 | $real_proto = " ($proto)"; |
102 | } else { |
103 | $real_proto = ''; |
104 | $proto = '@'; |
105 | } |
106 | $code = <<EOS; |
107 | sub$real_proto { |
108 | local(\$", \$!) = (', ', 0); |
109 | EOS |
110 | my @protos = fill_protos($proto); |
111 | $code .= write_invocation($core, $call, $name, @protos); |
112 | $code .= "}\n"; |
113 | print $code if $Debug; |
114 | $code = eval($code); |
115 | die if $@; |
116 | local($^W) = 0; # to avoid: Subroutine foo redefined ... |
117 | no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... |
118 | *{$sub} = $code; |
119 | } |
120 | |
121 | 1; |
122 | |
123 | __END__ |
124 | |
125 | =head1 NAME |
126 | |
127 | Fatal - replace functions with equivalents which succeed or die |
128 | |
129 | =head1 SYNOPSIS |
130 | |
131 | use Fatal qw(open close); |
132 | |
133 | sub juggle { . . . } |
134 | import Fatal 'juggle'; |
135 | |
136 | =head1 DESCRIPTION |
137 | |
138 | C<Fatal> provides a way to conveniently replace functions which normally |
139 | return a false value when they fail with equivalents which halt execution |
140 | if they are not successful. This lets you use these functions without |
141 | having to test their return values explicitly on each call. Errors are |
142 | reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you |
143 | wish to take some action before the program exits. |
144 | |
145 | The do-or-die equivalents are set up simply by calling Fatal's |
146 | C<import> routine, passing it the names of the functions to be |
147 | replaced. You may wrap both user-defined functions and overridable |
148 | CORE operators (except C<exec>, C<system> which cannot be expressed |
149 | via prototypes) in this way. |
150 | |
151 | =head1 AUTHOR |
152 | |
153 | Lionel.Cons@cern.ch |
154 | |
155 | prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu |
156 | |
157 | =cut |