I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / Fatal.pm
CommitLineData
e92e55da 1package Fatal;
2
3b825e41 3use 5.006_001;
e92e55da 4use Carp;
5use strict;
17f410f9 6our($AUTOLOAD, $Debug, $VERSION);
e92e55da 7
b0cb64b6 8$VERSION = 1.03;
e92e55da 9
10$Debug = 0 unless defined $Debug;
11
12sub import {
13 my $self = shift(@_);
14 my($sym, $pkg);
91c7a880 15 my $void = 0;
e92e55da 16 $pkg = (caller)[0];
17 foreach $sym (@_) {
91c7a880 18 if ($sym eq ":void") {
19 $void = 1;
20 }
21 else {
22 &_make_fatal($sym, $pkg, $void);
23 }
e92e55da 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 {
91c7a880 51 my ($core, $call, $name, $void, @argvs) = @_;
e92e55da 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 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 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 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 86}
87
88sub _make_fatal {
91c7a880 89 my($sub, $pkg, $void) = @_;
e92e55da 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 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);
91c7a880 124 $code .= write_invocation($core, $call, $name, $void, @protos);
e92e55da 125 $code .= "}\n";
126 print $code if $Debug;
2ba6ecf4 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 $@;
db376a24 131 no warnings; # to avoid: Subroutine foo redefined ...
2ba6ecf4 132 *{$sub} = $code;
133 }
e92e55da 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
59d9ee20 154return a false value when they fail with equivalents which raise exceptions
e92e55da 155if they are not successful. This lets you use these functions without
59d9ee20 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.
e92e55da 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
91c7a880 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
e92e55da 180=head1 AUTHOR
181
182Lionel.Cons@cern.ch
183
184prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
185
186=cut