diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/autodie |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/autodie')
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 |