perl/lib/Fatal.pm

package Fatal;

use 5.006_001;
use Carp;
use strict;
our($AUTOLOAD, $Debug, $VERSION);

$VERSION = 1.03;

$Debug = 0 unless defined $Debug;

sub import {
    my $self = shift(@_);
    my($sym, $pkg);
    my $void = 0;
    $pkg = (caller)[0];
    foreach $sym (@_) {
        if ($sym eq ":void") {
            $void = 1;
        }
        else {
            &_make_fatal($sym, $pkg, $void);
        }
    }
};

sub AUTOLOAD {
    my $cmd = $AUTOLOAD;
    $cmd =~ s/.*:://;
    &_make_fatal($cmd, (caller)[0]);
    goto &$AUTOLOAD;
}

sub fill_protos {
  my $proto = shift;
  my ($n, $isref, @out, @out1, $seen_semi) = -1;
  while ($proto =~ /\S/) {
    $n++;
    push(@out1,[$n,@out]) if $seen_semi;
    push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
    push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
    push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
    $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
    die "Unknown prototype letters: \"$proto\"";
  }
  push(@out1,[$n+1,@out]);
  @out1;
}

sub write_invocation {
  my ($core, $call, $name, $void, @argvs) = @_;
  if (@argvs == 1) {            # No optional arguments
    my @argv = @{$argvs[0]};
    shift @argv;
    return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
  } else {
    my $else = "\t";
    my (@out, @argv, $n);
    while (@argvs) {
      @argv = @{shift @argvs};
      $n = shift @argv;
      push @out, "$ {else}if (\@_ == $n) {\n";
      $else = "\t} els";
      push @out, 
          "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
    }
    push @out, <<EOC;
        }
        die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
EOC
    return join '', @out;
  }
}

sub one_invocation {
  my ($core, $call, $name, $void, @argv) = @_;
  local $" = ', ';
  if ($void) { 
    return qq/(defined wantarray)?$call(@argv):
              $call(@argv) || croak "Can't $name(\@_)/ . 
           ($core ? ': $!' : ', \$! is \"$!\"') . '"'
  } else {
    return qq{$call(@argv) || croak "Can't $name(\@_)} . 
           ($core ? ': $!' : ', \$! is \"$!\"') . '"';
  }
}

sub _make_fatal {
    my($sub, $pkg, $void) = @_;
    my($name, $code, $sref, $real_proto, $proto, $core, $call);
    my $ini = $sub;

    $sub = "${pkg}::$sub" unless $sub =~ /::/;
    $name = $sub;
    $name =~ s/.*::// or $name =~ s/^&//;
    print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
    croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
    if (defined(&$sub)) {       # user subroutine
        $sref = \&$sub;
        $proto = prototype $sref;
        $call = '&$sref';
    } elsif ($sub eq $ini) {    # Stray user subroutine
        die "$sub is not a Perl subroutine" 
    } else {                    # CORE subroutine
        $proto = eval { prototype "CORE::$name" };
        die "$name is neither a builtin, nor a Perl subroutine" 
          if $@;
        die "Cannot make a non-overridable builtin fatal"
          if not defined $proto;
        $core = 1;
        $call = "CORE::$name";
    }
    if (defined $proto) {
      $real_proto = " ($proto)";
    } else {
      $real_proto = '';
      $proto = '@';
    }
    $code = <<EOS;
sub$real_proto {
        local(\$", \$!) = (', ', 0);
EOS
    my @protos = fill_protos($proto);
    $code .= write_invocation($core, $call, $name, $void, @protos);
    $code .= "}\n";
    print $code if $Debug;
    {
      no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
      $code = eval("package $pkg; use Carp; $code");
      die if $@;
      no warnings;   # to avoid: Subroutine foo redefined ...
      *{$sub} = $code;
    }
}

1;

__END__

=head1 NAME

Fatal - replace functions with equivalents which succeed or die

=head1 SYNOPSIS

    use Fatal qw(open close);

    sub juggle { . . . }
    import Fatal 'juggle';

=head1 DESCRIPTION

C<Fatal> provides a way to conveniently replace functions which normally
return a false value when they fail with equivalents which raise exceptions
if they are not successful.  This lets you use these functions without
having to test their return values explicitly on each call.  Exceptions
can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.

The do-or-die equivalents are set up simply by calling Fatal's
C<import> routine, passing it the names of the functions to be
replaced.  You may wrap both user-defined functions and overridable
CORE operators (except C<exec>, C<system> which cannot be expressed
via prototypes) in this way.

If the symbol C<:void> appears in the import list, then functions
named later in that import list raise an exception only when
these are called in void context--that is, when their return
values are ignored.  For example

        use Fatal qw/:void open close/;

        # properly checked, so no exception raised on error
        if(open(FH, "< /bogotic") {
                warn "bogo file, dude: $!";
        }

        # not checked, so error raises an exception
        close FH;

=head1 AUTHOR

Lionel.Cons@cern.ch

prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu

=cut
Revision:	1.1
Committed:	Thu Jun 30 14:27:08 2005 UTC (21 years, 3 months ago) by root
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Fatal;
2
3			use 5.006_001;
4			use Carp;
5			use strict;
6			our($AUTOLOAD, $Debug, $VERSION);
7
8			$VERSION = 1.03;
9
10			$Debug = 0 unless defined $Debug;
11
12			sub 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
27			sub AUTOLOAD {
28			my $cmd = $AUTOLOAD;
29			$cmd =~ s/.*:://;
30			&_make_fatal($cmd, (caller)[0]);
31			goto &$AUTOLOAD;
32			}
33
34			sub 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
50			sub 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";
70			EOC
71			return join '', @out;
72			}
73			}
74
75			sub 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
88			sub _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;
120			sub$real_proto {
121			local(\$", \$!) = (', ', 0);
122			EOS
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
136			1;
137
138			__END__
139
140			=head1 NAME
141
142			Fatal - 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
153			C<Fatal> provides a way to conveniently replace functions which normally
154			return a false value when they fail with equivalents which raise exceptions
155			if they are not successful. This lets you use these functions without
156			having to test their return values explicitly on each call. Exceptions
157			can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
158
159			The do-or-die equivalents are set up simply by calling Fatal's
160			C<import> routine, passing it the names of the functions to be
161			replaced. You may wrap both user-defined functions and overridable
162			CORE operators (except C<exec>, C<system> which cannot be expressed
163			via prototypes) in this way.
164
165			If the symbol C<:void> appears in the import list, then functions
166			named later in that import list raise an exception only when
167			these are called in void context--that is, when their return
168			values 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
182			Lionel.Cons@cern.ch
183
184			prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
185
186			=cut