This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
From Paul Fenwick <pjf@perltraining.com.au>; Instructions on how to checkout/pull...
[perl5.git] / lib / Fatal.pm
CommitLineData
e92e55da
MB
1package Fatal;
2
3b825e41 3use 5.006_001;
e92e55da
MB
4use Carp;
5use strict;
17f410f9 6our($AUTOLOAD, $Debug, $VERSION);
e92e55da 7
df029878 8$VERSION = 1.06;
e92e55da
MB
9
10$Debug = 0 unless defined $Debug;
11
12sub import {
13 my $self = shift(@_);
14 my($sym, $pkg);
91c7a880 15 my $void = 0;
e92e55da
MB
16 $pkg = (caller)[0];
17 foreach $sym (@_) {
91c7a880
GS
18 if ($sym eq ":void") {
19 $void = 1;
20 }
21 else {
22 &_make_fatal($sym, $pkg, $void);
23 }
e92e55da
MB
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*\\([\@%\$\&])//;
594e23a5 41 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
e92e55da
MB
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 {
91c7a880 51 my ($core, $call, $name, $void, @argvs) = @_;
e92e55da
MB
52 if (@argvs == 1) { # No optional arguments
53 my @argv = @{$argvs[0]};
54 shift @argv;
91c7a880 55 return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
e92e55da
MB
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,
91c7a880 65 "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
e92e55da
MB
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 {
91c7a880 76 my ($core, $call, $name, $void, @argv) = @_;
e92e55da 77 local $" = ', ';
91c7a880
GS
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 }
e92e55da
MB
86}
87
88sub _make_fatal {
91c7a880 89 my($sub, $pkg, $void) = @_;
e92e55da
MB
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/^&//;
91c7a880 96 print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
e92e55da
MB
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';
910ad8dd
JP
102 } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
103 # Stray user subroutine
e92e55da
MB
104 die "$sub is not a Perl subroutine"
105 } else { # CORE subroutine
106 $proto = eval { prototype "CORE::$name" };
107 die "$name is neither a builtin, nor a Perl subroutine"
108 if $@;
df029878 109 die "Cannot make the non-overridable builtin $name fatal"
e92e55da
MB
110 if not defined $proto;
111 $core = 1;
112 $call = "CORE::$name";
113 }
114 if (defined $proto) {
115 $real_proto = " ($proto)";
116 } else {
117 $real_proto = '';
118 $proto = '@';
119 }
120 $code = <<EOS;
121sub$real_proto {
122 local(\$", \$!) = (', ', 0);
123EOS
124 my @protos = fill_protos($proto);
91c7a880 125 $code .= write_invocation($core, $call, $name, $void, @protos);
e92e55da
MB
126 $code .= "}\n";
127 print $code if $Debug;
2ba6ecf4
GS
128 {
129 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
130 $code = eval("package $pkg; use Carp; $code");
131 die if $@;
db376a24 132 no warnings; # to avoid: Subroutine foo redefined ...
2ba6ecf4
GS
133 *{$sub} = $code;
134 }
e92e55da
MB
135}
136
1371;
138
139__END__
140
141=head1 NAME
142
143Fatal - replace functions with equivalents which succeed or die
144
145=head1 SYNOPSIS
146
147 use Fatal qw(open close);
148
149 sub juggle { . . . }
150 import Fatal 'juggle';
151
152=head1 DESCRIPTION
153
154C<Fatal> provides a way to conveniently replace functions which normally
59d9ee20 155return a false value when they fail with equivalents which raise exceptions
e92e55da 156if they are not successful. This lets you use these functions without
59d9ee20
GS
157having to test their return values explicitly on each call. Exceptions
158can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
e92e55da
MB
159
160The do-or-die equivalents are set up simply by calling Fatal's
161C<import> routine, passing it the names of the functions to be
162replaced. You may wrap both user-defined functions and overridable
163CORE operators (except C<exec>, C<system> which cannot be expressed
164via prototypes) in this way.
165
91c7a880
GS
166If the symbol C<:void> appears in the import list, then functions
167named later in that import list raise an exception only when
168these are called in void context--that is, when their return
169values are ignored. For example
170
171 use Fatal qw/:void open close/;
172
173 # properly checked, so no exception raised on error
174 if(open(FH, "< /bogotic") {
175 warn "bogo file, dude: $!";
176 }
177
178 # not checked, so error raises an exception
179 close FH;
180
a6fd7f3f
RGS
181=head1 BUGS
182
183You should not fatalize functions that are called in list context, because this
184module tests whether a function has failed by testing the boolean truth of its
185return value in scalar context.
186
e92e55da
MB
187=head1 AUTHOR
188
10af26ed 189Lionel Cons (CERN).
e92e55da 190
10af26ed 191Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
e92e55da
MB
192
193=cut