File manager - Edit - /home/newsbmcs.com/public_html/static/img/logo/lib.tar
Back
Fatal.pm 0000644 00000163215 15027445044 0006146 0 ustar 00 package Fatal; # ABSTRACT: Replace functions with equivalents which succeed or die use 5.008; # 5.8.x needed for autodie use Carp; use strict; use warnings; use Tie::RefHash; # To cache subroutine refs use Config; use Scalar::Util qw(set_prototype looks_like_number); use autodie::Util qw( fill_protos install_subs make_core_trampoline on_end_of_compile_scope ); use constant PERL510 => ( $] >= 5.010 ); use constant LEXICAL_TAG => q{:lexical}; use constant VOID_TAG => q{:void}; use constant INSIST_TAG => q{!}; # Keys for %Cached_fatalised_sub (used in 3rd level) use constant CACHE_AUTODIE_LEAK_GUARD => 0; use constant CACHE_FATAL_WRAPPER => 1; use constant CACHE_FATAL_VOID => 2; use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; use constant ERROR_NOHINTS => "No user hints defined for %s"; use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; # Older versions of IPC::System::Simple don't support all the # features we need. use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; # EWOULDBLOCK values for systems that don't supply their own. # Even though this is defined with our, that's to help our # test code. Please don't rely upon this variable existing in # the future. our %_EWOULDBLOCK = ( MSWin32 => 33, ); $Carp::CarpInternal{'Fatal'} = 1; $Carp::CarpInternal{'autodie'} = 1; $Carp::CarpInternal{'autodie::exception'} = 1; # the linux parisc port has separate EAGAIN and EWOULDBLOCK, # and the kernel returns EAGAIN my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; # We have some tags that can be passed in for use with import. # These are all assumed to be CORE:: my %TAGS = ( ':io' => [qw(:dbm :file :filesys :ipc :socket read seek sysread syswrite sysseek )], ':dbm' => [qw(dbmopen dbmclose)], ':file' => [qw(open close flock sysopen fcntl binmode ioctl truncate)], ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir symlink rmdir readlink chmod chown utime)], ':ipc' => [qw(:msg :semaphore :shm pipe kill)], ':msg' => [qw(msgctl msgget msgrcv msgsnd)], ':threads' => [qw(fork)], ':semaphore'=>[qw(semctl semget semop)], ':shm' => [qw(shmctl shmget shmread)], ':system' => [qw(system exec)], # Can we use qw(getpeername getsockname)? What do they do on failure? # TODO - Can socket return false? ':socket' => [qw(accept bind connect getsockopt listen recv send setsockopt shutdown socketpair)], # Our defaults don't include system(), because it depends upon # an optional module, and it breaks the exotic form. # # This *may* change in the future. I'd love IPC::System::Simple # to be a dependency rather than a recommendation, and hence for # system() to be autodying by default. ':default' => [qw(:io :threads)], # Everything in v2.07 and before. This was :default less chmod and chown ':v207' => [qw(:threads :dbm :socket read seek sysread syswrite sysseek open close flock sysopen fcntl fileno binmode ioctl truncate opendir closedir chdir link unlink rename mkdir symlink rmdir readlink umask :msg :semaphore :shm pipe)], # Chmod was added in 2.13 ':v213' => [qw(:v207 chmod)], # chown, utime, kill were added in 2.14 ':v214' => [qw(:v213 chown utime kill)], # umask was removed in 2.26 ':v225' => [qw(:io :threads umask fileno)], # Version specific tags. These allow someone to specify # use autodie qw(:1.994) and know exactly what they'll get. ':1.994' => [qw(:v207)], ':1.995' => [qw(:v207)], ':1.996' => [qw(:v207)], ':1.997' => [qw(:v207)], ':1.998' => [qw(:v207)], ':1.999' => [qw(:v207)], ':1.999_01' => [qw(:v207)], ':2.00' => [qw(:v207)], ':2.01' => [qw(:v207)], ':2.02' => [qw(:v207)], ':2.03' => [qw(:v207)], ':2.04' => [qw(:v207)], ':2.05' => [qw(:v207)], ':2.06' => [qw(:v207)], ':2.06_01' => [qw(:v207)], ':2.07' => [qw(:v207)], # Last release without chmod ':2.08' => [qw(:v213)], ':2.09' => [qw(:v213)], ':2.10' => [qw(:v213)], ':2.11' => [qw(:v213)], ':2.12' => [qw(:v213)], ':2.13' => [qw(:v213)], # Last release without chown ':2.14' => [qw(:v225)], ':2.15' => [qw(:v225)], ':2.16' => [qw(:v225)], ':2.17' => [qw(:v225)], ':2.18' => [qw(:v225)], ':2.19' => [qw(:v225)], ':2.20' => [qw(:v225)], ':2.21' => [qw(:v225)], ':2.22' => [qw(:v225)], ':2.23' => [qw(:v225)], ':2.24' => [qw(:v225)], ':2.25' => [qw(:v225)], ':2.26' => [qw(:default)], ':2.27' => [qw(:default)], ':2.28' => [qw(:default)], ':2.29' => [qw(:default)], ':2.30' => [qw(:default)], ':2.31' => [qw(:default)], ':2.32' => [qw(:default)], ); { # Expand :all immediately by expanding and flattening all tags. # _expand_tag is not really optimised for expanding the ":all" # case (i.e. keys %TAGS, or values %TAGS for that matter), so we # just do it here. # # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being # pre-expanded. my %seen; my @all = grep { !/^:/ && !$seen{$_}++ } map { @{$_} } values %TAGS; $TAGS{':all'} = \@all; } # This hash contains subroutines for which we should # subroutine() // die() rather than subroutine() || die() my %Use_defined_or; # CORE::open returns undef on failure. It can legitimately return # 0 on success, eg: open(my $fh, '-|') || exec(...); @Use_defined_or{qw( CORE::fork CORE::recv CORE::send CORE::open CORE::fileno CORE::read CORE::readlink CORE::sysread CORE::syswrite CORE::sysseek CORE::umask )} = (); # Some functions can return true because they changed *some* things, but # not all of them. This is a list of offending functions, and how many # items to subtract from @_ to determine the "success" value they return. my %Returns_num_things_changed = ( 'CORE::chmod' => 1, 'CORE::chown' => 2, 'CORE::kill' => 1, # TODO: Could this return anything on negative args? 'CORE::unlink' => 0, 'CORE::utime' => 2, ); # Optional actions to take on the return value before returning it. my %Retval_action = ( "CORE::open" => q{ # apply the open pragma from our caller if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { # Get the caller's hint hash my $hints = (caller 0)[10]; # Decide if we're reading or writing and apply the appropriate encoding # These keys are undocumented. # Match what PerlIO_context_layers() does. Read gets the read layer, # everything else gets the write layer. my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; # Apply the encoding, if any. if( $encoding ) { binmode $_[0], $encoding; } } }, "CORE::sysopen" => q{ # apply the open pragma from our caller if( defined $retval ) { # Get the caller's hint hash my $hints = (caller 0)[10]; require Fcntl; # Decide if we're reading or writing and apply the appropriate encoding. # Match what PerlIO_context_layers() does. Read gets the read layer, # everything else gets the write layer. my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; # Apply the encoding, if any. if( $encoding ) { binmode $_[0], $encoding; } } }, ); my %reusable_builtins; # "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can # take file and directory handles, which are package depedent." # # You would be correct, except that prototype() returns signatures which don't # allow for passing of globs, and nobody's complained about that. You can # still use \*FILEHANDLE, but that results in a reference coming through, # and it's already pointing to the filehandle in the caller's packge, so # it's all okay. @reusable_builtins{qw( CORE::fork CORE::kill CORE::truncate CORE::chdir CORE::link CORE::unlink CORE::rename CORE::mkdir CORE::symlink CORE::rmdir CORE::readlink CORE::umask CORE::chmod CORE::chown CORE::utime CORE::msgctl CORE::msgget CORE::msgrcv CORE::msgsnd CORE::semctl CORE::semget CORE::semop CORE::shmctl CORE::shmget CORE::shmread CORE::exec CORE::system )} = (); # Cached_fatalised_sub caches the various versions of our # fatalised subs as they're produced. This means we don't # have to build our own replacement of CORE::open and friends # for every single package that wants to use them. my %Cached_fatalised_sub = (); # Every time we're called with package scope, we record the subroutine # (including package or CORE::) in %Package_Fatal. This allows us # to detect illegal combinations of autodie and Fatal, and makes sure # we don't accidently make a Fatal function autodying (which isn't # very useful). my %Package_Fatal = (); # The first time we're called with a user-sub, we cache it here. # In the case of a "no autodie ..." we put back the cached copy. my %Original_user_sub = (); # Is_fatalised_sub simply records a big map of fatalised subroutine # refs. It means we can avoid repeating work, or fatalising something # we've already processed. my %Is_fatalised_sub = (); tie %Is_fatalised_sub, 'Tie::RefHash'; # Our trampoline cache allows us to cache trampolines which are used to # bounce leaked wrapped core subroutines to their actual core counterparts. my %Trampoline_cache; # A cache mapping "CORE::<name>" to their prototype. Turns out that if # you "use autodie;" enough times, this pays off. my %CORE_prototype_cache; # We use our package in a few hash-keys. Having it in a scalar is # convenient. The "guard $PACKAGE" string is used as a key when # setting up lexical guards. my $PACKAGE = __PACKAGE__; my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' # Here's where all the magic happens when someone write 'use Fatal' # or 'use autodie'. sub import { my $class = shift(@_); my @original_args = @_; my $void = 0; my $lexical = 0; my $insist_hints = 0; my ($pkg, $filename) = caller(); @_ or return; # 'use Fatal' is a no-op. # If we see the :lexical flag, then _all_ arguments are # changed lexically if ($_[0] eq LEXICAL_TAG) { $lexical = 1; shift @_; # It is currently an implementation detail that autodie is # implemented as "use Fatal qw(:lexical ...)". For backwards # compatibility, we allow it - but not without a warning. # NB: Optimise for autodie as it is quite possibly the most # freq. consumer of this case. if ($class ne 'autodie' and not $class->isa('autodie')) { if ($class eq 'Fatal') { warnings::warnif( 'deprecated', '[deprecated] The "use Fatal qw(:lexical ...)" ' . 'should be replaced by "use autodie qw(...)". ' . 'Seen' # warnif appends " at <...>" ); } else { warnings::warnif( 'deprecated', "[deprecated] The class/Package $class is a " . 'subclass of Fatal and used the :lexical. ' . 'If $class provides lexical error checking ' . 'it should extend autodie instead of using :lexical. ' . 'Seen' # warnif appends " at <...>" ); } # "Promote" the call to autodie from here on. This is # already mostly the case (e.g. use Fatal qw(:lexical ...) # would throw autodie::exceptions on error rather than the # Fatal errors. $class = 'autodie'; # This requires that autodie is in fact loaded; otherwise # the "$class->X()" method calls below will explode. require autodie; # TODO, when autodie and Fatal are cleanly separated, we # should go a "goto &autodie::import" here instead. } # If we see no arguments and :lexical, we assume they # wanted ':default'. if (@_ == 0) { push(@_, ':default'); } # Don't allow :lexical with :void, it's needlessly confusing. if ( grep { $_ eq VOID_TAG } @_ ) { croak(ERROR_VOID_LEX); } } if ( grep { $_ eq LEXICAL_TAG } @_ ) { # If we see the lexical tag as the non-first argument, complain. croak(ERROR_LEX_FIRST); } my @fatalise_these = @_; # These subs will get unloaded at the end of lexical scope. my %unload_later; # These subs are to be installed into callers namespace. my %install_subs; # Use _translate_import_args to expand tags for us. It will # pass-through unknown tags (i.e. we have to manually handle # VOID_TAG). # # NB: _translate_import_args re-orders everything for us, so # we don't have to worry about stuff like: # # :default :void :io # # That will (correctly) translated into # # expand(:defaults-without-io) :void :io # # by _translate_import_args. for my $func ($class->_translate_import_args(@fatalise_these)) { if ($func eq VOID_TAG) { # When we see :void, set the void flag. $void = 1; } elsif ($func eq INSIST_TAG) { $insist_hints = 1; } else { # Otherwise, fatalise it. # Check to see if there's an insist flag at the front. # If so, remove it, and insist we have hints for this sub. my $insist_this = $insist_hints; if (substr($func, 0, 1) eq '!') { $func = substr($func, 1); $insist_this = 1; } # We're going to make a subroutine fatalistic. # However if we're being invoked with 'use Fatal qw(x)' # and we've already been called with 'no autodie qw(x)' # in the same scope, we consider this to be an error. # Mixing Fatal and autodie effects was considered to be # needlessly confusing on p5p. my $sub = $func; $sub = "${pkg}::$sub" unless $sub =~ /::/; # If we're being called as Fatal, and we've previously # had a 'no X' in scope for the subroutine, then complain # bitterly. if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); } # We're not being used in a confusing way, so make # the sub fatal. Note that _make_fatal returns the # old (original) version of the sub, or undef for # built-ins. my $sub_ref = $class->_make_fatal( $func, $pkg, $void, $lexical, $filename, $insist_this, \%install_subs, ); $Original_user_sub{$sub} ||= $sub_ref; # If we're making lexical changes, we need to arrange # for them to be cleaned at the end of our scope, so # record them here. $unload_later{$func} = $sub_ref if $lexical; } } install_subs($pkg, \%install_subs); if ($lexical) { # 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; # Our package guard gets invoked when we leave our lexical # scope. on_end_of_compile_scope(sub { install_subs($pkg, \%unload_later); }); # To allow others to determine when autodie was in scope, # and with what arguments, we also set a %^H hint which # is how we were called. # This feature should be considered EXPERIMENTAL, and # may change without notice. Please e-mail pjf@cpan.org # if you're actually using it. $^H{autodie} = "$PACKAGE @original_args"; } return; } sub unimport { my $class = shift; # Calling "no Fatal" must start with ":lexical" if ($_[0] ne LEXICAL_TAG) { croak(sprintf(ERROR_NO_LEX,$class)); } shift @_; # Remove :lexical my $pkg = (caller)[0]; # If we've been called with arguments, then the developer # has explicitly stated 'no autodie qw(blah)', # in which case, we disable Fatalistic behaviour for 'blah'. my @unimport_these = @_ ? @_ : ':all'; my (%uninstall_subs, %reinstall_subs); for my $symbol ($class->_translate_import_args(@unimport_these)) { my $sub = $symbol; $sub = "${pkg}::$sub" unless $sub =~ /::/; # If 'blah' was already enabled with Fatal (which has package # scope) then, this is considered an error. if (exists $Package_Fatal{$sub}) { croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); } # Record 'no autodie qw($sub)' as being in effect. # This is to catch conflicting semantics elsewhere # (eg, mixing Fatal with no autodie) $^H{$NO_PACKAGE}{$sub} = 1; # Record the current sub to be reinstalled at end of scope # and then restore the original (can be undef for "CORE::" # subs) { no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... $reinstall_subs{$symbol} = \&$sub if exists ${"${pkg}::"}{$symbol}; } $uninstall_subs{$symbol} = $Original_user_sub{$sub}; } install_subs($pkg, \%uninstall_subs); on_end_of_compile_scope(sub { install_subs($pkg, \%reinstall_subs); }); return; } sub _translate_import_args { my ($class, @args) = @_; my @result; my %seen; if (@args < 2) { # Optimize for this case, as it is fairly common. (e.g. use # autodie; or use autodie qw(:all); both trigger this). return unless @args; # Not a (known) tag, pass through. return @args unless exists($TAGS{$args[0]}); # Strip "CORE::" from all elements in the list as import and # unimport does not handle the "CORE::" prefix too well. # # NB: we use substr as it is faster than s/^CORE::// and # it does not change the elements. return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; } # We want to translate # # :default :void :io # # into (pseudo-ish): # # expanded(:threads) :void expanded(:io) # # We accomplish this by "reverse, expand + filter, reverse". for my $a (reverse(@args)) { if (exists $TAGS{$a}) { my $expanded = $class->_expand_tag($a); push(@result, # Remove duplicates after ... grep { !$seen{$_}++ } # we have stripped CORE:: (see above) map { substr($_, 6) } # We take the elements in reverse order # (as @result be reversed later). reverse(@{$expanded})); } else { # pass through - no filtering here for tags. # # The reason for not filtering tags cases like: # # ":default :void :io :void :threads" # # As we have reversed args, we see this as: # # ":threads :void :io :void* :default*" # # (Entries marked with "*" will be filtered out completely). When # reversed again, this will be: # # ":io :void :threads" # # But we would rather want it to be: # # ":void :io :threads" or ":void :io :void :threads" # my $letter = substr($a, 0, 1); if ($letter ne ':' && $a ne INSIST_TAG) { next if $seen{$a}++; if ($letter eq '!' and $seen{substr($a, 1)}++) { my $name = substr($a, 1); # People are being silly and doing: # # use autodie qw(!a a); # # Enjoy this little O(n) clean up... @result = grep { $_ ne $name } @result; } } push @result, $a; } } # Reverse the result to restore the input order return reverse(@result); } # NB: Perl::Critic's dump-autodie-tag-contents depends upon this # continuing to work. { # We assume that $TAGS{':all'} is pre-expanded and just fill it in # from the beginning. my %tag_cache = ( 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], ); # Expand a given tag (e.g. ":default") into a listref containing # all sub names covered by that tag. Each sub is returned as # "CORE::<name>" (i.e. "CORE::open" rather than "open"). # # NB: the listref must not be modified. sub _expand_tag { my ($class, $tag) = @_; if (my $cached = $tag_cache{$tag}) { return $cached; } if (not exists $TAGS{$tag}) { croak "Invalid exception class $tag"; } my @to_process = @{$TAGS{$tag}}; # If the tag is basically an alias of another tag (like e.g. ":2.11"), # then just share the resulting reference with the original content (so # we only pay for an extra reference for the alias memory-wise). if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { # We could do this for "non-tags" as well, but that only occurs # once at the time of writing (":threads" => ["fork"]), so # probably not worth it. my $expanded = $class->_expand_tag($to_process[0]); $tag_cache{$tag} = $expanded; return $expanded; } my %seen = (); my @taglist = (); for my $item (@to_process) { # substr is more efficient than m/^:/ for stuff like this, # at the price of being a bit more verbose/low-level. if (substr($item, 0, 1) eq ':') { # Use recursion here to ensure we expand a tag at most once. my $expanded = $class->_expand_tag($item); push @taglist, grep { !$seen{$_}++ } @{$expanded}; } else { my $subname = "CORE::$item"; push @taglist, $subname unless $seen{$subname}++; } } $tag_cache{$tag} = \@taglist; return \@taglist; } } # This is a backwards compatible version of _write_invocation. It's # recommended you don't use it. sub write_invocation { my ($core, $call, $name, $void, @args) = @_; return Fatal->_write_invocation( $core, $call, $name, $void, 0, # Lexical flag undef, # Sub, unused in legacy mode undef, # Subref, unused in legacy mode. @args ); } # This version of _write_invocation is used internally. It's not # recommended you call it from external code, as the interface WILL # change in the future. sub _write_invocation { my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; if (@argvs == 1) { # No optional arguments my @argv = @{$argvs[0]}; shift @argv; return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); } else { my $else = "\t"; my (@out, @argv, $n); while (@argvs) { @argv = @{shift @argvs}; $n = shift @argv; my $condition = "\@_ == $n"; if (@argv and $argv[-1] =~ /[#@]_/) { # This argv ends with '@' in the prototype, so it matches # any number of args >= the number of expressions in the # argv. $condition = "\@_ >= $n"; } push @out, "${else}if ($condition) {\n"; $else = "\t} els"; push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); } push @out, qq[ } die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; ]; return join '', @out; } } # This is a slim interface to ensure backward compatibility with # anyone doing very foolish things with old versions of Fatal. sub one_invocation { my ($core, $call, $name, $void, @argv) = @_; return Fatal->_one_invocation( $core, $call, $name, $void, undef, # Sub. Unused in back-compat mode. 1, # Back-compat flag undef, # Subref, unused in back-compat mode. @argv ); } # This is the internal interface that generates code. # NOTE: This interface WILL change in the future. Please do not # call this subroutine directly. # TODO: Whatever's calling this code has already looked up hints. Pass # them in, rather than look them up a second time. sub _one_invocation { my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; # If someone is calling us directly (a child class perhaps?) then # they could try to mix void without enabling backwards # compatibility. We just don't support this at all, so we gripe # about it rather than doing something unwise. if ($void and not $back_compat) { Carp::confess("Internal error: :void mode not supported with $class"); } # @argv only contains the results of the in-built prototype # function, and is therefore safe to interpolate in the # code generators below. # TODO - The following clobbers context, but that's what the # old Fatal did. Do we care? if ($back_compat) { # Use Fatal qw(system) will never be supported. It generated # a compile-time error with legacy Fatal, and there's no reason # to support it when autodie does a better job. if ($call eq 'CORE::system') { return q{ croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); }; } local $" = ', '; if ($void) { return qq/return (defined wantarray)?$call(@argv): $call(@argv) || Carp::croak("Can't $name(\@_)/ . ($core ? ': $!' : ', \$! is \"$!\"') . '")' } else { return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . ($core ? ': $!' : ', \$! is \"$!\"') . '")'; } } # The name of our original function is: # $call if the function is CORE # $sub if our function is non-CORE # The reason for this is that $call is what we're actually # calling. For our core functions, this is always # CORE::something. However for user-defined subs, we're about to # replace whatever it is that we're calling; as such, we actually # calling a subroutine ref. my $human_sub_name = $core ? $call : $sub; # Should we be testing to see if our result is defined, or # just true? my $use_defined_or; my $hints; # All user-sub hints, including list hints. if ( $core ) { # Core hints are built into autodie. $use_defined_or = exists ( $Use_defined_or{$call} ); } else { # User sub hints are looked up using autodie::hints, # since users may wish to add their own hints. require autodie::hints; $hints = autodie::hints->get_hints_for( $sref ); # We'll look up the sub's fullname. This means we # get better reports of where it came from in our # error messages, rather than what imported it. $human_sub_name = autodie::hints->sub_fullname( $sref ); } # Checks for special core subs. if ($call eq 'CORE::system') { # Leverage IPC::System::Simple if we're making an autodying # system. local $" = ", "; # We need to stash $@ into $E, rather than using # local $@ for the whole sub. If we don't then # any exceptions from internal errors in autodie/Fatal # will mysteriously disappear before propagating # upwards. return qq{ my \$retval; my \$E; { local \$@; eval { \$retval = IPC::System::Simple::system(@argv); }; \$E = \$@; } if (\$E) { # TODO - This can't be overridden in child # classes! die autodie::exception::system->new( function => q{CORE::system}, args => [ @argv ], message => "\$E", errno => \$!, ); } return \$retval; }; } local $" = ', '; # If we're going to throw an exception, here's the code to use. my $die = qq{ die $class->throw( function => q{$human_sub_name}, args => [ @argv ], pragma => q{$class}, errno => \$!, context => \$context, return => \$retval, eval_error => \$@ ) }; if ($call eq 'CORE::flock') { # flock needs special treatment. When it fails with # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just # means we couldn't get the lock right now. require POSIX; # For POSIX::EWOULDBLOCK local $@; # Don't blat anyone else's $@. # Ensure that our vendor supports EWOULDBLOCK. If they # don't (eg, Windows), then we use known values for its # equivalent on other systems. my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } || $_EWOULDBLOCK{$^O} || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); my $EAGAIN = $EWOULDBLOCK; if ($try_EAGAIN) { $EAGAIN = eval { POSIX::EAGAIN(); } || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); } require Fcntl; # For Fcntl::LOCK_NB return qq{ my \$context = wantarray() ? "list" : "scalar"; # Try to flock. If successful, return it immediately. my \$retval = $call(@argv); return \$retval if \$retval; # If we failed, but we're using LOCK_NB and # returned EWOULDBLOCK, it's not a real error. if (\$_[1] & Fcntl::LOCK_NB() and (\$! == $EWOULDBLOCK or ($try_EAGAIN and \$! == $EAGAIN ))) { return \$retval; } # Otherwise, we failed. Die noisily. $die; }; } if ($call eq 'CORE::kill') { return qq[ my \$num_things = \@_ - $Returns_num_things_changed{$call}; my \$context = ! defined wantarray() ? 'void' : 'scalar'; my \$signal = \$_[0]; my \$retval = $call(@argv); my \$sigzero = looks_like_number( \$signal ) && \$signal == 0; if ( ( \$sigzero && \$context eq 'void' ) or ( ! \$sigzero && \$retval != \$num_things ) ) { $die; } return \$retval; ]; } if (exists $Returns_num_things_changed{$call}) { # Some things return the number of things changed (like # chown, kill, chmod, etc). We only consider these successful # if *all* the things are changed. return qq[ my \$num_things = \@_ - $Returns_num_things_changed{$call}; my \$retval = $call(@argv); if (\$retval != \$num_things) { # We need \$context to throw an exception. # It's *always* set to scalar, because that's how # autodie calls chown() above. my \$context = "scalar"; $die; } return \$retval; ]; } # AFAIK everything that can be given an unopned filehandle # will fail if it tries to use it, so we don't really need # the 'unopened' warning class here. Especially since they # then report the wrong line number. # Other warnings are disabled because they produce excessive # complaints from smart-match hints under 5.10.1. my $code = qq[ no warnings qw(unopened uninitialized numeric); no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; if (wantarray) { my \@results = $call(@argv); my \$retval = \\\@results; my \$context = "list"; ]; my $retval_action = $Retval_action{$call} || ''; if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { # NB: Subroutine hints are passed as a full list. # This differs from the 5.10.0 smart-match behaviour, # but means that context unaware subroutines can use # the same hints in both list and scalar context. $code .= qq{ if ( \$hints->{list}->(\@results) ) { $die }; }; } elsif ( PERL510 and $hints ) { $code .= qq{ if ( \@results ~~ \$hints->{list} ) { $die }; }; } elsif ( $hints ) { croak sprintf(ERROR_58_HINTS, 'list', $sub); } else { $code .= qq{ # An empty list, or a single undef is failure if (! \@results or (\@results == 1 and ! defined \$results[0])) { $die; } } } # Tidy up the end of our wantarray call. $code .= qq[ return \@results; } ]; # Otherwise, we're in scalar context. # We're never in a void context, since we have to look # at the result. $code .= qq{ my \$retval = $call(@argv); my \$context = "scalar"; }; if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { # We always call code refs directly, since that always # works in 5.8.x, and always works in 5.10.1 return $code .= qq{ if ( \$hints->{scalar}->(\$retval) ) { $die }; $retval_action return \$retval; }; } elsif (PERL510 and $hints) { return $code . qq{ if ( \$retval ~~ \$hints->{scalar} ) { $die }; $retval_action return \$retval; }; } elsif ( $hints ) { croak sprintf(ERROR_58_HINTS, 'scalar', $sub); } return $code . ( $use_defined_or ? qq{ $die if not defined \$retval; $retval_action return \$retval; } : qq{ $retval_action return \$retval || $die; } ) ; } # This returns the old copy of the sub, so we can # put it back at end of scope. # TODO : Check to make sure prototypes are restored correctly. # TODO: Taking a huge list of arguments is awful. Rewriting to # take a hash would be lovely. # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 sub _make_fatal { my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); my $ini = $sub; my $name = $sub; if (index($sub, '::') == -1) { $sub = "${pkg}::$sub"; if (substr($name, 0, 1) eq '&') { $name = substr($name, 1); } } else { $name =~ s/.*:://; } # Figure if we're using lexical or package semantics and # twiddle the appropriate bits. if (not $lexical) { $Package_Fatal{$sub} = 1; } # TODO - We *should* be able to do skipping, since we know when # we've lexicalised / unlexicalised a subroutine. warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; if (defined(&$sub)) { # user subroutine # NOTE: Previously we would localise $@ at this point, so # the following calls to eval {} wouldn't interfere with anything # that's already in $@. Unfortunately, it would also stop # any of our croaks from triggering(!), which is even worse. # This could be something that we've fatalised that # was in core. # Store the current sub in case we need to restore it. $sref = \&$sub; if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { # Something we previously made Fatal that was core. # This is safe to replace with an autodying to core # version. $core = 1; $call = "CORE::$name"; $proto = $CORE_prototype_cache{$call}; # We return our $sref from this subroutine later # on, indicating this subroutine should be placed # back when we're finished. } else { # If this is something we've already fatalised or played with, # then look-up the name of the original sub for the rest of # our processing. if (exists($Is_fatalised_sub{$sref})) { # $sub is one of our wrappers around a CORE sub or a # user sub. Instead of wrapping our wrapper, lets just # generate a new wrapper for the original sub. # - NB: the current wrapper might be for a different class # than the one we are generating now (e.g. some limited # mixing between use Fatal + use autodie can occur). # - Even for nested autodie, we need this as the leak guards # differ. my $s = $Is_fatalised_sub{$sref}; if (defined($s)) { # It is a wrapper for a user sub $sub = $s; } else { # It is a wrapper for a CORE:: sub $core = 1; $call = "CORE::$name"; $proto = $CORE_prototype_cache{$call}; } } # A regular user sub, or a user sub wrapping a # core sub. if (!$core) { # A non-CORE sub might have hints and such... $proto = prototype($sref); $call = '&$sref'; require autodie::hints; $hints = autodie::hints->get_hints_for( $sref ); # If we've insisted on hints, but don't have them, then # bail out! if ($insist and not $hints) { croak(sprintf(ERROR_NOHINTS, $name)); } # Otherwise, use the default hints if we don't have # any. $hints ||= autodie::hints::DEFAULT_HINTS(); } } } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { # Stray user subroutine croak(sprintf(ERROR_NOTSUB,$sub)); } elsif ($name eq 'system') { # If we're fatalising system, then we need to load # helper code. # The business with $E is to avoid clobbering our caller's # $@, and to avoid $@ being localised when we croak. my $E; { local $@; eval { require IPC::System::Simple; # Only load it if we need it. require autodie::exception::system; }; $E = $@; } if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } # Make sure we're using a recent version of ISS that actually # support fatalised system. if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { croak sprintf( ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, $IPC::System::Simple::VERSION ); } $call = 'CORE::system'; $core = 1; } elsif ($name eq 'exec') { # Exec doesn't have a prototype. We don't care. This # breaks the exotic form with lexical scope, and gives # the regular form a "do or die" behavior as expected. $call = 'CORE::exec'; $core = 1; } else { # CORE subroutine $call = "CORE::$name"; if (exists($CORE_prototype_cache{$call})) { $proto = $CORE_prototype_cache{$call}; } else { my $E; { local $@; $proto = eval { prototype $call }; $E = $@; } croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; $CORE_prototype_cache{$call} = $proto; } $core = 1; } # TODO: This caching works, but I don't like using $void and # $lexical as keys. In particular, I suspect our code may end up # wrapping already wrapped code when autodie and Fatal are used # together. # NB: We must use '$sub' (the name plus package) and not # just '$name' (the short name) here. Failing to do so # results code that's in the wrong package, and hence has # access to the wrong package filehandles. $cache = $Cached_fatalised_sub{$class}{$sub}; if ($lexical) { $cache_type = CACHE_AUTODIE_LEAK_GUARD; } else { $cache_type = CACHE_FATAL_WRAPPER; $cache_type = CACHE_FATAL_VOID if $void; } if (my $subref = $cache->{$cache_type}) { $install_subs->{$name} = $subref; return $sref; } # If our subroutine is reusable (ie, not package depdendent), # then check to see if we've got a cached copy, and use that. # See RT #46984. (Thanks to Niels Thykier for being awesome!) if ($core && exists $reusable_builtins{$call}) { # For non-lexical subs, we can just use this cache directly # - for lexical variants, we need a leak guard as well. $code = $reusable_builtins{$call}{$lexical}; if (!$lexical && defined($code)) { $install_subs->{$name} = $code; return $sref; } } if (!($lexical && $core) && !defined($code)) { # No code available, generate it now. my $wrapper_pkg = $pkg; $wrapper_pkg = undef if (exists($reusable_builtins{$call})); $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto); if (!defined($wrapper_pkg)) { # cache it so we don't recompile this part again $reusable_builtins{$call}{$lexical} = $code; } } # Now we need to wrap our fatalised sub inside an itty bitty # closure, which can detect if we've leaked into another file. # Luckily, we only need to do this for lexical (autodie) # subs. Fatal subs can leak all they want, it's considered # a "feature" (or at least backwards compatible). # TODO: Cache our leak guards! # TODO: This is pretty hairy code. A lot more tests would # be really nice for this. my $installed_sub = $code; if ($lexical) { $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, $pkg, $proto); } $cache->{$cache_type} = $code; $install_subs->{$name} = $installed_sub; # Cache that we've now overridden this sub. If we get called # again, we may need to find that find subroutine again (eg, for hints). $Is_fatalised_sub{$installed_sub} = $sref; return $sref; } # This subroutine exists primarily so that child classes can override # it to point to their own exception class. Doing this is significantly # less complex than overriding throw() sub exception_class { return "autodie::exception" }; { my %exception_class_for; my %class_loaded; sub throw { my ($class, @args) = @_; # Find our exception class if we need it. my $exception_class = $exception_class_for{$class} ||= $class->exception_class; if (not $class_loaded{$exception_class}) { if ($exception_class =~ /[^\w:']/) { confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons."; } # Alas, Perl does turn barewords into modules unless they're # actually barewords. As such, we're left doing a string eval # to make sure we load our file correctly. my $E; { local $@; # We can't clobber $@, it's wrong! my $pm_file = $exception_class . ".pm"; $pm_file =~ s{ (?: :: | ' ) }{/}gx; eval { require $pm_file }; $E = $@; # Save $E despite ending our local. } # We need quotes around $@ to make sure it's stringified # while still in scope. Without them, we run the risk of # $@ having been cleared by us exiting the local() block. confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E; $class_loaded{$exception_class}++; } return $exception_class->new(@args); } } # Creates and returns a leak guard (with prototype if needed). sub _make_leak_guard { my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; # The leak guard is rather lengthly (in fact it makes up the most # of _make_leak_guard). It is possible to split it into a large # "generic" part and a small wrapper with call-specific # information. This was done in v2.19 and profiling suggested # that we ended up using a substantial amount of runtime in "goto" # between the leak guard(s) and the final sub. Therefore, the two # parts were merged into one to reduce the runtime overhead. my $leak_guard = sub { my $caller_level = 0; my $caller; while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { # If our filename is actually an eval, and we # reach it, then go to our autodying code immediatately. last if ($caller eq $filename); $caller_level++; } # We're now out of the eval stack. if ($caller eq $filename) { # No leak, call the wrapper. NB: In this case, it doesn't # matter if it is a CORE sub or not. if (!defined($wrapped_sub)) { # CORE sub that we were too lazy to compile when we # created this leak guard. die "$call is not CORE::<something>" if substr($call, 0, 6) ne 'CORE::'; my $name = substr($call, 6); my $sub = $name; my $lexical = 1; my $wrapper_pkg = $pkg; my $code; if (exists($reusable_builtins{$call})) { $code = $reusable_builtins{$call}{$lexical}; $wrapper_pkg = undef; } if (!defined($code)) { $code = $class->_compile_wrapper($wrapper_pkg, 1, # core $call, $name, 0, # void $lexical, $sub, undef, # subref (not used for core) undef, # hints (not used for core) $proto); if (!defined($wrapper_pkg)) { # cache it so we don't recompile this part again $reusable_builtins{$call}{$lexical} = $code; } } # As $wrapped_sub is "closed over", updating its value will # be "remembered" for the next call. $wrapped_sub = $code; } goto $wrapped_sub; } # We leaked, time to call the original function. # - for non-core functions that will be $orig_sub # - for CORE functions, $orig_sub may be a trampoline goto $orig_sub if defined($orig_sub); # We are wrapping a CORE sub and we do not have a trampoline # yet. # # If we've cached a trampoline, then use it. Usually only # resuable subs will have cache hits, but non-reusuably ones # can get it as well in (very) rare cases. It is mostly in # cases where a package uses autodie multiple times and leaks # from multiple places. Possibly something like: # # package Pkg::With::LeakyCode; # sub a { # use autodie; # code_that_leaks(); # } # # sub b { # use autodie; # more_leaky_code(); # } # # Note that we use "Fatal" as package name for reusable subs # because A) that allows us to trivially re-use the # trampolines as well and B) because the reusable sub is # compiled into "package Fatal" as well. $pkg = 'Fatal' if exists $reusable_builtins{$call}; $orig_sub = $Trampoline_cache{$pkg}{$call}; if (not $orig_sub) { # If we don't have a trampoline, we need to build it. # # We only generate trampolines when we need them, and # we can cache them by subroutine + package. # # As $orig_sub is "closed over", updating its value will # be "remembered" for the next call. $orig_sub = make_core_trampoline($call, $pkg, $proto); # We still cache it despite remembering it in $orig_sub as # well. In particularly, we rely on this to avoid # re-compiling the reusable trampolines. $Trampoline_cache{$pkg}{$call} = $orig_sub; } # Bounce to our trampoline, which takes us to our core sub. goto $orig_sub; }; # <-- end of leak guard # If there is a prototype on the original sub, copy it to the leak # guard. if (defined $proto) { # The "\&" may appear to be redundant but set_prototype # croaks when it is removed. set_prototype(\&$leak_guard, $proto); } return $leak_guard; } sub _compile_wrapper { my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; my $real_proto = ''; my @protos; my $code; if (defined $proto) { $real_proto = " ($proto)"; } else { $proto = '@'; } @protos = fill_protos($proto); $code = qq[ sub$real_proto { ]; if (!$lexical) { $code .= q[ local($", $!) = (', ', 0); ]; } # Don't have perl whine if exec fails, since we'll be handling # the exception now. $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos); $code .= "}\n"; warn $code if $Debug; # I thought that changing package was a monumental waste of # time for CORE subs, since they'll always be the same. However # that's not the case, since they may refer to package-based # filehandles (eg, with open). # # The %reusable_builtins hash defines ones we can aggressively # cache as they never depend upon package-based symbols. my $E; { no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... local $@; if (defined($wrapper_pkg)) { $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic } else { $code = eval("require Carp; $code"); ## no critic } $E = $@; } if (not $code) { my $true_name = $core ? $call : $sub; croak("Internal error in autodie/Fatal processing $true_name: $E"); } return $code; } # For some reason, dying while replacing our subs doesn't # kill our calling program. It simply stops the loading of # autodie and keeps going with everything else. The _autocroak # sub allows us to die with a vengeance. It should *only* ever be # used for serious internal errors, since the results of it can't # be captured. sub _autocroak { warn Carp::longmess(@_); exit(255); # Ugh! } 1; __END__ =head1 NAME Fatal - Replace functions with equivalents which succeed or die =head1 SYNOPSIS use Fatal qw(open close); open(my $fh, "<", $filename); # No need to check errors! use File::Copy qw(move); use Fatal qw(move); move($file1, $file2); # No need to check errors! sub juggle { . . . } Fatal->import('juggle'); =head1 BEST PRACTICE B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping, throws real exception objects, and provides much nicer error messages. The use of C<:void> with Fatal is discouraged. =head1 DESCRIPTION C<Fatal> provides a way to conveniently replace functions which normally return a false value when they fail with equivalents which raise exceptions if they are not successful. This lets you use these functions without having to test their return values explicitly on each call. Exceptions can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details. The do-or-die equivalents are set up simply by calling Fatal's C<import> routine, passing it the names of the functions to be replaced. You may wrap both user-defined functions and overridable CORE operators (except C<exec>, C<system>, C<print>, or any other built-in that cannot be expressed via prototypes) in this way. If the symbol C<:void> appears in the import list, then functions named later in that import list raise an exception only when these are called in void context--that is, when their return values are ignored. For example use Fatal qw/:void open close/; # properly checked, so no exception raised on error if (not open(my $fh, '<', '/bogotic') { warn "Can't open /bogotic: $!"; } # not checked, so error raises an exception close FH; The use of C<:void> is discouraged, as it can result in exceptions not being thrown if you I<accidentally> call a method without void context. Use L<autodie> instead if you need to be able to disable autodying/Fatal behaviour for a small block of code. =head1 DIAGNOSTICS =over 4 =item Bad subroutine name for Fatal: %s You've called C<Fatal> with an argument that doesn't look like a subroutine name, nor a switch that this version of Fatal understands. =item %s is not a Perl subroutine You've asked C<Fatal> to try and replace a subroutine which does not exist, or has not yet been defined. =item %s is neither a builtin, nor a Perl subroutine You've asked C<Fatal> to replace a subroutine, but it's not a Perl built-in, and C<Fatal> couldn't find it as a regular subroutine. It either doesn't exist or has not yet been defined. =item Cannot make the non-overridable %s fatal You've tried to use C<Fatal> on a Perl built-in that can't be overridden, such as C<print> or C<system>, which means that C<Fatal> can't help you, although some other modules might. See the L</"SEE ALSO"> section of this documentation. =item Internal error: %s You've found a bug in C<Fatal>. Please report it using the C<perlbug> command. =back =head1 BUGS C<Fatal> clobbers the context in which a function is called and always makes it a scalar context, except when the C<:void> tag is used. This problem does not exist in L<autodie>. "Used only once" warnings can be generated when C<autodie> or C<Fatal> is used with package filehandles (eg, C<FILE>). It's strongly recommended you use scalar filehandles instead. =head1 AUTHOR Original module by Lionel Cons (CERN). Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>. L<autodie> support, bugfixes, extended diagnostics, C<system> support, and major overhauling by Paul Fenwick <pjf@perltraining.com.au> =head1 LICENSE This module is free software, you may distribute it under the same terms as Perl itself. =head1 SEE ALSO L<autodie> for a nicer way to use lexical Fatal. L<IPC::System::Simple> for a similar idea for calls to C<system()> and backticks. =for Pod::Coverage exception_class fill_protos one_invocation throw write_invocation ERROR_NO_IPC_SYS_SIMPLE LEXICAL_TAG =cut File/Find.pm 0000644 00000100503 15027445044 0006645 0 ustar 00 package File::Find; use 5.006; use strict; use warnings; use warnings::register; our $VERSION = '1.37'; require Exporter; require Cwd; our @ISA = qw(Exporter); our @EXPORT = qw(find finddepth); use strict; my $Is_VMS = $^O eq 'VMS'; my $Is_Win32 = $^O eq 'MSWin32'; require File::Basename; require File::Spec; # Should ideally be my() not our() but local() currently # refuses to operate on lexicals our %SLnkSeen; our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, $pre_process, $post_process, $dangling_symlinks); sub contract_name { my ($cdir,$fn) = @_; return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir; $cdir = substr($cdir,0,rindex($cdir,'/')+1); $fn =~ s|^\./||; my $abs_name= $cdir . $fn; if (substr($fn,0,3) eq '../') { 1 while $abs_name =~ s!/[^/]*/\.\./+!/!; } return $abs_name; } sub PathCombine($$) { my ($Base,$Name) = @_; my $AbsName; if (substr($Name,0,1) eq '/') { $AbsName= $Name; } else { $AbsName= contract_name($Base,$Name); } # (simple) check for recursion my $newlen= length($AbsName); if ($newlen <= length($Base)) { if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') && $AbsName eq substr($Base,0,$newlen)) { return undef; } } return $AbsName; } sub Follow_SymLink($) { my ($AbsName) = @_; my ($NewName,$DEV, $INO); ($DEV, $INO)= lstat $AbsName; while (-l _) { if ($SLnkSeen{$DEV, $INO}++) { if ($follow_skip < 2) { die "$AbsName is encountered a second time"; } else { return undef; } } $NewName= PathCombine($AbsName, readlink($AbsName)); unless(defined $NewName) { if ($follow_skip < 2) { die "$AbsName is a recursive symbolic link"; } else { return undef; } } else { $AbsName= $NewName; } ($DEV, $INO) = lstat($AbsName); return undef unless defined $DEV; # dangling symbolic link } if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) { if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) { die "$AbsName encountered a second time"; } else { return undef; } } return $AbsName; } our($dir, $name, $fullname, $prune); sub _find_dir_symlnk($$$); sub _find_dir($$$); # check whether or not a scalar variable is tainted # (code straight from the Camel, 3rd ed., page 561) sub is_tainted_pp { my $arg = shift; my $nada = substr($arg, 0, 0); # zero-length local $@; eval { eval "# $nada" }; return length($@) != 0; } sub _find_opt { my $wanted = shift; return unless @_; die "invalid top directory" unless defined $_[0]; # This function must local()ize everything because callbacks may # call find() or finddepth() local %SLnkSeen; local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, $pre_process, $post_process, $dangling_symlinks); local($dir, $name, $fullname, $prune); local *_ = \my $a; my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd(); if ($Is_VMS) { # VMS returns this by default in VMS format which just doesn't # work for the rest of this module. $cwd = VMS::Filespec::unixpath($cwd); # Apparently this is not expected to have a trailing space. # To attempt to make VMS/UNIX conversions mostly reversible, # a trailing slash is needed. The run-time functions ignore the # resulting double slash, but it causes the perl tests to fail. $cwd =~ s#/\z##; # This comes up in upper case now, but should be lower. # In the future this could be exact case, no need to change. } my $cwd_untainted = $cwd; my $check_t_cwd = 1; $wanted_callback = $wanted->{wanted}; $bydepth = $wanted->{bydepth}; $pre_process = $wanted->{preprocess}; $post_process = $wanted->{postprocess}; $no_chdir = $wanted->{no_chdir}; $full_check = $Is_Win32 ? 0 : $wanted->{follow}; $follow = $Is_Win32 ? 0 : $full_check || $wanted->{follow_fast}; $follow_skip = $wanted->{follow_skip}; $untaint = $wanted->{untaint}; $untaint_pat = $wanted->{untaint_pattern}; $untaint_skip = $wanted->{untaint_skip}; $dangling_symlinks = $wanted->{dangling_symlinks}; # for compatibility reasons (find.pl, find2perl) local our ($topdir, $topdev, $topino, $topmode, $topnlink); # a symbolic link to a directory doesn't increase the link count $avoid_nlink = $follow || $File::Find::dont_use_nlink; my ($abs_dir, $Is_Dir); Proc_Top_Item: foreach my $TOP (@_) { my $top_item = $TOP; $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS; ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; if ($Is_Win32) { $top_item =~ s|[/\\]\z|| unless $top_item =~ m{^(?:\w:)?[/\\]$}; } else { $top_item =~ s|/\z|| unless $top_item eq '/'; } $Is_Dir= 0; if ($follow) { if (substr($top_item,0,1) eq '/') { $abs_dir = $top_item; } elsif ($top_item eq $File::Find::current_dir) { $abs_dir = $cwd; } else { # care about any ../ $top_item =~ s/\.dir\z//i if $Is_VMS; $abs_dir = contract_name("$cwd/",$top_item); } $abs_dir= Follow_SymLink($abs_dir); unless (defined $abs_dir) { if ($dangling_symlinks) { if (ref $dangling_symlinks eq 'CODE') { $dangling_symlinks->($top_item, $cwd); } else { warnings::warnif "$top_item is a dangling symbolic link\n"; } } next Proc_Top_Item; } if (-d _) { $top_item =~ s/\.dir\z//i if $Is_VMS; _find_dir_symlnk($wanted, $abs_dir, $top_item); $Is_Dir= 1; } } else { # no follow $topdir = $top_item; unless (defined $topnlink) { warnings::warnif "Can't stat $top_item: $!\n"; next Proc_Top_Item; } if (-d _) { $top_item =~ s/\.dir\z//i if $Is_VMS; _find_dir($wanted, $top_item, $topnlink); $Is_Dir= 1; } else { $abs_dir= $top_item; } } unless ($Is_Dir) { unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { ($dir,$_) = ('./', $top_item); } $abs_dir = $dir; if (( $untaint ) && (is_tainted($dir) )) { ( $abs_dir ) = $dir =~ m|$untaint_pat|; unless (defined $abs_dir) { if ($untaint_skip == 0) { die "directory $dir is still tainted"; } else { next Proc_Top_Item; } } } unless ($no_chdir || chdir $abs_dir) { warnings::warnif "Couldn't chdir $abs_dir: $!\n"; next Proc_Top_Item; } $name = $abs_dir . $_; # $File::Find::name $_ = $name if $no_chdir; { $wanted_callback->() }; # protect against wild "next" } unless ( $no_chdir ) { if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) { ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|; unless (defined $cwd_untainted) { die "insecure cwd in find(depth)"; } $check_t_cwd = 0; } unless (chdir $cwd_untainted) { die "Can't cd to $cwd: $!\n"; } } } } # API: # $wanted # $p_dir : "parent directory" # $nlink : what came back from the stat # preconditions: # chdir (if not no_chdir) to dir sub _find_dir($$$) { my ($wanted, $p_dir, $nlink) = @_; my ($CdLvl,$Level) = (0,0); my @Stack; my @filenames; my ($subcount,$sub_nlink); my $SE= []; my $dir_name= $p_dir; my $dir_pref; my $dir_rel = $File::Find::current_dir; my $tainted = 0; my $no_nlink; if ($Is_Win32) { $dir_pref = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" ); } elsif ($Is_VMS) { # VMS is returning trailing .dir on directories # and trailing . on files and symbolic links # in UNIX syntax. # $p_dir =~ s/\.(dir)?$//i unless $p_dir eq '.'; $dir_pref = ($p_dir =~ m/[\]>]+$/ ? $p_dir : "$p_dir/" ); } else { $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); } local ($dir, $name, $prune, *DIR); unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) { my $udir = $p_dir; if (( $untaint ) && (is_tainted($p_dir) )) { ( $udir ) = $p_dir =~ m|$untaint_pat|; unless (defined $udir) { if ($untaint_skip == 0) { die "directory $p_dir is still tainted"; } else { return; } } } unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { warnings::warnif "Can't cd to $udir: $!\n"; return; } } # push the starting directory push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; while (defined $SE) { unless ($bydepth) { $dir= $p_dir; # $File::Find::dir $name= $dir_name; # $File::Find::name $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ # prune may happen here $prune= 0; { $wanted_callback->() }; # protect against wild "next" next if $prune; } # change to that directory unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { my $udir= $dir_rel; if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) { ( $udir ) = $dir_rel =~ m|$untaint_pat|; unless (defined $udir) { if ($untaint_skip == 0) { die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; } else { # $untaint_skip == 1 next; } } } unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { warnings::warnif "Can't cd to (" . ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; next; } $CdLvl++; } $dir= $dir_name; # $File::Find::dir # Get the list of files in the current directory. unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) { warnings::warnif "Can't opendir($dir_name): $!\n"; next; } @filenames = readdir DIR; closedir(DIR); @filenames = $pre_process->(@filenames) if $pre_process; push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; # default: use whatever was specified # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) $no_nlink = $avoid_nlink; # if dir has wrong nlink count, force switch to slower stat method $no_nlink = 1 if ($nlink < 2); if ($nlink == 2 && !$no_nlink) { # This dir has no subdirectories. for my $FN (@filenames) { if ($Is_VMS) { # Big hammer here - Compensate for VMS trailing . and .dir # No win situation until this is changed, but this # will handle the majority of the cases with breaking the fewest $FN =~ s/\.dir\z//i; $FN =~ s#\.$## if ($FN ne '.'); } next if $FN =~ $File::Find::skip_pattern; $name = $dir_pref . $FN; # $File::Find::name $_ = ($no_chdir ? $name : $FN); # $_ { $wanted_callback->() }; # protect against wild "next" } } else { # This dir has subdirectories. $subcount = $nlink - 2; # HACK: insert directories at this position, so as to preserve # the user pre-processed ordering of files (thus ensuring # directory traversal is in user sorted order, not at random). my $stack_top = @Stack; for my $FN (@filenames) { next if $FN =~ $File::Find::skip_pattern; if ($subcount > 0 || $no_nlink) { # Seen all the subdirs? # check for directoriness. # stat is faster for a file in the current directory $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; if (-d _) { --$subcount; $FN =~ s/\.dir\z//i if $Is_VMS; # HACK: replace push to preserve dir traversal order #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; splice @Stack, $stack_top, 0, [$CdLvl,$dir_name,$FN,$sub_nlink]; } else { $name = $dir_pref . $FN; # $File::Find::name $_= ($no_chdir ? $name : $FN); # $_ { $wanted_callback->() }; # protect against wild "next" } } else { $name = $dir_pref . $FN; # $File::Find::name $_= ($no_chdir ? $name : $FN); # $_ { $wanted_callback->() }; # protect against wild "next" } } } } continue { while ( defined ($SE = pop @Stack) ) { ($Level, $p_dir, $dir_rel, $nlink) = @$SE; if ($CdLvl > $Level && !$no_chdir) { my $tmp; if ($Is_VMS) { $tmp = '[' . ('-' x ($CdLvl-$Level)) . ']'; } else { $tmp = join('/',('..') x ($CdLvl-$Level)); } die "Can't cd to $tmp from $dir_name: $!" unless chdir ($tmp); $CdLvl = $Level; } if ($Is_Win32) { $dir_name = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"); $dir_pref = "$dir_name/"; } elsif ($^O eq 'VMS') { if ($p_dir =~ m/[\]>]+$/) { $dir_name = $p_dir; $dir_name =~ s/([\]>]+)$/.$dir_rel$1/; $dir_pref = $dir_name; } else { $dir_name = "$p_dir/$dir_rel"; $dir_pref = "$dir_name/"; } } else { $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); $dir_pref = "$dir_name/"; } if ( $nlink == -2 ) { $name = $dir = $p_dir; # $File::Find::name / dir $_ = $File::Find::current_dir; $post_process->(); # End-of-directory processing } elsif ( $nlink < 0 ) { # must be finddepth, report dirname now $name = $dir_name; if ( substr($name,-2) eq '/.' ) { substr($name, length($name) == 2 ? -1 : -2) = ''; } $dir = $p_dir; $_ = ($no_chdir ? $dir_name : $dir_rel ); if ( substr($_,-2) eq '/.' ) { substr($_, length($_) == 2 ? -1 : -2) = ''; } { $wanted_callback->() }; # protect against wild "next" } else { push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; last; } } } } # API: # $wanted # $dir_loc : absolute location of a dir # $p_dir : "parent directory" # preconditions: # chdir (if not no_chdir) to dir sub _find_dir_symlnk($$$) { my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory my @Stack; my @filenames; my $new_loc; my $updir_loc = $dir_loc; # untainted parent directory my $SE = []; my $dir_name = $p_dir; my $dir_pref; my $loc_pref; my $dir_rel = $File::Find::current_dir; my $byd_flag; # flag for pending stack entry if $bydepth my $tainted = 0; my $ok = 1; $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); local ($dir, $name, $fullname, $prune, *DIR); unless ($no_chdir) { # untaint the topdir if (( $untaint ) && (is_tainted($dir_loc) )) { ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted # once untainted, $updir_loc is pushed on the stack (as parent directory); # hence, we don't need to untaint the parent directory every time we chdir # to it later unless (defined $updir_loc) { if ($untaint_skip == 0) { die "directory $dir_loc is still tainted"; } else { return; } } } $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir); unless ($ok) { warnings::warnif "Can't cd to $updir_loc: $!\n"; return; } } push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth; while (defined $SE) { unless ($bydepth) { # change (back) to parent directory (always untainted) unless ($no_chdir) { unless (chdir $updir_loc) { warnings::warnif "Can't cd to $updir_loc: $!\n"; next; } } $dir= $p_dir; # $File::Find::dir $name= $dir_name; # $File::Find::name $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ $fullname= $dir_loc; # $File::Find::fullname # prune may happen here $prune= 0; lstat($_); # make sure file tests with '_' work { $wanted_callback->() }; # protect against wild "next" next if $prune; } # change to that directory unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { $updir_loc = $dir_loc; if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) { # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; unless (defined $updir_loc) { if ($untaint_skip == 0) { die "directory $dir_loc is still tainted"; } else { next; } } } unless (chdir $updir_loc) { warnings::warnif "Can't cd to $updir_loc: $!\n"; next; } } $dir = $dir_name; # $File::Find::dir # Get the list of files in the current directory. unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) { warnings::warnif "Can't opendir($dir_loc): $!\n"; next; } @filenames = readdir DIR; closedir(DIR); for my $FN (@filenames) { if ($Is_VMS) { # Big hammer here - Compensate for VMS trailing . and .dir # No win situation until this is changed, but this # will handle the majority of the cases with breaking the fewest. $FN =~ s/\.dir\z//i; $FN =~ s#\.$## if ($FN ne '.'); } next if $FN =~ $File::Find::skip_pattern; # follow symbolic links / do an lstat $new_loc = Follow_SymLink($loc_pref.$FN); # ignore if invalid symlink unless (defined $new_loc) { if (!defined -l _ && $dangling_symlinks) { $fullname = undef; if (ref $dangling_symlinks eq 'CODE') { $dangling_symlinks->($FN, $dir_pref); } else { warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; } } else { $fullname = $loc_pref . $FN; } $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); { $wanted_callback->() }; next; } if (-d _) { if ($Is_VMS) { $FN =~ s/\.dir\z//i; $FN =~ s#\.$## if ($FN ne '.'); $new_loc =~ s/\.dir\z//i; $new_loc =~ s#\.$## if ($new_loc ne '.'); } push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1]; } else { $fullname = $new_loc; # $File::Find::fullname $name = $dir_pref . $FN; # $File::Find::name $_ = ($no_chdir ? $name : $FN); # $_ { $wanted_callback->() }; # protect against wild "next" } } } continue { while (defined($SE = pop @Stack)) { ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); $dir_pref = "$dir_name/"; $loc_pref = "$dir_loc/"; if ( $byd_flag < 0 ) { # must be finddepth, report dirname now unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted warnings::warnif "Can't cd to $updir_loc: $!\n"; next; } } $fullname = $dir_loc; # $File::Find::fullname $name = $dir_name; # $File::Find::name if ( substr($name,-2) eq '/.' ) { substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name } $dir = $p_dir; # $File::Find::dir $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ if ( substr($_,-2) eq '/.' ) { substr($_, length($_) == 2 ? -1 : -2) = ''; } lstat($_); # make sure file tests with '_' work { $wanted_callback->() }; # protect against wild "next" } else { push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth; last; } } } } sub wrap_wanted { my $wanted = shift; if ( ref($wanted) eq 'HASH' ) { # RT #122547 my %valid_options = map {$_ => 1} qw( wanted bydepth preprocess postprocess follow follow_fast follow_skip dangling_symlinks no_chdir untaint untaint_pattern untaint_skip ); my @invalid_options = (); for my $v (keys %{$wanted}) { push @invalid_options, $v unless exists $valid_options{$v}; } warn "Invalid option(s): @invalid_options" if @invalid_options; unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { die 'no &wanted subroutine given'; } if ( $wanted->{follow} || $wanted->{follow_fast}) { $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; } if ( $wanted->{untaint} ) { $wanted->{untaint_pattern} = $File::Find::untaint_pattern unless defined $wanted->{untaint_pattern}; $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; } return $wanted; } elsif( ref( $wanted ) eq 'CODE' ) { return { wanted => $wanted }; } else { die 'no &wanted subroutine given'; } } sub find { my $wanted = shift; _find_opt(wrap_wanted($wanted), @_); } sub finddepth { my $wanted = wrap_wanted(shift); $wanted->{bydepth} = 1; _find_opt($wanted, @_); } # default $File::Find::skip_pattern = qr/^\.{1,2}\z/; $File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; # this _should_ work properly on all platforms # where File::Find can be expected to work $File::Find::current_dir = File::Spec->curdir || '.'; $File::Find::dont_use_nlink = 1; # We need a function that checks if a scalar is tainted. Either use the # Scalar::Util module's tainted() function or our (slower) pure Perl # fallback is_tainted_pp() { local $@; eval { require Scalar::Util }; *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted; } 1; __END__ =head1 NAME File::Find - Traverse a directory tree. =head1 SYNOPSIS use File::Find; find(\&wanted, @directories_to_search); sub wanted { ... } use File::Find; finddepth(\&wanted, @directories_to_search); sub wanted { ... } use File::Find; find({ wanted => \&process, follow => 1 }, '.'); =head1 DESCRIPTION These are functions for searching through directory trees doing work on each file found similar to the Unix I<find> command. File::Find exports two functions, C<find> and C<finddepth>. They work similarly but have subtle differences. =over 4 =item B<find> find(\&wanted, @directories); find(\%options, @directories); C<find()> does a depth-first search over the given C<@directories> in the order they are given. For each file or directory found, it calls the C<&wanted> subroutine. (See below for details on how to use the C<&wanted> function). Additionally, for each directory found, it will C<chdir()> into that directory and continue the search, invoking the C<&wanted> function on each file or subdirectory in the directory. =item B<finddepth> finddepth(\&wanted, @directories); finddepth(\%options, @directories); C<finddepth()> works just like C<find()> except that it invokes the C<&wanted> function for a directory I<after> invoking it for the directory's contents. It does a postorder traversal instead of a preorder traversal, working from the bottom of the directory tree up where C<find()> works from the top of the tree down. =back =head2 %options The first argument to C<find()> is either a code reference to your C<&wanted> function, or a hash reference describing the operations to be performed for each file. The code reference is described in L</The wanted function> below. Here are the possible keys for the hash: =over 3 =item C<wanted> The value should be a code reference. This code reference is described in L</The wanted function> below. The C<&wanted> subroutine is mandatory. =item C<bydepth> Reports the name of a directory only AFTER all its entries have been reported. Entry point C<finddepth()> is a shortcut for specifying C<< { bydepth => 1 } >> in the first argument of C<find()>. =item C<preprocess> The value should be a code reference. This code reference is used to preprocess the current directory. The name of the currently processed directory is in C<$File::Find::dir>. Your preprocessing function is called after C<readdir()>, but before the loop that calls the C<wanted()> function. It is called with a list of strings (actually file/directory names) and is expected to return a list of strings. The code can be used to sort the file/directory names alphabetically, numerically, or to filter out directory entries based on their name alone. When I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. =item C<postprocess> The value should be a code reference. It is invoked just before leaving the currently processed directory. It is called in void context with no arguments. The name of the current directory is in C<$File::Find::dir>. This hook is handy for summarizing a directory, such as calculating its disk usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a no-op. =item C<follow> Causes symbolic links to be followed. Since directory trees with symbolic links (followed) may contain files more than once and may even have cycles, a hash has to be built up with an entry for each file. This might be expensive both in space and time for a large directory tree. See L</follow_fast> and L</follow_skip> below. If either I<follow> or I<follow_fast> is in effect: =over 6 =item * It is guaranteed that an I<lstat> has been called before the user's C<wanted()> function is called. This enables fast file checks involving C<_>. Note that this guarantee no longer holds if I<follow> or I<follow_fast> are not set. =item * There is a variable C<$File::Find::fullname> which holds the absolute pathname of the file with all symbolic links resolved. If the link is a dangling symbolic link, then fullname will be set to C<undef>. =back This is a no-op on Win32. =item C<follow_fast> This is similar to I<follow> except that it may report some files more than once. It does detect cycles, however. Since only symbolic links have to be hashed, this is much cheaper both in space and time. If processing a file more than once (by the user's C<wanted()> function) is worse than just taking time, the option I<follow> should be used. This is also a no-op on Win32. =item C<follow_skip> C<follow_skip==1>, which is the default, causes all files which are neither directories nor symbolic links to be ignored if they are about to be processed a second time. If a directory or a symbolic link are about to be processed a second time, File::Find dies. C<follow_skip==0> causes File::Find to die if any file is about to be processed a second time. C<follow_skip==2> causes File::Find to ignore any duplicate files and directories but to proceed normally otherwise. =item C<dangling_symlinks> Specifies what to do with symbolic links whose target doesn't exist. If true and a code reference, will be called with the symbolic link name and the directory it lives in as arguments. Otherwise, if true and warnings are on, a warning of the form C<"symbolic_link_name is a dangling symbolic link\n"> will be issued. If false, the dangling symbolic link will be silently ignored. =item C<no_chdir> Does not C<chdir()> to each directory as it recurses. The C<wanted()> function will need to be aware of this, of course. In this case, C<$_> will be the same as C<$File::Find::name>. =item C<untaint> If find is used in L<taint-mode|perlsec/Taint mode> (-T command line switch or if EUID != UID or if EGID != GID), then internally directory names have to be untainted before they can be C<chdir>'d to. Therefore they are checked against a regular expression I<untaint_pattern>. Note that all names passed to the user's C<wanted()> function are still tainted. If this option is used while not in taint-mode, C<untaint> is a no-op. =item C<untaint_pattern> See above. This should be set using the C<qr> quoting operator. The default is set to C<qr|^([-+@\w./]+)$|>. Note that the parentheses are vital. =item C<untaint_skip> If set, a directory which fails the I<untaint_pattern> is skipped, including all its sub-directories. The default is to C<die> in such a case. =back =head2 The wanted function The C<wanted()> function does whatever verifications you want on each file and directory. Note that despite its name, the C<wanted()> function is a generic callback function, and does B<not> tell File::Find if a file is "wanted" or not. In fact, its return value is ignored. The wanted function takes no arguments but rather does its work through a collection of variables. =over 4 =item C<$File::Find::dir> is the current directory name, =item C<$_> is the current filename within that directory =item C<$File::Find::name> is the complete pathname to the file. =back The above variables have all been localized and may be changed without affecting data outside of the wanted function. For example, when examining the file F</some/path/foo.ext> you will have: $File::Find::dir = /some/path/ $_ = foo.ext $File::Find::name = /some/path/foo.ext You are chdir()'d to C<$File::Find::dir> when the function is called, unless C<no_chdir> was specified. Note that when changing to directories is in effect, the root directory (F</>) is a somewhat special case inasmuch as the concatenation of C<$File::Find::dir>, C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The table below summarizes all variants: $File::Find::name $File::Find::dir $_ default / / . no_chdir=>0 /etc / etc /etc/x /etc x no_chdir=>1 / / / /etc / /etc /etc/x /etc /etc/x When C<follow> or C<follow_fast> are in effect, there is also a C<$File::Find::fullname>. The function may set C<$File::Find::prune> to prune the tree unless C<bydepth> was specified. Unless C<follow> or C<follow_fast> is specified, for compatibility reasons (find.pl, find2perl) there are in addition the following globals available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C<find2perl> tool (distributed as part of the App-find2perl CPAN distribution), which when fed, find2perl / -name .nfs\* -mtime +7 \ -exec rm -f {} \; -o -fstype nfs -prune produces something like: sub wanted { /^\.nfs.*\z/s && (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && int(-M _) > 7 && unlink($_) || ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && $dev < 0 && ($File::Find::prune = 1); } Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical filehandle that caches the information from the preceding C<stat()>, C<lstat()>, or filetest. Here's another interesting wanted function. It will find all symbolic links that don't resolve: sub wanted { -l && !-e && print "bogus link: $File::Find::name\n"; } Note that you may mix directories and (non-directory) files in the list of directories to be searched by the C<wanted()> function. find(\&wanted, "./foo", "./bar", "./baz/epsilon"); In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be evaluated by C<wanted()>. See also the script C<pfind> on CPAN for a nice application of this module. =head1 WARNINGS If you run your program with the C<-w> switch, or if you use the C<warnings> pragma, File::Find will report warnings for several weird situations. You can disable these warnings by putting the statement no warnings 'File::Find'; in the appropriate scope. See L<warnings> for more info about lexical warnings. =head1 CAVEAT =over 2 =item $dont_use_nlink You can set the variable C<$File::Find::dont_use_nlink> to 0 if you are sure the filesystem you are scanning reflects the number of subdirectories in the parent directory's C<nlink> count. If you do set C<$File::Find::dont_use_nlink> to 0, you may notice an improvement in speed at the risk of not recursing into subdirectories if a filesystem doesn't populate C<nlink> as expected. C<$File::Find::dont_use_nlink> now defaults to 1 on all platforms. =item symlinks Be aware that the option to follow symbolic links can be dangerous. Depending on the structure of the directory tree (including symbolic links to directories) you might traverse a given (physical) directory more than once (only if C<follow_fast> is in effect). Furthermore, deleting or changing files in a symbolically linked directory might cause very unpleasant surprises, since you delete or change files in an unknown directory. =back =head1 BUGS AND CAVEATS Despite the name of the C<finddepth()> function, both C<find()> and C<finddepth()> perform a depth-first search of the directory hierarchy. =head1 HISTORY File::Find used to produce incorrect results if called recursively. During the development of perl 5.8 this bug was fixed. The first fixed version of File::Find was 1.01. =head1 SEE ALSO L<find(1)>, find2perl. =cut File/Find/Rule.pm 0000644 00000050274 15027445044 0007565 0 ustar 00 # $Id$ package File::Find::Rule; use strict; use File::Spec; use Text::Glob 'glob_to_regex'; use Number::Compare; use Carp qw/croak/; use File::Find (); # we're only wrapping for now our $VERSION = '0.34'; # we'd just inherit from Exporter, but I want the colon sub import { my $pkg = shift; my $to = caller; for my $sym ( qw( find rule ) ) { no strict 'refs'; *{"$to\::$sym"} = \&{$sym}; } for (grep /^:/, @_) { my ($extension) = /^:(.*)/; eval "require File::Find::Rule::$extension"; croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; } } =head1 NAME File::Find::Rule - Alternative interface to File::Find =head1 SYNOPSIS use File::Find::Rule; # find all the subdirectories of a given directory my @subdirs = File::Find::Rule->directory->in( $directory ); # find all the .pm files in @INC my @files = File::Find::Rule->file() ->name( '*.pm' ) ->in( @INC ); # as above, but without method chaining my $rule = File::Find::Rule->new; $rule->file; $rule->name( '*.pm' ); my @files = $rule->in( @INC ); =head1 DESCRIPTION File::Find::Rule is a friendlier interface to File::Find. It allows you to build rules which specify the desired files and directories. =cut # the procedural shim *rule = \&find; sub find { my $object = __PACKAGE__->new(); my $not = 0; while (@_) { my $method = shift; my @args; if ($method =~ s/^\!//) { # jinkies, we're really negating this unshift @_, $method; $not = 1; next; } unless (defined prototype $method) { my $args = shift; @args = ref $args eq 'ARRAY' ? @$args : $args; } if ($not) { $not = 0; @args = $object->new->$method(@args); $method = "not"; } my @return = $object->$method(@args); return @return if $method eq 'in'; } $object; } =head1 METHODS =over =item C<new> A constructor. You need not invoke C<new> manually unless you wish to, as each of the rule-making methods will auto-create a suitable object if called as class methods. =cut sub new { my $referent = shift; my $class = ref $referent || $referent; bless { rules => [], subs => {}, iterator => [], extras => {}, maxdepth => undef, mindepth => undef, }, $class; } sub _force_object { my $object = shift; $object = $object->new() unless ref $object; $object; } =back =head2 Matching Rules =over =item C<name( @patterns )> Specifies names that should match. May be globs or regular expressions. $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex $set->name( 'foo.bar' ); # just things named foo.bar =cut sub _flatten { my @flat; while (@_) { my $item = shift; ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; } return @flat; } sub name { my $self = _force_object shift; my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); push @{ $self->{rules} }, { rule => 'name', code => join( ' || ', map { "m{$_}" } @names ), args => \@_, }; $self; } =item -X tests Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for details. None of these methods take arguments. Test | Method Test | Method ------|------------- ------|---------------- -r | readable -R | r_readable -w | writeable -W | r_writeable -w | writable -W | r_writable -x | executable -X | r_executable -o | owned -O | r_owned | | -e | exists -f | file -z | empty -d | directory -s | nonempty -l | symlink | -p | fifo -u | setuid -S | socket -g | setgid -b | block -k | sticky -c | character | -t | tty -M | modified | -A | accessed -T | ascii -C | changed -B | binary Though some tests are fairly meaningless as binary flags (C<modified>, C<accessed>, C<changed>), they have been included for completeness. # find nonempty files $rule->file, ->nonempty; =cut use vars qw( %X_tests ); %X_tests = ( -r => readable => -R => r_readable => -w => writeable => -W => r_writeable => -w => writable => -W => r_writable => -x => executable => -X => r_executable => -o => owned => -O => r_owned => -e => exists => -f => file => -z => empty => -d => directory => -s => nonempty => -l => symlink => => -p => fifo => -u => setuid => -S => socket => -g => setgid => -b => block => -k => sticky => -c => character => => -t => tty => -M => modified => -A => accessed => -T => ascii => -C => changed => -B => binary => ); for my $test (keys %X_tests) { my $sub = eval 'sub () { my $self = _force_object shift; push @{ $self->{rules} }, { code => "' . $test . ' \$_", rule => "'.$X_tests{$test}.'", }; $self; } '; no strict 'refs'; *{ $X_tests{$test} } = $sub; } =item stat tests The following C<stat> based methods are provided: C<dev>, C<ino>, C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>, C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat> for details. Each of these can take a number of targets, which will follow L<Number::Compare> semantics. $rule->size( 7 ); # exactly 7 $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes $rule->size( ">=7" ) ->size( "<=90" ); # between 7 and 90, inclusive $rule->size( 7, 9, 42 ); # 7, 9 or 42 =cut use vars qw( @stat_tests ); @stat_tests = qw( dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks ); { my $i = 0; for my $test (@stat_tests) { my $index = $i++; # to close over my $sub = sub { my $self = _force_object shift; my @tests = map { Number::Compare->parse_to_perl($_) } @_; push @{ $self->{rules} }, { rule => $test, args => \@_, code => 'do { my $val = (stat $_)['.$index.'] || 0;'. join ('||', map { "(\$val $_)" } @tests ).' }', }; $self; }; no strict 'refs'; *$test = $sub; } } =item C<any( @rules )> =item C<or( @rules )> Allows shortcircuiting boolean evaluation as an alternative to the default and-like nature of combined rules. C<any> and C<or> are interchangeable. # find avis, movs, things over 200M and empty files $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), File::Find::Rule->size( '>200M' ), File::Find::Rule->file->empty, ); =cut sub any { my $self = _force_object shift; # compile all the subrules to code fragments push @{ $self->{rules} }, { rule => "any", code => '(' . join( ' || ', map '( ' . $_->_compile . ' )', @_ ). ')', args => \@_, }; # merge all the subs hashes of the kids into ourself %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; $self; } *or = \&any; =item C<none( @rules )> =item C<not( @rules )> Negates a rule. (The inverse of C<any>.) C<none> and C<not> are interchangeable. # files that aren't 8.3 safe $rule->file ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); =cut sub not { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'not', args => \@_, code => '(' . join ( ' && ', map { "!(". $_->_compile . ")" } @_ ) . ")", }; # merge all the subs hashes into us %{ $self->{subs} } = map { %{ $_->{subs} } } $self, @_; $self; } *none = \¬ =item C<prune> Traverse no further. This rule always matches. =cut sub prune () { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'prune', code => '$File::Find::prune = 1' }; $self; } =item C<discard> Don't keep this file. This rule always matches. =cut sub discard () { my $self = _force_object shift; push @{ $self->{rules} }, { rule => 'discard', code => '$discarded = 1', }; $self; } =item C<exec( \&subroutine( $shortname, $path, $fullname ) )> Allows user-defined rules. Your subroutine will be invoked with C<$_> set to the current short name, and with parameters of the name, the path you're in, and the full relative filename. Return a true value if your rule matched. # get things with long names $rules->exec( sub { length > 20 } ); =cut sub exec { my $self = _force_object shift; my $code = shift; push @{ $self->{rules} }, { rule => 'exec', code => $code, }; $self; } =item C<grep( @specifiers )> Opens a file and tests it each line at a time. For each line it evaluates each of the specifiers, stopping at the first successful match. A specifier may be a regular expression or a subroutine. The subroutine will be invoked with the same parameters as an ->exec subroutine. It is possible to provide a set of negative specifiers by enclosing them in anonymous arrays. Should a negative specifier match the iteration is aborted and the clause is failed. For example: $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); Is a passing clause if the first line of a file looks like a perl shebang line. =cut sub grep { my $self = _force_object shift; my @pattern = map { ref $_ ? ref $_ eq 'ARRAY' ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ : [ $_ => 1 ] : [ qr/$_/ => 1 ] } @_; $self->exec( sub { local *FILE; open FILE, $_ or return; local ($_, $.); while (<FILE>) { for my $p (@pattern) { my ($rule, $ret) = @$p; return $ret if ref $rule eq 'Regexp' ? /$rule/ : $rule->(@_); } } return; } ); } =item C<maxdepth( $level )> Descend at most C<$level> (a non-negative integer) levels of directories below the starting point. May be invoked many times per rule, but only the most recent value is used. =item C<mindepth( $level )> Do not apply any tests at levels less than C<$level> (a non-negative integer). =item C<extras( \%extras )> Specifies extra values to pass through to C<File::File::find> as part of the options hash. For example this allows you to specify following of symlinks like so: my $rule = File::Find::Rule->extras({ follow => 1 }); May be invoked many times per rule, but only the most recent value is used. =cut for my $setter (qw( maxdepth mindepth extras )) { my $sub = sub { my $self = _force_object shift; $self->{$setter} = shift; $self; }; no strict 'refs'; *$setter = $sub; } =item C<relative> Trim the leading portion of any path found =cut sub relative () { my $self = _force_object shift; $self->{relative} = 1; $self; } =item C<canonpath> Normalize paths found using C<File::Spec->canonpath>. This will return paths with a file-seperator that is native to your OS (as determined by L<File::Spec>), instead of the default C</>. For example, this will return C<tmp/foobar> on Unix-ish OSes and C<tmp\foobar> on Win32. =cut sub canonpath () { my $self = _force_object shift; $self->{canonpath} = 1; $self; } =item C<not_*> Negated version of the rule. An effective shortand related to ! in the procedural interface. $foo->not_name('*.pl'); $foo->not( $foo->new->name('*.pl' ) ); =cut sub DESTROY {} sub AUTOLOAD { our $AUTOLOAD; $AUTOLOAD =~ /::not_([^:]*)$/ or croak "Can't locate method $AUTOLOAD"; my $method = $1; my $sub = sub { my $self = _force_object shift; $self->not( $self->new->$method(@_) ); }; { no strict 'refs'; *$AUTOLOAD = $sub; } &$sub; } =back =head2 Query Methods =over =item C<in( @directories )> Evaluates the rule, returns a list of paths to matching files and directories. =cut sub in { my $self = _force_object shift; my @found; my $fragment = $self->_compile; my %subs = %{ $self->{subs} }; warn "relative mode handed multiple paths - that's a bit silly\n" if $self->{relative} && @_ > 1; my $topdir; my $code = 'sub { (my $path = $File::Find::name) =~ s#^(?:\./+)+##; $path = "." if ($path eq ""); # See Debian bug #329377 my @args = ($_, $File::Find::dir, $path); my $maxdepth = $self->{maxdepth}; my $mindepth = $self->{mindepth}; my $relative = $self->{relative}; my $canonpath = $self->{canonpath}; # figure out the relative path and depth my $relpath = $File::Find::name; $relpath =~ s{^\Q$topdir\E/?}{}; my $depth = scalar File::Spec->splitdir($relpath); #print "name: \'$File::Find::name\' "; #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; defined $maxdepth && $depth >= $maxdepth and $File::Find::prune = 1; defined $mindepth && $depth < $mindepth and return; #print "Testing \'$_\'\n"; my $discarded; return unless ' . $fragment . '; return if $discarded; if ($relative) { if ($relpath ne "") { push @found, $canonpath ? File::Spec->canonpath($relpath) : $relpath; } } else { push @found, $canonpath ? File::Spec->canonpath($path) : $path; } }'; #use Data::Dumper; #print Dumper \%subs; #warn "Compiled sub: '$code'\n"; my $sub = eval "$code" or die "compile error '$code' $@"; for my $path (@_) { # $topdir is used for relative and maxdepth $topdir = $path; # slice off the trailing slash if there is one (the # maxdepth/mindepth code is fussy) $topdir =~ s{/?$}{} unless $topdir eq '/'; $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); } return @found; } sub _call_find { my $self = shift; File::Find::find( @_ ); } sub _compile { my $self = shift; return '1' unless @{ $self->{rules} }; my $code = join " && ", map { if (ref $_->{code}) { my $key = "$_->{code}"; $self->{subs}{$key} = $_->{code}; "\$subs{'$key'}->(\@args) # $_->{rule}\n"; } else { "( $_->{code} ) # $_->{rule}\n"; } } @{ $self->{rules} }; #warn $code; return $code; } =item C<start( @directories )> Starts a find across the specified directories. Matching items may then be queried using L</match>. This allows you to use a rule as an iterator. my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); while ( defined ( my $image = $rule->match ) ) { ... } =cut sub start { my $self = _force_object shift; $self->{iterator} = [ $self->in( @_ ) ]; $self; } =item C<match> Returns the next file which matches, false if there are no more. =cut sub match { my $self = _force_object shift; return shift @{ $self->{iterator} }; } 1; __END__ =back =head2 Extensions Extension modules are available from CPAN in the File::Find::Rule namespace. In order to use these extensions either use them directly: use File::Find::Rule::ImageSize; use File::Find::Rule::MMagic; # now your rules can use the clauses supplied by the ImageSize and # MMagic extension or, specify that File::Find::Rule should load them for you: use File::Find::Rule qw( :ImageSize :MMagic ); For notes on implementing your own extensions, consult L<File::Find::Rule::Extending> =head2 Further examples =over =item Finding perl scripts my $finder = File::Find::Rule->or ( File::Find::Rule->name( '*.pl' ), File::Find::Rule->exec( sub { if (open my $fh, $_) { my $shebang = <$fh>; close $fh; return $shebang =~ /^#!.*\bperl/; } return 0; } ), ); Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 =item ignore CVS directories my $rule = File::Find::Rule->new; $rule->or($rule->new ->directory ->name('CVS') ->prune ->discard, $rule->new); Note here the use of a null rule. Null rules match anything they see, so the effect is to match (and discard) directories called 'CVS' or to match anything. =back =head1 TWO FOR THE PRICE OF ONE File::Find::Rule also gives you a procedural interface. This is documented in L<File::Find::Rule::Procedural> =head1 EXPORTS L</find>, L</rule> =head1 TAINT MODE INTERACTION As of 0.32 File::Find::Rule doesn't capture the current working directory in a taint-unsafe manner. File::Find itself still does operations that the taint system will flag as insecure but you can use the L</extras> feature to ask L<File::Find> to internally C<untaint> file paths with a regex like so: my $rule = File::Find::Rule->extras({ untaint => 1 }); Please consult L<File::Find>'s documentation for C<untaint>, C<untaint_pattern>, and C<untaint_skip> for more information. =head1 BUGS The code makes use of the C<our> keyword and as such requires perl version 5.6.0 or newer. Currently it isn't possible to remove a clause from a rule object. If this becomes a significant issue it will be addressed. =head1 AUTHOR Richard Clamp <richardc@unixbeard.net> with input gained from this use.perl discussion: http://use.perl.org/~richardc/journal/6467 Additional proofreading and input provided by Kake, Greg McCarroll, and Andy Lester andy@petdance.com. =head1 COPYRIGHT Copyright (C) 2002, 2003, 2004, 2006, 2009, 2011 Richard Clamp. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1) If you want to know about the procedural interface, see L<File::Find::Rule::Procedural>, and if you have an idea for a neat extension L<File::Find::Rule::Extending> =cut Implementation notes: $self->rules is an array of hashrefs. it may be a code fragment or a call to a subroutine. Anonymous subroutines are stored in the $self->subs hashref keyed on the stringfied version of the coderef. When one File::Find::Rule object is combined with another, such as in the any and not operations, this entire hash is merged. The _compile method walks the rules element and simply glues the code fragments together so they can be compiled into an anyonymous File::Find match sub for speed [*] There's probably a win to be made with the current model in making stat calls use C<_>. For find( file => size => "> 20M" => size => "< 400M" ); up to 3 stats will happen for each candidate. Adding a priming _ would be a bit blind if the first operation was C< name => 'foo' >, since that can be tested by a single regex. Simply checking what the next type of operation doesn't work since any arbritary exec sub may or may not stat. Potentially worse, they could stat something else like so: # extract from the worlds stupidest make(1) find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); Maybe the best way is to treat C<_> as invalid after calling an exec, and doc that C<_> will only be meaningful after stat and -X tests if they're wanted in exec blocks. autodie/Scope/GuardStack.pm 0000644 00000006540 15027445044 0011647 0 ustar 00 package autodie::Scope::GuardStack; use strict; use warnings; use autodie::Scope::Guard; # ABSTRACT: Hook stack for managing scopes via %^H our $VERSION = '2.32'; # 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. autodie/Scope/Guard.pm 0000644 00000002564 15027445044 0010663 0 ustar 00 package autodie::Scope::Guard; use strict; use warnings; # ABSTRACT: Wrapper class for calling subs at end of scope our $VERSION = '2.32'; # 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. autodie/Util.pm 0000644 00000017077 15027445044 0007472 0 ustar 00 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.32'; # 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. autodie.pm 0000644 00000030356 15027445044 0006550 0 ustar 00 package autodie; use 5.008; use strict; use warnings; use parent qw(Fatal); our $VERSION; # ABSTRACT: Replace functions with ones that succeed or die with lexical scope BEGIN { our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ Incorrect version of Fatal.pm loaded by autodie. The autodie pragma uses an updated version of Fatal to do its heavy lifting. We seem to have loaded Fatal version %s, which is probably the version that came with your version of Perl. However autodie needs version %s, which would have come bundled with autodie. You may be able to solve this problem by adding the following line of code to your main program, before any use of Fatal or autodie. use lib "%s"; }; # We have to check we've got the right version of Fatal before we # try to compile the rest of our code, lest we use a constant # that doesn't exist. BEGIN { # If we have the wrong Fatal, then we've probably loaded the system # one, not our own. Complain, and give a useful hint. ;) if (defined($Fatal::VERSION) and defined($VERSION) and $Fatal::VERSION ne $VERSION) { my $autodie_path = $INC{'autodie.pm'}; $autodie_path =~ s/autodie\.pm//; require Carp; Carp::croak sprintf( ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path ); } } # When passing args to Fatal we want to keep the first arg # (our package) in place. Hence the splice. sub import { splice(@_,1,0,Fatal::LEXICAL_TAG); goto &Fatal::import; } sub unimport { splice(@_,1,0,Fatal::LEXICAL_TAG); goto &Fatal::unimport; } 1; __END__ =head1 NAME autodie - Replace functions with ones that succeed or die with lexical scope =head1 SYNOPSIS use autodie; # Recommended: implies 'use autodie qw(:default)' use autodie qw(:all); # Recommended more: defaults and system/exec. use autodie qw(open close); # open/close succeed or die open(my $fh, "<", $filename); # No need to check! { no autodie qw(open); # open failures won't die open(my $fh, "<", $filename); # Could fail silently! no autodie; # disable all autodies } print "Hello World" or die $!; # autodie DOESN'T check print! =head1 DESCRIPTION bIlujDI' yIchegh()Qo'; yIHegh()! It is better to die() than to return() in failure. -- Klingon programming proverb. The C<autodie> pragma provides a convenient way to replace functions that normally return false on failure with equivalents that throw an exception on failure. The C<autodie> pragma has I<lexical scope>, meaning that functions and subroutines altered with C<autodie> will only change their behaviour until the end of the enclosing block, file, or C<eval>. If C<system> is specified as an argument to C<autodie>, then it uses L<IPC::System::Simple> to do the heavy lifting. See the description of that module for more information. =head1 EXCEPTIONS Exceptions produced by the C<autodie> pragma are members of the L<autodie::exception> class. The preferred way to work with these exceptions under Perl 5.10 is as follows: eval { use autodie; open(my $fh, '<', $some_file); my @records = <$fh>; # Do things with @records... close($fh); }; if ($@ and $@->isa('autodie::exception')) { if ($@->matches('open')) { print "Error from open\n"; } if ($@->matches(':io' )) { print "Non-open, IO error."; } } elsif ($@) { # A non-autodie exception. } See L<autodie::exception> for further information on interrogating exceptions. =head1 CATEGORIES Autodie uses a simple set of categories to group together similar built-ins. Requesting a category type (starting with a colon) will enable autodie for all built-ins beneath that category. For example, requesting C<:file> will enable autodie for C<close>, C<fcntl>, C<open> and C<sysopen>. The categories are currently: :all :default :io read seek sysread sysseek syswrite :dbm dbmclose dbmopen :file binmode close chmod chown fcntl flock ioctl open sysopen truncate :filesys chdir closedir opendir link mkdir readlink rename rmdir symlink unlink :ipc kill pipe :msg msgctl msgget msgrcv msgsnd :semaphore semctl semget semop :shm shmctl shmget shmread :socket accept bind connect getsockopt listen recv send setsockopt shutdown socketpair :threads fork :system system exec Note that while the above category system is presently a strict hierarchy, this should not be assumed. A plain C<use autodie> implies C<use autodie qw(:default)>. Note that C<system> and C<exec> are not enabled by default. C<system> requires the optional L<IPC::System::Simple> module to be installed, and enabling C<system> or C<exec> will invalidate their exotic forms. See L</BUGS> below for more details. The syntax: use autodie qw(:1.994); allows the C<:default> list from a particular version to be used. This provides the convenience of using the default methods, but the surety that no behavioral changes will occur if the C<autodie> module is upgraded. C<autodie> can be enabled for all of Perl's built-ins, including C<system> and C<exec> with: use autodie qw(:all); =head1 FUNCTION SPECIFIC NOTES =head2 print The autodie pragma B<does not check calls to C<print>Z<>>. =head2 flock It is not considered an error for C<flock> to return false if it fails due to an C<EWOULDBLOCK> (or equivalent) condition. This means one can still use the common convention of testing the return value of C<flock> when called with the C<LOCK_NB> option: use autodie; if ( flock($fh, LOCK_EX | LOCK_NB) ) { # We have a lock } Autodying C<flock> will generate an exception if C<flock> returns false with any other error. =head2 system/exec The C<system> built-in is considered to have failed in the following circumstances: =over 4 =item * The command does not start. =item * The command is killed by a signal. =item * The command returns a non-zero exit value (but see below). =back On success, the autodying form of C<system> returns the I<exit value> rather than the contents of C<$?>. Additional allowable exit values can be supplied as an optional first argument to autodying C<system>: system( [ 0, 1, 2 ], $cmd, @args); # 0,1,2 are good exit values C<autodie> uses the L<IPC::System::Simple> module to change C<system>. See its documentation for further information. Applying C<autodie> to C<system> or C<exec> causes the exotic forms C<system { $cmd } @args > or C<exec { $cmd } @args> to be considered a syntax error until the end of the lexical scope. If you really need to use the exotic form, you can call C<CORE::system> or C<CORE::exec> instead, or use C<no autodie qw(system exec)> before calling the exotic form. =head1 GOTCHAS Functions called in list context are assumed to have failed if they return an empty list, or a list consisting only of a single undef element. Some builtins (e.g. C<chdir> or C<truncate>) has a call signature that cannot completely be representated with a Perl prototype. This means that some valid Perl code will be invalid under autodie. As an example: chdir(BAREWORD); Without autodie (and assuming BAREWORD is an open filehandle/dirhandle) this is a valid call to chdir. But under autodie, C<chdir> will behave like it had the prototype ";$" and thus BAREWORD will be a syntax error (under "use strict". Without strict, it will interpreted as a filename). =head1 DIAGNOSTICS =over 4 =item :void cannot be used with lexical scope The C<:void> option is supported in L<Fatal>, but not C<autodie>. To workaround this, C<autodie> may be explicitly disabled until the end of the current block with C<no autodie>. To disable autodie for only a single function (eg, open) use C<no autodie qw(open)>. C<autodie> performs no checking of called context to determine whether to throw an exception; the explicitness of error handling with C<autodie> is a deliberate feature. =item No user hints defined for %s You've insisted on hints for user-subroutines, either by pre-pending a C<!> to the subroutine name itself, or earlier in the list of arguments to C<autodie>. However the subroutine in question does not have any hints available. =back See also L<Fatal/DIAGNOSTICS>. =head1 Tips and Tricks =head2 Importing autodie into another namespace than "caller" It is possible to import autodie into a different namespace by using L<Import::Into>. However, you have to pass a "caller depth" (rather than a package name) for this to work correctly. =head1 BUGS "Used only once" warnings can be generated when C<autodie> or C<Fatal> is used with package filehandles (eg, C<FILE>). Scalar filehandles are strongly recommended instead. When using C<autodie> or C<Fatal> with user subroutines, the declaration of those subroutines must appear before the first use of C<Fatal> or C<autodie>, or have been exported from a module. Attempting to use C<Fatal> or C<autodie> on other user subroutines will result in a compile-time error. Due to a bug in Perl, C<autodie> may "lose" any format which has the same name as an autodying built-in or function. C<autodie> may not work correctly if used inside a file with a name that looks like a string eval, such as F<eval (3)>. =head2 autodie and string eval Due to the current implementation of C<autodie>, unexpected results may be seen when used near or with the string version of eval. I<None of these bugs exist when using block eval>. Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval> statements, although it can be explicitly enabled inside a string C<eval>. Under Perl 5.10 only, using a string eval when C<autodie> is in effect can cause the autodie behaviour to leak into the surrounding scope. This can be worked around by using a C<no autodie> at the end of the scope to explicitly remove autodie's effects, or by avoiding the use of string eval. I<None of these bugs exist when using block eval>. The use of C<autodie> with block eval is considered good practice. =head2 REPORTING BUGS Please report bugs via the GitHub Issue Tracker at L<https://github.com/pjf/autodie/issues> or via the CPAN Request Tracker at L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie>. =head1 FEEDBACK If you find this module useful, please consider rating it on the CPAN Ratings service at L<http://cpanratings.perl.org/rate?distribution=autodie> . The module author loves to hear how C<autodie> has made your life better (or worse). Feedback can be sent to E<lt>pjf@perltraining.com.auE<gt>. =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. =head1 SEE ALSO L<Fatal>, L<autodie::exception>, L<autodie::hints>, L<IPC::System::Simple> I<Perl tips, autodie> at L<http://perltraining.com.au/tips/2008-08-20.html> =head1 ACKNOWLEDGEMENTS Mark Reed and Roland Giersig -- Klingon translators. See the F<AUTHORS> file for full credits. The latest version of this file can be found at L<https://github.com/pjf/autodie/tree/master/AUTHORS> . =cut if.pm 0000644 00000007033 15027445044 0005510 0 ustar 00 package if; $VERSION = '0.0608'; sub work { my $method = shift() ? 'import' : 'unimport'; unless (@_ >= 2) { my $type = ($method eq 'import') ? 'use' : 'no'; die "Too few arguments to '$type if' (some code returning an empty list in list context?)" } return unless shift; # CONDITION my $p = $_[0]; # PACKAGE (my $file = "$p.pm") =~ s!::!/!g; require $file; # Works even if $_[0] is a keyword (like open) my $m = $p->can($method); goto &$m if $m; } sub import { shift; unshift @_, 1; goto &work } sub unimport { shift; unshift @_, 0; goto &work } 1; __END__ =head1 NAME if - C<use> a Perl module if a condition holds =head1 SYNOPSIS use if CONDITION, "MODULE", ARGUMENTS; no if CONDITION, "MODULE", ARGUMENTS; =head1 DESCRIPTION =head2 C<use if> The C<if> module is used to conditionally load another module. The construct: use if CONDITION, "MODULE", ARGUMENTS; ... will load C<MODULE> only if C<CONDITION> evaluates to true; it has no effect if C<CONDITION> evaluates to false. (The module name, assuming it contains at least one C<::>, must be quoted when C<'use strict "subs";'> is in effect.) If the CONDITION does evaluate to true, then the above line has the same effect as: use MODULE ARGUMENTS; For example, the F<Unicode::UCD> module's F<charinfo> function will use two functions from F<Unicode::Normalize> only if a certain condition is met: use if defined &DynaLoader::boot_DynaLoader, "Unicode::Normalize" => qw(getCombinClass NFD); Suppose you wanted C<ARGUMENTS> to be an empty list, I<i.e.>, to have the effect of: use MODULE (); You can't do this with the C<if> pragma; however, you can achieve exactly this effect, at compile time, with: BEGIN { require MODULE if CONDITION } =head2 C<no if> The C<no if> construct is mainly used to deactivate categories of warnings when those categories would produce superfluous output under specified versions of F<perl>. For example, the C<redundant> category of warnings was introduced in Perl-5.22. This warning flags certain instances of superfluous arguments to C<printf> and C<sprintf>. But if your code was running warnings-free on earlier versions of F<perl> and you don't care about C<redundant> warnings in more recent versions, you can call: use warnings; no if $] >= 5.022, q|warnings|, qw(redundant); my $test = { fmt => "%s", args => [ qw( x y ) ] }; my $result = sprintf $test->{fmt}, @{$test->{args}}; The C<no if> construct assumes that a module or pragma has correctly implemented an C<unimport()> method -- but most modules and pragmata have not. That explains why the C<no if> construct is of limited applicability. =head1 BUGS The current implementation does not allow specification of the required version of the module. =head1 SEE ALSO L<Module::Requires> can be used to conditionally load one or modules, with constraints based on the version of the module. Unlike C<if> though, L<Module::Requires> is not a core module. L<Module::Load::Conditional> provides a number of functions you can use to query what modules are available, and then load one or more of them at runtime. The L<provide> module from CPAN can be used to select one of several possible modules to load based on the version of Perl that is running. =head1 AUTHOR Ilya Zakharevich L<mailto:ilyaz@cpan.org>. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2002 by Ilya Zakharevich. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Tie/RefHash.pm 0000644 00000014135 15027445044 0007154 0 ustar 00 package Tie::RefHash; use vars qw/$VERSION/; $VERSION = "1.39"; use 5.005; =head1 NAME Tie::RefHash - use references as hash keys =head1 SYNOPSIS require 5.004; use Tie::RefHash; tie HASHVARIABLE, 'Tie::RefHash', LIST; tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; untie HASHVARIABLE; =head1 DESCRIPTION This module provides the ability to use references as hash keys if you first C<tie> the hash variable to this module. Normally, only the keys of the tied hash itself are preserved as references; to use references as keys in hashes-of-hashes, use Tie::RefHash::Nestable, included as part of Tie::RefHash. It is implemented using the standard perl TIEHASH interface. Please see the C<tie> entry in perlfunc(1) and perltie(1) for more information. The Nestable version works by looking for hash references being stored and converting them to tied hashes so that they too can have references as keys. This will happen without warning whenever you store a reference to one of your own hashes in the tied hash. =head1 EXAMPLE use Tie::RefHash; tie %h, 'Tie::RefHash'; $a = []; $b = {}; $c = \*main; $d = \"gunk"; $e = sub { 'foo' }; %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); $a->[0] = 'foo'; $b->{foo} = 'bar'; for (keys %h) { print ref($_), "\n"; } tie %h, 'Tie::RefHash::Nestable'; $h{$a}->{$b} = 1; for (keys %h, keys %{$h{$a}}) { print ref($_), "\n"; } =head1 THREAD SUPPORT L<Tie::RefHash> fully supports threading using the C<CLONE> method. =head1 STORABLE SUPPORT L<Storable> hooks are provided for semantically correct serialization and cloning of tied refhashes. =head1 RELIC SUPPORT This version of Tie::RefHash seems to no longer work with 5.004. This has not been throughly investigated. Patches welcome ;-) =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself =head1 MAINTAINER Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt> =head1 AUTHOR Gurusamy Sarathy gsar@activestate.com 'Nestable' by Ed Avis ed@membled.com =head1 SEE ALSO perl(1), perlfunc(1), perltie(1) =cut use Tie::Hash; use vars '@ISA'; @ISA = qw(Tie::Hash); use strict; use Carp qw/croak/; BEGIN { local $@; # determine whether we need to take care of threads use Config (); my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"} *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 }; *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 }; *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 }; } BEGIN { # create a refaddr function local $@; if ( _HAS_SCALAR_UTIL ) { Scalar::Util->import("refaddr"); } else { require overload; *refaddr = sub { if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) { return $1; } else { die "couldn't parse StrVal: " . overload::StrVal($_[0]); } }; } } my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed sub TIEHASH { my $c = shift; my $s = []; bless $s, $c; while (@_) { $s->STORE(shift, shift); } if (_HAS_THREADS ) { if ( _HAS_WEAKEN ) { # remember the object so that we can rekey it on CLONE push @thread_object_registry, $s; # but make this a weak reference, so that there are no leaks Scalar::Util::weaken( $thread_object_registry[-1] ); if ( ++$count > 1000 ) { # this ensures we don't fill up with a huge array dead weakrefs @thread_object_registry = grep { defined } @thread_object_registry; $count = 0; } } else { $count++; # used in the warning } } return $s; } my $storable_format_version = join("/", __PACKAGE__, "0.01"); sub STORABLE_freeze { my ( $self, $is_cloning ) = @_; my ( $refs, $reg ) = @$self; return ( $storable_format_version, [ values %$refs ], $reg || {} ); } sub STORABLE_thaw { my ( $self, $is_cloning, $version, $refs, $reg ) = @_; croak "incompatible versions of Tie::RefHash between freeze and thaw" unless $version eq $storable_format_version; @$self = ( {}, $reg ); $self->_reindex_keys( $refs ); } sub CLONE { my $pkg = shift; if ( $count and not _HAS_WEAKEN ) { warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken"; } # when the thread has been cloned all the objects need to be updated. # dead weakrefs are undefined, so we filter them out @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry; $count = 0; # we just cleaned up } sub _reindex_keys { my ( $self, $extra_keys ) = @_; # rehash all the ref keys based on their new StrVal %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] }); } sub FETCH { my($s, $k) = @_; if (ref $k) { my $kstr = refaddr($k); if (defined $s->[0]{$kstr}) { $s->[0]{$kstr}[1]; } else { undef; } } else { $s->[1]{$k}; } } sub STORE { my($s, $k, $v) = @_; if (ref $k) { $s->[0]{refaddr($k)} = [$k, $v]; } else { $s->[1]{$k} = $v; } $v; } sub DELETE { my($s, $k) = @_; (ref $k) ? (delete($s->[0]{refaddr($k)}) || [])->[1] : delete($s->[1]{$k}); } sub EXISTS { my($s, $k) = @_; (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k}); } sub FIRSTKEY { my $s = shift; keys %{$s->[0]}; # reset iterator keys %{$s->[1]}; # reset iterator $s->[2] = 0; # flag for iteration, see NEXTKEY $s->NEXTKEY; } sub NEXTKEY { my $s = shift; my ($k, $v); if (!$s->[2]) { if (($k, $v) = each %{$s->[0]}) { return $v->[0]; } else { $s->[2] = 1; } } return each %{$s->[1]}; } sub CLEAR { my $s = shift; $s->[2] = 0; %{$s->[0]} = (); %{$s->[1]} = (); } package Tie::RefHash::Nestable; use vars '@ISA'; @ISA = 'Tie::RefHash'; sub STORE { my($s, $k, $v) = @_; if (ref($v) eq 'HASH' and not tied %$v) { my @elems = %$v; tie %$v, ref($s), @elems; } $s->SUPER::STORE($k, $v); } 1; Number/Compare.pm 0000644 00000004536 15027445044 0007735 0 ustar 00 package Number::Compare; use strict; use Carp qw(croak); use vars qw/$VERSION/; $VERSION = '0.03'; sub new { my $referent = shift; my $class = ref $referent || $referent; my $expr = $class->parse_to_perl( shift ); bless eval "sub { \$_[0] $expr }", $class; } sub parse_to_perl { shift; my $test = shift; $test =~ m{^ ([<>]=?)? # comparison (.*?) # value ([kmg]i?)? # magnitude $}ix or croak "don't understand '$test' as a test"; my $comparison = $1 || '=='; my $target = $2; my $magnitude = $3 || ''; $target *= 1000 if lc $magnitude eq 'k'; $target *= 1024 if lc $magnitude eq 'ki'; $target *= 1000000 if lc $magnitude eq 'm'; $target *= 1024*1024 if lc $magnitude eq 'mi'; $target *= 1000000000 if lc $magnitude eq 'g'; $target *= 1024*1024*1024 if lc $magnitude eq 'gi'; return "$comparison $target"; } sub test { $_[0]->( $_[1] ) } 1; __END__ =head1 NAME Number::Compare - numeric comparisons =head1 SYNOPSIS Number::Compare->new(">1Ki")->test(1025); # is 1025 > 1024 my $c = Number::Compare->new(">1M"); $c->(1_200_000); # slightly terser invocation =head1 DESCRIPTION Number::Compare compiles a simple comparison to an anonymous subroutine, which you can call with a value to be tested again. Now this would be very pointless, if Number::Compare didn't understand magnitudes. The target value may use magnitudes of kilobytes (C<k>, C<ki>), megabytes (C<m>, C<mi>), or gigabytes (C<g>, C<gi>). Those suffixed with an C<i> use the appropriate 2**n version in accordance with the IEC standard: http://physics.nist.gov/cuu/Units/binary.html =head1 METHODS =head2 ->new( $test ) Returns a new object that compares the specified test. =head2 ->test( $value ) A longhanded version of $compare->( $value ). Predates blessed subroutine reference implementation. =head2 ->parse_to_perl( $test ) Returns a perl code fragment equivalent to the test. =head1 AUTHOR Richard Clamp <richardc@unixbeard.net> =head1 COPYRIGHT Copyright (C) 2002,2011 Richard Clamp. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO http://physics.nist.gov/cuu/Units/binary.html =cut Text/Glob.pm 0000644 00000011551 15027445044 0006721 0 ustar 00 package Text::Glob; use strict; use Exporter; use vars qw/$VERSION @ISA @EXPORT_OK $strict_leading_dot $strict_wildcard_slash/; $VERSION = '0.11'; @ISA = 'Exporter'; @EXPORT_OK = qw( glob_to_regex glob_to_regex_string match_glob ); $strict_leading_dot = 1; $strict_wildcard_slash = 1; use constant debug => 0; sub glob_to_regex { my $glob = shift; my $regex = glob_to_regex_string($glob); return qr/^$regex$/; } sub glob_to_regex_string { my $glob = shift; my $seperator = $Text::Glob::seperator; $seperator = "/" unless defined $seperator; $seperator = quotemeta($seperator); my ($regex, $in_curlies, $escaping); local $_; my $first_byte = 1; for ($glob =~ m/(.)/gs) { if ($first_byte) { if ($strict_leading_dot) { $regex .= '(?=[^\.])' unless $_ eq '.'; } $first_byte = 0; } if ($_ eq '/') { $first_byte = 1; } if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { $regex .= "\\$_"; } elsif ($_ eq '*') { $regex .= $escaping ? "\\*" : $strict_wildcard_slash ? "(?:(?!$seperator).)*" : ".*"; } elsif ($_ eq '?') { $regex .= $escaping ? "\\?" : $strict_wildcard_slash ? "(?!$seperator)." : "."; } elsif ($_ eq '{') { $regex .= $escaping ? "\\{" : "("; ++$in_curlies unless $escaping; } elsif ($_ eq '}' && $in_curlies) { $regex .= $escaping ? "}" : ")"; --$in_curlies unless $escaping; } elsif ($_ eq ',' && $in_curlies) { $regex .= $escaping ? "," : "|"; } elsif ($_ eq "\\") { if ($escaping) { $regex .= "\\\\"; $escaping = 0; } else { $escaping = 1; } next; } else { $regex .= $_; $escaping = 0; } $escaping = 0; } print "# $glob $regex\n" if debug; return $regex; } sub match_glob { print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; my $glob = shift; my $regex = glob_to_regex $glob; local $_; grep { $_ =~ $regex } @_; } 1; __END__ =head1 NAME Text::Glob - match globbing patterns against text =head1 SYNOPSIS use Text::Glob qw( match_glob glob_to_regex ); print "matched\n" if match_glob( "foo.*", "foo.bar" ); # prints foo.bar and foo.baz my $regex = glob_to_regex( "foo.*" ); for ( qw( foo.bar foo.baz foo bar ) ) { print "matched: $_\n" if /$regex/; } =head1 DESCRIPTION Text::Glob implements glob(3) style matching that can be used to match against text, rather than fetching names from a filesystem. If you want to do full file globbing use the File::Glob module instead. =head2 Routines =over =item match_glob( $glob, @things_to_test ) Returns the list of things which match the glob from the source list. =item glob_to_regex( $glob ) Returns a compiled regex which is the equivalent of the globbing pattern. =item glob_to_regex_string( $glob ) Returns a regex string which is the equivalent of the globbing pattern. =back =head1 SYNTAX The following metacharacters and rules are respected. =over =item C<*> - match zero or more characters C<a*> matches C<a>, C<aa>, C<aaaa> and many many more. =item C<?> - match exactly one character C<a?> matches C<aa>, but not C<a>, or C<aaa> =item Character sets/ranges C<example.[ch]> matches C<example.c> and C<example.h> C<demo.[a-c]> matches C<demo.a>, C<demo.b>, and C<demo.c> =item alternation C<example.{foo,bar,baz}> matches C<example.foo>, C<example.bar>, and C<example.baz> =item leading . must be explicitly matched C<*.foo> does not match C<.bar.foo>. For this you must either specify the leading . in the glob pattern (C<.*.foo>), or set C<$Text::Glob::strict_leading_dot> to a false value while compiling the regex. =item C<*> and C<?> do not match the separator (i.e. do not match C</>) C<*.foo> does not match C<bar/baz.foo>. For this you must either explicitly match the / in the glob (C<*/*.foo>), or set C<$Text::Glob::strict_wildcard_slash> to a false value while compiling the regex, or change the separator that Text::Glob uses by setting C<$Text::Glob::seperator> (with the typo, yes) to an alternative value while compiling the regex. =back =head1 BUGS The code uses qr// to produce compiled regexes, therefore this module requires perl version 5.005_03 or newer. =head1 AUTHOR Richard Clamp <richardc@unixbeard.net> =head1 COPYRIGHT Copyright (C) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<File::Glob>, glob(3) =cut
| ver. 1.4 |
Github
|
.
| PHP 8.2.28 | Generation time: 5.03 |
proxy
|
phpinfo
|
Settings