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