Cross Reference: Fatal.pm
xref
: /
osnet-11
/
usr
/
src
/
cmd
/
perl
/
5.8.4
/
distrib
/
lib
/
Fatal.pm
Home
History
Annotate
Line#
Navigate
Download
Search
only in
./
1
N/A
package
Fatal
;
1
N/A
1
N/A
use
5.006
_001
;
1
N/A
use
Carp
;
1
N/A
use
strict
;
1
N/A
our
($
AUTOLOAD
, $
Debug
, $
VERSION
);
1
N/A
1
N/A
$
VERSION
=
1.03
;
1
N/A
1
N/A
$
Debug
=
0
unless
defined
$
Debug
;
1
N/A
1
N/A
sub
import
{
1
N/A
my
$
self
=
shift
(@_);
1
N/A
my
($
sym
, $
pkg
);
1
N/A
my
$
void
=
0
;
1
N/A
$
pkg
= (
caller
)[
0
];
1
N/A
foreach
$
sym
(@_) {
1
N/A
if
($
sym
eq
":void"
) {
1
N/A
$
void
=
1
;
1
N/A
}
1
N/A
else
{
1
N/A
&
_make_fatal
($
sym
, $
pkg
, $
void
);
1
N/A
}
1
N/A
}
1
N/A
};
1
N/A
1
N/A
sub
AUTOLOAD
{
1
N/A
my
$
cmd
= $
AUTOLOAD
;
1
N/A
$
cmd
=~ s/.*:://;
1
N/A
&
_make_fatal
($
cmd
, (
caller
)[
0
]);
1
N/A
goto
&$
AUTOLOAD
;
1
N/A
}
1
N/A
1
N/A
sub
fill_protos
{
1
N/A
my
$
proto
=
shift
;
1
N/A
my
($n, $
isref
, @
out
, @
out1
, $
seen_semi
) = -
1
;
1
N/A
while
($
proto
=~ /\S/) {
1
N/A
$n++;
1
N/A
push
(@
out1
,[$n,@
out
])
if
$
seen_semi
;
1
N/A
push
(@
out
, $
1
.
"{\$_[$n]}"
),
next
if
$
proto
=~ s/^\s*\\([\@%\$\&])//;
1
N/A
push
(@
out
,
"\$_[$n]"
),
next
if
$
proto
=~ s/^\s*([*\$&])//;
1
N/A
push
(@
out
,
"\@_[$n..\$#_]"
),
last
if
$
proto
=~ s/^\s*(;\s*)?\@//;
1
N/A
$
seen_semi
=
1
, $n--,
next
if
$
proto
=~ s/^\s*;//;
# XXXX ????
1
N/A
die
"Unknown prototype letters: \"$proto\""
;
1
N/A
}
1
N/A
push
(@
out1
,[$n+
1
,@
out
]);
1
N/A
@
out1
;
1
N/A
}
1
N/A
1
N/A
sub
write_invocation
{
1
N/A
my
($
core
, $
call
, $
name
, $
void
, @
argvs
) = @_;
1
N/A
if
(@
argvs
==
1
) {
# No optional arguments
1
N/A
my
@
argv
= @{$
argvs
[
0
]};
1
N/A
shift
@
argv
;
1
N/A
return
"\t"
.
one_invocation
($
core
, $
call
, $
name
, $
void
, @
argv
) .
";\n"
;
1
N/A
}
else
{
1
N/A
my
$
else
=
"\t"
;
1
N/A
my
(@
out
, @
argv
, $n);
1
N/A
while
(@
argvs
) {
1
N/A
@
argv
= @{
shift
@
argvs
};
1
N/A
$n =
shift
@
argv
;
1
N/A
push
@
out
,
"$ {else}if (\@_ == $n) {\n"
;
1
N/A
$
else
=
"\t} els"
;
1
N/A
push
@
out
,
1
N/A
"\t\treturn "
.
one_invocation
($
core
, $
call
, $
name
, $
void
, @
argv
) .
";\n"
;
1
N/A
}
1
N/A
push
@
out
, <<
EOC
;
1
N/A
}
1
N/A
die
"$name(\@_): Do not expect to get "
,
scalar
\@_,
" arguments"
;
1
N/A
EOC
1
N/A
return
join
''
, @
out
;
1
N/A
}
1
N/A
}
1
N/A
1
N/A
sub
one_invocation
{
1
N/A
my
($
core
, $
call
, $
name
, $
void
, @
argv
) = @_;
1
N/A
local
$
" = ', ';
1
N/A
if
($
void
) {
1
N/A
return
qq
/(
defined
wantarray
)?$
call
(@
argv
):
1
N/A
$
call
(@
argv
) ||
croak
"Can't $name(\@_)/ .
1
N/A
($
core
?
': $!'
:
', \$! is \"$!\"'
) .
'"'
1
N/A
}
else
{
1
N/A
return
qq
{$
call
(@
argv
) ||
croak
"Can't $name(\@_)} .
1
N/A
($
core
?
': $!'
:
', \$! is \"$!\"'
) .
'"'
;
1
N/A
}
1
N/A
}
1
N/A
1
N/A
sub
_make_fatal
{
1
N/A
my
($
sub
, $
pkg
, $
void
) = @_;
1
N/A
my
($
name
, $
code
, $
sref
, $
real_proto
, $
proto
, $
core
, $
call
);
1
N/A
my
$
ini
= $
sub
;
1
N/A
1
N/A
$
sub
=
"${pkg}::$sub"
unless
$
sub
=~ /::/;
1
N/A
$
name
= $
sub
;
1
N/A
$
name
=~ s/.*:://
or
$
name
=~ s/^&//;
1
N/A
print
"# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n"
if
$
Debug
;
1
N/A
croak
"Bad subroutine name for Fatal: $name"
unless
$
name
=~ /^\w+$/;
1
N/A
if
(
defined
(&$
sub
)) {
# user subroutine
1
N/A
$
sref
= \&$
sub
;
1
N/A
$
proto
=
prototype
$
sref
;
1
N/A
$
call
=
'&$sref'
;
1
N/A
}
elsif
($
sub
eq
$
ini
) {
# Stray user subroutine
1
N/A
die
"$sub is not a Perl subroutine"
1
N/A
}
else
{
# CORE subroutine
1
N/A
$
proto
=
eval
{
prototype
"CORE::$name"
};
1
N/A
die
"$name is neither a builtin, nor a Perl subroutine"
1
N/A
if
$@;
1
N/A
die
"Cannot make a non-overridable builtin fatal"
1
N/A
if
not
defined
$
proto
;
1
N/A
$
core
=
1
;
1
N/A
$
call
=
"CORE::$name"
;
1
N/A
}
1
N/A
if
(
defined
$
proto
) {
1
N/A
$
real_proto
=
" ($proto)"
;
1
N/A
}
else
{
1
N/A
$
real_proto
=
''
;
1
N/A
$
proto
=
'@'
;
1
N/A
}
1
N/A
$
code
= <<
EOS
;
1
N/A
sub
$
real_proto
{
1
N/A
local
(\$
", \$!) = (', ', 0);
1
N/A
EOS
1
N/A
my
@
protos
=
fill_protos
($
proto
);
1
N/A
$
code
.=
write_invocation
($
core
, $
call
, $
name
, $
void
, @
protos
);
1
N/A
$
code
.=
"}\n"
;
1
N/A
print
$
code
if
$
Debug
;
1
N/A
{
1
N/A
no
strict
'refs'
;
# to avoid: Can't use string (...) as a symbol ref ...
1
N/A
$
code
=
eval
(
"package $pkg; use Carp; $code"
);
1
N/A
die
if
$@;
1
N/A
no
warnings
;
# to avoid: Subroutine foo redefined ...
1
N/A
*{$
sub
} = $
code
;
1
N/A
}
1
N/A
}
1
N/A
1
N/A
1
;
1
N/A
1
N/A
__END__
1
N/A
1
N/A
=head1 NAME
1
N/A
1
N/A
Fatal - replace functions with equivalents which succeed or die
1
N/A
1
N/A
=head1 SYNOPSIS
1
N/A
1
N/A
use Fatal qw(open close);
1
N/A
1
N/A
sub juggle { . . . }
1
N/A
import Fatal 'juggle';
1
N/A
1
N/A
=head1 DESCRIPTION
1
N/A
1
N/A
C<Fatal> provides a way to conveniently replace functions which normally
1
N/A
return a false value when they fail with equivalents which raise exceptions
1
N/A
if they are not successful. This lets you use these functions without
1
N/A
having to test their return values explicitly on each call. Exceptions
1
N/A
can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
1
N/A
1
N/A
The do-or-die equivalents are set up simply by calling Fatal's
1
N/A
C<import> routine, passing it the names of the functions to be
1
N/A
replaced. You may wrap both user-defined functions and overridable
1
N/A
CORE operators (except C<exec>, C<system> which cannot be expressed
1
N/A
via prototypes) in this way.
1
N/A
1
N/A
If the symbol C<:void> appears in the import list, then functions
1
N/A
named later in that import list raise an exception only when
1
N/A
these are called in void context--that is, when their return
1
N/A
values are ignored. For example
1
N/A
1
N/A
use Fatal qw/:void open close/;
1
N/A
1
N/A
# properly checked, so no exception raised on error
1
N/A
if(open(FH, "< /bogotic") {
1
N/A
warn "bogo file, dude: $!";
1
N/A
}
1
N/A
1
N/A
# not checked, so error raises an exception
1
N/A
close FH;
1
N/A
1
N/A
=head1 AUTHOR
1
N/A
1
N/A
Lionel.Cons@cern.ch
1
N/A
1
N/A
prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
1
N/A
1
N/A
=cut