1package Fatal;
2
3use 5.006_001;
4use Carp;
5use strict;
6our($AUTOLOAD, $Debug, $VERSION);
7
8$VERSION = 1.03;
9
10$Debug = 0 unless defined $Debug;
11
12sub import {
13    my $self = shift(@_);
14    my($sym, $pkg);
15    my $void = 0;
16    $pkg = (caller)[0];
17    foreach $sym (@_) {
18	if ($sym eq ":void") {
19	    $void = 1;
20	}
21	else {
22	    &_make_fatal($sym, $pkg, $void);
23	}
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 {
51  my ($core, $call, $name, $void, @argvs) = @_;
52  if (@argvs == 1) {		# No optional arguments
53    my @argv = @{$argvs[0]};
54    shift @argv;
55    return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
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,
65          "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
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 {
76  my ($core, $call, $name, $void, @argv) = @_;
77  local $" = ', ';
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  }
86}
87
88sub _make_fatal {
89    my($sub, $pkg, $void) = @_;
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/^&//;
96    print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
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);
124    $code .= write_invocation($core, $call, $name, $void, @protos);
125    $code .= "}\n";
126    print $code if $Debug;
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 $@;
131      no warnings;   # to avoid: Subroutine foo redefined ...
132      *{$sub} = $code;
133    }
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
154return a false value when they fail with equivalents which raise exceptions
155if they are not successful.  This lets you use these functions without
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.
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
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
180=head1 AUTHOR
181
182Lionel.Cons@cern.ch
183
184prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
185
186=cut
187