Initial Commit
This commit is contained in:
Riley Schneider
65
database/perl/lib/autodie/Scope/Guard.pm
Normal file
65
database/perl/lib/autodie/Scope/Guard.pm
Normal file
@@ -0,0 +1,65 @@
|
||||
package autodie::Scope::Guard;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# ABSTRACT: Wrapper class for calling subs at end of scope
|
||||
our $VERSION = '2.34'; # VERSION
|
||||
|
||||
# This code schedules the cleanup of subroutines at the end of
|
||||
# scope. It's directly inspired by chocolateboy's excellent
|
||||
# Scope::Guard module.
|
||||
|
||||
sub new {
|
||||
my ($class, $handler) = @_;
|
||||
return bless($handler, $class);
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
|
||||
$self->();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::Scope::Guard - Wrapper class for calling subs at end of scope
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use autodie::Scope::Guard;
|
||||
$^H{'my-key'} = autodie::Scope::Guard->new(sub {
|
||||
print "Hallo world\n";
|
||||
});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is used to bless perl subs so that they are invoked when
|
||||
they are destroyed. This is mostly useful for ensuring the code is
|
||||
invoked at end of scope. This module is not a part of autodie's
|
||||
public API.
|
||||
|
||||
This module is directly inspired by chocolateboy's excellent
|
||||
Scope::Guard module.
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=head3 new
|
||||
|
||||
my $hook = autodie::Scope::Guard->new(sub {});
|
||||
|
||||
Creates a new C<autodie::Scope::Guard>, which will invoke the given
|
||||
sub once it goes out of scope (i.e. its DESTROY handler is called).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2008-2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software. You may distribute it under the
|
||||
same terms as Perl itself.
|
||||
127
database/perl/lib/autodie/Scope/GuardStack.pm
Normal file
127
database/perl/lib/autodie/Scope/GuardStack.pm
Normal file
@@ -0,0 +1,127 @@
|
||||
package autodie::Scope::GuardStack;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use autodie::Scope::Guard;
|
||||
|
||||
# ABSTRACT: Hook stack for managing scopes via %^H
|
||||
our $VERSION = '2.34'; # VERSION
|
||||
|
||||
my $H_KEY_STEM = __PACKAGE__ . '/guard';
|
||||
my $COUNTER = 0;
|
||||
|
||||
# This code schedules the cleanup of subroutines at the end of
|
||||
# scope. It's directly inspired by chocolateboy's excellent
|
||||
# Scope::Guard module.
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
|
||||
return bless([], $class);
|
||||
}
|
||||
|
||||
sub push_hook {
|
||||
my ($self, $hook) = @_;
|
||||
my $h_key = $H_KEY_STEM . ($COUNTER++);
|
||||
my $size = @{$self};
|
||||
$^H{$h_key} = autodie::Scope::Guard->new(sub {
|
||||
# Pop the stack until we reach the right size
|
||||
# - this may seem weird, but it is to avoid relying
|
||||
# on "destruction order" of keys in %^H.
|
||||
#
|
||||
# Example:
|
||||
# {
|
||||
# use autodie; # hook 1
|
||||
# no autodie; # hook 2
|
||||
# use autodie; # hook 3
|
||||
# }
|
||||
#
|
||||
# Here we want call hook 3, then hook 2 and finally hook 1.
|
||||
# Any other order could have undesired consequences.
|
||||
#
|
||||
# Suppose hook 2 is destroyed first, it will pop hook 3 and
|
||||
# then hook 2. hook 3 will then be destroyed, but do nothing
|
||||
# since its "frame" was already popped and finally hook 1
|
||||
# will be popped and take its own frame with it.
|
||||
#
|
||||
# We need to check that $self still exists since things can get weird
|
||||
# during global destruction.
|
||||
$self->_pop_hook while $self && @{$self} > $size;
|
||||
});
|
||||
push(@{$self}, [$hook, $h_key]);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _pop_hook {
|
||||
my ($self) = @_;
|
||||
my ($hook, $key) = @{ pop(@{$self}) };
|
||||
my $ref = delete($^H{$key});
|
||||
$hook->();
|
||||
return;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
|
||||
# To be honest, I suspect @{$self} will always be empty here due
|
||||
# to the subs in %^H having references to the stack (which would
|
||||
# keep the stack alive until those have been destroyed). Anyhow,
|
||||
# it never hurt to be careful.
|
||||
$self->_pop_hook while @{$self};
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::Scope::GuardStack - Hook stack for managing scopes via %^H
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use autodie::Scope::GuardStack;
|
||||
my $stack = autodie::Scope::GuardStack->new
|
||||
$^H{'my-key'} = $stack;
|
||||
|
||||
$stack->push_hook(sub {});
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is a stack of hooks to be called in the right order as
|
||||
scopes go away. The stack is only useful when inserted into C<%^H>
|
||||
and will pop hooks as their "scope" is popped. This is useful for
|
||||
uninstalling or reinstalling subs in a namespace as a pragma goes
|
||||
out of scope.
|
||||
|
||||
Due to how C<%^H> works, this class is only useful during the
|
||||
compilation phase of a perl module and relies on the internals of how
|
||||
perl handles references in C<%^H>. This module is not a part of
|
||||
autodie's public API.
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=head3 new
|
||||
|
||||
my $stack = autodie::Scope::GuardStack->new;
|
||||
|
||||
Creates a new C<autodie::Scope::GuardStack>. The stack is initially
|
||||
empty and must be inserted into C<%^H> by the creator.
|
||||
|
||||
=head3 push_hook
|
||||
|
||||
$stack->push_hook(sub {});
|
||||
|
||||
Add a sub to the stack. The sub will be called once the current
|
||||
compile-time "scope" is left. Multiple hooks can be added per scope
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2013, Niels Thykier E<lt>niels@thykier.netE<gt>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software. You may distribute it under the
|
||||
same terms as Perl itself.
|
||||
250
database/perl/lib/autodie/Util.pm
Normal file
250
database/perl/lib/autodie/Util.pm
Normal file
@@ -0,0 +1,250 @@
|
||||
package autodie::Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Exporter 5.57 qw(import);
|
||||
|
||||
use autodie::Scope::GuardStack;
|
||||
|
||||
our @EXPORT_OK = qw(
|
||||
fill_protos
|
||||
install_subs
|
||||
make_core_trampoline
|
||||
on_end_of_compile_scope
|
||||
);
|
||||
|
||||
our $VERSION = '2.34'; # VERSION: Generated by DZP::OurPkg:Version
|
||||
|
||||
# ABSTRACT: Internal Utility subroutines for autodie and Fatal
|
||||
|
||||
# docs says we should pick __PACKAGE__ /<whatever>
|
||||
my $H_STACK_KEY = __PACKAGE__ . '/stack';
|
||||
|
||||
sub on_end_of_compile_scope {
|
||||
my ($hook) = @_;
|
||||
|
||||
# Dark magic to have autodie work under 5.8
|
||||
# Copied from namespace::clean, that copied it from
|
||||
# autobox, that found it on an ancient scroll written
|
||||
# in blood.
|
||||
|
||||
# This magic bit causes %^H to be lexically scoped.
|
||||
$^H |= 0x020000;
|
||||
|
||||
my $stack = $^H{$H_STACK_KEY};
|
||||
if (not defined($stack)) {
|
||||
$stack = autodie::Scope::GuardStack->new;
|
||||
$^H{$H_STACK_KEY} = $stack;
|
||||
}
|
||||
|
||||
$stack->push_hook($hook);
|
||||
return;
|
||||
}
|
||||
|
||||
# This code is based on code from the original Fatal. The "XXXX"
|
||||
# remark is from the original code and its meaning is (sadly) unknown.
|
||||
sub fill_protos {
|
||||
my ($proto) = @_;
|
||||
my ($n, $isref, @out, @out1, $seen_semi) = -1;
|
||||
if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) {
|
||||
# prototype is entirely slurply - special case that does not
|
||||
# require any handling.
|
||||
return ([0, '@_']);
|
||||
}
|
||||
|
||||
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 "Internal error: Unknown prototype letters: \"$proto\"";
|
||||
}
|
||||
push(@out1,[$n+1,@out]);
|
||||
return @out1;
|
||||
}
|
||||
|
||||
|
||||
sub make_core_trampoline {
|
||||
my ($call, $pkg, $proto_str) = @_;
|
||||
my $trampoline_code = 'sub {';
|
||||
my $trampoline_sub;
|
||||
my @protos = fill_protos($proto_str);
|
||||
|
||||
foreach my $proto (@protos) {
|
||||
local $" = ", "; # So @args is formatted correctly.
|
||||
my ($count, @args) = @$proto;
|
||||
if (@args && $args[-1] =~ m/[@#]_/) {
|
||||
$trampoline_code .= qq/
|
||||
if (\@_ >= $count) {
|
||||
return $call(@args);
|
||||
}
|
||||
/;
|
||||
} else {
|
||||
$trampoline_code .= qq<
|
||||
if (\@_ == $count) {
|
||||
return $call(@args);
|
||||
}
|
||||
>;
|
||||
}
|
||||
}
|
||||
|
||||
$trampoline_code .= qq< require Carp; Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >;
|
||||
my $E;
|
||||
|
||||
{
|
||||
local $@;
|
||||
$trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic
|
||||
$E = $@;
|
||||
}
|
||||
die "Internal error in Fatal/autodie: Leak-guard installation failure: $E"
|
||||
if $E;
|
||||
|
||||
return $trampoline_sub;
|
||||
}
|
||||
|
||||
# The code here is originally lifted from namespace::clean,
|
||||
# by Robert "phaylon" Sedlacek.
|
||||
#
|
||||
# It's been redesigned after feedback from ikegami on perlmonks.
|
||||
# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
|
||||
#
|
||||
# Given a package, and hash of (subname => subref) pairs,
|
||||
# we install the given subroutines into the package. If
|
||||
# a subref is undef, the subroutine is removed. Otherwise
|
||||
# it replaces any existing subs which were already there.
|
||||
|
||||
sub install_subs {
|
||||
my ($target_pkg, $subs_to_reinstate) = @_;
|
||||
|
||||
my $pkg_sym = "${target_pkg}::";
|
||||
|
||||
# It does not hurt to do this in a predictable order, and might help debugging.
|
||||
foreach my $sub_name (sort keys(%{$subs_to_reinstate})) {
|
||||
|
||||
# We will repeatedly mess with stuff that strict "refs" does
|
||||
# not like. So lets just disable it once for this entire
|
||||
# scope.
|
||||
no strict qw(refs); ## no critic
|
||||
|
||||
my $sub_ref = $subs_to_reinstate->{$sub_name};
|
||||
|
||||
my $full_path = ${pkg_sym}.${sub_name};
|
||||
my $oldglob = *$full_path;
|
||||
|
||||
# Nuke the old glob.
|
||||
delete($pkg_sym->{$sub_name});
|
||||
|
||||
# For some reason this local *alias = *$full_path triggers an
|
||||
# "only used once" warning. Not entirely sure why, but at
|
||||
# least it is easy to silence.
|
||||
no warnings qw(once);
|
||||
local *alias = *$full_path;
|
||||
use warnings qw(once);
|
||||
|
||||
# Copy innocent bystanders back. Note that we lose
|
||||
# formats; it seems that Perl versions up to 5.10.0
|
||||
# have a bug which causes copying formats to end up in
|
||||
# the scalar slot. Thanks to Ben Morrow for spotting this.
|
||||
|
||||
foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
|
||||
next unless defined(*$oldglob{$slot});
|
||||
*alias = *$oldglob{$slot};
|
||||
}
|
||||
|
||||
if ($sub_ref) {
|
||||
*$full_path = $sub_ref;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::Util - Internal Utility subroutines for autodie and Fatal
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# INTERNAL API for autodie and Fatal only!
|
||||
|
||||
use autodie::Util qw(on_end_of_compile_scope);
|
||||
on_end_of_compile_scope(sub { print "Hallo world\n"; });
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Interal Utilities for autodie and Fatal! This module is not a part of
|
||||
autodie's public API.
|
||||
|
||||
This module contains utility subroutines for abstracting away the
|
||||
underlying magic of autodie and (ab)uses of C<%^H> to call subs at the
|
||||
end of a (compile-time) scopes.
|
||||
|
||||
Note that due to how C<%^H> works, some of these utilities are only
|
||||
useful during the compilation phase of a perl module and relies on the
|
||||
internals of how perl handles references in C<%^H>.
|
||||
|
||||
=head2 Methods
|
||||
|
||||
=head3 on_end_of_compile_scope
|
||||
|
||||
on_end_of_compile_scope(sub { print "Hallo world\n"; });
|
||||
|
||||
Will invoke a sub at the end of a (compile-time) scope. The sub is
|
||||
called once with no arguments. Can be called multiple times (even in
|
||||
the same "compile-time" scope) to install multiple subs. Subs are
|
||||
called in a "first-in-last-out"-order (FILO or "stack"-order).
|
||||
|
||||
=head3 fill_protos
|
||||
|
||||
fill_protos('*$$;$@')
|
||||
|
||||
Given a Perl subroutine prototype, return a list of invocation
|
||||
specifications. Each specification is a listref, where the first
|
||||
member is the (minimum) number of arguments for this invocation
|
||||
specification. The remaining arguments are a string representation of
|
||||
how to pass the arguments correctly to a sub with the given prototype,
|
||||
when called with the given number of arguments.
|
||||
|
||||
The specifications are returned in increasing order of arguments
|
||||
starting at 0 (e.g. ';$') or 1 (e.g. '$@'). Note that if the
|
||||
prototype is "slurpy" (e.g. ends with a "@"), the number of arguments
|
||||
for the last specification is a "minimum" number rather than an exact
|
||||
number. This can be detected by the last member of the last
|
||||
specification matching m/[@#]_/.
|
||||
|
||||
=head3 make_core_trampoline
|
||||
|
||||
make_core_trampoline('CORE::open', 'main', prototype('CORE::open'))
|
||||
|
||||
Creates a trampoline for calling a core sub. Essentially, a tiny sub
|
||||
that figures out how we should be calling our core sub, puts in the
|
||||
arguments in the right way, and bounces our control over to it.
|
||||
|
||||
If we could reliably use `goto &` on core builtins, we wouldn't need
|
||||
this subroutine.
|
||||
|
||||
=head3 install_subs
|
||||
|
||||
install_subs('My::Module', { 'read' => sub { die("Hallo\n"), ... }})
|
||||
|
||||
Given a package name and a hashref mapping names to a subroutine
|
||||
reference (or C<undef>), this subroutine will install said subroutines
|
||||
on their given name in that module. If a name mapes to C<undef>, any
|
||||
subroutine with that name in the target module will be remove
|
||||
(possibly "unshadowing" a CORE sub of same name).
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2013-2014, Niels Thykier E<lt>niels@thykier.netE<gt>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software. You may distribute it under the
|
||||
same terms as Perl itself.
|
||||
879
database/perl/lib/autodie/exception.pm
Normal file
879
database/perl/lib/autodie/exception.pm
Normal file
@@ -0,0 +1,879 @@
|
||||
package autodie::exception;
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp qw(croak);
|
||||
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
our $VERSION = '2.34'; # VERSION: Generated by DZP::OurPkg:Version
|
||||
# ABSTRACT: Exceptions from autodying functions.
|
||||
|
||||
our $DEBUG = 0;
|
||||
|
||||
use overload
|
||||
q{""} => "stringify",
|
||||
# Overload smart-match only if we're using 5.10 or up
|
||||
($] >= 5.010 ? ('~~' => "matches") : ()),
|
||||
fallback => 1
|
||||
;
|
||||
|
||||
my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::exception - Exceptions from autodying functions.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
eval {
|
||||
use autodie;
|
||||
|
||||
open(my $fh, '<', 'some_file.txt');
|
||||
|
||||
...
|
||||
};
|
||||
|
||||
if (my $E = $@) {
|
||||
say "Ooops! ",$E->caller," had problems: $@";
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When an L<autodie> enabled function fails, it generates an
|
||||
C<autodie::exception> object. This can be interrogated to
|
||||
determine further information about the error that occurred.
|
||||
|
||||
This document is broken into two sections; those methods that
|
||||
are most useful to the end-developer, and those methods for
|
||||
anyone wishing to subclass or get very familiar with
|
||||
C<autodie::exception>.
|
||||
|
||||
=head2 Common Methods
|
||||
|
||||
These methods are intended to be used in the everyday dealing
|
||||
of exceptions.
|
||||
|
||||
The following assume that the error has been copied into
|
||||
a separate scalar:
|
||||
|
||||
if ($E = $@) {
|
||||
...
|
||||
}
|
||||
|
||||
This is not required, but is recommended in case any code
|
||||
is called which may reset or alter C<$@>.
|
||||
|
||||
=cut
|
||||
|
||||
=head3 args
|
||||
|
||||
my $array_ref = $E->args;
|
||||
|
||||
Provides a reference to the arguments passed to the subroutine
|
||||
that died.
|
||||
|
||||
=cut
|
||||
|
||||
sub args { return $_[0]->{$PACKAGE}{args}; }
|
||||
|
||||
=head3 function
|
||||
|
||||
my $sub = $E->function;
|
||||
|
||||
The subroutine (including package) that threw the exception.
|
||||
|
||||
=cut
|
||||
|
||||
sub function { return $_[0]->{$PACKAGE}{function}; }
|
||||
|
||||
=head3 file
|
||||
|
||||
my $file = $E->file;
|
||||
|
||||
The file in which the error occurred (eg, C<myscript.pl> or
|
||||
C<MyTest.pm>).
|
||||
|
||||
=cut
|
||||
|
||||
sub file { return $_[0]->{$PACKAGE}{file}; }
|
||||
|
||||
=head3 package
|
||||
|
||||
my $package = $E->package;
|
||||
|
||||
The package from which the exceptional subroutine was called.
|
||||
|
||||
=cut
|
||||
|
||||
sub package { return $_[0]->{$PACKAGE}{package}; }
|
||||
|
||||
=head3 caller
|
||||
|
||||
my $caller = $E->caller;
|
||||
|
||||
The subroutine that I<called> the exceptional code.
|
||||
|
||||
=cut
|
||||
|
||||
sub caller { return $_[0]->{$PACKAGE}{caller}; }
|
||||
|
||||
=head3 line
|
||||
|
||||
my $line = $E->line;
|
||||
|
||||
The line in C<< $E->file >> where the exceptional code was called.
|
||||
|
||||
=cut
|
||||
|
||||
sub line { return $_[0]->{$PACKAGE}{line}; }
|
||||
|
||||
=head3 context
|
||||
|
||||
my $context = $E->context;
|
||||
|
||||
The context in which the subroutine was called by autodie; usually
|
||||
the same as the context in which you called the autodying subroutine.
|
||||
This can be 'list', 'scalar', or undefined (unknown). It will never
|
||||
be 'void', as C<autodie> always captures the return value in one way
|
||||
or another.
|
||||
|
||||
For some core functions that always return a scalar value regardless
|
||||
of their context (eg, C<chown>), this may be 'scalar', even if you
|
||||
used a list context.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: The comments above say this can be undefined. Is that actually
|
||||
# the case? (With 'system', perhaps?)
|
||||
|
||||
sub context { return $_[0]->{$PACKAGE}{context} }
|
||||
|
||||
=head3 return
|
||||
|
||||
my $return_value = $E->return;
|
||||
|
||||
The value(s) returned by the failed subroutine. When the subroutine
|
||||
was called in a list context, this will always be a reference to an
|
||||
array containing the results. When the subroutine was called in
|
||||
a scalar context, this will be the actual scalar returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub return { return $_[0]->{$PACKAGE}{return} }
|
||||
|
||||
=head3 errno
|
||||
|
||||
my $errno = $E->errno;
|
||||
|
||||
The value of C<$!> at the time when the exception occurred.
|
||||
|
||||
B<NOTE>: This method will leave the main C<autodie::exception> class
|
||||
and become part of a role in the future. You should only call
|
||||
C<errno> for exceptions where C<$!> would reasonably have been
|
||||
set on failure.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: Make errno part of a role. It doesn't make sense for
|
||||
# everything.
|
||||
|
||||
sub errno { return $_[0]->{$PACKAGE}{errno}; }
|
||||
|
||||
=head3 eval_error
|
||||
|
||||
my $old_eval_error = $E->eval_error;
|
||||
|
||||
The contents of C<$@> immediately after autodie triggered an
|
||||
exception. This may be useful when dealing with modules such
|
||||
as L<Text::Balanced> that set (but do not throw) C<$@> on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
|
||||
|
||||
=head3 matches
|
||||
|
||||
if ( $e->matches('open') ) { ... }
|
||||
|
||||
if ( 'open' ~~ $e ) { ... }
|
||||
|
||||
C<matches> is used to determine whether a
|
||||
given exception matches a particular role.
|
||||
|
||||
An exception is considered to match a string if:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
For a string not starting with a colon, the string exactly matches the
|
||||
package and subroutine that threw the exception. For example,
|
||||
C<MyModule::log>. If the string does not contain a package name,
|
||||
C<CORE::> is assumed.
|
||||
|
||||
=item *
|
||||
|
||||
For a string that does start with a colon, if the subroutine
|
||||
throwing the exception I<does> that behaviour. For example, the
|
||||
C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
|
||||
|
||||
See L<autodie/CATEGORIES> for further information.
|
||||
|
||||
On Perl 5.10 and above, using smart-match (C<~~>) with an
|
||||
C<autodie::exception> object will use C<matches> underneath. This module
|
||||
used to recommend using smart-match with the exception object on the left
|
||||
hand side, but in future Perls that is likely to stop working.
|
||||
The smart-match facility of this class should only be used with the
|
||||
exception object on the right hand side. Having the exception object on
|
||||
the right is both future-proof and portable to older Perls, back to 5.10.
|
||||
Beware that this facility can only
|
||||
be relied upon when it is certain that the exception object actually is
|
||||
an C<autodie::exception> object; it is no more capable than an explicit
|
||||
call to the C<matches> method.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
{
|
||||
my (%cache);
|
||||
|
||||
sub matches {
|
||||
my ($this, $that) = @_;
|
||||
|
||||
# TODO - Handle references
|
||||
croak "UNIMPLEMENTED" if ref $that;
|
||||
|
||||
my $sub = $this->function;
|
||||
|
||||
if ($DEBUG) {
|
||||
my $sub2 = $this->function;
|
||||
warn "Smart-matching $that against $sub / $sub2\n";
|
||||
}
|
||||
|
||||
# Direct subname match.
|
||||
return 1 if $that eq $sub;
|
||||
return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
|
||||
return 0 if $that !~ /^:/;
|
||||
|
||||
# Cached match / check tags.
|
||||
require Fatal;
|
||||
|
||||
if (exists $cache{$sub}{$that}) {
|
||||
return $cache{$sub}{$that};
|
||||
}
|
||||
|
||||
# This rather awful looking line checks to see if our sub is in the
|
||||
# list of expanded tags, caches it, and returns the result.
|
||||
|
||||
return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
|
||||
}
|
||||
}
|
||||
|
||||
# This exists primarily so that child classes can override or
|
||||
# augment it if they wish.
|
||||
|
||||
sub _expand_tag {
|
||||
my ($this, @args) = @_;
|
||||
|
||||
return Fatal->_expand_tag(@args);
|
||||
}
|
||||
|
||||
=head2 Advanced methods
|
||||
|
||||
The following methods, while usable from anywhere, are primarily
|
||||
intended for developers wishing to subclass C<autodie::exception>,
|
||||
write code that registers custom error messages, or otherwise
|
||||
work closely with the C<autodie::exception> model.
|
||||
|
||||
=cut
|
||||
|
||||
# The table below records customer formatters.
|
||||
# TODO - Should this be a package var instead?
|
||||
# TODO - Should these be in a completely different file, or
|
||||
# perhaps loaded on demand? Most formatters will never
|
||||
# get used in most programs.
|
||||
|
||||
my %formatter_of = (
|
||||
'CORE::close' => \&_format_close,
|
||||
'CORE::open' => \&_format_open,
|
||||
'CORE::dbmopen' => \&_format_dbmopen,
|
||||
'CORE::flock' => \&_format_flock,
|
||||
'CORE::read' => \&_format_readwrite,
|
||||
'CORE::sysread' => \&_format_readwrite,
|
||||
'CORE::syswrite' => \&_format_readwrite,
|
||||
'CORE::chmod' => \&_format_chmod,
|
||||
'CORE::mkdir' => \&_format_mkdir,
|
||||
);
|
||||
|
||||
sub _beautify_arguments {
|
||||
shift @_;
|
||||
|
||||
# Walk through all our arguments, and...
|
||||
#
|
||||
# * Replace undef with the word 'undef'
|
||||
# * Replace globs with the string '$fh'
|
||||
# * Quote all other args.
|
||||
foreach my $arg (@_) {
|
||||
if (not defined($arg)) { $arg = 'undef' }
|
||||
elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
|
||||
else { $arg = qq{'$arg'} }
|
||||
}
|
||||
|
||||
return @_;
|
||||
}
|
||||
|
||||
sub _trim_package_name {
|
||||
# Info: The following is done since 05/2008 (which is before v1.10)
|
||||
|
||||
# TODO: This is probably a good idea for CORE, is it
|
||||
# a good idea for other subs?
|
||||
|
||||
# Trim package name off dying sub for error messages
|
||||
(my $name = $_[1]) =~ s/.*:://;
|
||||
return $name;
|
||||
}
|
||||
|
||||
# Returns the parameter formatted as octal number
|
||||
sub _octalize_number {
|
||||
my $number = $_[1];
|
||||
|
||||
# Only reformat if it looks like a whole number
|
||||
if ($number =~ /^\d+$/) {
|
||||
$number = sprintf("%#04lo", $number);
|
||||
}
|
||||
|
||||
return $number;
|
||||
}
|
||||
|
||||
# TODO: Our tests only check LOCK_EX | LOCK_NB is properly
|
||||
# formatted. Try other combinations and ensure they work
|
||||
# correctly.
|
||||
|
||||
sub _format_flock {
|
||||
my ($this) = @_;
|
||||
|
||||
require Fcntl;
|
||||
|
||||
my $filehandle = $this->args->[0];
|
||||
my $raw_mode = $this->args->[1];
|
||||
|
||||
my $mode_type;
|
||||
my $lock_unlock;
|
||||
|
||||
if ($raw_mode & Fcntl::LOCK_EX() ) {
|
||||
$lock_unlock = "lock";
|
||||
$mode_type = "for exclusive access";
|
||||
}
|
||||
elsif ($raw_mode & Fcntl::LOCK_SH() ) {
|
||||
$lock_unlock = "lock";
|
||||
$mode_type = "for shared access";
|
||||
}
|
||||
elsif ($raw_mode & Fcntl::LOCK_UN() ) {
|
||||
$lock_unlock = "unlock";
|
||||
$mode_type = "";
|
||||
}
|
||||
else {
|
||||
# I've got no idea what they're trying to do.
|
||||
$lock_unlock = "lock";
|
||||
$mode_type = "with mode $raw_mode";
|
||||
}
|
||||
|
||||
my $cooked_filehandle;
|
||||
|
||||
if ($filehandle and not ref $filehandle) {
|
||||
|
||||
# A package filehandle with a name!
|
||||
|
||||
$cooked_filehandle = " $filehandle";
|
||||
}
|
||||
else {
|
||||
# Otherwise we have a scalar filehandle.
|
||||
|
||||
$cooked_filehandle = '';
|
||||
|
||||
}
|
||||
|
||||
local $! = $this->errno;
|
||||
|
||||
return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
|
||||
|
||||
}
|
||||
|
||||
# Default formatter for CORE::chmod
|
||||
sub _format_chmod {
|
||||
my ($this) = @_;
|
||||
my @args = @{$this->args};
|
||||
|
||||
my $mode = shift @args;
|
||||
local $! = $this->errno;
|
||||
|
||||
$mode = $this->_octalize_number($mode);
|
||||
|
||||
@args = $this->_beautify_arguments(@args);
|
||||
|
||||
return "Can't chmod($mode, ". join(q{, }, @args) ."): $!";
|
||||
}
|
||||
|
||||
# Default formatter for CORE::mkdir
|
||||
sub _format_mkdir {
|
||||
my ($this) = @_;
|
||||
my @args = @{$this->args};
|
||||
|
||||
# If no mask is specified use default formatter
|
||||
if (@args < 2) {
|
||||
return $this->format_default;
|
||||
}
|
||||
|
||||
my $file = $args[0];
|
||||
my $mask = $args[1];
|
||||
local $! = $this->errno;
|
||||
|
||||
$mask = $this->_octalize_number($mask);
|
||||
|
||||
return "Can't mkdir('$file', $mask): '$!'";
|
||||
}
|
||||
|
||||
# Default formatter for CORE::dbmopen
|
||||
sub _format_dbmopen {
|
||||
my ($this) = @_;
|
||||
my @args = @{$this->args};
|
||||
|
||||
# TODO: Presently, $args flattens out the (usually empty) hash
|
||||
# which is passed as the first argument to dbmopen. This is
|
||||
# a bug in our args handling code (taking a reference to it would
|
||||
# be better), but for the moment we'll just examine the end of
|
||||
# our arguments list for message formatting.
|
||||
|
||||
my $mode = $args[-1];
|
||||
my $file = $args[-2];
|
||||
|
||||
$mode = $this->_octalize_number($mode);
|
||||
|
||||
local $! = $this->errno;
|
||||
|
||||
return "Can't dbmopen(%hash, '$file', $mode): '$!'";
|
||||
}
|
||||
|
||||
# Default formatter for CORE::close
|
||||
|
||||
sub _format_close {
|
||||
my ($this) = @_;
|
||||
my $close_arg = $this->args->[0];
|
||||
|
||||
local $! = $this->errno;
|
||||
|
||||
# If we've got an old-style filehandle, mention it.
|
||||
if ($close_arg and not ref $close_arg) {
|
||||
return "Can't close filehandle '$close_arg': '$!'";
|
||||
}
|
||||
|
||||
# TODO - This will probably produce an ugly error. Test and fix.
|
||||
return "Can't close($close_arg) filehandle: '$!'";
|
||||
|
||||
}
|
||||
|
||||
# Default formatter for CORE::read, CORE::sysread and CORE::syswrite
|
||||
#
|
||||
# Similar to default formatter with the buffer filtered out as it
|
||||
# may contain binary data.
|
||||
sub _format_readwrite {
|
||||
my ($this) = @_;
|
||||
my $call = $this->_trim_package_name($this->function);
|
||||
local $! = $this->errno;
|
||||
|
||||
# These subs receive the following arguments (in order):
|
||||
#
|
||||
# * FILEHANDLE
|
||||
# * SCALAR (buffer, we do not want to write this)
|
||||
# * LENGTH (optional for syswrite)
|
||||
# * OFFSET (optional for all)
|
||||
my (@args) = @{$this->args};
|
||||
my $arg_name = $args[1];
|
||||
if (defined($arg_name)) {
|
||||
if (ref($arg_name)) {
|
||||
my $name = blessed($arg_name) || ref($arg_name);
|
||||
$arg_name = "<${name}>";
|
||||
} else {
|
||||
$arg_name = '<BUFFER>';
|
||||
}
|
||||
} else {
|
||||
$arg_name = '<UNDEF>';
|
||||
}
|
||||
$args[1] = $arg_name;
|
||||
|
||||
return "Can't $call(" . join(q{, }, @args) . "): $!";
|
||||
}
|
||||
|
||||
# Default formatter for CORE::open
|
||||
|
||||
use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
|
||||
|
||||
sub _format_open_with_mode {
|
||||
my ($this, $mode, $file, $error) = @_;
|
||||
|
||||
my $wordy_mode;
|
||||
|
||||
if ($mode eq '<') { $wordy_mode = 'reading'; }
|
||||
elsif ($mode eq '>') { $wordy_mode = 'writing'; }
|
||||
elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
|
||||
|
||||
$file = '<undef>' if not defined $file;
|
||||
|
||||
return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
|
||||
|
||||
Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
|
||||
|
||||
}
|
||||
|
||||
sub _format_open {
|
||||
my ($this) = @_;
|
||||
|
||||
my @open_args = @{$this->args};
|
||||
|
||||
# Use the default formatter for single-arg and many-arg open
|
||||
if (@open_args <= 1 or @open_args >= 4) {
|
||||
return $this->format_default;
|
||||
}
|
||||
|
||||
# For two arg open, we have to extract the mode
|
||||
if (@open_args == 2) {
|
||||
my ($fh, $file) = @open_args;
|
||||
|
||||
if (ref($fh) eq "GLOB") {
|
||||
$fh = '$fh';
|
||||
}
|
||||
|
||||
my ($mode) = $file =~ m{
|
||||
^\s* # Spaces before mode
|
||||
(
|
||||
(?> # Non-backtracking subexp.
|
||||
< # Reading
|
||||
|>>? # Writing/appending
|
||||
)
|
||||
)
|
||||
[^&] # Not an ampersand (which means a dup)
|
||||
}x;
|
||||
|
||||
if (not $mode) {
|
||||
# Maybe it's a 2-arg open without any mode at all?
|
||||
# Detect the most simple case for this, where our
|
||||
# file consists only of word characters.
|
||||
|
||||
if ( $file =~ m{^\s*\w+\s*$} ) {
|
||||
$mode = '<'
|
||||
}
|
||||
else {
|
||||
# Otherwise, we've got no idea what's going on.
|
||||
# Use the default.
|
||||
return $this->format_default;
|
||||
}
|
||||
}
|
||||
|
||||
# Localising $! means perl makes it a pretty error for us.
|
||||
local $! = $this->errno;
|
||||
|
||||
return $this->_format_open_with_mode($mode, $file, $!);
|
||||
}
|
||||
|
||||
# Here we must be using three arg open.
|
||||
|
||||
my $file = $open_args[2];
|
||||
|
||||
local $! = $this->errno;
|
||||
|
||||
my $mode = $open_args[1];
|
||||
|
||||
local $@;
|
||||
|
||||
my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
|
||||
|
||||
return $msg if $msg;
|
||||
|
||||
# Default message (for pipes and odd things)
|
||||
|
||||
return "Can't open '$file' with mode '$open_args[1]': '$!'";
|
||||
}
|
||||
|
||||
=head3 register
|
||||
|
||||
autodie::exception->register( 'CORE::open' => \&mysub );
|
||||
|
||||
The C<register> method allows for the registration of a message
|
||||
handler for a given subroutine. The full subroutine name including
|
||||
the package should be used.
|
||||
|
||||
Registered message handlers will receive the C<autodie::exception>
|
||||
object as the first parameter.
|
||||
|
||||
=cut
|
||||
|
||||
sub register {
|
||||
my ($class, $symbol, $handler) = @_;
|
||||
|
||||
croak "Incorrect call to autodie::register" if @_ != 3;
|
||||
|
||||
$formatter_of{$symbol} = $handler;
|
||||
|
||||
}
|
||||
|
||||
=head3 add_file_and_line
|
||||
|
||||
say "Problem occurred",$@->add_file_and_line;
|
||||
|
||||
Returns the string C< at %s line %d>, where C<%s> is replaced with
|
||||
the filename, and C<%d> is replaced with the line number.
|
||||
|
||||
Primarily intended for use by format handlers.
|
||||
|
||||
=cut
|
||||
|
||||
# Simply produces the file and line number; intended to be added
|
||||
# to the end of error messages.
|
||||
|
||||
sub add_file_and_line {
|
||||
my ($this) = @_;
|
||||
|
||||
return sprintf(" at %s line %d\n", $this->file, $this->line);
|
||||
}
|
||||
|
||||
=head3 stringify
|
||||
|
||||
say "The error was: ",$@->stringify;
|
||||
|
||||
Formats the error as a human readable string. Usually there's no
|
||||
reason to call this directly, as it is used automatically if an
|
||||
C<autodie::exception> object is ever used as a string.
|
||||
|
||||
Child classes can override this method to change how they're
|
||||
stringified.
|
||||
|
||||
=cut
|
||||
|
||||
sub stringify {
|
||||
my ($this) = @_;
|
||||
|
||||
my $call = $this->function;
|
||||
my $msg;
|
||||
|
||||
if ($DEBUG) {
|
||||
my $dying_pkg = $this->package;
|
||||
my $sub = $this->function;
|
||||
my $caller = $this->caller;
|
||||
warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
|
||||
}
|
||||
|
||||
# TODO - This isn't using inheritance. Should it?
|
||||
if ( my $sub = $formatter_of{$call} ) {
|
||||
$msg = $sub->($this) . $this->add_file_and_line;
|
||||
} else {
|
||||
$msg = $this->format_default . $this->add_file_and_line;
|
||||
}
|
||||
$msg .= $this->{$PACKAGE}{_stack_trace}
|
||||
if $Carp::Verbose;
|
||||
|
||||
return $msg;
|
||||
}
|
||||
|
||||
=head3 format_default
|
||||
|
||||
my $error_string = $E->format_default;
|
||||
|
||||
This produces the default error string for the given exception,
|
||||
I<without using any registered message handlers>. It is primarily
|
||||
intended to be called from a message handler when they have
|
||||
been passed an exception they don't want to format.
|
||||
|
||||
Child classes can override this method to change how default
|
||||
messages are formatted.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: This produces ugly errors. Is there any way we can
|
||||
# dig around to find the actual variable names? I know perl 5.10
|
||||
# does some dark and terrible magicks to find them for undef warnings.
|
||||
|
||||
sub format_default {
|
||||
my ($this) = @_;
|
||||
|
||||
my $call = $this->_trim_package_name($this->function);
|
||||
|
||||
local $! = $this->errno;
|
||||
|
||||
my @args = @{ $this->args() };
|
||||
@args = $this->_beautify_arguments(@args);
|
||||
|
||||
# Format our beautiful error.
|
||||
|
||||
return "Can't $call(". join(q{, }, @args) . "): $!" ;
|
||||
|
||||
# TODO - Handle user-defined errors from hash.
|
||||
|
||||
# TODO - Handle default error messages.
|
||||
|
||||
}
|
||||
|
||||
=head3 new
|
||||
|
||||
my $error = autodie::exception->new(
|
||||
args => \@_,
|
||||
function => "CORE::open",
|
||||
errno => $!,
|
||||
context => 'scalar',
|
||||
return => undef,
|
||||
);
|
||||
|
||||
|
||||
Creates a new C<autodie::exception> object. Normally called
|
||||
directly from an autodying function. The C<function> argument
|
||||
is required, its the function we were trying to call that
|
||||
generated the exception. The C<args> parameter is optional.
|
||||
|
||||
The C<errno> value is optional. In versions of C<autodie::exception>
|
||||
1.99 and earlier the code would try to automatically use the
|
||||
current value of C<$!>, but this was unreliable and is no longer
|
||||
supported.
|
||||
|
||||
Atrributes such as package, file, and caller are determined
|
||||
automatically, and cannot be specified.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, @args) = @_;
|
||||
|
||||
my $this = {};
|
||||
|
||||
bless($this,$class);
|
||||
|
||||
# I'd love to use EVERY here, but it causes our code to die
|
||||
# because it wants to stringify our objects before they're
|
||||
# initialised, causing everything to explode.
|
||||
|
||||
$this->_init(@args);
|
||||
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub _init {
|
||||
|
||||
my ($this, %args) = @_;
|
||||
|
||||
# Capturing errno here is not necessarily reliable.
|
||||
my $original_errno = $!;
|
||||
|
||||
our $init_called = 1;
|
||||
|
||||
my $class = ref $this;
|
||||
|
||||
# We're going to walk up our call stack, looking for the
|
||||
# first thing that doesn't look like our exception
|
||||
# code, autodie/Fatal, or some whacky eval.
|
||||
|
||||
my ($package, $file, $line, $sub);
|
||||
|
||||
my $depth = 0;
|
||||
|
||||
while (1) {
|
||||
$depth++;
|
||||
|
||||
($package, $file, $line, $sub) = CORE::caller($depth);
|
||||
|
||||
# Skip up the call stack until we find something outside
|
||||
# of the Fatal/autodie/eval space.
|
||||
|
||||
next if $package->isa('Fatal');
|
||||
next if $package->isa($class);
|
||||
next if $package->isa(__PACKAGE__);
|
||||
|
||||
# Anything with the 'autodie::skip' role wants us to skip it.
|
||||
# https://github.com/pjf/autodie/issues/15
|
||||
|
||||
next if ($package->can('DOES') and $package->DOES('autodie::skip'));
|
||||
|
||||
next if $file =~ /^\(eval\s\d+\)$/;
|
||||
|
||||
last;
|
||||
|
||||
}
|
||||
|
||||
# We now have everything correct, *except* for our subroutine
|
||||
# name. If it's __ANON__ or (eval), then we need to keep on
|
||||
# digging deeper into our stack to find the real name. However we
|
||||
# don't update our other information, since that will be correct
|
||||
# for our current exception.
|
||||
|
||||
my $first_guess_subroutine = $sub;
|
||||
|
||||
while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
|
||||
$depth++;
|
||||
|
||||
$sub = (CORE::caller($depth))[3];
|
||||
}
|
||||
|
||||
# If we end up falling out the bottom of our stack, then our
|
||||
# __ANON__ guess is the best we can get. This includes situations
|
||||
# where we were called from the top level of a program.
|
||||
|
||||
if (not defined $sub) {
|
||||
$sub = $first_guess_subroutine;
|
||||
}
|
||||
|
||||
$this->{$PACKAGE}{package} = $package;
|
||||
$this->{$PACKAGE}{file} = $file;
|
||||
$this->{$PACKAGE}{line} = $line;
|
||||
$this->{$PACKAGE}{caller} = $sub;
|
||||
|
||||
# Tranks to %Carp::CarpInternal all Fatal, autodie and
|
||||
# autodie::exception stack frames are filtered already, but our
|
||||
# nameless wrapper is still present, so strip that.
|
||||
|
||||
my $trace = Carp::longmess();
|
||||
$trace =~ s/^\s*at \(eval[^\n]+\n//;
|
||||
|
||||
# And if we see an __ANON__, then we'll replace that with the actual
|
||||
# name of our autodying function.
|
||||
|
||||
my $short_func = $args{function};
|
||||
$short_func =~ s/^CORE:://;
|
||||
$trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/;
|
||||
|
||||
# And now we just fill in all our attributes.
|
||||
|
||||
$this->{$PACKAGE}{_stack_trace} = $trace;
|
||||
|
||||
$this->{$PACKAGE}{errno} = $args{errno} || 0;
|
||||
|
||||
$this->{$PACKAGE}{context} = $args{context};
|
||||
$this->{$PACKAGE}{return} = $args{return};
|
||||
$this->{$PACKAGE}{eval_error} = $args{eval_error};
|
||||
|
||||
$this->{$PACKAGE}{args} = $args{args} || [];
|
||||
$this->{$PACKAGE}{function}= $args{function} or
|
||||
croak("$class->new() called without function arg");
|
||||
|
||||
return $this;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<autodie>, L<autodie::exception::system>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C)2008 Paul Fenwick
|
||||
|
||||
This is free software. You may modify and/or redistribute this
|
||||
code under the same terms as Perl 5.10 itself, or, at your option,
|
||||
any later version of Perl 5.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
|
||||
83
database/perl/lib/autodie/exception/system.pm
Normal file
83
database/perl/lib/autodie/exception/system.pm
Normal file
@@ -0,0 +1,83 @@
|
||||
package autodie::exception::system;
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
use parent 'autodie::exception';
|
||||
use Carp qw(croak);
|
||||
|
||||
our $VERSION = '2.34'; # VERSION: Generated by DZP::OurPkg:Version
|
||||
|
||||
# ABSTRACT: Exceptions from autodying system().
|
||||
|
||||
my $PACKAGE = __PACKAGE__;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::exception::system - Exceptions from autodying system().
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
eval {
|
||||
use autodie qw(system);
|
||||
|
||||
system($cmd, @args);
|
||||
|
||||
};
|
||||
|
||||
if (my $E = $@) {
|
||||
say "Ooops! ",$E->caller," had problems: $@";
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a L<autodie::exception> class for failures from the
|
||||
C<system> command.
|
||||
|
||||
Presently there is no way to interrogate an C<autodie::exception::system>
|
||||
object for the command, exit status, and other information you'd expect
|
||||
such an object to hold. The interface will be expanded to accommodate
|
||||
this in the future.
|
||||
|
||||
=cut
|
||||
|
||||
sub _init {
|
||||
my ($this, %args) = @_;
|
||||
|
||||
$this->{$PACKAGE}{message} = $args{message}
|
||||
|| croak "'message' arg not supplied to autodie::exception::system->new";
|
||||
|
||||
return $this->SUPER::_init(%args);
|
||||
|
||||
}
|
||||
|
||||
=head2 stringify
|
||||
|
||||
When stringified, C<autodie::exception::system> objects currently
|
||||
use the message generated by L<IPC::System::Simple>.
|
||||
|
||||
=cut
|
||||
|
||||
sub stringify {
|
||||
|
||||
my ($this) = @_;
|
||||
|
||||
return $this->{$PACKAGE}{message} . $this->add_file_and_line;
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (C)2008 Paul Fenwick
|
||||
|
||||
This is free software. You may modify and/or redistribute this
|
||||
code under the same terms as Perl 5.10 itself, or, at your option,
|
||||
any later version of Perl 5.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
|
||||
601
database/perl/lib/autodie/hints.pm
Normal file
601
database/perl/lib/autodie/hints.pm
Normal file
@@ -0,0 +1,601 @@
|
||||
package autodie::hints;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use constant PERL58 => ( $] < 5.009 );
|
||||
|
||||
our $VERSION = '2.34'; # VERSION: Generated by DZP::OurPkg:Version
|
||||
|
||||
# ABSTRACT: Provide hints about user subroutines to autodie
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::hints - Provide hints about user subroutines to autodie
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Your::Module;
|
||||
|
||||
our %DOES = ( 'autodie::hints::provider' => 1 );
|
||||
|
||||
sub AUTODIE_HINTS {
|
||||
return {
|
||||
foo => { scalar => HINTS, list => SOME_HINTS },
|
||||
bar => { scalar => HINTS, list => MORE_HINTS },
|
||||
}
|
||||
}
|
||||
|
||||
# Later, in your main program...
|
||||
|
||||
use Your::Module qw(foo bar);
|
||||
use autodie qw(:default foo bar);
|
||||
|
||||
foo(); # succeeds or dies based on scalar hints
|
||||
|
||||
# Alternatively, hints can be set on subroutines we've
|
||||
# imported.
|
||||
|
||||
use autodie::hints;
|
||||
use Some::Module qw(think_positive);
|
||||
|
||||
BEGIN {
|
||||
autodie::hints->set_hints_for(
|
||||
\&think_positive,
|
||||
{
|
||||
fail => sub { $_[0] <= 0 }
|
||||
}
|
||||
)
|
||||
}
|
||||
use autodie qw(think_positive);
|
||||
|
||||
think_positive(...); # Returns positive or dies.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
=head2 Introduction
|
||||
|
||||
The L<autodie> pragma is very smart when it comes to working with
|
||||
Perl's built-in functions. The behaviour for these functions are
|
||||
fixed, and C<autodie> knows exactly how they try to signal failure.
|
||||
|
||||
But what about user-defined subroutines from modules? If you use
|
||||
C<autodie> on a user-defined subroutine then it assumes the following
|
||||
behaviour to demonstrate failure:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
A false value, in scalar context
|
||||
|
||||
=item *
|
||||
|
||||
An empty list, in list context
|
||||
|
||||
=item *
|
||||
|
||||
A list containing a single undef, in list context
|
||||
|
||||
=back
|
||||
|
||||
All other return values (including the list of the single zero, and the
|
||||
list containing a single empty string) are considered successful. However,
|
||||
real-world code isn't always that easy. Perhaps the code you're working
|
||||
with returns a string containing the word "FAIL" upon failure, or a
|
||||
two element list containing C<(undef, "human error message")>. To make
|
||||
autodie work with these sorts of subroutines, we have
|
||||
the I<hinting interface>.
|
||||
|
||||
The hinting interface allows I<hints> to be provided to C<autodie>
|
||||
on how it should detect failure from user-defined subroutines. While
|
||||
these I<can> be provided by the end-user of C<autodie>, they are ideally
|
||||
written into the module itself, or into a helper module or sub-class
|
||||
of C<autodie> itself.
|
||||
|
||||
=head2 What are hints?
|
||||
|
||||
A I<hint> is a subroutine or value that is checked against the
|
||||
return value of an autodying subroutine. If the match returns true,
|
||||
C<autodie> considers the subroutine to have failed.
|
||||
|
||||
If the hint provided is a subroutine, then C<autodie> will pass
|
||||
the complete return value to that subroutine. If the hint is
|
||||
any other value, then C<autodie> will smart-match against the
|
||||
value provided. In Perl 5.8.x there is no smart-match operator, and as such
|
||||
only subroutine hints are supported in these versions.
|
||||
|
||||
Hints can be provided for both scalar and list contexts. Note
|
||||
that an autodying subroutine will never see a void context, as
|
||||
C<autodie> always needs to capture the return value for examination.
|
||||
Autodying subroutines called in void context act as if they're called
|
||||
in a scalar context, but their return value is discarded after it
|
||||
has been checked.
|
||||
|
||||
=head2 Example hints
|
||||
|
||||
Hints may consist of subroutine references, objects overloading
|
||||
smart-match, regular expressions, and depending on Perl version possibly
|
||||
other things. You can specify different hints for how
|
||||
failure should be identified in scalar and list contexts.
|
||||
|
||||
These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
|
||||
calling C<< autodie::hints->set_hints_for() >>.
|
||||
|
||||
The most common context-specific hints are:
|
||||
|
||||
# Scalar failures always return undef:
|
||||
{ scalar => sub { !defined($_[0]) } }
|
||||
|
||||
# Scalar failures return any false value [default expectation]:
|
||||
{ scalar => sub { ! $_[0] } }
|
||||
|
||||
# Scalar failures always return zero explicitly:
|
||||
{ scalar => sub { defined($_[0]) && $_[0] eq '0' } }
|
||||
|
||||
# List failures always return an empty list:
|
||||
{ list => sub { !@_ } }
|
||||
|
||||
# List failures return () or (undef) [default expectation]:
|
||||
{ list => sub { ! @_ || @_ == 1 && !defined $_[0] } }
|
||||
|
||||
# List failures return () or a single false value:
|
||||
{ list => sub { ! @_ || @_ == 1 && !$_[0] } }
|
||||
|
||||
# List failures return (undef, "some string")
|
||||
{ list => sub { @_ == 2 && !defined $_[0] } }
|
||||
|
||||
# Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
|
||||
# returns (-1) in list context...
|
||||
autodie::hints->set_hints_for(
|
||||
\&foo,
|
||||
{
|
||||
scalar => qr/^ _? FAIL $/xms,
|
||||
list => sub { @_ == 1 && $_[0] eq -1 },
|
||||
}
|
||||
);
|
||||
|
||||
# Unsuccessful foo() returns 0 in all contexts...
|
||||
autodie::hints->set_hints_for(
|
||||
\&foo,
|
||||
{
|
||||
scalar => sub { defined($_[0]) && $_[0] == 0 },
|
||||
list => sub { @_ == 1 && defined($_[0]) && $_[0] == 0 },
|
||||
}
|
||||
);
|
||||
|
||||
This "in all contexts" construction is very common, and can be
|
||||
abbreviated, using the 'fail' key. This sets both the C<scalar>
|
||||
and C<list> hints to the same value:
|
||||
|
||||
# Unsuccessful foo() returns 0 in all contexts...
|
||||
autodie::hints->set_hints_for(
|
||||
\&foo,
|
||||
{
|
||||
fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
|
||||
}
|
||||
);
|
||||
|
||||
# Unsuccessful think_positive() returns negative number on failure...
|
||||
autodie::hints->set_hints_for(
|
||||
\&think_positive,
|
||||
{
|
||||
fail => sub { $_[0] < 0 }
|
||||
}
|
||||
);
|
||||
|
||||
# Unsuccessful my_system() returns non-zero on failure...
|
||||
autodie::hints->set_hints_for(
|
||||
\&my_system,
|
||||
{
|
||||
fail => sub { $_[0] != 0 }
|
||||
}
|
||||
);
|
||||
|
||||
=head1 Manually setting hints from within your program
|
||||
|
||||
If you are using a module which returns something special on failure, then
|
||||
you can manually create hints for each of the desired subroutines. Once
|
||||
the hints are specified, they are available for all files and modules loaded
|
||||
thereafter, thus you can move this work into a module and it will still
|
||||
work.
|
||||
|
||||
use Some::Module qw(foo bar);
|
||||
use autodie::hints;
|
||||
|
||||
autodie::hints->set_hints_for(
|
||||
\&foo,
|
||||
{
|
||||
scalar => SCALAR_HINT,
|
||||
list => LIST_HINT,
|
||||
}
|
||||
);
|
||||
autodie::hints->set_hints_for(
|
||||
\&bar,
|
||||
{ fail => SOME_HINT, }
|
||||
);
|
||||
|
||||
It is possible to pass either a subroutine reference (recommended) or a fully
|
||||
qualified subroutine name as the first argument. This means you can set hints
|
||||
on modules that I<might> get loaded:
|
||||
|
||||
use autodie::hints;
|
||||
autodie::hints->set_hints_for(
|
||||
'Some::Module:bar', { fail => SCALAR_HINT, }
|
||||
);
|
||||
|
||||
This technique is most useful when you have a project that uses a
|
||||
lot of third-party modules. You can define all your possible hints
|
||||
in one-place. This can even be in a sub-class of autodie. For
|
||||
example:
|
||||
|
||||
package my::autodie;
|
||||
|
||||
use parent qw(autodie);
|
||||
use autodie::hints;
|
||||
|
||||
autodie::hints->set_hints_for(...);
|
||||
|
||||
1;
|
||||
|
||||
You can now C<use my::autodie>, which will work just like the standard
|
||||
C<autodie>, but is now aware of any hints that you've set.
|
||||
|
||||
=head1 Adding hints to your module
|
||||
|
||||
C<autodie> provides a passive interface to allow you to declare hints for
|
||||
your module. These hints will be found and used by C<autodie> if it
|
||||
is loaded, but otherwise have no effect (or dependencies) without autodie.
|
||||
To set these, your module needs to declare that it I<does> the
|
||||
C<autodie::hints::provider> role. This can be done by writing your
|
||||
own C<DOES> method, using a system such as C<Class::DOES> to handle
|
||||
the heavy-lifting for you, or declaring a C<%DOES> package variable
|
||||
with a C<autodie::hints::provider> key and a corresponding true value.
|
||||
|
||||
Note that checking for a C<%DOES> hash is an C<autodie>-only
|
||||
short-cut. Other modules do not use this mechanism for checking
|
||||
roles, although you can use the C<Class::DOES> module from the
|
||||
CPAN to allow it.
|
||||
|
||||
In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
|
||||
a hash-reference containing the hints for your subroutines:
|
||||
|
||||
package Your::Module;
|
||||
|
||||
# We can use the Class::DOES from the CPAN to declare adherence
|
||||
# to a role.
|
||||
|
||||
use Class::DOES 'autodie::hints::provider' => 1;
|
||||
|
||||
# Alternatively, we can declare the role in %DOES. Note that
|
||||
# this is an autodie specific optimisation, although Class::DOES
|
||||
# can be used to promote this to a true role declaration.
|
||||
|
||||
our %DOES = ( 'autodie::hints::provider' => 1 );
|
||||
|
||||
# Finally, we must define the hints themselves.
|
||||
|
||||
sub AUTODIE_HINTS {
|
||||
return {
|
||||
foo => { scalar => HINTS, list => SOME_HINTS },
|
||||
bar => { scalar => HINTS, list => MORE_HINTS },
|
||||
baz => { fail => HINTS },
|
||||
}
|
||||
}
|
||||
|
||||
This allows your code to set hints without relying on C<autodie> and
|
||||
C<autodie::hints> being loaded, or even installed. In this way your
|
||||
code can do the right thing when C<autodie> is installed, but does not
|
||||
need to depend upon it to function.
|
||||
|
||||
=head1 Insisting on hints
|
||||
|
||||
When a user-defined subroutine is wrapped by C<autodie>, it will
|
||||
use hints if they are available, and otherwise reverts to the
|
||||
I<default behaviour> described in the introduction of this document.
|
||||
This can be problematic if we expect a hint to exist, but (for
|
||||
whatever reason) it has not been loaded.
|
||||
|
||||
We can ask autodie to I<insist> that a hint be used by prefixing
|
||||
an exclamation mark to the start of the subroutine name. A lone
|
||||
exclamation mark indicates that I<all> subroutines after it must
|
||||
have hints declared.
|
||||
|
||||
# foo() and bar() must have their hints defined
|
||||
use autodie qw( !foo !bar baz );
|
||||
|
||||
# Everything must have hints (recommended).
|
||||
use autodie qw( ! foo bar baz );
|
||||
|
||||
# bar() and baz() must have their hints defined
|
||||
use autodie qw( foo ! bar baz );
|
||||
|
||||
# Enable autodie for all of Perl's supported built-ins,
|
||||
# as well as for foo(), bar() and baz(). Everything must
|
||||
# have hints.
|
||||
use autodie qw( ! :all foo bar baz );
|
||||
|
||||
If hints are not available for the specified subroutines, this will cause a
|
||||
compile-time error. Insisting on hints for Perl's built-in functions
|
||||
(eg, C<open> and C<close>) is always successful.
|
||||
|
||||
Insisting on hints is I<strongly> recommended.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: implement regular expression hints
|
||||
|
||||
use constant UNDEF_ONLY => sub { not defined $_[0] };
|
||||
use constant EMPTY_OR_UNDEF => sub {
|
||||
! @_ or
|
||||
@_==1 && !defined $_[0]
|
||||
};
|
||||
|
||||
use constant EMPTY_ONLY => sub { @_ == 0 };
|
||||
use constant EMPTY_OR_FALSE => sub {
|
||||
! @_ or
|
||||
@_==1 && !$_[0]
|
||||
};
|
||||
|
||||
use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] };
|
||||
|
||||
use constant DEFAULT_HINTS => {
|
||||
scalar => UNDEF_ONLY,
|
||||
list => EMPTY_OR_UNDEF,
|
||||
};
|
||||
|
||||
|
||||
use constant HINTS_PROVIDER => 'autodie::hints::provider';
|
||||
|
||||
our $DEBUG = 0;
|
||||
|
||||
# Only ( undef ) is a strange but possible situation for very
|
||||
# badly written code. It's not supported yet.
|
||||
|
||||
my %Hints = (
|
||||
'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
|
||||
'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
|
||||
'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
|
||||
'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
|
||||
);
|
||||
|
||||
# Start by using Sub::Identify if it exists on this system.
|
||||
|
||||
eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
|
||||
|
||||
# If it doesn't exist, we'll define our own. This code is directly
|
||||
# taken from Rafael Garcia's Sub::Identify 0.04, used under the same
|
||||
# license as Perl itself.
|
||||
|
||||
if ($@) {
|
||||
require B;
|
||||
|
||||
no warnings 'once';
|
||||
|
||||
*get_code_info = sub ($) {
|
||||
|
||||
my ($coderef) = @_;
|
||||
ref $coderef or return;
|
||||
my $cv = B::svref_2object($coderef);
|
||||
$cv->isa('B::CV') or return;
|
||||
# bail out if GV is undefined
|
||||
$cv->GV->isa('B::SPECIAL') and return;
|
||||
|
||||
return ($cv->GV->STASH->NAME, $cv->GV->NAME);
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
sub sub_fullname {
|
||||
return join( '::', get_code_info( $_[1] ) );
|
||||
}
|
||||
|
||||
my %Hints_loaded = ();
|
||||
|
||||
sub load_hints {
|
||||
my ($class, $sub) = @_;
|
||||
|
||||
my ($package) = ( $sub =~ /(.*)::/ );
|
||||
|
||||
if (not defined $package) {
|
||||
require Carp;
|
||||
Carp::croak(
|
||||
"Internal error in autodie::hints::load_hints - no package found.
|
||||
");
|
||||
}
|
||||
|
||||
# Do nothing if we've already tried to load hints for
|
||||
# this package.
|
||||
return if $Hints_loaded{$package}++;
|
||||
|
||||
my $hints_available = 0;
|
||||
|
||||
{
|
||||
no strict 'refs'; ## no critic
|
||||
|
||||
if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
|
||||
$hints_available = 1;
|
||||
}
|
||||
elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) {
|
||||
$hints_available = 1;
|
||||
}
|
||||
elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
|
||||
$hints_available = 1;
|
||||
}
|
||||
}
|
||||
|
||||
return if not $hints_available;
|
||||
|
||||
my %package_hints = %{ $package->AUTODIE_HINTS };
|
||||
|
||||
foreach my $sub (keys %package_hints) {
|
||||
|
||||
my $hint = $package_hints{$sub};
|
||||
|
||||
# Ensure we have a package name.
|
||||
$sub = "${package}::$sub" if $sub !~ /::/;
|
||||
|
||||
# TODO - Currently we don't check for conflicts, should we?
|
||||
$Hints{$sub} = $hint;
|
||||
|
||||
$class->normalise_hints(\%Hints, $sub);
|
||||
}
|
||||
|
||||
return;
|
||||
|
||||
}
|
||||
|
||||
sub normalise_hints {
|
||||
my ($class, $hints, $sub) = @_;
|
||||
|
||||
if ( exists $hints->{$sub}->{fail} ) {
|
||||
|
||||
if ( exists $hints->{$sub}->{scalar} or
|
||||
exists $hints->{$sub}->{list}
|
||||
) {
|
||||
# TODO: Turn into a proper diagnostic.
|
||||
require Carp;
|
||||
local $Carp::CarpLevel = 1;
|
||||
Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
|
||||
}
|
||||
|
||||
# Set our scalar and list hints.
|
||||
|
||||
$hints->{$sub}->{scalar} =
|
||||
$hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
|
||||
|
||||
return;
|
||||
|
||||
}
|
||||
|
||||
# Check to make sure all our hints exist.
|
||||
|
||||
foreach my $hint (qw(scalar list)) {
|
||||
if ( not exists $hints->{$sub}->{$hint} ) {
|
||||
# TODO: Turn into a proper diagnostic.
|
||||
require Carp;
|
||||
local $Carp::CarpLevel = 1;
|
||||
Carp::croak("$hint hint missing for $sub");
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub get_hints_for {
|
||||
my ($class, $sub) = @_;
|
||||
|
||||
my $subname = $class->sub_fullname( $sub );
|
||||
|
||||
# If we have hints loaded for a sub, then return them.
|
||||
|
||||
if ( exists $Hints{ $subname } ) {
|
||||
return $Hints{ $subname };
|
||||
}
|
||||
|
||||
# If not, we try to load them...
|
||||
|
||||
$class->load_hints( $subname );
|
||||
|
||||
# ...and try again!
|
||||
|
||||
if ( exists $Hints{ $subname } ) {
|
||||
return $Hints{ $subname };
|
||||
}
|
||||
|
||||
# It's the caller's responsibility to use defaults if desired.
|
||||
# This allows on autodie to insist on hints if needed.
|
||||
|
||||
return;
|
||||
|
||||
}
|
||||
|
||||
sub set_hints_for {
|
||||
my ($class, $sub, $hints) = @_;
|
||||
|
||||
if (ref $sub) {
|
||||
$sub = $class->sub_fullname( $sub );
|
||||
|
||||
require Carp;
|
||||
|
||||
$sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
|
||||
}
|
||||
|
||||
if ($DEBUG) {
|
||||
warn "autodie::hints: Setting $sub to hints: $hints\n";
|
||||
}
|
||||
|
||||
$Hints{ $sub } = $hints;
|
||||
|
||||
$class->normalise_hints(\%Hints, $sub);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 Diagnostics
|
||||
|
||||
=over 4
|
||||
|
||||
=item Attempts to set_hints_for unidentifiable subroutine
|
||||
|
||||
You've called C<< autodie::hints->set_hints_for() >> using a subroutine
|
||||
reference, but that reference could not be resolved back to a
|
||||
subroutine name. It may be an anonymous subroutine (which can't
|
||||
be made autodying), or may lack a name for other reasons.
|
||||
|
||||
If you receive this error with a subroutine that has a real name,
|
||||
then you may have found a bug in autodie. See L<autodie/BUGS>
|
||||
for how to report this.
|
||||
|
||||
=item fail hints cannot be provided with either scalar or list hints for %s
|
||||
|
||||
When defining hints, you can either supply both C<list> and
|
||||
C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
|
||||
You can't mix and match them.
|
||||
|
||||
=item %s hint missing for %s
|
||||
|
||||
You've provided either a C<scalar> hint without supplying
|
||||
a C<list> hint, or vice-versa. You I<must> supply both C<scalar>
|
||||
and C<list> hints, I<or> a single C<fail> hint.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
Dr Damian Conway for suggesting the hinting interface and providing the
|
||||
example usage.
|
||||
|
||||
=item *
|
||||
|
||||
Jacinta Richardson for translating much of my ideas into this
|
||||
documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software. You may distribute it under the
|
||||
same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<autodie>, L<Class::DOES>
|
||||
|
||||
=for Pod::Coverage get_hints_for load_hints normalise_hints sub_fullname get_code_info
|
||||
|
||||
=cut
|
||||
56
database/perl/lib/autodie/skip.pm
Normal file
56
database/perl/lib/autodie/skip.pm
Normal file
@@ -0,0 +1,56 @@
|
||||
package autodie::skip;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '2.34'; # VERSION
|
||||
|
||||
# This package exists purely so people can inherit from it,
|
||||
# which isn't at all how roles are supposed to work, but it's
|
||||
# how people will use them anyway.
|
||||
|
||||
if ($] < 5.010) {
|
||||
# Older Perls don't have a native ->DOES. Let's provide a cheap
|
||||
# imitation here.
|
||||
|
||||
*DOES = sub { return shift->isa(@_); };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
autodie::skip - Skip a package when throwing autodie exceptions
|
||||
|
||||
=head1 SYNPOSIS
|
||||
|
||||
use parent qw(autodie::skip);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This dummy class exists to signal that the class inheriting it should
|
||||
be skipped when reporting exceptions from autodie. This is useful
|
||||
for utility classes like L<Path::Tiny> that wish to report the location
|
||||
of where they were called on failure.
|
||||
|
||||
If your class has a better way of doing roles, then you should not
|
||||
load this class and instead simply say that your class I<DOES>
|
||||
C<autodie::skip> instead.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2013, Paul Fenwick <pjf@cpan.org>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This module is free software. You may distribute it under the same
|
||||
terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<autodie>, L<autodie::exception>
|
||||
|
||||
=for Pod::Coverage DOES
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user