summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/autodie
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/autodie')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/Guard.pm65
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/GuardStack.pm127
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Util.pm250
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception.pm877
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception/system.pm83
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/hints.pm601
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/skip.pm56
7 files changed, 2059 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/Guard.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/Guard.pm
new file mode 100644
index 0000000000..bd34fc81b2
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/Guard.pm
@@ -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.29'; # 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.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/GuardStack.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/GuardStack.pm
new file mode 100644
index 0000000000..3ee3ae51db
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Scope/GuardStack.pm
@@ -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.29'; # 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.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Util.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Util.pm
new file mode 100644
index 0000000000..2a308a8977
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/Util.pm
@@ -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.29'; # 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.
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception.pm
new file mode 100644
index 0000000000..8743719cb8
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception.pm
@@ -0,0 +1,877 @@
+package autodie::exception;
+use 5.008;
+use strict;
+use warnings;
+use Carp qw(croak);
+
+our $VERSION = '2.29002';
+# 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>
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception/system.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception/system.pm
new file mode 100644
index 0000000000..e6305fd42e
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/exception/system.pm
@@ -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.29'; # 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>
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/hints.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/hints.pm
new file mode 100644
index 0000000000..be9fbceb47
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/hints.pm
@@ -0,0 +1,601 @@
+package autodie::hints;
+
+use strict;
+use warnings;
+
+use constant PERL58 => ( $] < 5.009 );
+
+our $VERSION = '2.29001';
+
+# 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
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/skip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/skip.pm
new file mode 100644
index 0000000000..9a048fe62f
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/autodie/skip.pm
@@ -0,0 +1,56 @@
+package autodie::skip;
+use strict;
+use warnings;
+
+our $VERSION = '2.29'; # 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