diff --git a/configure b/configure index 43fdaf24..c5979160 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.67 for parallel 20101113. +# Generated by GNU Autoconf 2.67 for parallel 20101115. # # Report bugs to . # @@ -551,8 +551,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='parallel' PACKAGE_TARNAME='parallel' -PACKAGE_VERSION='20101113' -PACKAGE_STRING='parallel 20101113' +PACKAGE_VERSION='20101115' +PACKAGE_STRING='parallel 20101115' PACKAGE_BUGREPORT='bug-parallel@gnu.org' PACKAGE_URL='' @@ -1168,7 +1168,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures parallel 20101113 to adapt to many kinds of systems. +\`configure' configures parallel 20101115 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1234,7 +1234,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of parallel 20101113:";; + short | recursive ) echo "Configuration of parallel 20101115:";; esac cat <<\_ACEOF @@ -1301,7 +1301,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -parallel configure 20101113 +parallel configure 20101115 generated by GNU Autoconf 2.67 Copyright (C) 2010 Free Software Foundation, Inc. @@ -1318,7 +1318,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by parallel $as_me 20101113, which was +It was created by parallel $as_me 20101115, which was generated by GNU Autoconf 2.67. Invocation command line was $ $0 $@ @@ -2133,7 +2133,7 @@ fi # Define the identity of the package. PACKAGE='parallel' - VERSION='20101113' + VERSION='20101115' cat >>confdefs.h <<_ACEOF @@ -2684,7 +2684,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by parallel $as_me 20101113, which was +This file was extended by parallel $as_me 20101115, which was generated by GNU Autoconf 2.67. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -2746,7 +2746,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -parallel config.status 20101113 +parallel config.status 20101115 configured by $0, generated by GNU Autoconf 2.67, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 0da77b64..a5cc4c1b 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([parallel], [20101113], [bug-parallel@gnu.org]) +AC_INIT([parallel], [20101115], [bug-parallel@gnu.org]) AM_INIT_AUTOMAKE([-Wall -Werror foreign]) AC_CONFIG_HEADERS([config.h]) AC_CONFIG_FILES([ diff --git a/src/parallel b/src/parallel index 4691aa35..7a770dd3 100755 --- a/src/parallel +++ b/src/parallel @@ -2608,7 +2608,7 @@ sub get_options_from_array { sub parse_options { # Returns: N/A # Defaults: - $Global::version = 20101113; + $Global::version = 20101115; $Global::progname = 'parallel'; $Global::debug = 0; $Global::verbose = 0; diff --git a/src/sql b/src/sql index 08f33ddc..1991550c 100755 --- a/src/sql +++ b/src/sql @@ -528,7 +528,7 @@ $Global::Initfile && unlink $Global::Initfile; exit ($err); sub parse_options { - $Global::version = 20101113; + $Global::version = 20101115; $Global::progname = 'sql'; # This must be done first as this may exec myself diff --git a/testsuite/input-files/perllib/AutoLoader.pm b/testsuite/input-files/perllib/AutoLoader.pm new file mode 100644 index 00000000..89ac88d0 --- /dev/null +++ b/testsuite/input-files/perllib/AutoLoader.pm @@ -0,0 +1,198 @@ +package AutoLoader; + +use strict; +use 5.006_001; + +our($VERSION, $AUTOLOAD); + +my $is_dosish; +my $is_epoc; +my $is_vms; +my $is_macos; + +BEGIN { + $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; + $is_epoc = $^O eq 'epoc'; + $is_vms = $^O eq 'VMS'; + $is_macos = $^O eq 'MacOS'; + $VERSION = '5.68'; +} + +AUTOLOAD { + my $sub = $AUTOLOAD; + my $filename = AutoLoader::find_filename( $sub ); + + my $save = $@; + local $!; # Do not munge the value. + eval { local $SIG{__DIE__}; require $filename }; + if ($@) { + if (substr($sub,-9) eq '::DESTROY') { + no strict 'refs'; + *$sub = sub {}; + $@ = undef; + } elsif ($@ =~ /^Can't locate/) { + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can successfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval { local $SIG{__DIE__}; require $filename }; + } + } + if ($@){ + $@ =~ s/ at .*\n//; + my $error = $@; + require Carp; + Carp::croak($error); + } + } + $@ = $save; + goto &$sub; +} + +sub find_filename { + my $sub = shift; + my $filename; + # Braces used to preserve $1 et al. + { + # Try to find the autoloaded file from the package-qualified + # name of the sub. e.g., if the sub needed is + # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is + # something like '/usr/lib/perl5/Getopt/Long.pm', and the + # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is + # 'lib/Getopt/Long.pm', and we want to require + # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). + # In this case, we simple prepend the 'auto/' and let the + # C take care of the searching for us. + + my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); + $pkg =~ s#::#/#g; + if (defined($filename = $INC{"$pkg.pm"})) { + if ($is_macos) { + $pkg =~ tr#/#:#; + $filename = undef + unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; + } else { + $filename = undef + unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; + } + + # if the file exists, then make sure that it is a + # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', + # or './lib/auto/foo/bar.al'. This avoids C searching + # (and failing) to find the 'lib/auto/foo/bar.al' because it + # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). + + if (defined $filename and -r $filename) { + unless ($filename =~ m|^/|s) { + if ($is_dosish) { + unless ($filename =~ m{^([a-z]:)?[\\/]}is) { + if ($^O ne 'NetWare') { + $filename = "./$filename"; + } else { + $filename = "$filename"; + } + } + } + elsif ($is_epoc) { + unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { + $filename = "./$filename"; + } + } + elsif ($is_vms) { + # XXX todo by VMSmiths + $filename = "./$filename"; + } + elsif (!$is_macos) { + $filename = "./$filename"; + } + } + } + else { + $filename = undef; + } + } + unless (defined $filename) { + # let C do the searching + $filename = "auto/$sub.al"; + $filename =~ s#::#/#g; + } + } + return $filename; +} + +sub import { + my $pkg = shift; + my $callpkg = caller; + + # + # Export symbols, but not by accident of inheritance. + # + + if ($pkg eq 'AutoLoader') { + if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) { + no strict 'refs'; + *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD; + } + } + + # + # Try to find the autosplit index file. Eg., if the call package + # is POSIX, then $INC{POSIX.pm} is something like + # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in + # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then + # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require + # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). + # + + (my $calldir = $callpkg) =~ s#::#/#g; + my $path = $INC{$calldir . '.pm'}; + if (defined($path)) { + # Try absolute path name, but only eval it if the + # transformation from module path to autosplit.ix path + # succeeded! + my $replaced_okay; + if ($is_macos) { + (my $malldir = $calldir) =~ tr#/#:#; + $replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s); + } else { + $replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#); + } + + eval { require $path; } if $replaced_okay; + # If that failed, try relative path with normal @INC searching. + if (!$replaced_okay or $@) { + $path ="auto/$calldir/autosplit.ix"; + eval { require $path; }; + } + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } + } +} + +sub unimport { + my $callpkg = caller; + + no strict 'refs'; + + for my $exported (qw( AUTOLOAD )) { + my $symname = $callpkg . '::' . $exported; + undef *{ $symname } if \&{ $symname } == \&{ $exported }; + *{ $symname } = \&{ $symname }; + } +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/Carp.pm b/testsuite/input-files/perllib/Carp.pm new file mode 100644 index 00000000..cd97564f --- /dev/null +++ b/testsuite/input-files/perllib/Carp.pm @@ -0,0 +1,51 @@ +package Carp; + +our $VERSION = '1.11'; +# this file is an utra-lightweight stub. The first time a function is +# called, Carp::Heavy is loaded, and the real short/longmessmess_jmp +# subs are installed + +our $MaxEvalLen = 0; +our $Verbose = 0; +our $CarpLevel = 0; +our $MaxArgLen = 64; # How much of each argument to print. 0 = all. +our $MaxArgNums = 8; # How many arguments to print. 0 = all. + +require Exporter; +our @ISA = ('Exporter'); +our @EXPORT = qw(confess croak carp); +our @EXPORT_OK = qw(cluck verbose longmess shortmess); +our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + +sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } + +# fixed hooks for stashes to point to +sub longmess { goto &longmess_jmp } +sub shortmess { goto &shortmess_jmp } +# these two are replaced when Carp::Heavy is loaded +sub longmess_jmp { + local($@, $!); + eval { require Carp::Heavy }; + return $@ if $@; + goto &longmess_real; +} +sub shortmess_jmp { + local($@, $!); + eval { require Carp::Heavy }; + return $@ if $@; + goto &shortmess_real; +} + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } + +1; +__END__ + diff --git a/testsuite/input-files/perllib/Carp/Heavy.pm b/testsuite/input-files/perllib/Carp/Heavy.pm new file mode 100644 index 00000000..04ec1064 --- /dev/null +++ b/testsuite/input-files/perllib/Carp/Heavy.pm @@ -0,0 +1,297 @@ +# Carp::Heavy uses some variables in common with Carp. +package Carp; + +# On one line so MakeMaker will see it. +use Carp; our $VERSION = $Carp::VERSION; +# use strict; # not yet + +# 'use Carp' just installs some very lightweight stubs; the first time +# these are called, they require Carp::Heavy which installs the real +# routines. + +# The members of %Internal are packages that are internal to perl. +# Carp will not report errors from within these packages if it +# can. The members of %CarpInternal are internal to Perl's warning +# system. Carp will not report errors from within these packages +# either, and will not report calls *to* these packages for carp and +# croak. They replace $CarpLevel, which is deprecated. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + +# disable these by default, so they can live w/o require Carp +$CarpInternal{Carp}++; +$CarpInternal{warnings}++; +$Internal{Exporter}++; +$Internal{'Exporter::Heavy'}++; + +our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); + +# XXX longmess_real and shortmess_real should really be merged into +# XXX {long|sort}mess_heavy at some point + +sub longmess_real { + # Icky backwards compatibility wrapper. :-( + # + # The story is that the original implementation hard-coded the + # number of call levels to go back, so calls to longmess were off + # by one. Other code began calling longmess and expecting this + # behaviour, so the replacement has to emulate that behaviour. + my $call_pack = caller(); + if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { + return longmess_heavy(@_); + } + else { + local $CarpLevel = $CarpLevel + 1; + return longmess_heavy(@_); + } +}; + +sub shortmess_real { + # Icky backwards compatibility wrapper. :-( + local @CARP_NOT = caller(); + shortmess_heavy(@_); +}; + +# replace the two hooks added by Carp + +# aliasing the whole glob rather than just the CV slot avoids 'redefined' +# warnings, even in the presence of perl -W (as used by lib/warnings.t !) +# However it has the potential to create infinite loops, if somehow Carp +# is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true. +# Hence the extra hack of deleting the previous typeglob first. + +delete $Carp::{shortmess_jmp}; +delete $Carp::{longmess_jmp}; +*longmess_jmp = *longmess_real; +*shortmess_jmp = *shortmess_real; + +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + my @args = map {Carp::format_arg($_)} @DB::args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (', ', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} + +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (ref($arg)) { + $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; + } + if (defined($arg)) { + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxArgLen); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + } else { + $arg = 'undef'; + } + + # The following handling of "control chars" is direct from + # the original code - it is broken on Unicode though. + # Suggestions? + utf8::is_utf8($arg) + or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + return $arg; +} + +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} + +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{evaltext})) { + my $eval = $info->{evaltext}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; + } + } + + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} + +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} + +sub longmess_heavy { + return @_ if ref($_[0]); # don't break references as exceptions + my $i = long_error_loc(); + return ret_backtrace($i, @_); +} + +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &threads::tid) { + my $tid = threads->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess; +} + +sub ret_summary { + my ($i, @error) = @_; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &threads::tid) { + my $tid = threads->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; +} + +sub short_error_loc { + # You have to create your (hash)ref out here, rather than defaulting it + # inside trusts *on a lexical*, as you want it to persist across calls. + # (You can default it on $_[2], but that gets messy) + my $cache = {}; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # don't break references as exceptions + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } +} + +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} + +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; + } + return exists $known->{$parent}; +} + +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + no strict 'refs'; + no warnings 'once'; + return @{"$class\::CARP_NOT"} + ? @{"$class\::CARP_NOT"} + : @{"$class\::ISA"}; +} + +1; + diff --git a/testsuite/input-files/perllib/Cwd.pm b/testsuite/input-files/perllib/Cwd.pm new file mode 100644 index 00000000..e7031d96 --- /dev/null +++ b/testsuite/input-files/perllib/Cwd.pm @@ -0,0 +1,648 @@ +package Cwd; + +use strict; +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + +$VERSION = '3.30'; +my $xs_version = $VERSION; +$VERSION = eval $VERSION; + +@ISA = qw/ Exporter /; +@EXPORT = qw(cwd getcwd fastcwd fastgetcwd); +push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32'; +@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath); + +# sys_cwd may keep the builtin command + +# All the functionality of this module may provided by builtins, +# there is no sense to process the rest of the file. +# The best choice may be to have this in BEGIN, but how to return from BEGIN? + +if ($^O eq 'os2') { + local $^W = 0; + + *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd; + *getcwd = \&cwd; + *fastgetcwd = \&cwd; + *fastcwd = \&cwd; + + *fast_abs_path = \&sys_abspath if defined &sys_abspath; + *abs_path = \&fast_abs_path; + *realpath = \&fast_abs_path; + *fast_realpath = \&fast_abs_path; + + return 1; +} + +# Need to look up the feature settings on VMS. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_vms_feature; +BEGIN { + if ($^O eq 'VMS') { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_vms_feature = 1; + } + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _vms_unix_rpt { + my $unix_rpt; + if ($use_vms_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + } + return $unix_rpt; +} + +# Need to look up the EFS character set mode. This may become a dynamic +# mode in the future. +sub _vms_efs { + my $efs; + if ($use_vms_feature) { + $efs = VMS::Feature::current("efs_charset"); + } else { + my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; + $efs = $env_efs =~ /^[ET1]/i; + } + return $efs; +} + +# If loading the XS stuff doesn't work, we can fall back to pure perl +eval { + if ( $] >= 5.006 ) { + require XSLoader; + XSLoader::load( __PACKAGE__, $xs_version); + } else { + require DynaLoader; + push @ISA, 'DynaLoader'; + __PACKAGE__->bootstrap( $xs_version ); + } +}; + +# Must be after the DynaLoader stuff: +$VERSION = eval $VERSION; + +# Big nasty table of function aliases +my %METHOD_MAP = + ( + VMS => + { + cwd => '_vms_cwd', + getcwd => '_vms_cwd', + fastcwd => '_vms_cwd', + fastgetcwd => '_vms_cwd', + abs_path => '_vms_abs_path', + fast_abs_path => '_vms_abs_path', + }, + + MSWin32 => + { + # We assume that &_NT_cwd is defined as an XSUB or in the core. + cwd => '_NT_cwd', + getcwd => '_NT_cwd', + fastcwd => '_NT_cwd', + fastgetcwd => '_NT_cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + dos => + { + cwd => '_dos_cwd', + getcwd => '_dos_cwd', + fastgetcwd => '_dos_cwd', + fastcwd => '_dos_cwd', + abs_path => 'fast_abs_path', + }, + + # QNX4. QNX6 has a $os of 'nto'. + qnx => + { + cwd => '_qnx_cwd', + getcwd => '_qnx_cwd', + fastgetcwd => '_qnx_cwd', + fastcwd => '_qnx_cwd', + abs_path => '_qnx_abs_path', + fast_abs_path => '_qnx_abs_path', + }, + + cygwin => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + realpath => 'fast_abs_path', + }, + + epoc => + { + cwd => '_epoc_cwd', + getcwd => '_epoc_cwd', + fastgetcwd => '_epoc_cwd', + fastcwd => '_epoc_cwd', + abs_path => 'fast_abs_path', + }, + + MacOS => + { + getcwd => 'cwd', + fastgetcwd => 'cwd', + fastcwd => 'cwd', + abs_path => 'fast_abs_path', + }, + ); + +$METHOD_MAP{NT} = $METHOD_MAP{MSWin32}; + +# Find the pwd command in the expected locations. We assume these +# are safe. This prevents _backtick_pwd() consulting $ENV{PATH} +# so everything works under taint mode. +my $pwd_cmd; +foreach my $try ('/bin/pwd', + '/usr/bin/pwd', + '/QOpenSys/bin/pwd', # OS/400 PASE. + ) { + + if( -x $try ) { + $pwd_cmd = $try; + last; + } +} +my $found_pwd_cmd = defined($pwd_cmd); +unless ($pwd_cmd) { + # Isn't this wrong? _backtick_pwd() will fail if somenone has + # pwd in their path but it is not /bin/pwd or /usr/bin/pwd? + # See [perl #16774]. --jhi + $pwd_cmd = 'pwd'; +} + +# Lazy-load Carp +sub _carp { require Carp; Carp::carp(@_) } +sub _croak { require Carp; Carp::croak(@_) } + +# The 'natural and safe form' for UNIX (pwd may be setuid root) +sub _backtick_pwd { + # Localize %ENV entries in a way that won't create new hash keys + my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV); + local @ENV{@localize}; + + my $cwd = `$pwd_cmd`; + # Belt-and-suspenders in case someone said "undef $/". + local $/ = "\n"; + # `pwd` may fail e.g. if the disk is full + chomp($cwd) if defined $cwd; + $cwd; +} + +# Since some ports may predefine cwd internally (e.g., NT) +# we take care not to override an existing definition for cwd(). + +unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) { + # The pwd command is not available in some chroot(2)'ed environments + my $sep = $Config::Config{path_sep} || ':'; + my $os = $^O; # Protect $^O from tainting + + # Try again to find a pwd, this time searching the whole PATH. + if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows + my @candidates = split($sep, $ENV{PATH}); + while (!$found_pwd_cmd and @candidates) { + my $candidate = shift @candidates; + $found_pwd_cmd = 1 if -x "$candidate/pwd"; + } + } + + # MacOS has some special magic to make `pwd` work. + if( $os eq 'MacOS' || $found_pwd_cmd ) + { + *cwd = \&_backtick_pwd; + } + else { + *cwd = \&getcwd; + } +} + +if ($^O eq 'cygwin') { + # We need to make sure cwd() is called with no args, because it's + # got an arg-less prototype and will die if args are present. + local $^W = 0; + my $orig_cwd = \&cwd; + *cwd = sub { &$orig_cwd() } +} + +# set a reasonable (and very safe) default for fastgetcwd, in case it +# isn't redefined later (20001212 rspier) +*fastgetcwd = \&cwd; + +# A non-XS version of getcwd() - also used to bootstrap the perl build +# process, when miniperl is running and no XS loading happens. +sub _perl_getcwd +{ + abs_path('.'); +} + +# By John Bazik +# +# Usage: $cwd = &fastcwd; +# +# This is a faster version of getcwd. It's also more dangerous because +# you might chdir out of a directory that you can't chdir back into. + +sub fastcwd_ { + my($odev, $oino, $cdev, $cino, $tdev, $tino); + my(@path, $path); + local(*DIR); + + my($orig_cdev, $orig_cino) = stat('.'); + ($cdev, $cino) = ($orig_cdev, $orig_cino); + for (;;) { + my $direntry; + ($odev, $oino) = ($cdev, $cino); + CORE::chdir('..') || return undef; + ($cdev, $cino) = stat('.'); + last if $odev == $cdev && $oino == $cino; + opendir(DIR, '.') || return undef; + for (;;) { + $direntry = readdir(DIR); + last unless defined $direntry; + next if $direntry eq '.'; + next if $direntry eq '..'; + + ($tdev, $tino) = lstat($direntry); + last unless $tdev != $odev || $tino != $oino; + } + closedir(DIR); + return undef unless defined $direntry; # should never happen + unshift(@path, $direntry); + } + $path = '/' . join('/', @path); + if ($^O eq 'apollo') { $path = "/".$path; } + # At this point $path may be tainted (if tainting) and chdir would fail. + # Untaint it then check that we landed where we started. + $path =~ /^(.*)\z/s # untaint + && CORE::chdir($1) or return undef; + ($cdev, $cino) = stat('.'); + die "Unstable directory path, current directory changed unexpectedly" + if $cdev != $orig_cdev || $cino != $orig_cino; + $path; +} +if (not defined &fastcwd) { *fastcwd = \&fastcwd_ } + +# Keeps track of current working directory in PWD environment var +# Usage: +# use Cwd 'chdir'; +# chdir $newdir; + +my $chdir_init = 0; + +sub chdir_init { + if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') { + my($dd,$di) = stat('.'); + my($pd,$pi) = stat($ENV{'PWD'}); + if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) { + $ENV{'PWD'} = cwd(); + } + } + else { + my $wd = cwd(); + $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32'; + $ENV{'PWD'} = $wd; + } + # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar) + if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) { + my($pd,$pi) = stat($2); + my($dd,$di) = stat($1); + if (defined $pd and defined $dd and $di == $pi and $dd == $pd) { + $ENV{'PWD'}="$2$3"; + } + } + $chdir_init = 1; +} + +sub chdir { + my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir) + $newdir =~ s|///*|/|g unless $^O eq 'MSWin32'; + chdir_init() unless $chdir_init; + my $newpwd; + if ($^O eq 'MSWin32') { + # get the full path name *before* the chdir() + $newpwd = Win32::GetFullPathName($newdir); + } + + return 0 unless CORE::chdir $newdir; + + if ($^O eq 'VMS') { + return $ENV{'PWD'} = $ENV{'DEFAULT'} + } + elsif ($^O eq 'MacOS') { + return $ENV{'PWD'} = cwd(); + } + elsif ($^O eq 'MSWin32') { + $ENV{'PWD'} = $newpwd; + return 1; + } + + if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in + $ENV{'PWD'} = cwd(); + } elsif ($newdir =~ m#^/#s) { + $ENV{'PWD'} = $newdir; + } else { + my @curdir = split(m#/#,$ENV{'PWD'}); + @curdir = ('') unless @curdir; + my $component; + foreach $component (split(m#/#, $newdir)) { + next if $component eq '.'; + pop(@curdir),next if $component eq '..'; + push(@curdir,$component); + } + $ENV{'PWD'} = join('/',@curdir) || '/'; + } + 1; +} + +sub _perl_abs_path +{ + my $start = @_ ? shift : '.'; + my($dotdots, $cwd, @pst, @cst, $dir, @tst); + + unless (@cst = stat( $start )) + { + _carp("stat($start): $!"); + return ''; + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + # NOTE that this routine assumes that '/' is the only directory separator. + + my ($dir, $file) = $start =~ m{^(.*)/(.+)$} + or return cwd() . '/' . $start; + + # Can't use "-l _" here, because the previous stat was a stat(), not an lstat(). + if (-l $start) { + my $link_target = readlink($start); + die "Can't resolve link $start: $!" unless defined $link_target; + + require File::Spec; + $link_target = $dir . '/' . $link_target + unless File::Spec->file_name_is_absolute($link_target); + + return abs_path($link_target); + } + + return $dir ? abs_path($dir) . "/$file" : "/$file"; + } + + $cwd = ''; + $dotdots = $start; + do + { + $dotdots .= '/..'; + @pst = @cst; + local *PARENT; + unless (opendir(PARENT, $dotdots)) + { + # probably a permissions issue. Try the native command. + return File::Spec->rel2abs( $start, _backtick_pwd() ); + } + unless (@cst = stat($dotdots)) + { + _carp("stat($dotdots): $!"); + closedir(PARENT); + return ''; + } + if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) + { + $dir = undef; + } + else + { + do + { + unless (defined ($dir = readdir(PARENT))) + { + _carp("readdir($dotdots): $!"); + closedir(PARENT); + return ''; + } + $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) + } + while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || + $tst[1] != $pst[1]); + } + $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; + closedir(PARENT); + } while (defined $dir); + chop($cwd) unless $cwd eq '/'; # drop the trailing / + $cwd; +} + +my $Curdir; +sub fast_abs_path { + local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage + my $cwd = getcwd(); + require File::Spec; + my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir); + + # Detaint else we'll explode in taint mode. This is safe because + # we're not doing anything dangerous with it. + ($path) = $path =~ /(.*)/; + ($cwd) = $cwd =~ /(.*)/; + + unless (-e $path) { + _croak("$path: No such file or directory"); + } + + unless (-d _) { + # Make sure we can be invoked on plain files, not just directories. + + my ($vol, $dir, $file) = File::Spec->splitpath($path); + return File::Spec->catfile($cwd, $path) unless length $dir; + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + $link_target = File::Spec->catpath($vol, $dir, $link_target) + unless File::Spec->file_name_is_absolute($link_target); + + return fast_abs_path($link_target); + } + + return $dir eq File::Spec->rootdir + ? File::Spec->catpath($vol, $dir, $file) + : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file; + } + + if (!CORE::chdir($path)) { + _croak("Cannot chdir to $path: $!"); + } + my $realpath = getcwd(); + if (! ((-d $cwd) && (CORE::chdir($cwd)))) { + _croak("Cannot chdir back to $cwd: $!"); + } + $realpath; +} + +# added function alias to follow principle of least surprise +# based on previous aliasing. --tchrist 27-Jan-00 +*fast_realpath = \&fast_abs_path; + +# --- PORTING SECTION --- + +# VMS: $ENV{'DEFAULT'} points to default directory at all times +# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu +# Note: Use of Cwd::chdir() causes the logical name PWD to be defined +# in the process logical name table as the default device and directory +# seen by Perl. This may not be the same as the default device +# and directory seen by DCL after Perl exits, since the effects +# the CRTL chdir() function persist only until Perl exits. + +sub _vms_cwd { + return $ENV{'DEFAULT'}; +} + +sub _vms_abs_path { + return $ENV{'DEFAULT'} unless @_; + my $path = shift; + + my $efs = _vms_efs; + my $unix_rpt = _vms_unix_rpt; + + if (defined &VMS::Filespec::vmsrealpath) { + my $path_unix = 0; + my $path_vms = 0; + + $path_unix = 1 if ($path =~ m#(?<=\^)/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = $path_unix; + if ($efs) { + # In case of a tie, the Unix report mode decides. + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = 0 if $path_vms; + } + } + + if ($unix_mode) { + # Unix format + return VMS::Filespec::unixrealpath($path); + } + + # VMS format + + my $new_path = VMS::Filespec::vmsrealpath($path); + + # Perl expects directories to be in directory format + $new_path = VMS::Filespec::pathify($new_path) if -d $path; + return $new_path; + } + + # Fallback to older algorithm if correct ones are not + # available. + + if (-l $path) { + my $link_target = readlink($path); + die "Can't resolve link $path: $!" unless defined $link_target; + + return _vms_abs_path($link_target); + } + + # may need to turn foo.dir into [.foo] + my $pathified = VMS::Filespec::pathify($path); + $path = $pathified if defined $pathified; + + return VMS::Filespec::rmsexpand($path); +} + +sub _os2_cwd { + $ENV{'PWD'} = `cmd /c cd`; + chomp $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +sub _win32_cwd { + if (defined &DynaLoader::boot_DynaLoader) { + $ENV{'PWD'} = Win32::GetCwd(); + } + else { # miniperl + chomp($ENV{'PWD'} = `cd`); + } + $ENV{'PWD'} =~ s:\\:/:g ; + return $ENV{'PWD'}; +} + +*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd; + +sub _dos_cwd { + if (!defined &Dos::GetCwd) { + $ENV{'PWD'} = `command /c cd`; + chomp $ENV{'PWD'}; + $ENV{'PWD'} =~ s:\\:/:g ; + } else { + $ENV{'PWD'} = Dos::GetCwd(); + } + return $ENV{'PWD'}; +} + +sub _qnx_cwd { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + $ENV{'PWD'} = `/usr/bin/fullpath -t`; + chomp $ENV{'PWD'}; + return $ENV{'PWD'}; +} + +sub _qnx_abs_path { + local $ENV{PATH} = ''; + local $ENV{CDPATH} = ''; + local $ENV{ENV} = ''; + my $path = @_ ? shift : '.'; + local *REALPATH; + + defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or + die "Can't open /usr/bin/fullpath: $!"; + my $realpath = ; + close REALPATH; + chomp $realpath; + return $realpath; +} + +sub _epoc_cwd { + $ENV{'PWD'} = EPOC::getcwd(); + return $ENV{'PWD'}; +} + +# Now that all the base-level functions are set up, alias the +# user-level functions to the right places + +if (exists $METHOD_MAP{$^O}) { + my $map = $METHOD_MAP{$^O}; + foreach my $name (keys %$map) { + local $^W = 0; # assignments trigger 'subroutine redefined' warning + no strict 'refs'; + *{$name} = \&{$map->{$name}}; + } +} + +# In case the XS version doesn't load. +*abs_path = \&_perl_abs_path unless defined &abs_path; +*getcwd = \&_perl_getcwd unless defined &getcwd; + +# added function alias for those of us more +# used to the libc function. --tchrist 27-Jan-00 +*realpath = \&abs_path; + +1; diff --git a/testsuite/input-files/perllib/Data/Dump.pm b/testsuite/input-files/perllib/Data/Dump.pm new file mode 100644 index 00000000..3557d778 --- /dev/null +++ b/testsuite/input-files/perllib/Data/Dump.pm @@ -0,0 +1,713 @@ +package Data::Dump; + +use strict; +use vars qw(@EXPORT @EXPORT_OK $VERSION $DEBUG); +use subs qq(dump); + +require Exporter; +*import = \&Exporter::import; +@EXPORT = qw(dd ddx); +@EXPORT_OK = qw(dump pp dumpf quote); + +$VERSION = "1.17"; +$DEBUG = 0; + +use overload (); +use vars qw(%seen %refcnt @dump @fixup %require $TRY_BASE64 @FILTERS $INDENT); + +$TRY_BASE64 = 50 unless defined $TRY_BASE64; +$INDENT = " " unless defined $INDENT; + +sub dump +{ + local %seen; + local %refcnt; + local %require; + local @fixup; + + require Data::Dump::FilterContext if @FILTERS; + + my $name = "a"; + my @dump; + + for my $v (@_) { + my $val = _dump($v, $name, [], tied($v)); + push(@dump, [$name, $val]); + } continue { + $name++; + } + + my $out = ""; + if (%require) { + for (sort keys %require) { + $out .= "require $_;\n"; + } + } + if (%refcnt) { + # output all those with refcounts first + for (@dump) { + my $name = $_->[0]; + if ($refcnt{$name}) { + $out .= "my \$$name = $_->[1];\n"; + undef $_->[1]; + } + } + for (@fixup) { + $out .= "$_;\n"; + } + } + + my $paren = (@dump != 1); + $out .= "(" if $paren; + $out .= format_list($paren, undef, + map {defined($_->[1]) ? $_->[1] : "\$".$_->[0]} + @dump + ); + $out .= ")" if $paren; + + if (%refcnt || %require) { + $out .= ";\n"; + $out =~ s/^/$INDENT/gm; + $out = "do {\n$out}"; + } + + #use Data::Dumper; print Dumper(\%refcnt); + #use Data::Dumper; print Dumper(\%seen); + + print STDERR "$out\n" unless defined wantarray; + $out; +} + +*pp = \&dump; + +sub dd { + print dump(@_), "\n"; +} + +sub ddx { + my(undef, $file, $line) = caller; + $file =~ s,.*[\\/],,; + my $out = "$file:$line: " . dump(@_) . "\n"; + $out =~ s/^/# /gm; + print $out; +} + +sub dumpf { + require Data::Dump::Filtered; + goto &Data::Dump::Filtered::dump_filtered; +} + +sub _dump +{ + my $ref = ref $_[0]; + my $rval = $ref ? $_[0] : \$_[0]; + shift; + + my($name, $idx, $dont_remember, $pclass, $pidx) = @_; + + my($class, $type, $id); + if (overload::StrVal($rval) =~ /^(?:([^=]+)=)?([A-Z]+)\(0x([^\)]+)\)$/) { + $class = $1; + $type = $2; + $id = $3; + } else { + die "Can't parse " . overload::StrVal($rval); + } + if ($] < 5.008 && $type eq "SCALAR") { + $type = "REF" if $ref eq "REF"; + } + warn "\$$name(@$idx) $class $type $id ($ref)" if $DEBUG; + + my $out; + my $comment; + my $hide_keys; + if (@FILTERS) { + my $pself = ""; + $pself = fullname("self", [@$idx[$pidx..(@$idx - 1)]]) if $pclass; + my $ctx = Data::Dump::FilterContext->new($rval, $class, $type, $ref, $pclass, $pidx, $idx); + my @bless; + for my $filter (@FILTERS) { + if (my $f = $filter->($ctx, $rval)) { + if (my $v = $f->{object}) { + local @FILTERS; + $out = _dump($v, $name, $idx, 1); + $dont_remember++; + } + if (defined(my $c = $f->{bless})) { + push(@bless, $c); + } + if (my $c = $f->{comment}) { + $comment = $c; + } + if (defined(my $c = $f->{dump})) { + $out = $c; + $dont_remember++; + } + if (my $h = $f->{hide_keys}) { + if (ref($h) eq "ARRAY") { + $hide_keys = sub { + for my $k (@$h) { + return 1 if $k eq $_[0]; + } + return 0; + }; + } + } + } + } + push(@bless, "") if defined($out) && !@bless; + if (@bless) { + $class = shift(@bless); + warn "More than one filter callback tried to bless object" if @bless; + } + } + + unless ($dont_remember) { + if (my $s = $seen{$id}) { + my($sname, $sidx) = @$s; + $refcnt{$sname}++; + my $sref = fullname($sname, $sidx, + ($ref && $type eq "SCALAR")); + warn "SEEN: [\$$name(@$idx)] => [\$$sname(@$sidx)] ($ref,$sref)" if $DEBUG; + return $sref unless $sname eq $name; + $refcnt{$name}++; + push(@fixup, fullname($name,$idx)." = $sref"); + return "do{my \$fix}" if @$idx && $idx->[-1] eq '$'; + return "'fix'"; + } + $seen{$id} = [$name, $idx]; + } + + if ($class) { + $pclass = $class; + $pidx = @$idx; + } + + if (defined $out) { + # keep it + } + elsif ($type eq "SCALAR" || $type eq "REF" || $type eq "REGEXP") { + if ($ref) { + if ($class && $class eq "Regexp") { + my $v = "$rval"; + + my $mod = ""; + if ($v =~ /^\(\?([msix-]+):([\x00-\xFF]*)\)\z/) { + $mod = $1; + $v = $2; + $mod =~ s/-.*//; + } + + my $sep = '/'; + my $sep_count = ($v =~ tr/\///); + if ($sep_count) { + # see if we can find a better one + for ('|', ',', ':', '#') { + my $c = eval "\$v =~ tr/\Q$_\E//"; + #print "SEP $_ $c $sep_count\n"; + if ($c < $sep_count) { + $sep = $_; + $sep_count = $c; + last if $sep_count == 0; + } + } + } + $v =~ s/\Q$sep\E/\\$sep/g; + + $out = "qr$sep$v$sep$mod"; + undef($class); + } + else { + delete $seen{$id} if $type eq "SCALAR"; # will be seen again shortly + my $val = _dump($$rval, $name, [@$idx, "\$"], 0, $pclass, $pidx); + $out = $class ? "do{\\(my \$o = $val)}" : "\\$val"; + } + } else { + if (!defined $$rval) { + $out = "undef"; + } + elsif ($$rval =~ /^-?[1-9]\d{0,9}\z/ || $$rval eq "0") { + $out = $$rval; + } + else { + $out = str($$rval); + } + if ($class && !@$idx) { + # Top is an object, not a reference to one as perl needs + $refcnt{$name}++; + my $obj = fullname($name, $idx); + my $cl = quote($class); + push(@fixup, "bless \\$obj, $cl"); + } + } + } + elsif ($type eq "GLOB") { + if ($ref) { + delete $seen{$id}; + my $val = _dump($$rval, $name, [@$idx, "*"], 0, $pclass, $pidx); + $out = "\\$val"; + if ($out =~ /^\\\*Symbol::/) { + $require{Symbol}++; + $out = "Symbol::gensym()"; + } + } else { + my $val = "$$rval"; + $out = "$$rval"; + + for my $k (qw(SCALAR ARRAY HASH)) { + my $gval = *$$rval{$k}; + next unless defined $gval; + next if $k eq "SCALAR" && ! defined $$gval; # always there + my $f = scalar @fixup; + push(@fixup, "RESERVED"); # overwritten after _dump() below + $gval = _dump($gval, $name, [@$idx, "*{$k}"], 0, $pclass, $pidx); + $refcnt{$name}++; + my $gname = fullname($name, $idx); + $fixup[$f] = "$gname = $gval"; #XXX indent $gval + } + } + } + elsif ($type eq "ARRAY") { + my @vals; + my $tied = tied_str(tied(@$rval)); + my $i = 0; + for my $v (@$rval) { + push(@vals, _dump($v, $name, [@$idx, "[$i]"], $tied, $pclass, $pidx)); + $i++; + } + $out = "[" . format_list(1, $tied, @vals) . "]"; + } + elsif ($type eq "HASH") { + my(@keys, @vals); + my $tied = tied_str(tied(%$rval)); + + # statistics to determine variation in key lengths + my $kstat_max = 0; + my $kstat_sum = 0; + my $kstat_sum2 = 0; + + my @orig_keys = keys %$rval; + if ($hide_keys) { + @orig_keys = grep !$hide_keys->($_), @orig_keys; + } + my $text_keys = 0; + for (@orig_keys) { + $text_keys++, last unless /^[-+]?(?:0|[1-9]\d*)(?:\.\d+)?\z/; + } + + if ($text_keys) { + @orig_keys = sort { lc($a) cmp lc($b) } @orig_keys; + } + else { + @orig_keys = sort { $a <=> $b } @orig_keys; + } + + my $quote; + for my $key (@orig_keys) { + next if $key =~ /^-?[a-zA-Z_]\w*\z/; + next if $key =~ /^-?[1-9]\d{0,8}\z/; + $quote++; + last; + } + + for my $key (@orig_keys) { + my $val = \$rval->{$key}; # capture value before we modify $key + $key = quote($key) if $quote; + $kstat_max = length($key) if length($key) > $kstat_max; + $kstat_sum += length($key); + $kstat_sum2 += length($key)*length($key); + + push(@keys, $key); + push(@vals, _dump($$val, $name, [@$idx, "{$key}"], $tied, $pclass, $pidx)); + } + my $nl = ""; + my $klen_pad = 0; + my $tmp = "@keys @vals"; + if (length($tmp) > 60 || $tmp =~ /\n/ || $tied) { + $nl = "\n"; + + # Determine what padding to add + if ($kstat_max < 4) { + $klen_pad = $kstat_max; + } + elsif (@keys >= 2) { + my $n = @keys; + my $avg = $kstat_sum/$n; + my $stddev = sqrt(($kstat_sum2 - $n * $avg * $avg) / ($n - 1)); + + # I am not actually very happy with this heuristics + if ($stddev / $kstat_max < 0.25) { + $klen_pad = $kstat_max; + } + if ($DEBUG) { + push(@keys, "__S"); + push(@vals, sprintf("%.2f (%d/%.1f/%.1f)", + $stddev / $kstat_max, + $kstat_max, $avg, $stddev)); + } + } + } + $out = "{$nl"; + $out .= "$INDENT# $tied$nl" if $tied; + while (@keys) { + my $key = shift @keys; + my $val = shift @vals; + my $vpad = $INDENT . (" " x ($klen_pad ? $klen_pad + 4 : 0)); + $val =~ s/\n/\n$vpad/gm; + my $kpad = $nl ? $INDENT : " "; + $key .= " " x ($klen_pad - length($key)) if $nl; + $out .= "$kpad$key => $val,$nl"; + } + $out =~ s/,$/ / unless $nl; + $out .= "}"; + } + elsif ($type eq "CODE") { + $out = 'sub { ... }'; + } + else { + warn "Can't handle $type data"; + $out = "'#$type#'"; + } + + if ($class && $ref) { + $out = "bless($out, " . quote($class) . ")"; + } + if ($comment) { + $comment =~ s/^/# /gm; + $comment .= "\n" unless $comment =~ /\n\z/; + $comment =~ s/^#[ \t]+\n/\n/; + $out = "$comment$out"; + } + return $out; +} + +sub tied_str { + my $tied = shift; + if ($tied) { + if (my $tied_ref = ref($tied)) { + $tied = "tied $tied_ref"; + } + else { + $tied = "tied"; + } + } + return $tied; +} + +sub fullname +{ + my($name, $idx, $ref) = @_; + substr($name, 0, 0) = "\$"; + + my @i = @$idx; # need copy in order to not modify @$idx + if ($ref && @i && $i[0] eq "\$") { + shift(@i); # remove one deref + $ref = 0; + } + while (@i && $i[0] eq "\$") { + shift @i; + $name = "\$$name"; + } + + my $last_was_index; + for my $i (@i) { + if ($i eq "*" || $i eq "\$") { + $last_was_index = 0; + $name = "$i\{$name}"; + } elsif ($i =~ s/^\*//) { + $name .= $i; + $last_was_index++; + } else { + $name .= "->" unless $last_was_index++; + $name .= $i; + } + } + $name = "\\$name" if $ref; + $name; +} + +sub format_list +{ + my $paren = shift; + my $comment = shift; + my $indent_lim = $paren ? 0 : 1; + if (@_ > 3) { + # can we use range operator to shorten the list? + my $i = 0; + while ($i < @_) { + my $j = $i + 1; + my $v = $_[$i]; + while ($j < @_) { + # XXX allow string increment too? + if ($v eq "0" || $v =~ /^-?[1-9]\d{0,9}\z/) { + $v++; + } + elsif ($v =~ /^"([A-Za-z]{1,3}\d*)"\z/) { + $v = $1; + $v++; + $v = qq("$v"); + } + else { + last; + } + last if $_[$j] ne $v; + $j++; + } + if ($j - $i > 3) { + splice(@_, $i, $j - $i, "$_[$i] .. $_[$j-1]"); + } + $i++; + } + } + my $tmp = "@_"; + if ($comment || (@_ > $indent_lim && (length($tmp) > 60 || $tmp =~ /\n/))) { + my @elem = @_; + for (@elem) { s/^/$INDENT/gm; } + return "\n" . ($comment ? "$INDENT# $comment\n" : "") . + join(",\n", @elem, ""); + } else { + return join(", ", @_); + } +} + +sub str { + if (length($_[0]) > 20) { + for ($_[0]) { + # Check for repeated string + if (/^(.)\1\1\1/s) { + # seems to be a repating sequence, let's check if it really is + # without backtracking + unless (/[^\Q$1\E]/) { + my $base = quote($1); + my $repeat = length; + return "($base x $repeat)" + } + } + # Length protection because the RE engine will blow the stack [RT#33520] + if (length($_) < 16 * 1024 && /^(.{2,5}?)\1*\z/s) { + my $base = quote($1); + my $repeat = length($_)/length($1); + return "($base x $repeat)"; + } + } + } + + local $_ = "e; + + if (length($_) > 40 && !/\\x\{/ && length($_) > (length($_[0]) * 2)) { + # too much binary data, better to represent as a hex/base64 string + + # Base64 is more compact than hex when string is longer than + # 17 bytes (not counting any require statement needed). + # But on the other hand, hex is much more readable. + if ($TRY_BASE64 && length($_[0]) > $TRY_BASE64 && + eval { require MIME::Base64 }) + { + $require{"MIME::Base64"}++; + return "MIME::Base64::decode(\"" . + MIME::Base64::encode($_[0],"") . + "\")"; + } + return "pack(\"H*\",\"" . unpack("H*", $_[0]) . "\")"; + } + + return $_; +} + +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + +# put a string value in double quotes +sub quote { + local($_) = $_[0]; + # If there are many '"' we might want to use qq() instead + s/([\\\"\@\$])/\\$1/g; + return qq("$_") unless /[^\040-\176]/; # fast exit + + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + + s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + s/([^\040-\176])/sprintf('\\x{%X}',ord($1))/eg; + + return qq("$_"); +} + +1; + +__END__ + +=head1 NAME + +Data::Dump - Pretty printing of data structures + +=head1 SYNOPSIS + + use Data::Dump qw(dump); + + $str = dump(@list); + @copy_of_list = eval $str; + + # or use it for easy debug printout + use Data::Dump; dd localtime; + +=head1 DESCRIPTION + +This module provide a few functions that traverse their +argument and produces a string as its result. The string contains +Perl code that, when Ced, produces a deep copy of the original +arguments. + +The main feature of the module is that it strives to produce output +that is easy to read. Example: + + @a = (1, [2, 3], {4 => 5}); + dump(@a); + +Produces: + + "(1, [2, 3], { 4 => 5 })" + +If you dump just a little data, it is output on a single line. If +you dump data that is more complex or there is a lot of it, line breaks +are automatically added to keep it easy to read. + +The following functions are provided (only the dd* functions are exported by default): + +=over + +=item dump( ... ) + +=item pp( ... ) + +Returns a string containing a Perl expression. If you pass this +string to Perl's built-in eval() function it should return a copy of +the arguments you passed to dump(). + +If you call the function with multiple arguments then the output will +be wrapped in parenthesis "( ..., ... )". If you call the function with a +single argument the output will not have the wrapping. If you call the function with +a single scalar (non-reference) argument it will just return the +scalar quoted if needed, but never break it into multiple lines. If you +pass multiple arguments or references to arrays of hashes then the +return value might contain line breaks to format it for easier +reading. The returned string will never be "\n" terminated, even if +contains multiple lines. This allows code like this to place the +semicolon in the expected place: + + print '$obj = ', dump($obj), ";\n"; + +If dump() is called in void context, then the dump is printed on +STDERR and then "\n" terminated. You might find this useful for quick +debug printouts, but the dd*() functions might be better alternatives +for this. + +There is no difference between dump() and pp(), except that dump() +shares its name with a not-so-useful perl builtin. Because of this +some might want to avoid using that name. + +=item quote( $string ) + +Returns a quoted version of the provided string. + +It differs from C in that it will quote even numbers and +not try to come up with clever expressions that might shorten the +output. If a non-scalar argument is provided then it's just stringified +instead of traversed. + +=item dd( ... ) + +=item ddx( ... ) + +These functions will call dump() on their argument and print the +result to STDOUT (actually, it's the currently selected output handle, but +STDOUT is the default for that). + +The difference between them is only that ddx() will prefix the lines +it prints with "# " and mark the first line with the file and line +number where it was called. This is meant to be useful for debug +printouts of state within programs. + +=item dumpf( ..., \&filter ) + +Short hand for calling the dump_filtered() function of L. +This works like dump(), but the last argument should be a filter callback +function. As objects are visited the filter callback is invoked and it +can modify how the objects are dumped. + +=back + +=head1 CONFIGURATION + +There are a few global variables that can be set to modify the output +generated by the dump functions. It's wise to localize the setting of +these. + +=over + +=item $Data::Dump::INDENT + +This holds the string that's used for indenting multiline data structures. +It's default value is " " (two spaces). Set it to "" to suppress indentation. +Setting it to "| " makes for nice visuals even if the dump output then fails to +be valid Perl. + +=item $Data::Dump::TRY_BASE64 + +How long must a binary string be before we try to use the base64 encoding +for the dump output. The default is 50. Set it to 0 to disable base64 dumps. + +=back + + +=head1 LIMITATIONS + +Code references will be dumped as C<< sub { ... } >>. Thus, Cing them will +not reproduce the original routine. The C<...>-operator used will also require +perl-5.12 or better to be evaled. + +If you forget to explicitly import the C function, your code will +core dump. That's because you just called the builtin C function +by accident, which intentionally dumps core. Because of this you can +also import the same function as C, mnemonic for "pretty-print". + +=head1 HISTORY + +The C module grew out of frustration with Sarathy's +in-most-cases-excellent C. Basic ideas and some code +are shared with Sarathy's module. + +The C module provides a much simpler interface than +C. No OO interface is available and there are fewer +configuration options to worry about. The other benefit is +that the dump produced does not try to set any variables. It only +returns what is needed to produce a copy of the arguments. This means +that C simply returns C<'"foo"'>, and C simply +returns C<'(1, 2, 3)'>. + +=head1 SEE ALSO + +L, L, L, L, +L + +=head1 AUTHORS + +The C module is written by Gisle Aas , based +on C by Gurusamy Sarathy . + + Copyright 1998-2010 Gisle Aas. + Copyright 1996-1998 Gurusamy Sarathy. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/testsuite/input-files/perllib/Errno.pm b/testsuite/input-files/perllib/Errno.pm new file mode 100644 index 00000000..0da8bda4 --- /dev/null +++ b/testsuite/input-files/perllib/Errno.pm @@ -0,0 +1,228 @@ +# +# This file is auto-generated. ***ANY*** changes here will be lost +# + +package Errno; +our (@EXPORT_OK,%EXPORT_TAGS,@ISA,$VERSION,%errno,$AUTOLOAD); +use Exporter (); +use strict; + +$VERSION = "1.11"; +$VERSION = eval $VERSION; +@ISA = qw(Exporter); + +@EXPORT_OK = qw(EBADR ENOMSG ENOTSUP ESTRPIPE EADDRINUSE EL3HLT EBADF + ENOTBLK ENAVAIL ECHRNG ENOTNAM ELNRNG ENOKEY EXDEV EBADE EBADSLT + ECONNREFUSED ENOSTR ENONET EOVERFLOW EISCONN EFBIG EKEYREVOKED + ECONNRESET EWOULDBLOCK ELIBMAX EREMOTEIO ERFKILL ENOPKG ELIBSCN + EDESTADDRREQ ENOTSOCK EIO EMEDIUMTYPE EINPROGRESS ERANGE EAFNOSUPPORT + EADDRNOTAVAIL EINTR EREMOTE EILSEQ ENOMEM EPIPE ENETUNREACH ENODATA + EUSERS EOPNOTSUPP EPROTO EISNAM ESPIPE EALREADY ENAMETOOLONG ENOEXEC + EISDIR EBADRQC EEXIST EDOTDOT ELIBBAD EOWNERDEAD ESRCH EFAULT EXFULL + EDEADLOCK EAGAIN ENOPROTOOPT ENETDOWN EPROTOTYPE EL2NSYNC ENETRESET + EUCLEAN EADV EROFS ESHUTDOWN EMULTIHOP EPROTONOSUPPORT ENFILE ENOLCK + ECONNABORTED ECANCELED EDEADLK ESRMNT ENOLINK ETIME ENOTDIR EINVAL + ENOTTY ENOANO ELOOP ENOENT EPFNOSUPPORT EBADMSG ENOMEDIUM EL2HLT EDOM + EBFONT EKEYEXPIRED EMSGSIZE ENOCSI EL3RST ENOSPC EIDRM ENOBUFS ENOSYS + EHOSTDOWN EBADFD ENOSR ENOTCONN ESTALE EDQUOT EKEYREJECTED EMFILE + ENOTRECOVERABLE EACCES EBUSY E2BIG EPERM ELIBEXEC ETOOMANYREFS ELIBACC + ENOTUNIQ ECOMM ERESTART ESOCKTNOSUPPORT EUNATCH ETIMEDOUT ENXIO ENODEV + ETXTBSY EMLINK ECHILD EHOSTUNREACH EREMCHG ENOTEMPTY); + +%EXPORT_TAGS = ( + POSIX => [qw( + E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY + EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK + EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH + EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS + ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK + ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART + EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT + ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV + )] +); + +sub EPERM () { 1 } +sub ENOENT () { 2 } +sub ESRCH () { 3 } +sub EINTR () { 4 } +sub EIO () { 5 } +sub ENXIO () { 6 } +sub E2BIG () { 7 } +sub ENOEXEC () { 8 } +sub EBADF () { 9 } +sub ECHILD () { 10 } +sub EWOULDBLOCK () { 11 } +sub EAGAIN () { 11 } +sub ENOMEM () { 12 } +sub EACCES () { 13 } +sub EFAULT () { 14 } +sub ENOTBLK () { 15 } +sub EBUSY () { 16 } +sub EEXIST () { 17 } +sub EXDEV () { 18 } +sub ENODEV () { 19 } +sub ENOTDIR () { 20 } +sub EISDIR () { 21 } +sub EINVAL () { 22 } +sub ENFILE () { 23 } +sub EMFILE () { 24 } +sub ENOTTY () { 25 } +sub ETXTBSY () { 26 } +sub EFBIG () { 27 } +sub ENOSPC () { 28 } +sub ESPIPE () { 29 } +sub EROFS () { 30 } +sub EMLINK () { 31 } +sub EPIPE () { 32 } +sub EDOM () { 33 } +sub ERANGE () { 34 } +sub EDEADLOCK () { 35 } +sub EDEADLK () { 35 } +sub ENAMETOOLONG () { 36 } +sub ENOLCK () { 37 } +sub ENOSYS () { 38 } +sub ENOTEMPTY () { 39 } +sub ELOOP () { 40 } +sub ENOMSG () { 42 } +sub EIDRM () { 43 } +sub ECHRNG () { 44 } +sub EL2NSYNC () { 45 } +sub EL3HLT () { 46 } +sub EL3RST () { 47 } +sub ELNRNG () { 48 } +sub EUNATCH () { 49 } +sub ENOCSI () { 50 } +sub EL2HLT () { 51 } +sub EBADE () { 52 } +sub EBADR () { 53 } +sub EXFULL () { 54 } +sub ENOANO () { 55 } +sub EBADRQC () { 56 } +sub EBADSLT () { 57 } +sub EBFONT () { 59 } +sub ENOSTR () { 60 } +sub ENODATA () { 61 } +sub ETIME () { 62 } +sub ENOSR () { 63 } +sub ENONET () { 64 } +sub ENOPKG () { 65 } +sub EREMOTE () { 66 } +sub ENOLINK () { 67 } +sub EADV () { 68 } +sub ESRMNT () { 69 } +sub ECOMM () { 70 } +sub EPROTO () { 71 } +sub EMULTIHOP () { 72 } +sub EDOTDOT () { 73 } +sub EBADMSG () { 74 } +sub EOVERFLOW () { 75 } +sub ENOTUNIQ () { 76 } +sub EBADFD () { 77 } +sub EREMCHG () { 78 } +sub ELIBACC () { 79 } +sub ELIBBAD () { 80 } +sub ELIBSCN () { 81 } +sub ELIBMAX () { 82 } +sub ELIBEXEC () { 83 } +sub EILSEQ () { 84 } +sub ERESTART () { 85 } +sub ESTRPIPE () { 86 } +sub EUSERS () { 87 } +sub ENOTSOCK () { 88 } +sub EDESTADDRREQ () { 89 } +sub EMSGSIZE () { 90 } +sub EPROTOTYPE () { 91 } +sub ENOPROTOOPT () { 92 } +sub EPROTONOSUPPORT () { 93 } +sub ESOCKTNOSUPPORT () { 94 } +sub ENOTSUP () { 95 } +sub EOPNOTSUPP () { 95 } +sub EPFNOSUPPORT () { 96 } +sub EAFNOSUPPORT () { 97 } +sub EADDRINUSE () { 98 } +sub EADDRNOTAVAIL () { 99 } +sub ENETDOWN () { 100 } +sub ENETUNREACH () { 101 } +sub ENETRESET () { 102 } +sub ECONNABORTED () { 103 } +sub ECONNRESET () { 104 } +sub ENOBUFS () { 105 } +sub EISCONN () { 106 } +sub ENOTCONN () { 107 } +sub ESHUTDOWN () { 108 } +sub ETOOMANYREFS () { 109 } +sub ETIMEDOUT () { 110 } +sub ECONNREFUSED () { 111 } +sub EHOSTDOWN () { 112 } +sub EHOSTUNREACH () { 113 } +sub EALREADY () { 114 } +sub EINPROGRESS () { 115 } +sub ESTALE () { 116 } +sub EUCLEAN () { 117 } +sub ENOTNAM () { 118 } +sub ENAVAIL () { 119 } +sub EISNAM () { 120 } +sub EREMOTEIO () { 121 } +sub EDQUOT () { 122 } +sub ENOMEDIUM () { 123 } +sub EMEDIUMTYPE () { 124 } +sub ECANCELED () { 125 } +sub ENOKEY () { 126 } +sub EKEYEXPIRED () { 127 } +sub EKEYREVOKED () { 128 } +sub EKEYREJECTED () { 129 } +sub EOWNERDEAD () { 130 } +sub ENOTRECOVERABLE () { 131 } +sub ERFKILL () { 132 } + +sub TIEHASH { bless [] } + +sub FETCH { + my ($self, $errname) = @_; + my $proto = prototype("Errno::$errname"); + my $errno = ""; + if (defined($proto) && $proto eq "") { + no strict 'refs'; + $errno = &$errname; + $errno = 0 unless $! == $errno; + } + return $errno; +} + +sub STORE { + require Carp; + Carp::confess("ERRNO hash is read only!"); +} + +*CLEAR = \&STORE; +*DELETE = \&STORE; + +sub NEXTKEY { + my($k,$v); + while(($k,$v) = each %Errno::) { + my $proto = prototype("Errno::$k"); + last if (defined($proto) && $proto eq ""); + } + $k +} + +sub FIRSTKEY { + my $s = scalar keys %Errno::; # initialize iterator + goto &NEXTKEY; +} + +sub EXISTS { + my ($self, $errname) = @_; + my $r = ref $errname; + my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef; + defined($proto) && $proto eq ""; +} + +tie %!, __PACKAGE__; + +1; +__END__ + diff --git a/testsuite/input-files/perllib/Exporter.pm b/testsuite/input-files/perllib/Exporter.pm new file mode 100644 index 00000000..9c751cfd --- /dev/null +++ b/testsuite/input-files/perllib/Exporter.pm @@ -0,0 +1,99 @@ +package Exporter; + +require 5.006; + +# Be lean. +#use strict; +#no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.63'; +our (%Cache); + +# Carp 1.05+ does this now for us, but we may be running with an old Carp +$Carp::Internal{Exporter}++; + +sub as_heavy { + require Exporter::Heavy; + # Unfortunately, this does not work if the caller is aliased as *name = \&foo + # Thus the need to create a lot of identical subroutines + my $c = (caller(1))[3]; + $c =~ s/.*:://; + \&{"Exporter::Heavy::heavy_$c"}; +} + +sub export { + goto &{as_heavy()}; +} + +sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { + *{$callpkg."::import"} = \&import; + return; + } + + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my($exports, $fail) = (\@{"$pkg\::EXPORT"}, \@{"$pkg\::EXPORT_FAIL"}); + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or @$fail > 1; + my $export_cache = ($Cache{$pkg} ||= {}); + my $args = @_ or @_ = @$exports; + + local $_; + if ($args and not %$export_cache) { + s/^&//, $export_cache->{$_} = 1 + foreach (@$exports, @{"$pkg\::EXPORT_OK"}); + } + my $heavy; + # Try very hard not to use {} and hence have to enter scope on the foreach + # We bomb out of the loop with last as soon as heavy is set. + if ($args or $fail) { + ($heavy = (/\W/ or $args and not exists $export_cache->{$_} + or @$fail and $_ eq $fail->[0])) and last + foreach (@_); + } else { + ($heavy = /\W/) and last + foreach (@_); + } + return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; + local $SIG{__WARN__} = + sub {require Carp; &Carp::carp}; + # shortcut for the common case of no type character + *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; +} + +# Default methods + +sub export_fail { + my $self = shift; + @_; +} + +# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as +# *name = \&foo. Thus the need to create a lot of identical subroutines +# Otherwise we could have aliased them to export(). + +sub export_to_level { + goto &{as_heavy()}; +} + +sub export_tags { + goto &{as_heavy()}; +} + +sub export_ok_tags { + goto &{as_heavy()}; +} + +sub require_version { + goto &{as_heavy()}; +} + +1; +__END__ + diff --git a/testsuite/input-files/perllib/Exporter/Heavy.pm b/testsuite/input-files/perllib/Exporter/Heavy.pm new file mode 100644 index 00000000..78dba390 --- /dev/null +++ b/testsuite/input-files/perllib/Exporter/Heavy.pm @@ -0,0 +1,237 @@ +package Exporter::Heavy; + +use strict; +no strict 'refs'; + +# On one line so MakeMaker will see it. +require Exporter; our $VERSION = $Exporter::VERSION; + +# Carp 1.05+ does this now for us, but we may be running with an old Carp +$Carp::Internal{'Exporter::Heavy'}++; + +# +# We go to a lot of trouble not to 'require Carp' at file scope, +# because Carp requires Exporter, and something has to give. +# + +sub _rebuild_cache { + my ($pkg, $exports, $cache) = @_; + s/^&// foreach @$exports; + @{$cache}{@$exports} = (1) x @$exports; + my $ok = \@{"${pkg}::EXPORT_OK"}; + if (@$ok) { + s/^&// foreach @$ok; + @{$cache}{@$ok} = (1) x @$ok; + } +} + +sub heavy_export { + + # First make import warnings look like they're coming from the "use". + local $SIG{__WARN__} = sub { + my $text = shift; + if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::carp($text); + } + else { + warn $text; + } + }; + local $SIG{__DIE__} = sub { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") + if $_[0] =~ /^Unable to create sub named "(.*?)::"/; + }; + + my($pkg, $callpkg, @imports) = @_; + my($type, $sym, $cache_is_current, $oops); + my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, + $Exporter::Cache{$pkg} ||= {}); + + if (@imports) { + if (!%$export_cache) { + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (grep m{^[/!:]}, @imports) { + my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; + my $tagdata; + my %imports; + my($remove, $spec, @names, @allexports); + # negated first item implies starting with default set: + unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; + foreach $spec (@imports){ + $remove = $spec =~ s/^!//; + + if ($spec =~ s/^://){ + if ($spec eq 'DEFAULT'){ + @names = @$exports; + } + elsif ($tagdata = $tagsref->{$spec}) { + @names = @$tagdata; + } + else { + warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; + ++$oops; + next; + } + } + elsif ($spec =~ m:^/(.*)/$:){ + my $patn = $1; + @allexports = keys %$export_cache unless @allexports; # only do keys once + @names = grep(/$patn/, @allexports); # not anchored by default + } + else { + @names = ($spec); # is a normal symbol name + } + + warn "Import ".($remove ? "del":"add").": @names " + if $Exporter::Verbose; + + if ($remove) { + foreach $sym (@names) { delete $imports{$sym} } + } + else { + @imports{@names} = (1) x @names; + } + } + @imports = keys %imports; + } + + my @carp; + foreach $sym (@imports) { + if (!$export_cache->{$sym}) { + if ($sym =~ m/^\d/) { + $pkg->VERSION($sym); # inherit from UNIVERSAL + # If the version number was the only thing specified + # then we should act as if nothing was specified: + if (@imports == 1) { + @imports = @$exports; + last; + } + # We need a way to emulate 'use Foo ()' but still + # allow an easy version check: "use Foo 1.23, ''"; + if (@imports == 2 and !$imports[1]) { + @imports = (); + last; + } + } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { + # Last chance - see if they've updated EXPORT_OK since we + # cached it. + + unless ($cache_is_current) { + %$export_cache = (); + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (!$export_cache->{$sym}) { + # accumulate the non-exports + push @carp, + qq["$sym" is not exported by the $pkg module\n]; + $oops++; + } + } + } + } + if ($oops) { + require Carp; + Carp::croak("@{carp}Can't continue after import errors"); + } + } + else { + @imports = @$exports; + } + + my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, + $Exporter::FailCache{$pkg} ||= {}); + + if (@$fail) { + if (!%$fail_cache) { + # Build cache of symbols. Optimise the lookup by adding + # barewords twice... both with and without a leading &. + # (Technique could be applied to $export_cache at cost of memory) + my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; + warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; + @{$fail_cache}{@expanded} = (1) x @expanded; + } + my @failed; + foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } + if (@failed) { + @failed = $pkg->export_fail(@failed); + foreach $sym (@failed) { + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); + } + if (@failed) { + require Carp; + Carp::croak("Can't continue after import errors"); + } + } + } + + warn "Importing into $callpkg from $pkg: ", + join(", ",sort @imports) if $Exporter::Verbose; + + foreach $sym (@imports) { + # shortcut for the common case of no type character + (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) + unless $sym =~ s/^(\W)//; + $type = $1; + no warnings 'once'; + *{"${callpkg}::$sym"} = + $type eq '&' ? \&{"${pkg}::$sym"} : + $type eq '$' ? \${"${pkg}::$sym"} : + $type eq '@' ? \@{"${pkg}::$sym"} : + $type eq '%' ? \%{"${pkg}::$sym"} : + $type eq '*' ? *{"${pkg}::$sym"} : + do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; + } +} + +sub heavy_export_to_level +{ + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); +} + +# Utility functions + +sub _push_tags { + my($pkg, $var, $syms) = @_; + my @nontag = (); + my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; + push(@{"${pkg}::$var"}, + map { $export_tags->{$_} ? @{$export_tags->{$_}} + : scalar(push(@nontag,$_),$_) } + (@$syms) ? @$syms : keys %$export_tags); + if (@nontag and $^W) { + # This may change to a die one day + require Carp; + Carp::carp(join(", ", @nontag)." are not tags of $pkg"); + } +} + +sub heavy_require_version { + my($self, $wanted) = @_; + my $pkg = ref $self || $self; + return ${pkg}->VERSION($wanted); +} + +sub heavy_export_tags { + _push_tags((caller)[0], "EXPORT", \@_); +} + +sub heavy_export_ok_tags { + _push_tags((caller)[0], "EXPORT_OK", \@_); +} + +1; diff --git a/testsuite/input-files/perllib/Fcntl.pm b/testsuite/input-files/perllib/Fcntl.pm new file mode 100644 index 00000000..41a3859f --- /dev/null +++ b/testsuite/input-files/perllib/Fcntl.pm @@ -0,0 +1,189 @@ +package Fcntl; + +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD); + +require Exporter; +use XSLoader (); +@ISA = qw(Exporter); +BEGIN { + $VERSION = "1.06"; +} + +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = + qw( + FD_CLOEXEC + F_ALLOCSP + F_ALLOCSP64 + F_COMPAT + F_DUP2FD + F_DUPFD + F_EXLCK + F_FREESP + F_FREESP64 + F_FSYNC + F_FSYNC64 + F_GETFD + F_GETFL + F_GETLK + F_GETLK64 + F_GETOWN + F_NODNY + F_POSIX + F_RDACC + F_RDDNY + F_RDLCK + F_RWACC + F_RWDNY + F_SETFD + F_SETFL + F_SETLK + F_SETLK64 + F_SETLKW + F_SETLKW64 + F_SETOWN + F_SHARE + F_SHLCK + F_UNLCK + F_UNSHARE + F_WRACC + F_WRDNY + F_WRLCK + O_ACCMODE + O_ALIAS + O_APPEND + O_ASYNC + O_BINARY + O_CREAT + O_DEFER + O_DIRECT + O_DIRECTORY + O_DSYNC + O_EXCL + O_EXLOCK + O_LARGEFILE + O_NDELAY + O_NOCTTY + O_NOFOLLOW + O_NOINHERIT + O_NONBLOCK + O_RANDOM + O_RAW + O_RDONLY + O_RDWR + O_RSRC + O_RSYNC + O_SEQUENTIAL + O_SHLOCK + O_SYNC + O_TEMPORARY + O_TEXT + O_TRUNC + O_WRONLY + ); + +# Other items we are prepared to export if requested +@EXPORT_OK = qw( + DN_ACCESS + DN_ATTRIB + DN_CREATE + DN_DELETE + DN_MODIFY + DN_MULTISHOT + DN_RENAME + FAPPEND + FASYNC + FCREAT + FDEFER + FDSYNC + FEXCL + FLARGEFILE + FNDELAY + FNONBLOCK + FRSYNC + FSYNC + FTRUNC + F_GETLEASE + F_GETSIG + F_NOTIFY + F_SETLEASE + F_SETSIG + LOCK_EX + LOCK_MAND + LOCK_NB + LOCK_READ + LOCK_RW + LOCK_SH + LOCK_UN + LOCK_WRITE + O_IGNORE_CTTY + O_NOATIME + O_NOLINK + O_NOTRANS + SEEK_CUR + SEEK_END + SEEK_SET + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IREAD S_IWRITE S_IEXEC + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO + &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE + FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)], + 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)], + 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + S_ISREG S_ISDIR S_ISLNK S_ISSOCK + S_ISBLK S_ISCHR S_ISFIFO + S_ISWHT S_ISENFMT + S_IFMT S_IMODE + )], +); + +# Force the constants to become inlined +BEGIN { + XSLoader::load 'Fcntl', $VERSION; +} + +sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() } +sub S_IMODE { $_[0] & 07777 } + +sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() } +sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() } +sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() } +sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() } +sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() } +sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() } +sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() } +sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() } +sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } + +sub AUTOLOAD { + (my $constname = $AUTOLOAD) =~ s/.*:://; + die "&Fcntl::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { + my (undef,$file,$line) = caller; + die "$error at $file line $line.\n"; + } + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + +1; diff --git a/testsuite/input-files/perllib/File/Basename.pm b/testsuite/input-files/perllib/File/Basename.pm new file mode 100644 index 00000000..b3fe0ac6 --- /dev/null +++ b/testsuite/input-files/perllib/File/Basename.pm @@ -0,0 +1,402 @@ +=head1 NAME + +File::Basename - Parse file paths into directory, filename and suffix. + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist); + $name = fileparse($fullname,@suffixlist); + + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + +=head1 DESCRIPTION + +These routines allow you to parse file paths into their directory, filename +and suffix. + +B: C and C emulate the behaviours, and +quirks, of the shell and C functions of the same name. See each +function's documentation for details. If your concern is just parsing +paths it is safer to use L's C and +C methods. + +It is guaranteed that + + # Where $path_separator is / for Unix, \ for Windows, etc... + dirname($path) . $path_separator . basename($path); + +is equivalent to the original path for all systems but VMS. + + +=cut + + +package File::Basename; + +# A bit of juggling to insure that C always works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT + import re 'taint'; +} + + +use strict; +use 5.006; +use warnings; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +$VERSION = "2.77"; + +fileparse_set_fstype($^O); + + +=over 4 + +=item C +X + + my($filename, $directories, $suffix) = fileparse($path); + my($filename, $directories, $suffix) = fileparse($path, @suffixes); + my $filename = fileparse($path, @suffixes); + +The C routine divides a file path into its $directories, $filename +and (optionally) the filename $suffix. + +$directories contains everything up to and including the last +directory separator in the $path including the volume (if applicable). +The remainder of the $path is the $filename. + + # On Unix returns ("baz", "/foo/bar/", "") + fileparse("/foo/bar/baz"); + + # On Windows returns ("baz", "C:\foo\bar\", "") + fileparse("C:\foo\bar\baz"); + + # On Unix returns ("", "/foo/bar/baz/", "") + fileparse("/foo/bar/baz/"); + +If @suffixes are given each element is a pattern (either a string or a +C) matched against the end of the $filename. The matching +portion is removed and becomes the $suffix. + + # On Unix returns ("baz", "/foo/bar/", ".txt") + fileparse("/foo/bar/baz.txt", qr/\.[^.]*/); + +If type is non-Unix (see C) then the pattern +matching for suffix removal is performed case-insensitively, since +those systems are not case-sensitive when opening existing files. + +You are guaranteed that C<$directories . $filename . $suffix> will +denote the same location as the original $path. + +=cut + + +sub fileparse { + my($fullname,@suffices) = @_; + + unless (defined $fullname) { + require Carp; + Carp::croak("fileparse(): need a valid pathname"); + } + + my $orig_type = ''; + my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + + my($taint) = substr($fullname,0,0); # Is $fullname tainted? + + if ($type eq "VMS" and $fullname =~ m{/} ) { + # We're doing Unix emulation + $orig_type = $type; + $type = 'Unix'; + } + + my($dirpath, $basename); + + if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; + } + elsif ($type eq "OS2") { + ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); + $dirpath = './' unless $dirpath; # Can't be 0 + $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; + } + elsif ($type eq "MacOS") { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); + $dirpath = ':' unless $dirpath; + } + elsif ($type eq "AmigaOS") { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); + $dirpath = './' unless $dirpath; + } + elsif ($type eq 'VMS' ) { + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); + $dirpath ||= ''; # should always be defined + } + else { # Default to Unix semantics. + ($dirpath,$basename) = ($fullname =~ m{^(.*/)?(.*)}s); + if ($orig_type eq 'VMS' and $fullname =~ m{^(/[^/]+/000000(/|$))(.*)}) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m{^(.*/)?(.*)}s); + $dirpath ||= ''; # should always be defined + $dirpath = $devspec.$dirpath; + } + $dirpath = './' unless $dirpath; + } + + + my $tail = ''; + my $suffix = ''; + if (@suffices) { + foreach $suffix (@suffices) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//s) { + $taint .= substr($suffix,0,0); + $tail = $1 . $tail; + } + } + } + + # Ensure taint is propgated from the path to its pieces. + $tail .= $taint; + wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) + : ($basename .= $taint); +} + + + +=item C +X X + + my $filename = basename($path); + my $filename = basename($path, @suffixes); + +This function is provided for compatibility with the Unix shell command +C. It does B always return the file name portion of a +path as you might expect. To be safe, if you want the file name portion of +a path use C. + +C returns the last level of a filepath even if the last +level is clearly directory. In effect, it is acting like C for +paths. This differs from C's behaviour. + + # Both return "bar" + basename("/foo/bar"); + basename("/foo/bar/"); + +@suffixes work as in C except all regex metacharacters are +quoted. + + # These two function calls are equivalent. + my $filename = basename("/foo/bar/baz.txt", ".txt"); + my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/); + +Also note that in order to be compatible with the shell command, +C does not strip off a suffix if it is identical to the +remaining characters in the filename. + +=cut + + +sub basename { + my($path) = shift; + + # From BSD basename(1) + # The basename utility deletes any prefix ending with the last slash `/' + # character present in string (after first stripping trailing slashes) + _strip_trailing_sep($path); + + my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) ); + + # From BSD basename(1) + # The suffix is not stripped if it is identical to the remaining + # characters in string. + if( length $suffix and !length $basename ) { + $basename = $suffix; + } + + # Ensure that basename '/' == '/' + if( !length $basename ) { + $basename = $dirname; + } + + return $basename; +} + + + +=item C +X + +This function is provided for compatibility with the Unix shell +command C and has inherited some of its quirks. In spite of +its name it does B always return the directory name as you might +expect. To be safe, if you want the directory name of a path use +C. + +Only on VMS (where there is no ambiguity between the file and directory +portions of a path) and AmigaOS (possibly due to an implementation quirk in +this module) does C work like C, returning just the +$directories. + + # On VMS and AmigaOS + my $directories = dirname($path); + +When using Unix or MSDOS syntax this emulates the C shell function +which is subtly different from how C works. It returns all but +the last level of a file path even if the last level is clearly a directory. +In effect, it is not returning the directory portion but simply the path one +level up acting like C for file paths. + +Also unlike C, C does not include a trailing slash on +its returned path. + + # returns /foo/bar. fileparse() would return /foo/bar/ + dirname("/foo/bar/baz"); + + # also returns /foo/bar despite the fact that baz is clearly a + # directory. fileparse() would return /foo/bar/baz/ + dirname("/foo/bar/baz/"); + + # returns '.'. fileparse() would return 'foo/' + dirname("foo/"); + +Under VMS, if there is no directory information in the $path, then the +current default device and directory is used. + +=cut + + +sub dirname { + my $path = shift; + + my($type) = $Fileparse_fstype; + + if( $type eq 'VMS' and $path =~ m{/} ) { + # Parse as Unix + local($File::Basename::Fileparse_fstype) = ''; + return dirname($path); + } + + my($basename, $dirname) = fileparse($path); + + if ($type eq 'VMS') { + $dirname ||= $ENV{DEFAULT}; + } + elsif ($type eq 'MacOS') { + if( !length($basename) && $dirname !~ /^[^:]+:\z/) { + _strip_trailing_sep($dirname); + ($basename,$dirname) = fileparse $dirname; + } + $dirname .= ":" unless $dirname =~ /:\z/; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + elsif ($type eq 'AmigaOS') { + if ( $dirname =~ /:\z/) { return $dirname } + chop $dirname; + $dirname =~ s{[^:/]+\z}{} unless length($basename); + } + else { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + + $dirname; +} + + +# Strip the trailing path separator. +sub _strip_trailing_sep { + my $type = $Fileparse_fstype; + + if ($type eq 'MacOS') { + $_[0] =~ s/([^:]):\z/$1/s; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + $_[0] =~ s/([^:])[\\\/]*\z/$1/; + } + else { + $_[0] =~ s{(.)/*\z}{$1}s; + } +} + + +=item C +X + + my $type = fileparse_set_fstype(); + my $previous_type = fileparse_set_fstype($type); + +Normally File::Basename will assume a file path type native to your current +operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...). +With this function you can override that assumption. + +Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS", +"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility), +"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is +given "Unix" will be assumed. + +If you've selected VMS syntax, and the file specification you pass to +one of these routines contains a "/", they assume you are using Unix +emulation and apply the Unix syntax rules instead, for that function +call only. + +=back + +=cut + + +BEGIN { + +my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc); +my @Types = (@Ignore_Case, qw(Unix)); + +sub fileparse_set_fstype { + my $old = $Fileparse_fstype; + + if (@_) { + my $new_type = shift; + + $Fileparse_fstype = 'Unix'; # default + foreach my $type (@Types) { + $Fileparse_fstype = $type if $new_type =~ /^$type/i; + } + + $Fileparse_igncase = + (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0; + } + + return $old; +} + +} + + +1; + + +=head1 SEE ALSO + +L, L, L diff --git a/testsuite/input-files/perllib/File/Glob.pm b/testsuite/input-files/perllib/File/Glob.pm new file mode 100644 index 00000000..57c30b43 --- /dev/null +++ b/testsuite/input-files/perllib/File/Glob.pm @@ -0,0 +1,190 @@ +package File::Glob; + +use strict; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +use XSLoader (); + +@ISA = qw(Exporter); + +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + +@EXPORT_OK = qw( + csh_glob + bsd_glob + glob + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + bsd_glob + ) ], +); + +$VERSION = '1.06'; + +sub import { + require Exporter; + my $i = 1; + while ($i < @_) { + if ($_[$i] =~ /^:(case|nocase|globally)$/) { + splice(@_, $i, 1); + $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; + $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; + if ($1 eq 'globally') { + local $^W; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; + } + next; + } + ++$i; + } + goto &Exporter::import; +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my ($error, $val) = constant($constname); + if ($error) { + require Carp; + Carp::croak($error); + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +XSLoader::load 'File::Glob', $VERSION; + +# Preloaded methods go here. + +sub GLOB_ERROR { + return (constant('GLOB_ERROR'))[1]; +} + +sub GLOB_CSH () { + GLOB_BRACE() + | GLOB_NOMAGIC() + | GLOB_QUOTE() + | GLOB_TILDE() + | GLOB_ALPHASORT() +} + +$DEFAULT_FLAGS = GLOB_CSH(); +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { + $DEFAULT_FLAGS |= GLOB_NOCASE(); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +sub bsd_glob { + my ($pat,$flags) = @_; + $flags = $DEFAULT_FLAGS if @_ < 2; + return doglob($pat,$flags); +} + +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + splice @_, 1; # don't pass PL_glob_index as flags! + goto &bsd_glob; +} + +## borrowed heavily from gsar's File::DosGlob +my %iter; +my %entries; + +sub csh_glob { + my $pat = shift; + my $cxix = shift; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. + if ($pat =~ /\s/) { + # XXX this is needed for compatibility with the csh + # implementation in Perl. Need to support a flag + # to disable this behavior. + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + if (@pat) { + $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; + } + else { + $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; + } + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +1; +__END__ + diff --git a/testsuite/input-files/perllib/File/Path.pm b/testsuite/input-files/perllib/File/Path.pm new file mode 100644 index 00000000..e31191f5 --- /dev/null +++ b/testsuite/input-files/perllib/File/Path.pm @@ -0,0 +1,895 @@ +package File::Path; + +use 5.005_04; +use strict; + +use Cwd 'getcwd'; +use File::Basename (); +use File::Spec (); + +BEGIN { + if ($] < 5.006) { + # can't say 'opendir my $dh, $dirname' + # need to initialise $dh + eval "use Symbol"; + } +} + +use Exporter (); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +$VERSION = '2.07_03'; +@ISA = qw(Exporter); +@EXPORT = qw(mkpath rmtree); +@EXPORT_OK = qw(make_path remove_tree); + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; + +# These OSes complain if you want to remove a file that you have no +# write permission to: +my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2); + +# Unix-like systems need to stat each directory in order to detect +# race condition. MS-Windows is immune to this particular attack. +my $Need_Stat_Check = !($^O eq 'MSWin32'); + +sub _carp { + require Carp; + goto &Carp::carp; +} + +sub _croak { + require Carp; + goto &Carp::croak; +} + +sub _error { + my $arg = shift; + my $message = shift; + my $object = shift; + + if ($arg->{error}) { + $object = '' unless defined $object; + $message .= ": $!" if $!; + push @{${$arg->{error}}}, {$object => $message}; + } + else { + _carp(defined($object) ? "$message for $object: $!" : "$message: $!"); + } +} + +sub make_path { + push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + goto &mkpath; +} + +sub mkpath { + my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $mode); + ($paths, $verbose, $mode) = @_; + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + $arg->{verbose} = $verbose; + $arg->{mode} = defined $mode ? $mode : 0777; + } + else { + $arg = pop @_; + $arg->{mode} = delete $arg->{mask} if exists $arg->{mask}; + $arg->{mode} = 0777 unless exists $arg->{mode}; + ${$arg->{error}} = [] if exists $arg->{error}; + $paths = [@_]; + } + return _mkpath($arg, $paths); +} + +sub _mkpath { + my $arg = shift; + my $paths = shift; + + my(@created,$path); + foreach $path (@$paths) { + next unless defined($path) and length($path); + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT + # Logic wants Unix paths, so go with the flow. + if ($Is_VMS) { + next if $path eq '/'; + $path = VMS::Filespec::unixify($path); + } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,_mkpath($arg, [$parent])); + } + print "mkdir $path\n" if $arg->{verbose}; + if (mkdir($path,$arg->{mode})) { + push(@created, $path); + } + else { + my $save_bang = $!; + my ($e, $e1) = ($save_bang, $^E); + $e .= "; $e1" if $e ne $e1; + # allow for another process to have created it meanwhile + if (!-d $path) { + $! = $save_bang; + if ($arg->{error}) { + push @{${$arg->{error}}}, {$path => $e}; + } + else { + _croak("mkdir $path: $e"); + } + } + } + } + return @created; +} + +sub remove_tree { + push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH'); + goto &rmtree; +} + +sub _is_subdir { + my($dir, $test) = @_; + + my($dv, $dd) = File::Spec->splitpath($dir, 1); + my($tv, $td) = File::Spec->splitpath($test, 1); + + # not on same volume + return 0 if $dv ne $tv; + + my @d = File::Spec->splitdir($dd); + my @t = File::Spec->splitdir($td); + + # @t can't be a subdir if it's shorter than @d + return 0 if @t < @d; + + return join('/', @d) eq join('/', splice @t, 0, +@d); +} + +sub rmtree { + my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH')); + + my $arg; + my $paths; + + if ($old_style) { + my ($verbose, $safe); + ($paths, $verbose, $safe) = @_; + $arg->{verbose} = $verbose; + $arg->{safe} = defined $safe ? $safe : 0; + + if (defined($paths) and length($paths)) { + $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY'); + } + else { + _carp ("No root path(s) specified\n"); + return 0; + } + } + else { + $arg = pop @_; + ${$arg->{error}} = [] if exists $arg->{error}; + ${$arg->{result}} = [] if exists $arg->{result}; + $paths = [@_]; + } + + $arg->{prefix} = ''; + $arg->{depth} = 0; + + my @clean_path; + $arg->{cwd} = getcwd() or do { + _error($arg, "cannot fetch initial working directory"); + return 0; + }; + for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint + + for my $p (@$paths) { + # need to fixup case and map \ to / on Windows + my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p; + my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd}; + my $ortho_root_length = length($ortho_root); + $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']' + if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) { + local $! = 0; + _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p); + next; + } + + if ($Is_MacOS) { + $p = ":$p" unless $p =~ /:/; + $p .= ":" unless $p =~ /:\z/; + } + elsif ($^O eq 'MSWin32') { + $p =~ s{[/\\]\z}{}; + } + else { + $p =~ s{/\z}{}; + } + push @clean_path, $p; + } + + @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do { + _error($arg, "cannot stat initial working directory", $arg->{cwd}); + return 0; + }; + + return _rmtree($arg, \@clean_path); +} + +sub _rmtree { + my $arg = shift; + my $paths = shift; + + my $count = 0; + my $curdir = File::Spec->curdir(); + my $updir = File::Spec->updir(); + + my (@files, $root); + ROOT_DIR: + foreach $root (@$paths) { + # since we chdir into each directory, it may not be obvious + # to figure out where we are if we generate a message about + # a file name. We therefore construct a semi-canonical + # filename, anchored from the directory being unlinked (as + # opposed to being truly canonical, anchored from the root (/). + + my $canon = $arg->{prefix} + ? File::Spec->catfile($arg->{prefix}, $root) + : $root + ; + + my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR; + + if ( -d _ ) { + $root = VMS::Filespec::pathify($root) if $Is_VMS; + + if (!chdir($root)) { + # see if we can escalate privileges to get in + # (e.g. funny protection mask such as -w- instead of rwx) + $perm &= 07777; + my $nperm = $perm | 0700; + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) { + _error($arg, "cannot make child directory read-write-exec", $canon); + next ROOT_DIR; + } + elsif (!chdir($root)) { + _error($arg, "cannot chdir to child", $canon); + next ROOT_DIR; + } + } + + my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do { + _error($arg, "cannot stat current working directory", $canon); + next ROOT_DIR; + }; + + if ($Need_Stat_Check) { + ($ldev eq $cur_dev and $lino eq $cur_inode) + or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + } + + $perm &= 07777; # don't forget setuid, setgid, sticky bits + my $nperm = $perm | 0700; + + # notabene: 0700 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + + if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) { + _error($arg, "cannot make directory read+writeable", $canon); + $nperm = $perm; + } + + my $d; + $d = gensym() if $] < 5.006; + if (!opendir $d, $curdir) { + _error($arg, "cannot opendir", $canon); + @files = (); + } + else { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names if taint mode is + # active, or any perl < 5.006 + @files = map { /\A(.*)\z/s; $1 } readdir $d; + } + else { + @files = readdir $d; + } + closedir $d; + } + + if ($Is_VMS) { + # Deleting large numbers of files from VMS Files-11 + # filesystems is faster if done in reverse ASCIIbetical order. + # include '.' to '.;' from blead patch #31775 + @files = map {$_ eq '.' ? '.;' : $_} reverse @files; + ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//; + } + + @files = grep {$_ ne $updir and $_ ne $curdir} @files; + + if (@files) { + # remove the contained files before the directory itself + my $narg = {%$arg}; + @{$narg}{qw(device inode cwd prefix depth)} + = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1); + $count += _rmtree($narg, \@files); + } + + # restore directory permissions of required now (in case the rmdir + # below fails), while we are still in the directory and may do so + # without a race via '.' + if ($nperm != $perm and not chmod($perm, $curdir)) { + _error($arg, "cannot reset chmod", $canon); + } + + # don't leave the client code in an unexpected directory + chdir($arg->{cwd}) + or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting."); + + # ensure that a chdir upwards didn't take us somewhere other + # than we expected (see CVE-2002-0435) + ($cur_dev, $cur_inode) = (stat $curdir)[0,1] + or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting."); + + if ($Need_Stat_Check) { + ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode) + or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."); + } + + if ($arg->{depth} or !$arg->{keep_root}) { + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + if ($Force_Writeable and !chmod $perm | 0700, $root) { + _error($arg, "cannot make directory writeable", $canon); + } + print "rmdir $root\n" if $arg->{verbose}; + if (rmdir $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + ++$count; + } + else { + _error($arg, "cannot remove directory", $canon); + if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + ) { + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + } + } + } + } + else { + # not a directory + $root = VMS::Filespec::vmsify("./$root") + if $Is_VMS + && !File::Spec->file_name_is_absolute($root) + && ($root !~ m/(?]+/); # not already in VMS syntax + + if ($arg->{safe} && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $arg->{verbose}; + next ROOT_DIR; + } + + my $nperm = $perm & 07777 | 0600; + if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) { + _error($arg, "cannot make file writeable", $canon); + } + print "unlink $canon\n" if $arg->{verbose}; + # delete all versions under VMS + for (;;) { + if (unlink $root) { + push @{${$arg->{result}}}, $root if $arg->{result}; + } + else { + _error($arg, "cannot unlink file", $canon); + $Force_Writeable and chmod($perm, $root) or + _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon); + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + return $count; +} + +sub _slash_lc { + # fix up slashes and case on MSWin32 so that we can determine that + # c:\path\to\dir is underneath C:/Path/To + my $path = shift; + $path =~ tr{\\}{/}; + return lc($path); +} + +1; +__END__ + +=head1 NAME + +File::Path - Create or remove directory trees + +=head1 VERSION + +This document describes version 2.07 of File::Path, released +2008-11-09. + +=head1 SYNOPSIS + + use File::Path qw(make_path remove_tree); + + make_path('foo/bar/baz', '/zug/zwang'); + make_path('foo/bar/baz', '/zug/zwang', { + verbose => 1, + mode => 0711, + }); + + remove_tree('foo/bar/baz', '/zug/zwang'); + remove_tree('foo/bar/baz', '/zug/zwang', { + verbose => 1, + error => \my $err_list, + }); + + # legacy (interface promoted before v2.00) + mkpath('/foo/bar/baz'); + mkpath('/foo/bar/baz', 1, 0711); + mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + rmtree('foo/bar/baz', 1, 1); + rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); + + # legacy (interface promoted before v2.06) + mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 }); + +=head1 DESCRIPTION + +This module provide a convenient way to create directories of +arbitrary depth and to delete an entire directory subtree from the +filesystem. + +The following functions are provided: + +=over + +=item make_path( $dir1, $dir2, .... ) + +=item make_path( $dir1, $dir2, ...., \%opts ) + +The C function creates the given directories if they don't +exists before, much like the Unix command C. + +The function accepts a list of directories to be created. Its +behaviour may be tuned by an optional hashref appearing as the last +parameter on the call. + +The function returns the list of directories actually created during +the call; in scalar context the number of directories created. + +The following keys are recognised in the option hash: + +=over + +=item mode => $num + +The numeric permissions mode to apply to each created directory +(defaults to 0777), to be modified by the current C. If the +directory already exists (and thus does not need to be created), +the permissions will not be modified. + +C is recognised as an alias for this parameter. + +=item verbose => $bool + +If present, will cause C to print the name of each directory +as it is created. By default nothing is printed. + +=item error => \$err + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store any errors that are encountered. See the L section for more information. + +If this parameter is not used, certain error conditions may raise +a fatal error that will cause the program will halt, unless trapped +in an C block. + +=back + +=item mkpath( $dir ) + +=item mkpath( $dir, $verbose, $mode ) + +=item mkpath( [$dir1, $dir2,...], $verbose, $mode ) + +=item mkpath( $dir1, $dir2,..., \%opt ) + +The mkpath() function provide the legacy interface of make_path() with +a different interpretation of the arguments passed. The behaviour and +return value of the function is otherwise identical to make_path(). + +=item remove_tree( $dir1, $dir2, .... ) + +=item remove_tree( $dir1, $dir2, ...., \%opts ) + +The C function deletes the given directories and any +files and subdirectories they might contain, much like the Unix +command C or C on Windows. + +The function accepts a list of directories to be +removed. Its behaviour may be tuned by an optional hashref +appearing as the last parameter on the call. + +The functions returns the number of files successfully deleted. + +The following keys are recognised in the option hash: + +=over + +=item verbose => $bool + +If present, will cause C to print the name of each file as +it is unlinked. By default nothing is printed. + +=item safe => $bool + +When set to a true value, will cause C to skip the files +for which the process lacks the required privileges needed to delete +files, such as delete privileges on VMS. In other words, the code +will make no attempt to alter file permissions. Thus, if the process +is interrupted, no filesystem object will be left in a more +permissive mode. + +=item keep_root => $bool + +When set to a true value, will cause all files and subdirectories +to be removed, except the initially specified directories. This comes +in handy when cleaning out an application's scratch directory. + + remove_tree( '/tmp', {keep_root => 1} ); + +=item result => \$res + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store all files and directories unlinked +during the call. If nothing is unlinked, the array will be empty. + + remove_tree( '/tmp', {result => \my $list} ); + print "unlinked $_\n" for @$list; + +This is a useful alternative to the C key. + +=item error => \$err + +If present, it should be a reference to a scalar. +This scalar will be made to reference an array, which will +be used to store any errors that are encountered. See the L section for more information. + +Removing things is a much more dangerous proposition than +creating things. As such, there are certain conditions that +C may encounter that are so dangerous that the only +sane action left is to kill the program. + +Use C to trap all that is reasonable (problems with +permissions and the like), and let it die if things get out +of hand. This is the safest course of action. + +=back + +=item rmtree( $dir ) + +=item rmtree( $dir, $verbose, $safe ) + +=item rmtree( [$dir1, $dir2,...], $verbose, $safe ) + +=item rmtree( $dir1, $dir2,..., \%opt ) + +The rmtree() function provide the legacy interface of remove_tree() +with a different interpretation of the arguments passed. The behaviour +and return value of the function is otherwise identical to +remove_tree(). + +=back + +=head2 ERROR HANDLING + +=over 4 + +=item B + +The following error handling mechanism is considered +experimental and is subject to change pending feedback from +users. + +=back + +If C or C encounter an error, a diagnostic +message will be printed to C via C (for non-fatal +errors), or via C (for fatal errors). + +If this behaviour is not desirable, the C attribute may be +used to hold a reference to a variable, which will be used to store +the diagnostics. The variable is made a reference to an array of hash +references. Each hash contain a single key/value pair where the key +is the name of the file, and the value is the error message (including +the contents of C<$!> when appropriate). If a general error is +encountered the diagnostic key will be empty. + +An example usage looks like: + + remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} ); + if (@$err) { + for my $diag (@$err) { + my ($file, $message) = %$diag; + if ($file eq '') { + print "general error: $message\n"; + } + else { + print "problem unlinking $file: $message\n"; + } + } + } + else { + print "No error encountered\n"; + } + +Note that if no errors are encountered, C<$err> will reference an +empty array. This means that C<$err> will always end up TRUE; so you +need to test C<@$err> to determine if errors occured. + +=head2 NOTES + +C blindly exports C and C into the +current namespace. These days, this is considered bad style, but +to change it now would break too much code. Nonetheless, you are +invited to specify what it is you are expecting to use: + + use File::Path 'rmtree'; + +The routines C and C are B exported +by default. You must specify which ones you want to use. + + use File::Path 'remove_tree'; + +Note that a side-effect of the above is that C and C +are no longer exported at all. This is due to the way the C +module works. If you are migrating a codebase to use the new +interface, you will have to list everything explicitly. But that's +just good practice anyway. + + use File::Path qw(remove_tree rmtree); + +=head3 SECURITY CONSIDERATIONS + +There were race conditions 1.x implementations of File::Path's +C function (although sometimes patched depending on the OS +distribution or platform). The 2.0 version contains code to avoid the +problem mentioned in CVE-2002-0435. + +See the following pages for more information: + + http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905 + http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html + http://www.debian.org/security/2005/dsa-696 + +Additionally, unless the C parameter is set (or the +third parameter in the traditional interface is TRUE), should a +C be interrupted, files that were originally in read-only +mode may now have their permissions set to a read-write (or "delete +OK") mode. + +=head1 DIAGNOSTICS + +FATAL errors will cause the program to halt (C), since the +problem is so severe that it would be dangerous to continue. (This +can always be trapped with C, but it's not a good idea. Under +the circumstances, dying is the best thing to do). + +SEVERE errors may be trapped using the modern interface. If the +they are not trapped, or the old interface is used, such an error +will cause the program will halt. + +All other errors may be trapped using the modern interface, otherwise +they will be Ced about. Program execution will not be halted. + +=over 4 + +=item mkdir [path]: [errmsg] (SEVERE) + +C was unable to create the path. Probably some sort of +permissions error at the point of departure, or insufficient resources +(such as free inodes on Unix). + +=item No root path(s) specified + +C was not given any paths to create. This message is only +emitted if the routine is called with the traditional interface. +The modern interface will remain silent if given nothing to do. + +=item No such file or directory + +On Windows, if C gives you this warning, it may mean that +you have exceeded your filesystem's maximum path length. + +=item cannot fetch initial working directory: [errmsg] + +C attempted to determine the initial directory by calling +C, but the call failed for some reason. No attempt +will be made to delete anything. + +=item cannot stat initial working directory: [errmsg] + +C attempted to stat the initial directory (after having +successfully obtained its name via C), however, the call +failed for some reason. No attempt will be made to delete anything. + +=item cannot chdir to [dir]: [errmsg] + +C attempted to set the working directory in order to +begin deleting the objects therein, but was unsuccessful. This is +usually a permissions issue. The routine will continue to delete +other things, but this directory will be left intact. + +=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +C recorded the device and inode of a directory, and then +moved into it. It then performed a C on the current directory +and detected that the device and inode were no longer the same. As +this is at the heart of the race condition problem, the program +will die at this point. + +=item cannot make directory [dir] read+writeable: [errmsg] + +C attempted to change the permissions on the current directory +to ensure that subsequent unlinkings would not run into problems, +but was unable to do so. The permissions remain as they were, and +the program will carry on, doing the best it can. + +=item cannot read [dir]: [errmsg] + +C tried to read the contents of the directory in order +to acquire the names of the directory entries to be unlinked, but +was unsuccessful. This is usually a permissions issue. The +program will continue, but the files in this directory will remain +after the call. + +=item cannot reset chmod [dir]: [errmsg] + +C, after having deleted everything in a directory, attempted +to restore its permissions to the original state but failed. The +directory may wind up being left behind. + +=item cannot remove [dir] when cwd is [dir] + +The current working directory of the program is F +and you are attempting to remove an ancestor, such as F. +The directory tree is left untouched. + +The solution is to C out of the child directory to a place +outside the directory tree to be removed. + +=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL) + +C, after having deleted everything and restored the permissions +of a directory, was unable to chdir back to the parent. The program +halts to avoid a race condition from occurring. + +=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL) + +C was unable to stat the parent directory after have returned +from the child. Since there is no way of knowing if we returned to +where we think we should be (by comparing device and inode) the only +way out is to C. + +=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL) + +When C returned from deleting files in a child directory, a +check revealed that the parent directory it returned to wasn't the one +it started out from. This is considered a sign of malicious activity. + +=item cannot make directory [dir] writeable: [errmsg] + +Just before removing a directory (after having successfully removed +everything it contained), C attempted to set the permissions +on the directory to ensure it could be removed and failed. Program +execution continues, but the directory may possibly not be deleted. + +=item cannot remove directory [dir]: [errmsg] + +C attempted to remove a directory, but failed. This may because +some objects that were unable to be removed remain in the directory, or +a permissions issue. The directory will be left behind. + +=item cannot restore permissions of [dir] to [0nnn]: [errmsg] + +After having failed to remove a directory, C was unable to +restore its permissions from a permissive state back to a possibly +more restrictive setting. (Permissions given in octal). + +=item cannot make file [file] writeable: [errmsg] + +C attempted to force the permissions of a file to ensure it +could be deleted, but failed to do so. It will, however, still attempt +to unlink the file. + +=item cannot unlink file [file]: [errmsg] + +C failed to remove a file. Probably a permissions issue. + +=item cannot restore permissions of [file] to [0nnn]: [errmsg] + +After having failed to remove a file, C was also unable +to restore the permissions on the file to a possibly less permissive +setting. (Permissions given in octal). + +=back + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +Allows files and directories to be moved to the Trashcan/Recycle +Bin (where they may later be restored if necessary) if the operating +system supports such functionality. This feature may one day be +made available directly in C. + +=item * + +L + +When removing directory trees, if you want to examine each file to +decide whether to delete it (and possibly leaving large swathes +alone), F offers a convenient and flexible approach +to examining directory trees. + +=back + +=head1 BUGS + +Please report all bugs on the RT queue: + +L + +=head1 ACKNOWLEDGEMENTS + +Paul Szabo identified the race condition originally, and Brendan +O'Dea wrote an implementation for Debian that addressed the problem. +That code was used as a basis for the current code. Their efforts +are greatly appreciated. + +Gisle Aas made a number of improvements to the documentation for +2.07 and his advice and assistance is also greatly appreciated. + +=head1 AUTHORS + +Tim Bunce and Charles Bailey. Currently maintained by David Landgren +>. + +=head1 COPYRIGHT + +This module is copyright (C) Charles Bailey, Tim Bunce and +David Landgren 1995-2008. All rights reserved. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/testsuite/input-files/perllib/File/Spec.pm b/testsuite/input-files/perllib/File/Spec.pm new file mode 100644 index 00000000..a417d276 --- /dev/null +++ b/testsuite/input-files/perllib/File/Spec.pm @@ -0,0 +1,27 @@ +package File::Spec; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS', + epoc => 'Epoc', + NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin'); + +my $module = $module{$^O} || 'Unix'; + +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/File/Spec/Unix.pm b/testsuite/input-files/perllib/File/Spec/Unix.pm new file mode 100644 index 00000000..7beae084 --- /dev/null +++ b/testsuite/input-files/perllib/File/Spec/Unix.pm @@ -0,0 +1,269 @@ +package File::Spec::Unix; + +use strict; +use vars qw($VERSION); + +$VERSION = '3.30'; +$VERSION = eval $VERSION; + +sub canonpath { + my ($self,$path) = @_; + return unless defined $path; + + # Handle POSIX-style node names beginning with double slash (qnx, nto) + # (POSIX says: "a pathname that begins with two successive slashes + # may be interpreted in an implementation-defined manner, although + # more than two leading slashes shall be treated as a single slash.") + my $node = ''; + my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { + $node = $1; + } + # This used to be + # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); + # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail + # (Mainly because trailing "" directories didn't get stripped). + # Why would cygwin avoid collapsing multiple slashes into one? --jhi + $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx + $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx + $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return "$node$path"; +} + +sub catdir { + my $self = shift; + + $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' +} + +sub catfile { + my $self = shift; + my $file = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "/" unless substr($dir,-1) eq "/"; + return $dir.$file; +} + +sub curdir { '.' } + +sub devnull { '/dev/null' } + +sub rootdir { '/' } + +my $tmpdir; +sub _tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + my @dirlist = @_; + { + no strict 'refs'; + if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + } + foreach (@dirlist) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = $self->curdir unless defined $tmpdir; + $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + return $tmpdir; +} + +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); +} + +sub updir { '..' } + +sub no_upwards { + my $self = shift; + return grep(!/^\.{1,2}\z/s, @_); +} + +sub case_tolerant { 0 } + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); +} + +sub path { + return () unless exists $ENV{PATH}; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +sub join { + my $self = shift; + return $self->catfile(@_); +} + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + +sub splitdir { + return split m|/|, $_[1], -1; # Preserve trailing fields +} + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +sub abs2rel { + my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + ($path, $base) = map $self->canonpath($_), $path, $base; + + if (grep $self->file_name_is_absolute($_), $path, $base) { + ($path, $base) = map $self->rel2abs($_), $path, $base; + } + else { + # save a couple of cwd()s if both paths are relative + ($path, $base) = map $self->catdir('/', $_), $path, $base; + } + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + my $path_directories = ($self->splitpath($path, 1))[1]; + my $base_directories = ($self->splitpath($base, 1))[1]; + + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + if ($base_directories eq $self->rootdir) { + shift @pathchunks; + return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); + } + + while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { + shift @pathchunks ; + shift @basechunks ; + } + return $self->curdir unless @pathchunks || @basechunks; + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. + my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} + +sub _same { + $_[1] eq $_[2]; +} + +sub rel2abs { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + +# Internal routine to File::Spec, no point in making this public since +# it is the standard Cwd interface. Most of the platform-specific +# File::Spec subclasses use this. +sub _cwd { + require Cwd; + Cwd::getcwd(); +} + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + pop @dirs if @dirs && $dirs[-1] eq ''; + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + +1; diff --git a/testsuite/input-files/perllib/File/Temp.pm b/testsuite/input-files/perllib/File/Temp.pm new file mode 100644 index 00000000..a2d4ae07 --- /dev/null +++ b/testsuite/input-files/perllib/File/Temp.pm @@ -0,0 +1,2452 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=begin __INTERNALS + +=head1 PORTABILITY + +This section is at the top in order to provide easier access to +porters. It is not expected to be rendered by a standard pod +formatting tool. Please skip straight to the SYNOPSIS section if you +are not trying to port this module to a new platform. + +This module is designed to be portable across operating systems and it +currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS +(Classic). When porting to a new OS there are generally three main +issues that have to be solved: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C reliable? By default all the +return values from C are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C fails +then the C comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); + + binmode( $fh, ":utf8" ); + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + +Object interface: + + require File::Temp; + use File::Temp (); + use File::Temp qw/ :seekable /; + + $fh = File::Temp->new(); + $fname = $fh->filename; + + $fh = File::Temp->new(TEMPLATE => $template); + $fname = $fh->filename; + + $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); + print $tmp "Some data\n"; + print "Filename is $tmp\n"; + $tmp->seek( 0, SEEK_END ); + +The following interfaces are provided for compatibility with +existing APIs. They should not be used in new code. + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=head1 DESCRIPTION + +C can be used to create and open temporary files in a safe +way. There is both a function interface and an object-oriented +interface. The File::Temp constructor or the tempfile() function can +be used to return the name and the open filehandle of a temporary +file. The tempdir() function can be used to create a temporary +directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +Filehandles returned by these functions support the seekable methods. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.004 so give them what they want :-) +use 5.004; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use IO::Seekable; # For SEEK_* +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# pre-emptively load Carp::Heavy. If we don't when we run out of file +# handles and attempt to call croak() we get an error message telling +# us that Carp::Heavy won't load rather than an error telling us we +# have run out of file handles. We either preload croak() or we +# switch the calls to croak from _gettemp() to use die. +eval { require Carp::Heavy; }; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + +### For the OO interface +use base qw/ IO::Handle IO::Seekable /; +use overload '""' => "STRINGIFY", fallback => 1; + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); + +$DEBUG = 0; +$KEEP_ALL = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + cleanup + SEEK_SET + SEEK_CUR + SEEK_END + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp','seekable'); + +# Version number + +$VERSION = '0.22'; + +# This is a list of characters that can be used in random filenames + +my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z + a b c d e f g h i j k l m n o p q r s t u v w x y z + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 1000; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; +my $LOCKFLAG; + +unless ($^O eq 'MacOS') { + for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } + # Special case O_EXLOCK + $LOCKFLAG = eval { + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + &Fcntl::O_EXLOCK(); + }; +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + local($@); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # e.g. CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } +} + +# Private hash tracking which files have been created by each process id via the OO interface +my %FILES_CREATED_BY_OBJECT; + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix +# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "use_exlock" => 1, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must end with at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry (i.e. the directory template) that means + # we are in the current directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-e $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; + return (); + } + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + my $safeerr; + unless (_is_safe($parent,\$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + my $safeerr; + unless (_is_verysafe($parent, \$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # in case of odd umask force rw + chmod(0600, $path); + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Open the temp directory + if (mkdir( $path, 0700)) { + # in case of odd umask + chmod(0700, $path); + + return undef, $path; + } else { + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + my $end = ( $] >= 5.006 ? "\\z" : "\\Z" ); + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; + } + return $path; +} + +# Internal routine to force a temp file to be writable after +# it is created so that we can unlink it. Windows seems to occassionally +# force a file to be readonly when written to certain temp locations +sub _force_writable { + my $file = shift; + chmod 0600, $file; +} + + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + } + ; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the effective uid from the $> variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d $path) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k $path) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + local($@); + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories They will + # only exist in this block. + + # This means we only have to set up a single END block to remove + # all files. + + # in order to prevent child processes inadvertently deleting the parent + # temp files we use a hash to store the temp files and directories + # created by a particular process id. + + # %files_to_unlink contains values that are references to an array of + # array references containing the filehandle and filename associated with + # the temp file. + my (%files_to_unlink, %dirs_to_unlink); + + # Set up an end block to use these arrays + END { + local($., $@, $!, $^E, $?); + cleanup(); + } + + # Cleanup function. Always triggered on END but can be invoked + # manually. + sub cleanup { + if (!$KEEP_ALL) { + # Files + my @files = (exists $files_to_unlink{$$} ? + @{ $files_to_unlink{$$} } : () ); + foreach my $file (@files) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + _force_writable( $file->[1] ); # for windows + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + my @dirs = (exists $dirs_to_unlink{$$} ? + @{ $dirs_to_unlink{$$} } : () ); + foreach my $dir (@dirs) { + if (-d $dir) { + # Some versions of rmtree will abort if you attempt to remove + # the directory you are sitting in. We protect that and turn it + # into a warning. We do this because this occurs during + # cleanup and so can not be caught by the user. + eval { rmtree($dir, $DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + } + + # clear the arrays + @{ $files_to_unlink{$$} } = () + if exists $files_to_unlink{$$}; + @{ $dirs_to_unlink{$$} } = () + if exists $dirs_to_unlink{$$}; + } + } + + + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; + $dirs_to_unlink{$$} = [] + unless exists $dirs_to_unlink{$$}; + push (@{ $dirs_to_unlink{$$} }, $fname); + + } else { + carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; + } + + } else { + + if (-f $fname) { + + # file exists so store handle and name for later removal + $files_to_unlink{$$} = [] + unless exists $files_to_unlink{$$}; + push(@{ $files_to_unlink{$$} }, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; + } + + } + + } + + +} + +=head1 OBJECT-ORIENTED INTERFACE + +This is the primary interface for interacting with +C. Using the OO interface a temporary file can be created +when the object is constructed and the file can be removed when the +object is no longer required. + +Note that there is no method to obtain the filehandle from the +C object. The object itself acts as a filehandle. Also, +the object is configured such that it stringifies to the name of the +temporary file, and can be compared to a filename directly. The object +isa C and isa C so all those methods are +available. + +=over 4 + +=item B + +Create a temporary file object. + + my $tmp = File::Temp->new(); + +by default the object is constructed as if C +was called without options, but with the additional behaviour +that the temporary file is removed by the object destructor +if UNLINK is set to true (the default). + +Supported arguments are the same as for C: UNLINK +(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename +template is specified using the TEMPLATE option. The OPEN option +is not supported (the file is always opened). + + $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', + DIR => 'mydir', + SUFFIX => '.dat'); + +Arguments are case insensitive. + +Can call croak() if an error occurs. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + # read arguments and convert keys to upper case + my %args = @_; + %args = map { uc($_), $args{$_} } keys %args; + + # see if they are unlinking (defaulting to yes) + my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); + delete $args{UNLINK}; + + # template (store it in an array so that it will + # disappear from the arg list of tempfile) + my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); + delete $args{TEMPLATE}; + + # Protect OPEN + delete $args{OPEN}; + + # Open the file and retain file handle and file name + my ($fh, $path) = tempfile( @template, %args ); + + print "Tmp: $fh - $path\n" if $DEBUG; + + # Store the filename in the scalar slot + ${*$fh} = $path; + + # Cache the filename by pid so that the destructor can decide whether to remove it + $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; + + # Store unlink information in hash slot (plus other constructor info) + %{*$fh} = %args; + + # create the object + bless $fh, $class; + + # final method-based configuration + $fh->unlink_on_destroy( $unlink ); + + return $fh; +} + +=item B + +Create a temporary directory using an object oriented interface. + + $dir = File::Temp->newdir(); + +By default the directory is deleted when the object goes out of scope. + +Supports the same options as the C function. Note that directories +created with this method default to CLEANUP => 1. + + $dir = File::Temp->newdir( $template, %options ); + +=cut + +sub newdir { + my $self = shift; + + # need to handle args as in tempdir because we have to force CLEANUP + # default without passing CLEANUP to tempdir + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + my %options = @_; + my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); + + delete $options{CLEANUP}; + + my $tempdir; + if (defined $template) { + $tempdir = tempdir( $template, %options ); + } else { + $tempdir = tempdir( %options ); + } + return bless { DIRNAME => $tempdir, + CLEANUP => $cleanup, + LAUNCHPID => $$, + }, "File::Temp::Dir"; +} + +=item B + +Return the name of the temporary file associated with this object +(if the object was created using the "new" constructor). + + $filename = $tmp->filename; + +This method is called automatically when the object is used as +a string. + +=cut + +sub filename { + my $self = shift; + return ${*$self}; +} + +sub STRINGIFY { + my $self = shift; + return $self->filename; +} + +=item B + +Return the name of the temporary directory associated with this +object (if the object was created using the "newdir" constructor). + + $dirname = $tmpdir->dirname; + +This method is called automatically when the object is used in string context. + +=item B + +Control whether the file is unlinked when the object goes out of scope. +The file is removed if this value is true and $KEEP_ALL is not. + + $fh->unlink_on_destroy( 1 ); + +Default is for the file to be removed. + +=cut + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + ${*$self}{UNLINK} = shift; + } + return ${*$self}{UNLINK}; +} + +=item B + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using C) +if the constructor was called with UNLINK set to 1 (the default state +if UNLINK is not specified). + +No error is given if the unlink fails. + +If the object has been passed to a child process during a fork, the +file will be deleted when the object goes out of scope in the parent. + +For a temporary directory object the directory will be removed +unless the CLEANUP argument was used in the constructor (and set to +false) or C was modified after creation. + +If the global variable $KEEP_ALL is true, the file or directory +will not be removed. + +=cut + +sub DESTROY { + local($., $@, $!, $^E, $?); + my $self = shift; + + # Make sure we always remove the file from the global hash + # on destruction. This prevents the hash from growing uncontrollably + # and post-destruction there is no reason to know about the file. + my $file = $self->filename; + my $was_created_by_proc; + if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) { + $was_created_by_proc = 1; + delete $FILES_CREATED_BY_OBJECT{$$}{$file}; + } + + if (${*$self}{UNLINK} && !$KEEP_ALL) { + print "# ---------> Unlinking $self\n" if $DEBUG; + + # only delete if this process created it + return unless $was_created_by_proc; + + # The unlink1 may fail if the file has been closed + # by the caller. This leaves us with the decision + # of whether to refuse to remove the file or simply + # do an unlink without test. Seems to be silly + # to do this when we are trying to be careful + # about security + _force_writable( $file ); # for windows + unlink1( $self, $file ) + or unlink($file); + } +} + +=back + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +at the end of the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, TMPDIR => 1); + +Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file +into the same temporary directory as would be used if no template was +specified at all. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits (dependent on +$KEEP_ALL). Default is for the file to be removed if a file handle is +requested and to be kept if the filename is requested. In a scalar +context (where no filename is returned) the file is always deleted +either (depending on the operating system) on exit or when it is +closed (unless $KEEP_ALL is true when the temp file is created). + +Use the object-oriented interface if fine-grained control of when +a file is removed is required. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( DIR => $dir ); + +If called in scalar context, only the filehandle is returned and the +file will automatically be deleted when closed on operating systems +that support this (see the description of tmpfile() elsewhere in this +document). This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition by fumbling +with the filename. On systems that can not unlink an open file or can +not mark a file as temporary when it is opened (for example, Windows +NT uses the C flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C +flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +If the operating system supports it (for example BSD derived systems), the +filehandle will be opened with O_EXLOCK (open with exclusive file lock). +This can sometimes cause problems if the intention is to pass the filename +to another system that expects to take an exclusive lock itself (such as +DBD::SQLite) whilst ensuring that the tempfile is not reused. In this +situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK +will be true (this retains compatibility with earlier releases). + + ($fh, $filename) = tempfile($template, EXLOCK => 0); + +Options can be combined as required. + +Will croak() if there is an error. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + "TMPDIR" => 0, # Place tempfile in tempdir if template specified + "EXLOCK" => 1, # Open file with O_EXLOCK + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + # End up with current directory if neither DIR not TMPDIR are set + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + $template = File::Spec->catfile(File::Spec->tmpdir, $template ); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it (which may be + # important if they want a child process to use the file) + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + "use_exlock" => $options{EXLOCK}, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B + +This is the recommended interface for creation of temporary +directories. By default the directory will not be removed on exit +(that is, it won't be temporary; this behaviour can not be changed +because of issues with backwards compatibility). To enable removal +either use the CLEANUP option which will trigger removal on program +exit, or consider using the "newdir" method in the object interface which +will allow the directory to be cleaned up when the object goes out of +scope. + +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, create the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C option is ignored if C is set +explicitly. Additionally, C is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +Will croak() if there is an error. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F. The trailing X's are replaced +with unique alphanumeric combinations. + +Will croak() if there is an error. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C and suffix of C<.dat> +would generate a file similar to F. + +Returns just the filehandle alone when called in scalar context. + +Will croak() if there is an error. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. + +Directory must be removed by the caller. + +Will croak() if there is an error. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +Will croak() if there is an error. + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L +using the mkstemp() from this module. + +Unlike the L implementations, the directory used +for the temporary file is not specified in a system include +file (C) but simply depends on the choice of tmpdir() +returned by L. On some implementations this +location can be set using the C environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L for information on the choice of temporary +directory for a particular operating system. + +Will croak() if there is an error. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B + +Returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +Will croak() if there is an error. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C +with C if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +Will croak() if there is an error. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) + or die "Error unlinking file $path safely"; + +Returns false on error but croaks() if there is a security +anomaly. The filehandle is not closed since on some occasions this is +not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C and C fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C being more accurate than +C, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +This function is disabled if the global variable $KEEP_ALL is true +and an unlink on open file is supported. If the unlink is to be deferred +to the END block, the file is still registered for removal. + +This function should not be called if you are using the object oriented +interface since the it will interfere with the object destructor deleting +the file. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + + # return early (Without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + my @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=item B + +Compare C of filehandle with C of provided filename. This +can be used to check that the filename and filehandle initially point +to the same file and that the number of links to the file is 1 (all +fields returned by stat() are compared). + + cmpstat($fh, $path) + or die "Error comparing handle with file"; + +Returns false if the stat information differs or if the link count is +greater than 1. Calls croak if there is a security anomaly. + +On certain platforms, for example Windows, not all the fields returned by stat() +can be compared. For example, the C and C fields seem to be +different in Windows. Also, it seems that the size of the file +returned by stat() does not always agree, with C being more +accurate than C, presumably because of caching issues +even when using autoflush (this is usually overcome by waiting a while +after writing to the tempfile before attempting to C it). + +Not exported by default. + +=cut + +sub cmpstat { + + croak 'Usage: cmpstat(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Comparing stat\n" + if $DEBUG; + + # Stat the filehandle - which may be closed if someone has manually + # closed the file. Can not turn off warnings without using $^W + # unless we upgrade to 5.006 minimum requirement + my @fh; + { + local ($^W) = 0; + @fh = stat $fh; + } + return unless @fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f $path) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } elsif ($^O eq 'mpeix') { + @okstat = (0..4,8..10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + return 1; +} + +=item B + +Similar to C except after file comparison using cmpstat, the +filehandle is closed prior to attempting to unlink the file. This +allows the file to be removed without using an END block, but does +mean that the post-unlink comparison of the filehandle state provided +by C is not available. + + unlink1($fh, $path) + or die "Error closing and unlinking file"; + +Usually called from the object destructor when using the OO interface. + +Not exported by default. + +This function is disabled if the global variable $KEEP_ALL is true. + +Can call croak() if there is a security anomaly during the stat() +comparison. + +=cut + +sub unlink1 { + croak 'Usage: unlink1(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # Close the file + close( $fh ) or return 0; + + # Make sure the file is writable (for windows) + _force_writable( $path ); + + # return early (without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # remove the file + return unlink($path); +} + +=item B + +Calling this function will cause any temp files or temp directories +that are registered for removal to be removed. This happens automatically +when the process exits but can be triggered manually if the caller is sure +that none of the temp files are required. This method can be registered as +an Apache callback. + +On OSes where temp files are automatically removed when the temp file +is closed, calling this function will have no effect other than to remove +temporary directories (which may include temporary files). + + File::Temp::cleanup(); + +Not exported by default. + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and is +writable, that temporary files are opened only if they do not already +exist, and that possible race conditions are avoided. Finally the +L function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C, C, C etc) rather than +simply by root. + +This is required since on many unix systems C is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C is set to MEDIUM or higher. + +=cut + +{ + my $TopSystemUID = 10; + $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=item B<$KEEP_ALL> + +Controls whether temporary files and directories should be retained +regardless of any instructions in the program to remove them +automatically. This is useful for debugging but should not be used in +production code. + + $File::Temp::KEEP_ALL = 1; + +Default is for files to be removed as requested by the caller. + +In some cases, files will only be retained if this variable is true +when the file is created. This means that you can not create a temporary +file, set this variable and expect the temp file to still be around +when the program exits. + +=item B<$DEBUG> + +Controls whether debugging messages should be enabled. + + $File::Temp::DEBUG = 1; + +Default is for debugging mode to be disabled. + +=back + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head2 Forking + +In some cases files created by File::Temp are removed from within an +END block. Since END blocks are triggered when a child process exits +(unless C is used by the child) File::Temp takes care +to only remove those temp files created by a particular process ID. This +means that a child will not attempt to remove temp files created by the +parent process. + +If you are forking many processes in parallel that are all creating +temporary files, you may need to reset the random number seed using +srand(EXPR) in each child else all the children will attempt to walk +through the same set of random file names and may well cause +themselves to give up if they exceed the number of retry attempts. + +=head2 Directory removal + +Note that if you have chdir'ed into the temporary directory and it is +subsequently cleaned up (either in the END block or as part of object +destruction), then you will get a warning from File::Path::rmtree(). + +=head2 BINMODE + +The file returned by File::Temp will have been opened in binary mode +if such a mode is available. If that is not correct, use the C +function to change the mode of the filehandle. + +Note that you can modify the encoding of a file opened by File::Temp +also by using C. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. The module was shipped +as a standard part of perl from v5.6.1. + +=head1 SEE ALSO + +L, L, L, L + +See L and L, L for +different implementations of temporary file handling. + +See L for an alternative object-oriented wrapper for +the C function. + +=head1 AUTHOR + +Tim Jenness Etjenness@cpan.orgE + +Copyright (C) 2007-2009 Tim Jenness. +Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + +package File::Temp::Dir; + +use File::Path qw/ rmtree /; +use strict; +use overload '""' => "STRINGIFY", fallback => 1; + +# private class specifically to support tempdir objects +# created by File::Temp->newdir + +# ostensibly the same method interface as File::Temp but without +# inheriting all the IO::Seekable methods and other cruft + +# Read-only - returns the name of the temp directory + +sub dirname { + my $self = shift; + return $self->{DIRNAME}; +} + +sub STRINGIFY { + my $self = shift; + return $self->dirname; +} + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + $self->{CLEANUP} = shift; + } + return $self->{CLEANUP}; +} + +sub DESTROY { + my $self = shift; + local($., $@, $!, $^E, $?); + if ($self->unlink_on_destroy && + $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { + if (-d $self->{DIRNAME}) { + # Some versions of rmtree will abort if you attempt to remove + # the directory you are sitting in. We protect that and turn it + # into a warning. We do this because this occurs during object + # destruction and so can not be caught by the user. + eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + } +} + + +1; diff --git a/testsuite/input-files/perllib/FileHandle.pm b/testsuite/input-files/perllib/FileHandle.pm new file mode 100644 index 00000000..67613403 --- /dev/null +++ b/testsuite/input-files/perllib/FileHandle.pm @@ -0,0 +1,105 @@ +package FileHandle; + +use 5.006; +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK); + +$VERSION = "2.02"; + +require IO::File; +@ISA = qw(IO::File); + +@EXPORT = qw(_IOFBF _IOLBF _IONBF); + +@EXPORT_OK = qw( + pipe + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + + print + printf + getline + getlines +); + +# +# Everything we're willing to export, we must first import. +# +import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; + +# +# Some people call "FileHandle::function", so all the functions +# that were in the old FileHandle class must be imported, too. +# +{ + no strict 'refs'; + + my %import = ( + 'IO::Handle' => + [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets + eof flush error clearerr setbuf setvbuf _open_mode_string)], + 'IO::Seekable' => + [qw(seek tell getpos setpos)], + 'IO::File' => + [qw(new new_tmpfile open)] + ); + for my $pkg (keys %import) { + for my $func (@{$import{$pkg}}) { + my $c = *{"${pkg}::$func"}{CODE} + or die "${pkg}::$func missing"; + *$func = $c; + } + } +} + +# +# Specialized importer for Fcntl magic. +# +sub import { + my $pkg = shift; + my $callpkg = caller; + require Exporter; + Exporter::export($pkg, $callpkg, @_); + + # + # If the Fcntl extension is available, + # export its constants. + # + eval { + require Fcntl; + Exporter::export('Fcntl', $callpkg); + }; +} + +################################################ +# This is the only exported function we define; +# the rest come from other classes. +# + +sub pipe { + my $r = new IO::Handle; + my $w = new IO::Handle; + CORE::pipe($r, $w) or return undef; + ($r, $w); +} + +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/Getopt/Long.pm b/testsuite/input-files/perllib/Getopt/Long.pm new file mode 100644 index 00000000..04038db5 --- /dev/null +++ b/testsuite/input-files/perllib/Getopt/Long.pm @@ -0,0 +1,2504 @@ +# Getopt::Long.pm -- Universal options parsing + +package Getopt::Long; + +# RCS Status : $Id: GetoptLong.pm,v 2.72 2005-04-28 21:18:33+02 jv Exp $ +# Author : Johan Vromans +# Created On : Tue Sep 11 15:00:12 1990 +# Last Modified By: Johan Vromans +# Last Modified On: Wed Dec 14 21:17:21 2005 +# Update Count : 1458 +# Status : Released + +################ Copyright ################ + +# This program is Copyright 1990,2005 by Johan Vromans. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the Perl Artistic License or the +# GNU General Public License as published by the Free Software +# Foundation; either version 2 of the License, or (at your option) any +# later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# If you do not have a copy of the GNU General Public License write to +# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +# MA 02139, USA. + +################ Module Preamble ################ + +use 5.004; + +use strict; + +use vars qw($VERSION); +$VERSION = 2.35; +# For testing versions only. +#use vars qw($VERSION_STRING); +#$VERSION_STRING = "2.35"; + +use Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK); +@ISA = qw(Exporter); + +# Exported subroutines. +sub GetOptions(@); # always +sub Configure(@); # on demand +sub HelpMessage(@); # on demand +sub VersionMessage(@); # in demand + +BEGIN { + # Init immediately so their contents can be used in the 'use vars' below. + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure); +} + +# User visible variables. +use vars @EXPORT, @EXPORT_OK; +use vars qw($error $debug $major_version $minor_version); +# Deprecated visible variables. +use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough); +# Official invisible variables. +use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); + +# Public subroutines. +sub config(@); # deprecated name + +# Private subroutines. +sub ConfigDefaults(); +sub ParseOptionSpec($$); +sub OptCtl($); +sub FindOption($$$$); +sub ValidValue ($$$$$); + +################ Local Variables ################ + +# $requested_version holds the version that was mentioned in the 'use' +# or 'require', if any. It can be used to enable or disable specific +# features. +my $requested_version = 0; + +################ Resident subroutines ################ + +sub ConfigDefaults() { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $genprefix = "(--|-)"; + $autoabbrev = 0; # no automatic abbrev of options + $bundling = 0; # no bundling of single letter switches + $getopt_compat = 0; # disallow '+' to start options + $order = $REQUIRE_ORDER; + } + else { + $genprefix = "(--|-|\\+)"; + $autoabbrev = 1; # automatic abbrev of options + $bundling = 0; # bundling off by default + $getopt_compat = 1; # allow '+' to start options + $order = $PERMUTE; + } + # Other configurable settings. + $debug = 0; # for debugging + $error = 0; # error tally + $ignorecase = 1; # ignore case when matching options + $passthrough = 0; # leave unrecognized options alone + $gnu_compat = 0; # require --opt=val if value is optional + $longprefix = "(--)"; # what does a long prefix look like +} + +# Override import. +sub import { + my $pkg = shift; # package + my @syms = (); # symbols to import + my @config = (); # configuration + my $dest = \@syms; # symbols first + for ( @_ ) { + if ( $_ eq ':config' ) { + $dest = \@config; # config next + next; + } + push(@$dest, $_); # push + } + # Hide one level and call super. + local $Exporter::ExportLevel = 1; + push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions + $pkg->SUPER::import(@syms); + # And configure. + Configure(@config) if @config; +} + +################ Initialization ################ + +# Values for $order. See GNU getopt.c for details. +($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); +# Version major/minor numbers. +($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; + +ConfigDefaults(); + +################ OO Interface ################ + +package Getopt::Long::Parser; + +# Store a copy of the default configuration. Since ConfigDefaults has +# just been called, what we get from Configure is the default. +my $default_config = do { + Getopt::Long::Configure () +}; + +sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; + + # Register the callers package. + my $self = { caller_pkg => (caller)[0] }; + + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); + $self->{settings} = Getopt::Long::Configure ($save); + delete ($atts{config}); + } + # Else use default config. + else { + $self->{settings} = $default_config; + } + + if ( %atts ) { # Oops + die(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))."\n"); + } + + $self; +} + +sub configure { + my ($self) = shift; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Getopt::Long::Configure ($save); +} + +sub getoptions { + my ($self) = shift; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller_pkg}; + + eval { + # Locally set exception handler to default, otherwise it will + # be called implicitly here, and again explicitly when we try + # to deliver the messages. + local ($SIG{__DIE__}) = '__DEFAULT__'; + $ret = Getopt::Long::GetOptions (@_); + }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; +} + +package Getopt::Long; + +################ Back to Normal ################ + +# Indices in option control info. +# Note that ParseOptions uses the fields directly. Search for 'hard-wired'. +use constant CTL_TYPE => 0; +#use constant CTL_TYPE_FLAG => ''; +#use constant CTL_TYPE_NEG => '!'; +#use constant CTL_TYPE_INCR => '+'; +#use constant CTL_TYPE_INT => 'i'; +#use constant CTL_TYPE_INTINC => 'I'; +#use constant CTL_TYPE_XINT => 'o'; +#use constant CTL_TYPE_FLOAT => 'f'; +#use constant CTL_TYPE_STRING => 's'; + +use constant CTL_CNAME => 1; + +use constant CTL_DEFAULT => 2; + +use constant CTL_DEST => 3; + use constant CTL_DEST_SCALAR => 0; + use constant CTL_DEST_ARRAY => 1; + use constant CTL_DEST_HASH => 2; + use constant CTL_DEST_CODE => 3; + +use constant CTL_AMIN => 4; +use constant CTL_AMAX => 5; + +# FFU. +#use constant CTL_RANGE => ; +#use constant CTL_REPEAT => ; + +sub GetOptions(@) { + + my @optionlist = @_; # local copy of the option descriptions + my $argend = '--'; # option list terminator + my %opctl = (); # table of option specs + my $pkg = $caller || (caller)[0]; # current context + # Needed if linkage is omitted. + my @ret = (); # accum for non-options + my %linkage; # linkage + my $userlinkage; # user supplied HASH + my $opt; # current option + my $prefix = $genprefix; # current prefix + + $error = ''; + + if ( $debug ) { + # Avoid some warnings if debugging. + local ($^W) = 0; + print STDERR + ("Getopt::Long $Getopt::Long::VERSION (", + '$Revision: 2.72 $', ") ", + "called from package \"$pkg\".", + "\n ", + "ARGV: (@ARGV)", + "\n ", + "autoabbrev=$autoabbrev,". + "bundling=$bundling,", + "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", + "order=$order,", + "\n ", + "ignorecase=$ignorecase,", + "requested_version=$requested_version,", + "passthrough=$passthrough,", + "genprefix=\"$genprefix\",", + "longprefix=\"$longprefix\".", + "\n"); + } + + # Check for ref HASH as first argument. + # First argument may be an object. It's OK to use this as long + # as it is really a hash underneath. + $userlinkage = undef; + if ( @optionlist && ref($optionlist[0]) and + UNIVERSAL::isa($optionlist[0],'HASH') ) { + $userlinkage = shift (@optionlist); + print STDERR ("=> user linkage: $userlinkage\n") if $debug; + } + + # See if the first element of the optionlist contains option + # starter characters. + # Be careful not to interpret '<>' as option starters. + if ( @optionlist && $optionlist[0] =~ /^\W+$/ + && !($optionlist[0] eq '<>' + && @optionlist > 0 + && ref($optionlist[1])) ) { + $prefix = shift (@optionlist); + # Turn into regexp. Needs to be parenthesized! + $prefix =~ s/(\W)/\\$1/g; + $prefix = "([" . $prefix . "])"; + print STDERR ("=> prefix=\"$prefix\"\n") if $debug; + } + + # Verify correctness of optionlist. + %opctl = (); + while ( @optionlist ) { + my $opt = shift (@optionlist); + + unless ( defined($opt) ) { + $error .= "Undefined argument in option spec\n"; + next; + } + + # Strip leading prefix so people can specify "--foo=i" if they like. + $opt = $+ if $opt =~ /^$prefix+(.*)$/s; + + if ( $opt eq '<>' ) { + if ( (defined $userlinkage) + && !(@optionlist > 0 && ref($optionlist[0])) + && (exists $userlinkage->{$opt}) + && ref($userlinkage->{$opt}) ) { + unshift (@optionlist, $userlinkage->{$opt}); + } + unless ( @optionlist > 0 + && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { + $error .= "Option spec <> requires a reference to a subroutine\n"; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + $linkage{'<>'} = shift (@optionlist); + next; + } + + # Parse option spec. + my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); + unless ( defined $name ) { + # Failed. $orig contains the error message. Sorry for the abuse. + $error .= $orig; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + + # If no linkage is supplied in the @optionlist, copy it from + # the userlinkage if available. + if ( defined $userlinkage ) { + unless ( @optionlist > 0 && ref($optionlist[0]) ) { + if ( exists $userlinkage->{$orig} && + ref($userlinkage->{$orig}) ) { + print STDERR ("=> found userlinkage for \"$orig\": ", + "$userlinkage->{$orig}\n") + if $debug; + unshift (@optionlist, $userlinkage->{$orig}); + } + else { + # Do nothing. Being undefined will be handled later. + next; + } + } + } + + # Copy the linkage. If omitted, link to global variable. + if ( @optionlist > 0 && ref($optionlist[0]) ) { + print STDERR ("=> link \"$orig\" to $optionlist[0]\n") + if $debug; + my $rl = ref($linkage{$orig} = shift (@optionlist)); + + if ( $rl eq "ARRAY" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; + } + elsif ( $rl eq "HASH" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; + } + elsif ( $rl eq "SCALAR" ) { +# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { +# my $t = $linkage{$orig}; +# $$t = $linkage{$orig} = []; +# } +# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { +# } +# else { + # Ok. +# } + } + elsif ( $rl eq "CODE" ) { + # Ok. + } + else { + $error .= "Invalid option linkage for \"$opt\"\n"; + } + } + else { + # Link to global $opt_XXX variable. + # Make sure a valid perl identifier results. + my $ov = $orig; + $ov =~ s/\W/_/g; + if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); + } + elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); + } + else { + print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); + } + } + } + + # Bail out if errors found. + die ($error) if $error; + $error = 0; + + # Supply --version and --help support, if needed and allowed. + if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{version}) ) { + $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; + $linkage{version} = \&VersionMessage; + } + $auto_version = 1; + } + if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { + $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; + $linkage{help} = \&HelpMessage; + } + $auto_help = 1; + } + + # Show the options tables if debugging. + if ( $debug ) { + my ($arrow, $k, $v); + $arrow = "=> "; + while ( ($k,$v) = each(%opctl) ) { + print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); + $arrow = " "; + } + } + + # Process argument list + my $goon = 1; + while ( $goon && @ARGV > 0 ) { + + # Get next argument. + $opt = shift (@ARGV); + print STDERR ("=> arg \"", $opt, "\"\n") if $debug; + + # Double dash is option list terminator. + if ( $opt eq $argend ) { + push (@ret, $argend) if $passthrough; + last; + } + + # Look it up. + my $tryopt = $opt; + my $found; # success status + my $key; # key (if hash type) + my $arg; # option argument + my $ctl; # the opctl entry + + ($found, $opt, $ctl, $arg, $key) = + FindOption ($prefix, $argend, $opt, \%opctl); + + if ( $found ) { + + # FindOption undefines $opt in case of errors. + next unless defined $opt; + + my $argcnt = 0; + while ( defined $arg ) { + + # Get the canonical name. + print STDERR ("=> cname for \"$opt\" is ") if $debug; + $opt = $ctl->[CTL_CNAME]; + print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; + + if ( defined $linkage{$opt} ) { + print STDERR ("=> ref(\$L{$opt}) -> ", + ref($linkage{$opt}), "\n") if $debug; + + if ( ref($linkage{$opt}) eq 'SCALAR' ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined ${$linkage{$opt}} ) { + ${$linkage{$opt}} += $arg; + } + else { + ${$linkage{$opt}} = $arg; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to ARRAY\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = []; + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to HASH\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = {}; + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + else { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") + if $debug; + ${$linkage{$opt}} = $arg; + } + } + elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( ref($linkage{$opt}) eq 'HASH' ) { + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'CODE' ) { + print STDERR ("=> &L{$opt}(\"$opt\"", + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", + ", \"$arg\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { + &{$linkage{$opt}}($opt, + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), + $arg); + }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("Invalid REF type \"", ref($linkage{$opt}), + "\" in linkage\n"); + die("Getopt::Long -- internal error!\n"); + } + } + # No entry in linkage means entry in userlinkage. + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") + if $debug; + push (@{$userlinkage->{$opt}}, $arg); + } + else { + print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") + if $debug; + $userlinkage->{$opt} = [$arg]; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $userlinkage->{$opt}->{$key} = $arg; + } + else { + print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") + if $debug; + $userlinkage->{$opt} = {$key => $arg}; + } + } + else { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined $userlinkage->{$opt} ) { + $userlinkage->{$opt} += $arg; + } + else { + $userlinkage->{$opt} = $arg; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } + } + + $argcnt++; + last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; + undef($arg); + + # Need more args? + if ( $argcnt < $ctl->[CTL_AMIN] ) { + if ( @ARGV ) { + if ( ValidValue($ctl, $ARGV[0], 1, $argend, $prefix) ) { + $arg = shift(@ARGV); + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + warn("Value \"$ARGV[0]\" invalid for option $opt\n"); + $error++; + } + else { + warn("Insufficient arguments for option $opt\n"); + $error++; + } + } + + # Any more args? + if ( @ARGV && ValidValue($ctl, $ARGV[0], 0, $argend, $prefix) ) { + $arg = shift(@ARGV); + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + } + } + + # Not an option. Save it if we $PERMUTE and don't have a <>. + elsif ( $order == $PERMUTE ) { + # Try non-options call-back. + my $cb; + if ( (defined ($cb = $linkage{'<>'})) ) { + print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = '__DEFAULT__'; + eval { &$cb ($tryopt) }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("=> saving \"$tryopt\" ", + "(not an option, may permute)\n") if $debug; + push (@ret, $tryopt); + } + next; + } + + # ...otherwise, terminate. + else { + # Push this one back and exit. + unshift (@ARGV, $tryopt); + return ($error == 0); + } + + } + + # Finish. + if ( @ret && $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug; + unshift (@ARGV, @ret); + } + + return ($error == 0); +} + +# A readable representation of what's in an optbl. +sub OptCtl ($) { + my ($v) = @_; + my @v = map { defined($_) ? ($_) : ("") } @$v; + "[". + join(",", + "\"$v[CTL_TYPE]\"", + "\"$v[CTL_CNAME]\"", + "\"$v[CTL_DEFAULT]\"", + ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], + $v[CTL_AMIN] || '', + $v[CTL_AMAX] || '', +# $v[CTL_RANGE] || '', +# $v[CTL_REPEAT] || '', + ). "]"; +} + +# Parse an option specification and fill the tables. +sub ParseOptionSpec ($$) { + my ($opt, $opctl) = @_; + + # Match option spec. + if ( $opt !~ m;^ + ( + # Option name + (?: \w+[-\w]* ) + # Alias names, or "?" + (?: \| (?: \? | \w[-\w]* )? )* + )? + ( + # Either modifiers ... + [!+] + | + # ... or a value/dest/repeat specification + [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )? + | + # ... or an optional-with-default spec + : (?: -?\d+ | \+ ) [@%]? + )? + $;x ) { + return (undef, "Error in option spec: \"$opt\"\n"); + } + + my ($names, $spec) = ($1, $2); + $spec = '' unless defined $spec; + + # $orig keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $orig; + + my @names; + if ( defined $names ) { + @names = split (/\|/, $names); + $orig = $names[0]; + } + else { + @names = (''); + $orig = ''; + } + + # Construct the opctl entries. + my $entry; + if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { + # Fields are hard-wired here. + $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0]; + } + elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) { + my $def = $1; + my $dest = $2; + my $type = $def eq '+' ? 'I' : 'i'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,$def eq '+' ? undef : $def, + $dest,0,1]; + } + else { + my ($mand, $type, $dest) = + $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/; + return (undef, "Cannot repeat while bundling: \"$opt\"\n") + if $bundling && defined($4); + my ($mi, $cm, $ma) = ($5, $6, $7); + return (undef, "{0} is useless in option spec: \"$opt\"\n") + if defined($mi) && !$mi && !defined($ma) && !defined($cm); + + $type = 'i' if $type eq 'n'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Default minargs to 1/0 depending on mand status. + $mi = $mand eq '=' ? 1 : 0 unless defined $mi; + # Adjust mand status according to minargs. + $mand = $mi ? '=' : ':'; + # Adjust maxargs. + $ma = $mi ? $mi : 1 unless defined $ma || defined $cm; + return (undef, "Max must be greater than zero in option spec: \"$opt\"\n") + if defined($ma) && !$ma; + return (undef, "Max less than min in option spec: \"$opt\"\n") + if defined($ma) && $ma < $mi; + + # Fields are hard-wired here. + $entry = [$type,$orig,undef,$dest,$mi,$ma||-1]; + } + + # Process all names. First is canonical, the rest are aliases. + my $dups = ''; + foreach ( @names ) { + + $_ = lc ($_) + if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + + if ( exists $opctl->{$_} ) { + $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; + } + + if ( $spec eq '!' ) { + $opctl->{"no$_"} = $entry; + $opctl->{"no-$_"} = $entry; + $opctl->{$_} = [@$entry]; + $opctl->{$_}->[CTL_TYPE] = ''; + } + else { + $opctl->{$_} = $entry; + } + } + + if ( $dups && $^W ) { + foreach ( split(/\n+/, $dups) ) { + warn($_."\n"); + } + } + ($names[0], $orig); +} + +# Option lookup. +sub FindOption ($$$$) { + + # returns (1, $opt, $ctl, $arg, $key) if okay, + # returns (1, undef) if option in error, + # returns (0) otherwise. + + my ($prefix, $argend, $opt, $opctl) = @_; + + print STDERR ("=> find \"$opt\"\n") if $debug; + + return (0) unless $opt =~ /^$prefix(.*)$/s; + return (0) if $opt eq "-" && !defined $opctl->{''}; + + $opt = $+; + my $starter = $1; + + print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; + + my $optarg; # value supplied with --opt=value + my $rest; # remainder from unbundling + + # If it is a long option, it may include the value. + # With getopt_compat, only if not bundling. + if ( ($starter=~/^$longprefix$/ + || ($getopt_compat && ($bundling == 0 || $bundling == 2))) + && $opt =~ /^([^=]+)=(.*)$/s ) { + $opt = $1; + $optarg = $2; + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") if $debug; + } + + #### Look it up ### + + my $tryopt = $opt; # option to try + + if ( $bundling && $starter eq '-' ) { + + # To try overrides, obey case ignore. + $tryopt = $ignorecase ? lc($opt) : $opt; + + # If bundling == 2, long options can override bundles. + if ( $bundling == 2 && length($tryopt) > 1 + && defined ($opctl->{$tryopt}) ) { + print STDERR ("=> $starter$tryopt overrides unbundling\n") + if $debug; + } + else { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + $rest = undef unless $rest ne ''; + } + } + + # Try auto-abbreviation. + elsif ( $autoabbrev ) { + # Sort the possible long option names. + my @names = sort(keys (%$opctl)); + # Downcase if allowed. + $opt = lc ($opt) if $ignorecase; + $tryopt = $opt; + # Turn option name into pattern. + my $pat = quotemeta ($opt); + # Look up in option names. + my @hits = grep (/^$pat/, @names); + print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", + "out of ", scalar(@names), "\n") if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + # See if all matches are for the same option. + my %hit; + foreach ( @hits ) { + my $hit = $_; + $hit = $opctl->{$hit}->[CTL_CNAME] + if defined $opctl->{$hit}->[CTL_CNAME]; + $hit{$hit} = 1; + } + # Remove auto-supplied options (version, help). + if ( keys(%hit) == 2 ) { + if ( $auto_version && exists($hit{version}) ) { + delete $hit{version}; + } + elsif ( $auto_help && exists($hit{help}) ) { + delete $hit{help}; + } + } + # Now see if it really is ambiguous. + unless ( keys(%hit) == 1 ) { + return (0) if $passthrough; + warn ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); + $error++; + return (1, undef); + } + @hits = keys(%hit); + } + + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + $tryopt = lc ($tryopt) if $ignorecase; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; + } + } + + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + + # Check validity by fetching the info. + my $ctl = $opctl->{$tryopt}; + unless ( defined $ctl ) { + return (0) if $passthrough; + # Pretend one char when bundling. + if ( $bundling == 1 && length($starter) == 1 ) { + $opt = substr($opt,0,1); + unshift (@ARGV, $starter.$rest) if defined $rest; + } + warn ("Unknown option: ", $opt, "\n"); + $error++; + return (1, undef); + } + # Apparently valid. + $opt = $tryopt; + print STDERR ("=> found ", OptCtl($ctl), + " for \"", $opt, "\"\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + my $type = $ctl->[CTL_TYPE]; + my $arg; + + if ( $type eq '' || $type eq '!' || $type eq '+' ) { + if ( defined $optarg ) { + return (0) if $passthrough; + warn ("Option ", $opt, " does not take an argument\n"); + $error++; + undef $opt; + } + elsif ( $type eq '' || $type eq '+' ) { + # Supply explicit value. + $arg = 1; + } + else { + $opt =~ s/^no-?//i; # strip NO prefix + $arg = 0; # supply explicit value + } + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, $opt, $ctl, $arg); + } + + # Get mandatory status and type info. + my $mand = $ctl->[CTL_AMIN]; + + # Check if there is an option argument available. + if ( $gnu_compat && defined $optarg && $optarg eq '' ) { + return (1, $opt, $ctl, $type eq 's' ? '' : 0) unless $mand; + $optarg = 0 unless $type eq 's'; + } + + # Check if there is an option argument available. + if ( defined $optarg + ? ($optarg eq '') + : !(defined $rest || @ARGV > 0) ) { + # Complain if this option needs an argument. + if ( $mand ) { + return (0) if $passthrough; + warn ("Option ", $opt, " requires an argument\n"); + $error++; + return (1, undef); + } + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + return (1, $opt, $ctl, + defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + $type eq 's' ? '' : 0); + } + + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@ARGV))); + + # Get key if this is a "name=value" pair for a hash option. + my $key; + if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { + ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) + : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + ($mand ? undef : ($type eq 's' ? "" : 1))); + if (! defined $arg) { + warn ("Option $opt, key \"$key\", requires a value\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + } + + #### Check if the argument is valid for this option #### + + my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1, $opt, $ctl, $arg, $key) if $mand; + + # An optional string takes almost anything. + return (1, $opt, $ctl, $arg, $key) + if defined $optarg || defined $rest; + return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$prefix.+/) { + # Push back. + unshift (@ARGV, $arg); + # Supply empty value. + $arg = ''; + } + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" + : "[-+]?[0-9]+"; + + if ( $bundling && defined $rest + && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg =~ /^($o_valid)$/si ) { + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + } + else { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (", + $type eq 'o' ? "extended " : '', + "number expected)\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + # Supply default value. + $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; + } + } + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + if ( $bundling && defined $rest && + $rest =~ /^($key_valid)([-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)?)(.*)$/s ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg !~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/ ) { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@ARGV, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + # Push back. + unshift (@ARGV, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@ARGV, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; + } + } + } + else { + die("Getopt::Long internal error (Can't happen)\n"); + } + return (1, $opt, $ctl, $arg, $key); +} + +sub ValidValue ($$$$$) { + my ($ctl, $arg, $mand, $argend, $prefix) = @_; + + if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + return 0 unless $arg =~ /[^=]+=(.*)/; + $arg = $1; + } + + my $type = $ctl->[CTL_TYPE]; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1) if $mand; + + return (1) if $arg eq "-"; + + # Check for option or option list terminator. + return 0 if $arg eq $argend || $arg =~ /^$prefix.+/; + return 1; + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = + $type eq 'o' ? "[-+]?[1-9][0-9]*|0x[0-9a-f]+|0b[01]+|0[0-7]*" + : "[-+]?[0-9]+"; + + return $arg =~ /^$o_valid$/si; + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + # We require at least one digit before a point or 'e', + # and at least one digit following the point and 'e'. + # [-]NN[.NN][eNN] + return $arg =~ /^[-+]?[0-9.]+(\.[0-9]+)?([eE][-+]?[0-9]+)?$/; + } + die("ValidValue: Cannot happen\n"); +} + +# Getopt::Long Configuration. +sub Configure (@) { + my (@options) = @_; + + my $prevconfig = + [ $error, $debug, $major_version, $minor_version, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ]; + + if ( ref($options[0]) eq 'ARRAY' ) { + ( $error, $debug, $major_version, $minor_version, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix ) = @{shift(@options)}; + } + + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?(.*)$/s ) { + $action = 0; + $try = $+; + } + if ( ($try eq 'default' or $try eq 'defaults') && $action ) { + ConfigDefaults (); + } + elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { + local $ENV{POSIXLY_CORRECT}; + $ENV{POSIXLY_CORRECT} = 1 if $action; + ConfigDefaults (); + } + elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { + $autoabbrev = $action; + } + elsif ( $try eq 'getopt_compat' ) { + $getopt_compat = $action; + } + elsif ( $try eq 'gnu_getopt' ) { + if ( $action ) { + $gnu_compat = 1; + $bundling = 1; + $getopt_compat = 0; + $order = $PERMUTE; + } + } + elsif ( $try eq 'gnu_compat' ) { + $gnu_compat = $action; + } + elsif ( $try =~ /^(auto_?)?version$/ ) { + $auto_version = $action; + } + elsif ( $try =~ /^(auto_?)?help$/ ) { + $auto_help = $action; + } + elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { + $ignorecase = $action; + } + elsif ( $try eq 'ignore_case_always' ) { + $ignorecase = $action ? 2 : 0; + } + elsif ( $try eq 'bundling' ) { + $bundling = $action; + } + elsif ( $try eq 'bundling_override' ) { + $bundling = $action ? 2 : 0; + } + elsif ( $try eq 'require_order' ) { + $order = $action ? $REQUIRE_ORDER : $PERMUTE; + } + elsif ( $try eq 'permute' ) { + $order = $action ? $PERMUTE : $REQUIRE_ORDER; + } + elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { + $passthrough = $action; + } + elsif ( $try =~ /^prefix=(.+)$/ && $action ) { + $genprefix = $1; + # Turn into regexp. Needs to be parenthesized! + $genprefix = "(" . quotemeta($genprefix) . ")"; + eval { '' =~ /$genprefix/; }; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { + $genprefix = $1; + # Parenthesize if needed. + $genprefix = "(" . $genprefix . ")" + unless $genprefix =~ /^\(.*\)$/; + eval { '' =~ m"$genprefix"; }; + die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; + } + elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { + $longprefix = $1; + # Parenthesize if needed. + $longprefix = "(" . $longprefix . ")" + unless $longprefix =~ /^\(.*\)$/; + eval { '' =~ m"$longprefix"; }; + die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + die("Getopt::Long: unknown config parameter \"$opt\"") + } + } + $prevconfig; +} + +# Deprecated name. +sub config (@) { + Configure (@_); +} + +# Issue a standard message for --version. +# +# The arguments are mostly the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub VersionMessage(@) { + # Massage args. + my $pa = setup_pa_args("version", @_); + + my $v = $main::VERSION; + my $fh = $pa->{-output} || + ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; + + print $fh (defined($pa->{-message}) ? $pa->{-message} : (), + $0, defined $v ? " version $v" : (), + "\n", + "(", __PACKAGE__, "::", "GetOptions", + " version ", + defined($Getopt::Long::VERSION_STRING) + ? $Getopt::Long::VERSION_STRING : $VERSION, ";", + " Perl version ", + $] >= 5.006 ? sprintf("%vd", $^V) : $], + ")\n"); + exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; +} + +# Issue a standard message for --help. +# +# The arguments are the same as for Pod::Usage::pod2usage: +# +# - a number (exit value) +# - a string (lead in message) +# - a hash with options. See Pod::Usage for details. +# +sub HelpMessage(@) { + eval { + require Pod::Usage; + import Pod::Usage; + 1; + } || die("Cannot provide help: cannot load Pod::Usage\n"); + + # Note that pod2usage will issue a warning if -exitval => NOEXIT. + pod2usage(setup_pa_args("help", @_)); + +} + +# Helper routine to set up a normalized hash ref to be used as +# argument to pod2usage. +sub setup_pa_args($@) { + my $tag = shift; # who's calling + + # If called by direct binding to an option, it will get the option + # name and value as arguments. Remove these, if so. + @_ = () if @_ == 2 && $_[0] eq $tag; + + my $pa; + if ( @_ > 1 ) { + $pa = { @_ }; + } + else { + $pa = shift || {}; + } + + # At this point, $pa can be a number (exit value), string + # (message) or hash with options. + + if ( UNIVERSAL::isa($pa, 'HASH') ) { + # Get rid of -msg vs. -message ambiguity. + $pa->{-message} = $pa->{-msg}; + delete($pa->{-msg}); + } + elsif ( $pa =~ /^-?\d+$/ ) { + $pa = { -exitval => $pa }; + } + else { + $pa = { -message => $pa }; + } + + # These are _our_ defaults. + $pa->{-verbose} = 0 unless exists($pa->{-verbose}); + $pa->{-exitval} = 0 unless exists($pa->{-exitval}); + $pa; +} + +# Sneak way to know what version the user requested. +sub VERSION { + $requested_version = $_[1]; + shift->SUPER::VERSION(@_); +} + +1; + +################ Documentation ################ + +=head1 NAME + +Getopt::Long - Extended processing of command line options + +=head1 SYNOPSIS + + use Getopt::Long; + my $data = "file.dat"; + my $length = 24; + my $verbose; + $result = GetOptions ("length=i" => \$length, # numeric + "file=s" => \$data, # string + "verbose" => \$verbose); # flag + +=head1 DESCRIPTION + +The Getopt::Long module implements an extended getopt function called +GetOptions(). This function adheres to the POSIX syntax for command +line options, with GNU extensions. In general, this means that options +have long names instead of single letters, and are introduced with a +double dash "--". Support for bundling of command line options, as was +the case with the more traditional single-letter approach, is provided +but not enabled by default. + +=head1 Command Line Options, an Introduction + +Command line operated programs traditionally take their arguments from +the command line, for example filenames or other information that the +program needs to know. Besides arguments, these programs often take +command line I as well. Options are not necessary for the +program to work, hence the name 'option', but are used to modify its +default behaviour. For example, a program could do its job quietly, +but with a suitable option it could provide verbose information about +what it did. + +Command line options come in several flavours. Historically, they are +preceded by a single dash C<->, and consist of a single letter. + + -l -a -c + +Usually, these single-character options can be bundled: + + -lac + +Options can have values, the value is placed after the option +character. Sometimes with whitespace in between, sometimes not: + + -s 24 -s24 + +Due to the very cryptic nature of these options, another style was +developed that used long names. So instead of a cryptic C<-l> one +could use the more descriptive C<--long>. To distinguish between a +bundle of single-character options and a long one, two dashes are used +to precede the option name. Early implementations of long options used +a plus C<+> instead. Also, option values could be specified either +like + + --size=24 + +or + + --size 24 + +The C<+> form is now obsolete and strongly deprecated. + +=head1 Getting Started with Getopt::Long + +Getopt::Long is the Perl5 successor of C. This was the +first Perl module that provided support for handling the new style of +command line options, hence the name Getopt::Long. This module also +supports single-character options and bundling. Single character +options may be any alphabetic character, a question mark, and a dash. +Long options may consist of a series of letters, digits, and dashes. +Although this is currently not enforced by Getopt::Long, multiple +consecutive dashes are not allowed, and the option name must not end +with a dash. + +To use Getopt::Long from a Perl program, you must include the +following line in your Perl program: + + use Getopt::Long; + +This will load the core of the Getopt::Long module and prepare your +program for using it. Most of the actual Getopt::Long code is not +loaded until you really call one of its functions. + +In the default configuration, options names may be abbreviated to +uniqueness, case does not matter, and a single dash is sufficient, +even for long option names. Also, options may be placed between +non-option arguments. See L for more +details on how to configure Getopt::Long. + +=head2 Simple options + +The most simple options are the ones that take no values. Their mere +presence on the command line enables the option. Popular examples are: + + --all --verbose --quiet --debug + +Handling simple options is straightforward: + + my $verbose = ''; # option variable with default value (false) + my $all = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, 'all' => \$all); + +The call to GetOptions() parses the command line arguments that are +present in C<@ARGV> and sets the option variable to the value C<1> if +the option did occur on the command line. Otherwise, the option +variable is not touched. Setting the option value to true is often +called I the option. + +The option name as specified to the GetOptions() function is called +the option I. Later we'll see that this specification +can contain more than just the option name. The reference to the +variable is called the option I. + +GetOptions() will return a true value if the command line could be +processed successfully. Otherwise, it will write error messages to +STDERR, and return a false result. + +=head2 A little bit less simple options + +Getopt::Long supports two useful variants of simple options: +I options and I options. + +A negatable option is specified with an exclamation mark C after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose!' => \$verbose); + +Now, using C<--verbose> on the command line will enable C<$verbose>, +as expected. But it is also allowed to use C<--noverbose>, which will +disable C<$verbose> by setting its value to C<0>. Using a suitable +default value, the program can find out whether C<$verbose> is false +by default, or disabled by using C<--noverbose>. + +An incremental option is specified with a plus C<+> after the +option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose+' => \$verbose); + +Using C<--verbose> on the command line will increment the value of +C<$verbose>. This way the program can keep track of how many times the +option occurred on the command line. For example, each occurrence of +C<--verbose> could increase the verbosity level of the program. + +=head2 Mixing command line option with other arguments + +Usually programs take command line options as well as other arguments, +for example, file names. It is good practice to always specify the +options first, and the other arguments last. Getopt::Long will, +however, allow the options and arguments to be mixed and 'filter out' +all the options before passing the rest of the arguments to the +program. To stop Getopt::Long from processing further arguments, +insert a double dash C<--> on the command line: + + --size 24 -- --all + +In this example, C<--all> will I be treated as an option, but +passed to the program unharmed, in C<@ARGV>. + +=head2 Options with values + +For options that take values it must be specified whether the option +value is required or not, and what kind of value the option expects. + +Three kinds of values are supported: integer numbers, floating point +numbers, and strings. + +If the option value is required, Getopt::Long will take the +command line argument that follows the option and assign this to the +option variable. If, however, the option value is specified as +optional, this will only be done if that value does not look like a +valid command line option itself. + + my $tag = ''; # option variable with default value + GetOptions ('tag=s' => \$tag); + +In the option specification, the option name is followed by an equals +sign C<=> and the letter C. The equals sign indicates that this +option requires a value. The letter C indicates that this value is +an arbitrary string. Other possible value types are C for integer +values, and C for floating point values. Using a colon C<:> instead +of the equals sign indicates that the option value is optional. In +this case, if no suitable value is supplied, string valued options get +an empty string C<''> assigned, while numeric options are set to C<0>. + +=head2 Options with multiple values + +Options sometimes take several values. For example, a program could +use multiple directories to search for library files: + + --library lib/stdlib --library lib/extlib + +To accomplish this behaviour, simply specify an array reference as the +destination for the option: + + GetOptions ("library=s" => \@libfiles); + +Alternatively, you can specify that the option can have multiple +values by adding a "@", and pass a scalar reference as the +destination: + + GetOptions ("library=s@" => \$libfiles); + +Used with the example above, C<@libfiles> (or C<@$libfiles>) would +contain two strings upon completion: C<"lib/srdlib"> and +C<"lib/extlib">, in that order. It is also possible to specify that +only integer or floating point numbers are acceptable values. + +Often it is useful to allow comma-separated lists of values as well as +multiple occurrences of the options. This is easy using Perl's split() +and join() operators: + + GetOptions ("library=s" => \@libfiles); + @libfiles = split(/,/,join(',',@libfiles)); + +Of course, it is important to choose the right separator string for +each purpose. + +Warning: What follows is an experimental feature. + +Options can take multiple values at once, for example + + --coordinates 52.2 16.4 --rgbcolor 255 255 149 + +This can be accomplished by adding a repeat specifier to the option +specification. Repeat specifiers are very similar to the C<{...}> +repeat specifiers that can be used with regular expression patterns. +For example, the above command line would be handled as follows: + + GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color); + +The destination for the option must be an array or array reference. + +It is also possible to specify the minimal and maximal number of +arguments an option takes. C indicates an option that +takes at least two and at most 4 arguments. C indicates one +or more values; C indicates zero or more option values. + +=head2 Options with hash values + +If the option destination is a reference to a hash, the option will +take, as value, strings of the form IC<=>I. The value will +be stored with the specified key in the hash. + + GetOptions ("define=s" => \%defines); + +Alternatively you can use: + + GetOptions ("define=s%" => \$defines); + +When used with command line options: + + --define os=linux --define vendor=redhat + +the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> +with value C<"linux> and C<"vendor"> with value C<"redhat">. It is +also possible to specify that only integer or floating point numbers +are acceptable values. The keys are always taken to be strings. + +=head2 User-defined subroutines to handle options + +Ultimate control over what should be done when (actually: each time) +an option is encountered on the command line can be achieved by +designating a reference to a subroutine (or an anonymous subroutine) +as the option destination. When GetOptions() encounters the option, it +will call the subroutine with two or three arguments. The first +argument is the name of the option. For a scalar or array destination, +the second argument is the value to be stored. For a hash destination, +the second arguments is the key to the hash, and the third argument +the value to be stored. It is up to the subroutine to store the value, +or do whatever it thinks is appropriate. + +A trivial application of this mechanism is to implement options that +are related to each other. For example: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, + 'quiet' => sub { $verbose = 0 }); + +Here C<--verbose> and C<--quiet> control the same variable +C<$verbose>, but with opposite values. + +If the subroutine needs to signal an error, it should call die() with +the desired error message as its argument. GetOptions() will catch the +die(), issue the error message, and record that an error result must +be returned upon completion. + +If the text of the error message starts with an exclamation mark C +it is interpreted specially by GetOptions(). There is currently one +special command implemented: C will cause GetOptions() +to stop processing options, as if it encountered a double dash C<-->. + +=head2 Options with multiple names + +Often it is user friendly to supply alternate mnemonic names for +options. For example C<--height> could be an alternate name for +C<--length>. Alternate names can be included in the option +specification, separated by vertical bar C<|> characters. To implement +the above example: + + GetOptions ('length|height=f' => \$length); + +The first name is called the I name, the other names are +called I. When using a hash to store options, the key will +always be the primary name. + +Multiple alternate names are possible. + +=head2 Case and abbreviations + +Without additional configuration, GetOptions() will ignore the case of +option names, and allow the options to be abbreviated to uniqueness. + + GetOptions ('length|height=f' => \$length, "head" => \$head); + +This call will allow C<--l> and C<--L> for the length option, but +requires a least C<--hea> and C<--hei> for the head and height options. + +=head2 Summary of Option Specifications + +Each option specifier consists of two parts: the name specification +and the argument specification. + +The name specification contains the name of the option, optionally +followed by a list of alternative names separated by vertical bar +characters. + + length option name is "length" + length|size|l name is "length", aliases are "size" and "l" + +The argument specification is optional. If omitted, the option is +considered boolean, a value of 1 will be assigned when the option is +used on the command line. + +The argument specification can be + +=over 4 + +=item ! + +The option does not take an argument and may be negated by prefixing +it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of +1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of +0 will be assigned). If the option has aliases, this applies to the +aliases as well. + +Using negation on a single letter option when bundling is in effect is +pointless and will result in a warning. + +=item + + +The option does not take an argument and will be incremented by 1 +every time it appears on the command line. E.g. C<"more+">, when used +with C<--more --more --more>, will increment the value three times, +resulting in a value of 3 (provided it was 0 or undefined at first). + +The C<+> specifier is ignored if the option destination is not a scalar. + +=item = I [ I ] [ I ] + +The option requires an argument of the given type. Supported types +are: + +=over 4 + +=item s + +String. An arbitrary sequence of characters. It is valid for the +argument to start with C<-> or C<-->. + +=item i + +Integer. An optional leading plus or minus sign, followed by a +sequence of digits. + +=item o + +Extended integer, Perl style. This can be either an optional leading +plus or minus sign, followed by a sequence of digits, or an octal +string (a zero, optionally followed by '0', '1', .. '7'), or a +hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case +insensitive), or a binary string (C<0b> followed by a series of '0' +and '1'). + +=item f + +Real number. For example C<3.14>, C<-6.23E24> and so on. + +=back + +The I can be C<@> or C<%> to specify that the option is +list or a hash valued. This is only needed when the destination for +the option value is not otherwise specified. It should be omitted when +not needed. + +The I specifies the number of values this option takes per +occurrence on the command line. It has the format C<{> [ I ] [ C<,> [ I ] ] C<}>. + +I denotes the minimal number of arguments. It defaults to 1 for +options with C<=> and to 0 for options with C<:>, see below. Note that +I overrules the C<=> / C<:> semantics. + +I denotes the maximum number of arguments. It must be at least +I. If I is omitted, I, there is no +upper bound to the number of argument values taken. + +=item : I [ I ] + +Like C<=>, but designates the argument as optional. +If omitted, an empty string will be assigned to string values options, +and the value zero to numeric options. + +Note that if a string argument starts with C<-> or C<-->, it will be +considered an option on itself. + +=item : I [ I ] + +Like C<:i>, but if the value is omitted, the I will be assigned. + +=item : + [ I ] + +Like C<:i>, but if the value is omitted, the current value for the +option will be incremented. + +=back + +=head1 Advanced Possibilities + +=head2 Object oriented interface + +Getopt::Long can be used in an object oriented way as well: + + use Getopt::Long; + $p = new Getopt::Long::Parser; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... + +Configuration options can be passed to the constructor: + + $p = new Getopt::Long::Parser + config => [...configuration options...]; + +=head2 Thread Safety + +Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is +I thread safe when using the older (experimental and now +obsolete) threads implementation that was added to Perl 5.005. + +=head2 Documentation and help texts + +Getopt::Long encourages the use of Pod::Usage to produce help +messages. For example: + + use Getopt::Long; + use Pod::Usage; + + my $man = 0; + my $help = 0; + + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-exitstatus => 0, -verbose => 2) if $man; + + __END__ + + =head1 NAME + + sample - Using Getopt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +See L for details. + +=head2 Storing option values in a hash + +Sometimes, for example when there are a lot of options, having a +separate variable for each of them can be cumbersome. GetOptions() +supports, as an alternative mechanism, storing options in a hash. + +To obtain this, a reference to a hash must be passed I to GetOptions(). For each option that is specified on the +command line, the option value will be stored in the hash with the +option name as key. Options that are not actually used on the command +line will not be put in the hash, on other words, +C (or defined()) can be used to test if an option +was used. The drawback is that warnings will be issued if the program +runs under C and uses C<$h{option}> without testing with +exists() or defined() first. + + my %h = (); + GetOptions (\%h, 'length=i'); # will store in $h{length} + +For options that take list or hash values, it is necessary to indicate +this by appending an C<@> or C<%> sign after the type: + + GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} + +To make things more complicated, the hash may contain references to +the actual destinations, for example: + + my $len = 0; + my %h = ('length' => \$len); + GetOptions (\%h, 'length=i'); # will store in $len + +This example is fully equivalent with: + + my $len = 0; + GetOptions ('length=i' => \$len); # will store in $len + +Any mixture is possible. For example, the most frequently used options +could be stored in variables while all other options get stored in the +hash: + + my $verbose = 0; # frequently referred + my $debug = 0; # frequently referred + my %h = ('verbose' => \$verbose, 'debug' => \$debug); + GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); + if ( $verbose ) { ... } + if ( exists $h{filter} ) { ... option 'filter' was specified ... } + +=head2 Bundling + +With bundling it is possible to set several single-character options +at once. For example if C, C and C are all valid options, + + -vax + +would set all three. + +Getopt::Long supports two levels of bundling. To enable bundling, a +call to Getopt::Long::Configure is required. + +The first level of bundling can be enabled with: + + Getopt::Long::Configure ("bundling"); + +Configured this way, single-character options can be bundled but long +options B always start with a double dash C<--> to avoid +ambiguity. For example, when C, C, C and C are all valid +options, + + -vax + +would set C, C and C, but + + --vax + +would set C. + +The second level of bundling lifts this restriction. It can be enabled +with: + + Getopt::Long::Configure ("bundling_override"); + +Now, C<-vax> would set the option C. + +When any level of bundling is enabled, option values may be inserted +in the bundle. For example: + + -h24w80 + +is equivalent to + + -h 24 -w 80 + +When configured for bundling, single-character options are matched +case sensitive while long options are matched case insensitive. To +have the single-character options matched case insensitive as well, +use: + + Getopt::Long::Configure ("bundling", "ignorecase_always"); + +It goes without saying that bundling can be quite confusing. + +=head2 The lonesome dash + +Normally, a lone dash C<-> on the command line will not be considered +an option. Option processing will terminate (unless "permute" is +configured) and the dash will be left in C<@ARGV>. + +It is possible to get special treatment for a lone dash. This can be +achieved by adding an option specification with an empty name, for +example: + + GetOptions ('' => \$stdio); + +A lone dash on the command line will now be a legal option, and using +it will set variable C<$stdio>. + +=head2 Argument callback + +A special option 'name' C<< <> >> can be used to designate a subroutine +to handle non-option arguments. When GetOptions() encounters an +argument that does not look like an option, it will immediately call this +subroutine and passes it one parameter: the argument name. + +For example: + + my $width = 80; + sub process { ... } + GetOptions ('width=i' => \$width, '<>' => \&process); + +When applied to the following command line: + + arg1 --width=72 arg2 --width=60 arg3 + +This will call +C while C<$width> is C<80>, +C while C<$width> is C<72>, and +C while C<$width> is C<60>. + +This feature requires configuration option B, see section +L. + +=head1 Configuring Getopt::Long + +Getopt::Long can be configured by calling subroutine +Getopt::Long::Configure(). This subroutine takes a list of quoted +strings, each specifying a configuration option to be enabled, e.g. +C, or disabled, e.g. C. Case does not +matter. Multiple calls to Configure() are possible. + +Alternatively, as of version 2.24, the configuration options may be +passed together with the C statement: + + use Getopt::Long qw(:config no_ignore_case bundling); + +The following options are available: + +=over 12 + +=item default + +This option causes all configuration options to be reset to their +default values. + +=item posix_default + +This option causes all configuration options to be reset to their +default values as if the environment variable POSIXLY_CORRECT had +been set. + +=item auto_abbrev + +Allow option names to be abbreviated to uniqueness. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. + +=item getopt_compat + +Allow C<+> to start options. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. + +=item gnu_compat + +C controls whether C<--opt=> is allowed, and what it should +do. Without C, C<--opt=> gives an error. With C, +C<--opt=> will give option C and empty value. +This is the way GNU getopt_long() does it. + +=item gnu_getopt + +This is a short way of setting C C C +C. With C, command line handling should be +fully compatible with GNU getopt_long(). + +=item require_order + +Whether command line arguments are allowed to be mixed with options. +Default is disabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is enabled. + +See also C, which is the opposite of C. + +=item permute + +Whether command line arguments are allowed to be mixed with options. +Default is enabled unless environment variable +POSIXLY_CORRECT has been set, in which case C is disabled. +Note that C is the opposite of C. + +If C is enabled, this means that + + --foo arg1 --bar arg2 arg3 + +is equivalent to + + --foo --bar arg1 arg2 arg3 + +If an argument callback routine is specified, C<@ARGV> will always be +empty upon successful return of GetOptions() since all options have been +processed. The only exception is when C<--> is used: + + --foo arg1 --bar arg2 -- arg3 + +This will call the callback routine for arg1 and arg2, and then +terminate GetOptions() leaving C<"arg2"> in C<@ARGV>. + +If C is enabled, options processing +terminates when the first non-option is encountered. + + --foo arg1 --bar arg2 arg3 + +is equivalent to + + --foo -- arg1 --bar arg2 arg3 + +If C is also enabled, options processing will terminate +at the first unrecognized option, or non-option, whichever comes +first. + +=item bundling (default: disabled) + +Enabling this option will allow single-character options to be +bundled. To distinguish bundles from long option names, long options +I be introduced with C<--> and bundles with C<->. + +Note that, if you have options C, C and C, and +auto_abbrev enabled, possible arguments and option settings are: + + using argument sets option(s) + ------------------------------------------ + -a, --a a + -l, --l l + -al, -la, -ala, -all,... a, l + --al, --all all + +The surprising part is that C<--a> sets option C (due to auto +completion), not C. + +Note: disabling C also disables C. + +=item bundling_override (default: disabled) + +If C is enabled, bundling is enabled as with +C but now long option names override option bundles. + +Note: disabling C also disables C. + +B Using option bundling can easily lead to unexpected results, +especially when mixing long options and bundles. Caveat emptor. + +=item ignore_case (default: enabled) + +If enabled, case is ignored when matching long option names. If, +however, bundling is enabled as well, single character options will be +treated case-sensitive. + +With C, option specifications for options that only +differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as +duplicates. + +Note: disabling C also disables C. + +=item ignore_case_always (default: disabled) + +When bundling is in effect, case is ignored on single-character +options also. + +Note: disabling C also disables C. + +=item auto_version (default:disabled) + +Automatically provide support for the B<--version> option if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a standard version message that includes the +program name, its version (if $main::VERSION is defined), and the +versions of Getopt::Long and Perl. The message will be written to +standard output and processing will terminate. + +C will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C statement. + +=item auto_help (default:disabled) + +Automatically provide support for the B<--help> and B<-?> options if +the application did not specify a handler for this option itself. + +Getopt::Long will provide a help message using module L. The +message, derived from the SYNOPSIS POD section, will be written to +standard output and processing will terminate. + +C will be enabled if the calling program explicitly +specified a version number higher than 2.32 in the C or +C statement. + +=item pass_through (default: disabled) + +Options that are unknown, ambiguous or supplied with an invalid option +value are passed through in C<@ARGV> instead of being flagged as +errors. This makes it possible to write wrapper scripts that process +only part of the user supplied command line arguments, and pass the +remaining options to some other program. + +If C is enabled, options processing will terminate at +the first unrecognized option, or non-option, whichever comes first. +However, if C is enabled instead, results can become confusing. + +Note that the options terminator (default C<-->), if present, will +also be passed through in C<@ARGV>. + +=item prefix + +The string that starts options. If a constant string is not +sufficient, see C. + +=item prefix_pattern + +A Perl pattern that identifies the strings that introduce options. +Default is C<--|-|\+> unless environment variable +POSIXLY_CORRECT has been set, in which case it is C<--|->. + +=item long_prefix_pattern + +A Perl pattern that allows the disambiguation of long and short +prefixes. Default is C<-->. + +Typically you only need to set this if you are using nonstandard +prefixes and want some or all of them to have the same semantics as +'--' does under normal circumstances. + +For example, setting prefix_pattern to C<--|-|\+|\/> and +long_prefix_pattern to C<--|\/> would add Win32 style argument +handling. + +=item debug (default: disabled) + +Enable debugging output. + +=back + +=head1 Exportable Methods + +=over + +=item VersionMessage + +This subroutine provides a standard version message. Its argument can be: + +=over 4 + +=item * + +A string containing the text of a message to print I printing +the standard message. + +=item * + +A numeric value corresponding to the desired exit status. + +=item * + +A reference to a hash. + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over 4 + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=back + +You cannot tie this routine directly to an option, e.g.: + + GetOptions("version" => \&VersionMessage); + +Use this instead: + + GetOptions("version" => sub { VersionMessage() }); + +=item HelpMessage + +This subroutine produces a standard help message, derived from the +program's POD section SYNOPSIS using L. It takes the same +arguments as VersionMessage(). In particular, you cannot tie it +directly to an option, e.g.: + + GetOptions("help" => \&HelpMessage); + +Use this instead: + + GetOptions("help" => sub { HelpMessage() }); + +=back + +=head1 Return values and Errors + +Configuration errors and errors in the option definitions are +signalled using die() and will terminate the calling program unless +the call to Getopt::Long::GetOptions() was embedded in C, or die() was trapped using C<$SIG{__DIE__}>. + +GetOptions returns true to indicate success. +It returns false when the function detected one or more errors during +option parsing. These errors are signalled using warn() and can be +trapped with C<$SIG{__WARN__}>. + +=head1 Legacy + +The earliest development of C started in 1990, with Perl +version 4. As a result, its development, and the development of +Getopt::Long, has gone through several stages. Since backward +compatibility has always been extremely important, the current version +of Getopt::Long still supports a lot of constructs that nowadays are +no longer necessary or otherwise unwanted. This section describes +briefly some of these 'features'. + +=head2 Default destinations + +When no destination is specified for an option, GetOptions will store +the resultant value in a global variable named CI, where +I is the primary name of this option. When a progam executes +under C (recommended), these variables must be +pre-declared with our() or C. + + our $opt_length = 0; + GetOptions ('length=i'); # will store in $opt_length + +To yield a usable Perl variable, characters that are not part of the +syntax for variables are translated to underscores. For example, +C<--fpp-struct-return> will set the variable +C<$opt_fpp_struct_return>. Note that this variable resides in the +namespace of the calling program, not necessarily C
. For +example: + + GetOptions ("size=i", "sizes=i@"); + +with command line "-size 10 -sizes 24 -sizes 48" will perform the +equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + +=head2 Alternative option starters + +A string of alternative option starter characters may be passed as the +first argument (or the first argument after a leading hash reference +argument). + + my $len = 0; + GetOptions ('/', 'length=i' => $len); + +Now the command line may look like: + + /length 24 -- arg + +Note that to terminate options processing still requires a double dash +C<-->. + +GetOptions() will not interpret a leading C<< "<>" >> as option starters +if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as +option starters, use C<< "><" >>. Confusing? Well, B anyway. + +=head2 Configuration variables + +Previous versions of Getopt::Long used variables for the purpose of +configuring. Although manipulating these variables still work, it is +strongly encouraged to use the C routine that was introduced +in version 2.17. Besides, it is much easier. + +=head1 Trouble Shooting + +=head2 GetOptions does not return a false result when an option is not supplied + +That's why they're called 'options'. + +=head2 GetOptions does not split the command line correctly + +The command line is not split by GetOptions, but by the command line +interpreter (CLI). On Unix, this is the shell. On Windows, it is +COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. + +It is important to know that these CLIs may behave different when the +command line contains special characters, in particular quotes or +backslashes. For example, with Unix shells you can use single quotes +(C<'>) and double quotes (C<">) to group words together. The following +alternatives are equivalent on Unix: + + "two words" + 'two words' + two\ words + +In case of doubt, insert the following statement in front of your Perl +program: + + print STDERR (join("|",@ARGV),"\n"); + +to verify how your CLI passes the arguments to the program. + +=head2 Undefined subroutine &main::GetOptions called + +Are you running Windows, and did you write + + use GetOpt::Long; + +(note the capital 'O')? + +=head2 How do I put a "-?" option into a Getopt::Long? + +You can only obtain this using an alias, and Getopt::Long of at least +version 2.13. + + use Getopt::Long; + GetOptions ("help|?"); # -help and -? will both set $opt_help + +=head1 AUTHOR + +Johan Vromans + +=head1 COPYRIGHT AND DISCLAIMER + +This program is Copyright 1990,2005 by Johan Vromans. +This program is free software; you can redistribute it and/or +modify it under the terms of the Perl Artistic License or the +GNU General Public License as published by the Free Software +Foundation; either version 2 of the License, or (at your option) any +later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +If you do not have a copy of the GNU General Public License write to +the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +MA 02139, USA. + +=cut + diff --git a/testsuite/input-files/perllib/IO.pm b/testsuite/input-files/perllib/IO.pm new file mode 100644 index 00000000..f28a812f --- /dev/null +++ b/testsuite/input-files/perllib/IO.pm @@ -0,0 +1,28 @@ +# + +package IO; + +use XSLoader (); +use Carp; +use strict; +use warnings; + +our $VERSION = "1.25"; +XSLoader::load 'IO', $VERSION; + +sub import { + shift; + + warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated}) + if @_ == 0 ; + + my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); + + eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) + or croak $@; +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/IO/File.pm b/testsuite/input-files/perllib/IO/File.pm new file mode 100644 index 00000000..bf73876c --- /dev/null +++ b/testsuite/input-files/perllib/IO/File.pm @@ -0,0 +1,82 @@ +# + +package IO::File; + +use 5.006_001; +use strict; +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; +use File::Spec; + +require Exporter; + +@ISA = qw(IO::Handle IO::Seekable Exporter); + +$VERSION = "1.14"; + +@EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } elsif ($mode =~ /:/) { + return open($fh, $mode, $file) if @_ == 3; + croak 'usage: $fh->open(FILENAME, IOLAYERS)'; + } else { + return open($fh, IO::Handle::_open_mode_string($mode), $file); + } + } + open($fh, $file); +} + +################################################ +## Binmode +## + +sub binmode { + ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])'; + + my($fh, $layer) = @_; + + return binmode $$fh unless $layer; + return binmode $$fh, $layer; +} + +1; diff --git a/testsuite/input-files/perllib/IO/Handle.pm b/testsuite/input-files/perllib/IO/Handle.pm new file mode 100644 index 00000000..140e7932 --- /dev/null +++ b/testsuite/input-files/perllib/IO/Handle.pm @@ -0,0 +1,376 @@ +package IO::Handle; + +use 5.006_001; +use strict; +our($VERSION, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO (); # Load the XS module + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.28"; +$VERSION = eval $VERSION; + +@EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + say + getline + getlines + + printflush + flush + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $io = gensym; + bless $io, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $io = gensym; + shift; + IO::Handle::fdopen($io, @_) + or return undef; + bless $io, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; +} + +sub close { + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; + + close($io); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $io->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $io->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $io->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $io->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $io->print(ARGS)'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub say { + @_ or croak 'usage: $io->say(ARGS)'; + my $this = shift; + local $\ = "\n"; + print $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $io->getline()'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $io->getlines()'; + wantarray or + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; + my $this = shift; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $io->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; + local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } +} + +sub stat { + @_ == 1 or croak 'usage: $io->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + local $.; + () = tell qualify($_[0], caller) if ref($_[0]); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $io = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $io $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name(qualify($fmt,caller)); + CORE::write($io); + $io->format_name($oldfmt); + } else { + CORE::write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); +} + +sub ioctl { + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + +# so that flush.pl can be deprecated + +sub printflush { + my $io = shift; + my $old; + $old = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } +} + +1; diff --git a/testsuite/input-files/perllib/IO/Seekable.pm b/testsuite/input-files/perllib/IO/Seekable.pm new file mode 100644 index 00000000..025b89fa --- /dev/null +++ b/testsuite/input-files/perllib/IO/Seekable.pm @@ -0,0 +1,36 @@ +# + +package IO::Seekable; + +use 5.006_001; +use Carp; +use strict; +our($VERSION, @EXPORT, @ISA); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.10"; +$VERSION = eval $VERSION; + +sub seek { + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $io->tell()'; + tell($_[0]); +} + +1; diff --git a/testsuite/input-files/perllib/IPC/Open3.pm b/testsuite/input-files/perllib/IPC/Open3.pm new file mode 100644 index 00000000..3cdc4968 --- /dev/null +++ b/testsuite/input-files/perllib/IPC/Open3.pm @@ -0,0 +1,274 @@ +package IPC::Open3; + +use strict; +no strict 'refs'; # because users pass me bareword filehandles +our ($VERSION, @ISA, @EXPORT); + +require Exporter; + +use Carp; +use Symbol qw(gensym qualify); + +$VERSION = 1.04; +@ISA = qw(Exporter); +@EXPORT = qw(open3); + +# &open3: Marc Horowitz +# derived mostly from &open2 by tom christiansen, +# fixed for 5.001 by Ulrich Kunitz +# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career +# fixed for autovivving FHs, tchrist again +# allow fd numbers to be used, by Frank Tobin +# allow '-' as command (c.f. open "-|"), by Adam Spiers +# +# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# +# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# +# spawn the given $cmd and connect rdr for +# reading, wtr for writing, and err for errors. +# if err is '', or the same as rdr, then stdout and +# stderr of the child are on the same fh. returns pid +# of child (or dies on failure). + +# if wtr begins with '<&', then wtr will be closed in the parent, and +# the child will read from it directly. if rdr or err begins with +# '>&', then the child will send output directly to that fd. In both +# cases, there will be a dup() instead of a pipe() made. + +# WARNING: this is dangerous, as you may block forever +# unless you are very careful. +# +# $wtr is left unbuffered. +# +# abort program if +# rdr or wtr are null +# a system call fails + +our $Me = 'open3 (bug)'; # you should never see this, it's always localized + +# Fatal.pm needs to be fixed WRT prototypes. + +sub xfork { + my $pid = fork; + defined $pid or croak "$Me: fork failed: $!"; + return $pid; +} + +sub xpipe { + pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; +} + +# I tried using a * prototype character for the filehandle but it still +# disallows a bearword while compiling under strict subs. + +sub xopen { + open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; +} + +sub xclose { + close $_[0] or croak "$Me: close($_[0]) failed: $!"; +} + +sub fh_is_fd { + return $_[0] =~ /\A=?(\d+)\z/; +} + +sub xfileno { + return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd + return fileno $_[0]; +} + +my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; + +sub _open3 { + local $Me = shift; + my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; + my($dup_wtr, $dup_rdr, $dup_err, $kidpid); + + if (@cmd > 1 and $cmd[0] eq '-') { + croak "Arguments don't make sense when the command is '-'" + } + + # simulate autovivification of filehandles because + # it's too ugly to use @_ throughout to make perl do it for us + # tchrist 5-Mar-00 + + unless (eval { + $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr; + $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr; + 1; }) + { + # must strip crud for croak to add back, or looks ugly + $@ =~ s/(?<=value attempted) at .*//s; + croak "$Me: $@"; + } + + $dad_err ||= $dad_rdr; + + $dup_wtr = ($dad_wtr =~ s/^[<>]&//); + $dup_rdr = ($dad_rdr =~ s/^[<>]&//); + $dup_err = ($dad_err =~ s/^[<>]&//); + + # force unqualified filehandles into caller's package + $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); + $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); + $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); + + my $kid_rdr = gensym; + my $kid_wtr = gensym; + my $kid_err = gensym; + + xpipe $kid_rdr, $dad_wtr if !$dup_wtr; + xpipe $dad_rdr, $kid_wtr if !$dup_rdr; + xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr; + + $kidpid = $do_spawn ? -1 : xfork; + if ($kidpid == 0) { # Kid + # A tie in the parent should not be allowed to cause problems. + untie *STDIN; + untie *STDOUT; + # If she wants to dup the kid's stderr onto her stdout I need to + # save a copy of her stdout before I put something else there. + if ($dad_rdr ne $dad_err && $dup_err + && xfileno($dad_err) == fileno(STDOUT)) { + my $tmp = gensym; + xopen($tmp, ">&$dad_err"); + $dad_err = $tmp; + } + + if ($dup_wtr) { + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr); + } else { + xclose $dad_wtr; + xopen \*STDIN, "<&=" . fileno $kid_rdr; + } + if ($dup_rdr) { + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr); + } else { + xclose $dad_rdr; + xopen \*STDOUT, ">&=" . fileno $kid_wtr; + } + if ($dad_rdr ne $dad_err) { + if ($dup_err) { + # I have to use a fileno here because in this one case + # I'm doing a dup but the filehandle might be a reference + # (from the special case above). + xopen \*STDERR, ">&" . xfileno($dad_err) + if fileno(STDERR) != xfileno($dad_err); + } else { + xclose $dad_err; + xopen \*STDERR, ">&=" . fileno $kid_err; + } + } else { + xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); + } + return 0 if ($cmd[0] eq '-'); + local($")=(" "); + exec @cmd or do { + carp "$Me: exec of @cmd failed"; + eval { require POSIX; POSIX::_exit(255); }; + exit 255; + }; + } elsif ($do_spawn) { + # All the bookkeeping of coincidence between handles is + # handled in spawn_with_handles. + + my @close; + if ($dup_wtr) { + $kid_rdr = \*{$dad_wtr}; + push @close, $kid_rdr; + } else { + push @close, \*{$dad_wtr}, $kid_rdr; + } + if ($dup_rdr) { + $kid_wtr = \*{$dad_rdr}; + push @close, $kid_wtr; + } else { + push @close, \*{$dad_rdr}, $kid_wtr; + } + if ($dad_rdr ne $dad_err) { + if ($dup_err) { + $kid_err = \*{$dad_err}; + push @close, $kid_err; + } else { + push @close, \*{$dad_err}, $kid_err; + } + } else { + $kid_err = $kid_wtr; + } + require IO::Pipe; + $kidpid = eval { + spawn_with_handles( [ { mode => 'r', + open_as => $kid_rdr, + handle => \*STDIN }, + { mode => 'w', + open_as => $kid_wtr, + handle => \*STDOUT }, + { mode => 'w', + open_as => $kid_err, + handle => \*STDERR }, + ], \@close, @cmd); + }; + die "$Me: $@" if $@; + } + + xclose $kid_rdr if !$dup_wtr; + xclose $kid_wtr if !$dup_rdr; + xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err; + # If the write handle is a dup give it away entirely, close my copy + # of it. + xclose $dad_wtr if $dup_wtr; + + select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + $kidpid; +} + +sub open3 { + if (@_ < 4) { + local $" = ', '; + croak "open3(@_): not enough arguments"; + } + return _open3 'open3', scalar caller, @_ +} + +sub spawn_with_handles { + my $fds = shift; # Fields: handle, mode, open_as + my $close_in_child = shift; + my ($fd, $pid, @saved_fh, $saved, %saved, @errs); + require Fcntl; + + foreach $fd (@$fds) { + $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); + $saved{fileno $fd->{handle}} = $fd->{tmp_copy}; + } + foreach $fd (@$fds) { + bless $fd->{handle}, 'IO::Handle' + unless eval { $fd->{handle}->isa('IO::Handle') } ; + # If some of handles to redirect-to coincide with handles to + # redirect, we need to use saved variants: + $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as}, + $fd->{mode}); + } + unless ($^O eq 'MSWin32') { + # Stderr may be redirected below, so we save the err text: + foreach $fd (@$close_in_child) { + fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" + unless $saved{fileno $fd}; # Do not close what we redirect! + } + } + + unless (@errs) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; + } + + foreach $fd (@$fds) { + $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); + $fd->{tmp_copy}->close or croak "Can't close: $!"; + } + croak join "\n", @errs if @errs; + return $pid; +} + +1; # so require is happy diff --git a/testsuite/input-files/perllib/List/Util.pm b/testsuite/input-files/perllib/List/Util.pm new file mode 100644 index 00000000..aced6b15 --- /dev/null +++ b/testsuite/input-files/perllib/List/Util.pm @@ -0,0 +1,233 @@ +# List::Util.pm +# +# Copyright (c) 1997-2009 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# This module is normally only loaded if the XS module is not available + +package List::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); +require Exporter; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +$VERSION = "1.23"; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +eval { + # PERL_DL_NONLAZY must be false, or any errors in loading will just + # cause the perl code to be tested + local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; + eval { + require XSLoader; + XSLoader::load('List::Util', $XS_VERSION); + 1; + } or do { + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + }; +} unless $TESTING_PERL_ONLY; + + +if (!defined &sum) { + require List::Util::PP; + List::Util::PP->import; +} + +1; + +__END__ + +=head1 NAME + +List::Util - A selection of general-utility list subroutines + +=head1 SYNOPSIS + + use List::Util qw(first max maxstr min minstr reduce shuffle sum); + +=head1 DESCRIPTION + +C contains a selection of subroutines that people have +expressed would be nice to have in the perl core, but the usage would +not really be high enough to warrant the use of a keyword, and the size +so small such that being individual extensions would be wasteful. + +By default C does not export any subroutines. The +subroutines defined are + +=over 4 + +=item first BLOCK LIST + +Similar to C in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C returns the first element where the result from +BLOCK is a true value. If BLOCK never returns true or LIST was empty then +C is returned. + + $foo = first { defined($_) } @list # first defined value in @list + $foo = first { $_ > $value } @list # first value in @list which + # is greater than $value + +This function could be implemented using C like this + + $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list + +for example wanted() could be defined() which would return the first +defined value in @list + +=item max LIST + +Returns the entry in the list with the highest numerical value. If the +list is empty then C is returned. + + $foo = max 1..10 # 10 + $foo = max 3,9,12 # 12 + $foo = max @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a > $b ? $a : $b } 1..10 + +=item maxstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the highest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = maxstr 'A'..'Z' # 'Z' + $foo = maxstr "hello","world" # "world" + $foo = maxstr @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' + +=item min LIST + +Similar to C but returns the entry in the list with the lowest +numerical value. If the list is empty then C is returned. + + $foo = min 1..10 # 1 + $foo = min 3,9,12 # 3 + $foo = min @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a < $b ? $a : $b } 1..10 + +=item minstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the lowest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = minstr 'A'..'Z' # 'A' + $foo = minstr "hello","world" # "hello" + $foo = minstr @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' + +=item reduce BLOCK LIST + +Reduces LIST by calling BLOCK, in a scalar context, multiple times, +setting C<$a> and C<$b> each time. The first call will be with C<$a> +and C<$b> set to the first two elements of the list, subsequent +calls will be done by setting C<$a> to the result of the previous +call and C<$b> to the next element in the list. + +Returns the result of the last call to BLOCK. If LIST is empty then +C is returned. If LIST only contains one element then that +element is returned and BLOCK is not executed. + + $foo = reduce { $a < $b ? $a : $b } 1..10 # min + $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr + $foo = reduce { $a + $b } 1 .. 10 # sum + $foo = reduce { $a . $b } @bar # concat + +If your algorithm requires that C produce an identity value, then +make sure that you always pass that identity value as the first argument to prevent +C being returned + + $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value + +=item shuffle LIST + +Returns the elements of LIST in a random order + + @cards = shuffle 0..51 # 0..51 in a random order + +=item sum LIST + +Returns the sum of all the elements in LIST. If LIST is empty then +C is returned. + + $foo = sum 1..10 # 55 + $foo = sum 3,9,12 # 24 + $foo = sum @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a + $b } 1..10 + +If your algorithm requires that C produce an identity of 0, then +make sure that you always pass C<0> as the first argument to prevent +C being returned + + $foo = sum 0, @values; + +=back + +=head1 KNOWN BUGS + +With perl versions prior to 5.005 there are some cases where reduce +will return an incorrect result. This will show up as test 7 of +reduce.t failing. + +=head1 SUGGESTED ADDITIONS + +The following are additions that have been requested, but I have been reluctant +to add due to them being very simple to implement in perl + + # One argument is true + + sub any { $_ && return 1 for @_; 0 } + + # All arguments are true + + sub all { $_ || return 0 for @_; 1 } + + # All arguments are false + + sub none { $_ && return 0 for @_; 1 } + + # One argument is false + + sub notall { $_ || return 1 for @_; 0 } + + # How many elements are true + + sub true { scalar grep { $_ } @_ } + + # How many elements are false + + sub false { scalar grep { !$_ } @_ } + +=head1 SEE ALSO + +L, L + +=head1 COPYRIGHT + +Copyright (c) 1997-2007 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/testsuite/input-files/perllib/POSIX.pm b/testsuite/input-files/perllib/POSIX.pm new file mode 100644 index 00000000..cb816f51 --- /dev/null +++ b/testsuite/input-files/perllib/POSIX.pm @@ -0,0 +1,77 @@ +package POSIX; +use strict; +use warnings; + +our(@ISA, %EXPORT_TAGS, @EXPORT_OK, @EXPORT, $AUTOLOAD, %SIGRT) = (); + +our $VERSION = "1.17"; + +use AutoLoader; + +use XSLoader (); + +use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD + F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND + O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC + O_WRONLY SEEK_CUR SEEK_END SEEK_SET + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID + S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR); + +# Grandfather old foo_h form to new :foo_h form +my $loaded; + +sub import { + load_imports() unless $loaded++; + my $this = shift; + my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; + local $Exporter::ExportLevel = 1; + Exporter::import($this,@list); +} + +sub croak { require Carp; goto &Carp::croak } +# declare usage to assist AutoLoad +sub usage; + +XSLoader::load 'POSIX', $VERSION; + +sub AUTOLOAD { + no strict; + no warnings 'uninitialized'; + if ($AUTOLOAD =~ /::(_?[a-z])/) { + # require AutoLoader; + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + local $! = 0; + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + my ($error, $val) = constant($constname); + croak $error if $error; + *$AUTOLOAD = sub { $val }; + + goto &$AUTOLOAD; +} + +package POSIX::SigAction; + +use AutoLoader 'AUTOLOAD'; + +package POSIX::SigRt; + +use AutoLoader 'AUTOLOAD'; + +use Tie::Hash; + +use vars qw($SIGACTION_FLAGS $_SIGRTMIN $_SIGRTMAX $_sigrtn @ISA); +@POSIX::SigRt::ISA = qw(Tie::StdHash); + +$SIGACTION_FLAGS = 0; + +tie %POSIX::SIGRT, 'POSIX::SigRt'; + +sub DESTROY {}; + +package POSIX; + +1; diff --git a/testsuite/input-files/perllib/Scalar/Util.pm b/testsuite/input-files/perllib/Scalar/Util.pm new file mode 100644 index 00000000..24138ca4 --- /dev/null +++ b/testsuite/input-files/perllib/Scalar/Util.pm @@ -0,0 +1,283 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2007 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Scalar::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL); +require Exporter; +require List::Util; # List::Util loads the XS + +@ISA = qw(Exporter); +@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +$VERSION = "1.23"; +$VERSION = eval $VERSION; + +unless (defined &dualvar) { + # Load Pure Perl version if XS not loaded + require Scalar::Util::PP; + Scalar::Util::PP->import; + push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); +} + +sub export_fail { + if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded + my $pat = join("|", @EXPORT_FAIL); + if (my ($err) = grep { /^($pat)$/ } @_ ) { + require Carp; + Carp::croak("$err is only available with the XS version of Scalar::Util"); + } + } + + if (grep { /^(weaken|isweak)$/ } @_ ) { + require Carp; + Carp::croak("Weak references are not implemented in the version of perl"); + } + + if (grep { /^(isvstring)$/ } @_ ) { + require Carp; + Carp::croak("Vstrings are not implemented in the version of perl"); + } + + @_; +} + +sub openhandle ($) { + my $fh = shift; + my $rt = reftype($fh) || ''; + + return defined(fileno($fh)) ? $fh : undef + if $rt eq 'IO'; + + if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) + $fh = \(my $tmp=$fh); + } + elsif ($rt ne 'GLOB') { + return undef; + } + + (tied(*$fh) or defined(fileno($fh))) + ? $fh : undef; +} + +1; + +__END__ + +=head1 NAME + +Scalar::Util - A selection of general-utility scalar subroutines + +=head1 SYNOPSIS + + use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted + weaken isvstring looks_like_number set_prototype); + # and other useful utils appearing below + +=head1 DESCRIPTION + +C contains a selection of subroutines that people have +expressed would be nice to have in the perl core, but the usage would +not really be high enough to warrant the use of a keyword, and the size +so small such that being individual extensions would be wasteful. + +By default C does not export any subroutines. The +subroutines defined are + +=over 4 + +=item blessed EXPR + +If EXPR evaluates to a blessed reference the name of the package +that it is blessed into is returned. Otherwise C is returned. + + $scalar = "foo"; + $class = blessed $scalar; # undef + + $ref = []; + $class = blessed $ref; # undef + + $obj = bless [], "Foo"; + $class = blessed $obj; # "Foo" + +=item dualvar NUM, STRING + +Returns a scalar that has the value NUM in a numeric context and the +value STRING in a string context. + + $foo = dualvar 10, "Hello"; + $num = $foo + 2; # 12 + $str = $foo . " world"; # Hello world + +=item isvstring EXPR + +If EXPR is a scalar which was coded as a vstring the result is true. + + $vs = v49.46.48; + $fmt = isvstring($vs) ? "%vd" : "%s"; #true + printf($fmt,$vs); + +=item isweak EXPR + +If EXPR is a scalar which is a weak reference the result is true. + + $ref = \$foo; + $weak = isweak($ref); # false + weaken($ref); + $weak = isweak($ref); # true + +B: Copying a weak reference creates a normal, strong, reference. + + $copy = $ref; + $weak = isweak($copy); # false + +=item looks_like_number EXPR + +Returns true if perl thinks EXPR is a number. See +L. + +=item openhandle FH + +Returns FH if FH may be used as a filehandle and is open, or FH is a tied +handle. Otherwise C is returned. + + $fh = openhandle(*STDIN); # \*STDIN + $fh = openhandle(\*STDIN); # \*STDIN + $fh = openhandle(*NOTOPEN); # undef + $fh = openhandle("scalar"); # undef + +=item readonly SCALAR + +Returns true if SCALAR is readonly. + + sub foo { readonly($_[0]) } + + $readonly = foo($bar); # false + $readonly = foo(0); # true + +=item refaddr EXPR + +If EXPR evaluates to a reference the internal memory address of +the referenced value is returned. Otherwise C is returned. + + $addr = refaddr "string"; # undef + $addr = refaddr \$var; # eg 12345678 + $addr = refaddr []; # eg 23456784 + + $obj = bless {}, "Foo"; + $addr = refaddr $obj; # eg 88123488 + +=item reftype EXPR + +If EXPR evaluates to a reference the type of the variable referenced +is returned. Otherwise C is returned. + + $type = reftype "string"; # undef + $type = reftype \$var; # SCALAR + $type = reftype []; # ARRAY + + $obj = bless {}, "Foo"; + $type = reftype $obj; # HASH + +=item set_prototype CODEREF, PROTOTYPE + +Sets the prototype of the given function, or deletes it if PROTOTYPE is +undef. Returns the CODEREF. + + set_prototype \&foo, '$$'; + +=item tainted EXPR + +Return true if the result of EXPR is tainted + + $taint = tainted("constant"); # false + $taint = tainted($ENV{PWD}); # true if running under -T + +=item weaken REF + +REF will be turned into a weak reference. This means that it will not +hold a reference count on the object it references. Also when the reference +count on that object reaches zero, REF will be set to undef. + +This is useful for keeping copies of references , but you don't want to +prevent the object being DESTROY-ed at its usual time. + + { + my $var; + $ref = \$var; + weaken($ref); # Make $ref a weak reference + } + # $ref is now undef + +Note that if you take a copy of a scalar with a weakened reference, +the copy will be a strong reference. + + my $var; + my $foo = \$var; + weaken($foo); # Make $foo a weak reference + my $bar = $foo; # $bar is now a strong reference + +This may be less obvious in other situations, such as C, for instance +when grepping through a list of weakened references to objects that may have +been destroyed already: + + @object = grep { defined } @object; + +This will indeed remove all references to destroyed objects, but the remaining +references to objects will be strong, causing the remaining objects to never +be destroyed because there is now always a strong reference to them in the +@object array. + +=back + +=head1 DIAGNOSTICS + +Module use may give one of the following errors during import. + +=over + +=item Weak references are not implemented in the version of perl + +The version of perl that you are using does not implement weak references, to use +C or C you will need to use a newer release of perl. + +=item Vstrings are not implemented in the version of perl + +The version of perl that you are using does not implement Vstrings, to use +C you will need to use a newer release of perl. + +=item C is only available with the XS version of Scalar::Util + +C contains both perl and C implementations of many of its functions +so that those without access to a C compiler may still use it. However some of the functions +are only available when a C compiler was available to compile the XS version of the extension. + +At present that list is: weaken, isweak, dualvar, isvstring, set_prototype + +=back + +=head1 KNOWN BUGS + +There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will +show up as tests 8 and 9 of dualvar.t failing + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +Copyright (c) 1997-2007 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +Except weaken and isweak which are + +Copyright (c) 1999 Tuomas J. Lukka . All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as perl itself. + +=cut diff --git a/testsuite/input-files/perllib/SelectSaver.pm b/testsuite/input-files/perllib/SelectSaver.pm new file mode 100644 index 00000000..4ccb837e --- /dev/null +++ b/testsuite/input-files/perllib/SelectSaver.pm @@ -0,0 +1,22 @@ +package SelectSaver; + +our $VERSION = '1.02'; + +require 5.000; +use Carp; +use Symbol; + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: SelectSaver->new( [FILEHANDLE] )'; + my $fh = select; + my $self = bless \$fh, $_[0]; + select qualify($_[1], caller) if @_ > 1; + $self; +} + +sub DESTROY { + my $self = $_[0]; + select $$self; +} + +1; diff --git a/testsuite/input-files/perllib/Symbol.pm b/testsuite/input-files/perllib/Symbol.pm new file mode 100644 index 00000000..72ef599e --- /dev/null +++ b/testsuite/input-files/perllib/Symbol.pm @@ -0,0 +1,91 @@ +package Symbol; + +BEGIN { require 5.005; } + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(gensym ungensym qualify qualify_to_ref); +@EXPORT_OK = qw(delete_package geniosym); + +$VERSION = '1.07'; + +my $genpkg = "Symbol::"; +my $genseq = 0; + +my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); + +# +# Note that we never _copy_ the glob; we just make a ref to it. +# If we did copy it, then SVf_FAKE would be set on the copy, and +# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. +# +sub gensym () { + my $name = "GEN" . $genseq++; + my $ref = \*{$genpkg . $name}; + delete $$genpkg{$name}; + $ref; +} + +sub geniosym () { + my $sym = gensym(); + # force the IO slot to be filled + select(select $sym); + *$sym{IO}; +} + +sub ungensym ($) {} + +sub qualify ($;$) { + my ($name) = @_; + if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) { + my $pkg; + # Global names: special character, "^xyz", or other. + if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) { + # RGS 2001-11-05 : translate leading ^X to control-char + $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei; + $pkg = "main"; + } + else { + $pkg = (@_ > 1) ? $_[1] : caller; + } + $name = $pkg . "::" . $name; + } + $name; +} + +sub qualify_to_ref ($;$) { + return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; +} + +# +# of Safe.pm lineage +# +sub delete_package ($) { + my $pkg = shift; + + # expand to full symbol table name if needed + + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; + + # free all the symbols in the package + + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + foreach my $name (keys %$leaf_symtab) { + undef *{$pkg . $name}; + } + + # delete the symbol table + + %$leaf_symtab = (); + delete $stem_symtab->{$leaf}; +} + +1; diff --git a/testsuite/input-files/perllib/Tie/Hash.pm b/testsuite/input-files/perllib/Tie/Hash.pm new file mode 100644 index 00000000..e3e8a243 --- /dev/null +++ b/testsuite/input-files/perllib/Tie/Hash.pm @@ -0,0 +1,74 @@ +package Tie::Hash; + +our $VERSION = '1.03'; + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pkg = shift; + if (defined &{"${pkg}::new"}) { + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIEHASH method"; + } +} + +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; +} + +sub CLEAR { + my $self = shift; + my $key = $self->FIRSTKEY(@_); + my @keys; + + while (defined $key) { + push @keys, $key; + $key = $self->NEXTKEY(@_, $key); + } + foreach $key (@keys) { + $self->DELETE(@_, $key); + } +} + +# The Tie::StdHash package implements standard perl hash behaviour. +# It exists to act as a base class for classes which only wish to +# alter some parts of their behaviour. + +package Tie::StdHash; +# @ISA = qw(Tie::Hash); # would inherit new() only + +sub TIEHASH { bless {}, $_[0] } +sub STORE { $_[0]->{$_[1]} = $_[2] } +sub FETCH { $_[0]->{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } +sub NEXTKEY { each %{$_[0]} } +sub EXISTS { exists $_[0]->{$_[1]} } +sub DELETE { delete $_[0]->{$_[1]} } +sub CLEAR { %{$_[0]} = () } +sub SCALAR { scalar %{$_[0]} } + +package Tie::ExtraHash; + +sub TIEHASH { my $p = shift; bless [{}, @_], $p } +sub STORE { $_[0][0]{$_[1]} = $_[2] } +sub FETCH { $_[0][0]{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } +sub NEXTKEY { each %{$_[0][0]} } +sub EXISTS { exists $_[0][0]->{$_[1]} } +sub DELETE { delete $_[0][0]->{$_[1]} } +sub CLEAR { %{$_[0][0]} = () } +sub SCALAR { scalar %{$_[0][0]} } + +1; diff --git a/testsuite/input-files/perllib/XSLoader.pm b/testsuite/input-files/perllib/XSLoader.pm new file mode 100644 index 00000000..b75b4ab7 --- /dev/null +++ b/testsuite/input-files/perllib/XSLoader.pm @@ -0,0 +1,117 @@ +# Generated from XSLoader.pm.PL (resolved %Config::Config value) + +package XSLoader; + +$VERSION = "0.10"; + +#use strict; + +# enable debug/trace messages from DynaLoader perl code +# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + + my $dl_dlext = 'so'; + +package DynaLoader; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_error); +package XSLoader; + +sub load { + package DynaLoader; + + die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_; + + my($module) = $_[0]; + + # work with static linking too + my $boots = "$module\::bootstrap"; + goto &$boots if defined &$boots; + + goto retry unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + my $modpname = join('/',@modparts); + my $modlibname = (caller())[1]; + my $c = @modparts; + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + my $bs = $file; + $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library + + if (-s $bs) { # only read file if it's not empty +# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; + eval { do $bs; }; + warn "$bs: $@\n" if $@; + } + + goto retry if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @DynaLoader::dl_require_symbols = ($bootname); + + my $boot_symbol_ref; + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@DynaLoader::dl_librefs,$libref); # record loaded object + + my @unresolved = dl_undef_symbols(); + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } + + $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + push(@DynaLoader::dl_modules, $module); # record loaded module + + boot: + my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file); + + # See comment block above + push(@DynaLoader::dl_shared_objects, $file); # record files loaded + return &$xs(@_); + + retry: + my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') || + XSLoader->can('bootstrap_inherit'); + goto &$bootstrap_inherit; +} + +# Versions of DynaLoader prior to 5.6.0 don't have this function. +sub bootstrap_inherit { + package DynaLoader; + + my $module = $_[0]; + local *DynaLoader::isa = *{"$module\::ISA"}; + local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader'); + # Cannot goto due to delocalization. Will report errors on a wrong line? + require DynaLoader; + DynaLoader::bootstrap(@_); +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/auto/Cwd/Cwd.so b/testsuite/input-files/perllib/auto/Cwd/Cwd.so new file mode 100644 index 00000000..57b7baca Binary files /dev/null and b/testsuite/input-files/perllib/auto/Cwd/Cwd.so differ diff --git a/testsuite/input-files/perllib/auto/Fcntl/Fcntl.so b/testsuite/input-files/perllib/auto/Fcntl/Fcntl.so new file mode 100644 index 00000000..7216ecad Binary files /dev/null and b/testsuite/input-files/perllib/auto/Fcntl/Fcntl.so differ diff --git a/testsuite/input-files/perllib/auto/File/Glob/Glob.so b/testsuite/input-files/perllib/auto/File/Glob/Glob.so new file mode 100644 index 00000000..553739ad Binary files /dev/null and b/testsuite/input-files/perllib/auto/File/Glob/Glob.so differ diff --git a/testsuite/input-files/perllib/auto/IO/IO.so b/testsuite/input-files/perllib/auto/IO/IO.so new file mode 100644 index 00000000..181cbbc4 Binary files /dev/null and b/testsuite/input-files/perllib/auto/IO/IO.so differ diff --git a/testsuite/input-files/perllib/auto/List/Util/Util.so b/testsuite/input-files/perllib/auto/List/Util/Util.so new file mode 100644 index 00000000..ba56ef09 Binary files /dev/null and b/testsuite/input-files/perllib/auto/List/Util/Util.so differ diff --git a/testsuite/input-files/perllib/auto/POSIX/POSIX.so b/testsuite/input-files/perllib/auto/POSIX/POSIX.so new file mode 100644 index 00000000..94e9ff79 Binary files /dev/null and b/testsuite/input-files/perllib/auto/POSIX/POSIX.so differ diff --git a/testsuite/input-files/perllib/auto/POSIX/autosplit.ix b/testsuite/input-files/perllib/auto/POSIX/autosplit.ix new file mode 100644 index 00000000..a13c556c --- /dev/null +++ b/testsuite/input-files/perllib/auto/POSIX/autosplit.ix @@ -0,0 +1,173 @@ +# Index created by AutoSplit for ../../lib/POSIX.pm +# (file acts as timestamp) +package POSIX; +sub usage ; +sub redef ; +sub unimpl ; +sub assert ; +sub tolower ; +sub toupper ; +sub closedir ; +sub opendir ; +sub readdir ; +sub rewinddir ; +sub errno ; +sub creat ; +sub fcntl ; +sub getgrgid ; +sub getgrnam ; +sub atan2 ; +sub cos ; +sub exp ; +sub fabs ; +sub log ; +sub pow ; +sub sin ; +sub sqrt ; +sub getpwnam ; +sub getpwuid ; +sub longjmp ; +sub setjmp ; +sub siglongjmp ; +sub sigsetjmp ; +sub kill ; +sub raise ; +sub offsetof ; +sub clearerr ; +sub fclose ; +sub fdopen ; +sub feof ; +sub fgetc ; +sub fgets ; +sub fileno ; +sub fopen ; +sub fprintf ; +sub fputc ; +sub fputs ; +sub fread ; +sub freopen ; +sub fscanf ; +sub fseek ; +sub fsync ; +sub ferror ; +sub fflush ; +sub fgetpos ; +sub fsetpos ; +sub ftell ; +sub fwrite ; +sub getc ; +sub getchar ; +sub gets ; +sub perror ; +sub printf ; +sub putc ; +sub putchar ; +sub puts ; +sub remove ; +sub rename ; +sub rewind ; +sub scanf ; +sub sprintf ; +sub sscanf ; +sub tmpfile ; +sub ungetc ; +sub vfprintf ; +sub vprintf ; +sub vsprintf ; +sub abs ; +sub atexit ; +sub atof ; +sub atoi ; +sub atol ; +sub bsearch ; +sub calloc ; +sub div ; +sub exit ; +sub free ; +sub getenv ; +sub labs ; +sub ldiv ; +sub malloc ; +sub qsort ; +sub rand ; +sub realloc ; +sub srand ; +sub system ; +sub memchr ; +sub memcmp ; +sub memcpy ; +sub memmove ; +sub memset ; +sub strcat ; +sub strchr ; +sub strcmp ; +sub strcpy ; +sub strcspn ; +sub strerror ; +sub strlen ; +sub strncat ; +sub strncmp ; +sub strncpy ; +sub strpbrk ; +sub strrchr ; +sub strspn ; +sub strstr ; +sub strtok ; +sub chmod ; +sub fstat ; +sub mkdir ; +sub stat ; +sub umask ; +sub wait ; +sub waitpid ; +sub gmtime ; +sub localtime ; +sub time ; +sub alarm ; +sub chdir ; +sub chown ; +sub execl ; +sub execle ; +sub execlp ; +sub execv ; +sub execve ; +sub execvp ; +sub fork ; +sub getegid ; +sub geteuid ; +sub getgid ; +sub getgroups ; +sub getlogin ; +sub getpgrp ; +sub getpid ; +sub getppid ; +sub getuid ; +sub isatty ; +sub link ; +sub rmdir ; +sub setbuf ; +sub setvbuf ; +sub sleep ; +sub unlink ; +sub utime ; +sub load_imports ; +package POSIX::SigAction; +sub new ; +sub handler ; +sub mask ; +sub flags ; +sub safe ; +package POSIX::SigRt; +sub _init ; +sub _croak ; +sub _getsig ; +sub _exist ; +sub _check ; +sub new ; +sub EXISTS ; +sub FETCH ; +sub STORE ; +sub DELETE ; +sub CLEAR ; +sub SCALAR ; +1; diff --git a/testsuite/input-files/perllib/auto/POSIX/load_imports.al b/testsuite/input-files/perllib/auto/POSIX/load_imports.al new file mode 100644 index 00000000..bcbd3d4b --- /dev/null +++ b/testsuite/input-files/perllib/auto/POSIX/load_imports.al @@ -0,0 +1,230 @@ +# NOTE: Derived from ../../lib/POSIX.pm. +# Changes made here will be lost when autosplit is run again. +# See AutoSplit.pm. +package POSIX; + +#line 759 "../../lib/POSIX.pm (autosplit into ../../lib/auto/POSIX/load_imports.al)" +sub load_imports { +%EXPORT_TAGS = ( + + assert_h => [qw(assert NDEBUG)], + + ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)], + + dirent_h => [], + + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], + + fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)], + + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], + + grp_h => [], + + limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], + + locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES + LC_MONETARY LC_NUMERIC LC_TIME NULL + localeconv setlocale)], + + math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], + + pwd_h => [], + + setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], + + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP + SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 + SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK + raise sigaction signal sigpending sigprocmask sigsuspend)], + + stdarg_h => [], + + stddef_h => [qw(NULL offsetof)], + + stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + STREAM_MAX TMP_MAX stderr stdin stdout + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)], + + stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX + abort atexit atof atoi atol bsearch calloc div + free getenv labs ldiv malloc mblen mbstowcs mbtowc + qsort realloc strtod strtol strtoul wcstombs wctomb)], + + string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)], + + sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)], + + sys_times_h => [], + + sys_types_h => [], + + sys_utsname_h => [qw(uname)], + + sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], + + termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )], + + time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)], + + unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf fsync getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], + + utime_h => [], + +); + +# Exporter::export_tags(); +{ + # De-duplicate the export list: + my %export; + @export{map {@$_} values %EXPORT_TAGS} = (); + # Doing the de-dup with a temporary hash has the advantage that the SVs in + # @EXPORT are actually shared hash key sacalars, which will save some memory. + push @EXPORT, keys %export; +} + +@EXPORT_OK = qw( + abs + alarm + atan2 + chdir + chmod + chown + close + closedir + cos + exit + exp + fcntl + fileno + fork + getc + getgrgid + getgrnam + getlogin + getpgrp + getppid + getpwnam + getpwuid + gmtime + isatty + kill + lchown + link + localtime + log + mkdir + nice + open + opendir + pipe + printf + rand + read + readdir + rename + rewinddir + rmdir + sin + sleep + sprintf + sqrt + srand + stat + system + time + times + umask + unlink + utime + wait + waitpid + write +); + +require Exporter; +} + +# end of POSIX::SigAction::load_imports +1; diff --git a/testsuite/input-files/perllib/base.pm b/testsuite/input-files/perllib/base.pm new file mode 100644 index 00000000..98a388ce --- /dev/null +++ b/testsuite/input-files/perllib/base.pm @@ -0,0 +1,181 @@ +package base; + +use strict 'vars'; +use vars qw($VERSION); +$VERSION = '2.14'; +$VERSION = eval $VERSION; + +# constant.pm is slow +sub SUCCESS () { 1 } + +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + +my $Fattr = \%fields::attr; + +sub has_fields { + my($base) = shift; + my $fglob = ${"$base\::"}{FIELDS}; + return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); +} + +sub has_version { + my($base) = shift; + my $vglob = ${$base.'::'}{VERSION}; + return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); +} + +sub has_attr { + my($proto) = shift; + my($class) = ref $proto || $proto; + return exists $Fattr->{$class}; +} + +sub get_attr { + $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; + return $Fattr->{$_[0]}; +} + +if ($] < 5.009) { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + my $f = \%{$_[0].'::FIELDS'}; + + # should be centralized in fields? perhaps + # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } + # is used here anyway, it doesn't matter. + bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); + + return $f; + } +} +else { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + return \%{$_[0].'::FIELDS'}; + } +} + +sub import { + my $class = shift; + + return SUCCESS unless @_; + + # List of base classes from which we will inherit %FIELDS. + my $fields_base; + + my $inheritor = caller(0); + my @isa_classes; + + my @bases; + foreach my $base (@_) { + if ( $inheritor eq $base ) { + warn "Class '$inheritor' tried to inherit from itself\n"; + } + + next if grep $_->isa($base), ($inheritor, @bases); + + if (has_version($base)) { + ${$base.'::VERSION'} = '-1, set by base.pm' + unless defined ${$base.'::VERSION'}; + } + else { + my $sigdie; + { + local $SIG{__DIE__}; + eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; + unless (%{"$base\::"}) { + require Carp; + local $" = " "; + Carp::croak(<[0] = @$battr; + + if( keys %$dfields ) { + warn <<"END"; +$derived is inheriting from $base but already has its own fields! +This will cause problems. Be sure you use base BEFORE declaring fields. +END + + } + + # Iterate through the base's fields adding all the non-private + # ones to the derived class. Hang on to the original attribute + # (Public, Private, etc...) and add Inherited. + # This is all too complicated to do efficiently with add_fields(). + while (my($k,$v) = each %$bfields) { + my $fno; + if ($fno = $dfields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited fields can't override existing fields"); + } + + if( $battr->[$v] & PRIVATE ) { + $dattr->[$v] = PRIVATE | INHERITED; + } + else { + $dattr->[$v] = INHERITED | $battr->[$v]; + $dfields->{$k} = $v; + } + } + + foreach my $idx (1..$#{$battr}) { + next if defined $dattr->[$idx]; + $dattr->[$idx] = $battr->[$idx] & INHERITED; + } +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/constant.pm b/testsuite/input-files/perllib/constant.pm new file mode 100644 index 00000000..b960676f --- /dev/null +++ b/testsuite/input-files/perllib/constant.pm @@ -0,0 +1,130 @@ +package constant; +use 5.005; +use strict; +use warnings::register; + +use vars qw($VERSION %declared); +$VERSION = '1.17'; + +#======================================================================= + +# Some names are evil choices. +my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; +$keywords{UNITCHECK}++ if $] > 5.009; + +my %forced_into_main = map +($_, 1), + qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; + +my %forbidden = (%keywords, %forced_into_main); + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + return unless @_; # Ignore 'use constant;' + my $constants; + my $multiple = ref $_[0]; + my $pkg = caller; + my $symtab; + my $str_end = $] >= 5.006 ? "\\z" : "\\Z"; + + if ($] > 5.009002) { + no strict 'refs'; + $symtab = \%{$pkg . '::'}; + }; + + if ( $multiple ) { + if (ref $_[0] ne 'HASH') { + require Carp; + Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); + } + $constants = shift; + } else { + $constants->{+shift} = undef; + } + + foreach my $name ( keys %$constants ) { + unless (defined $name) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + + # Normal constant name + if ($name =~ /^_?[^\W_0-9]\w*$str_end/ and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ /^[A-Za-z_]\w*$str_end/) { + # Then we'll warn only if you've asked for warnings + if (warnings::enabled()) { + if ($keywords{$name}) { + warnings::warn("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + warnings::warn("Constant name '$name' is " . + "forced into package main::"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ /^[01]?$str_end/) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); + } else { + Carp::croak("Constant name looks like boolean value"); + } + + } else { + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); + } + + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if ($multiple || @_ == 1) { + my $scalar = $multiple ? $constants->{$name} : $_[0]; + if ($symtab && !exists $symtab->{$name}) { + # No typeglob yet, so we can use a reference as space- + # efficient proxy for a constant subroutine + # The check in Perl_ck_rvconst knows that inlinable + # constants from cv_const_sv are read only. So we have to: + Internals::SvREADONLY($scalar, 1); + $symtab->{$name} = \$scalar; + mro::method_changed_in($pkg); + } else { + *$full_name = sub () { $scalar }; + } + } elsif (@_) { + my @list = @_; + *$full_name = sub () { @list }; + } else { + *$full_name = sub () { }; + } + } + } +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/overload.pm b/testsuite/input-files/perllib/overload.pm new file mode 100644 index 00000000..cf4a590c --- /dev/null +++ b/testsuite/input-files/perllib/overload.pm @@ -0,0 +1,178 @@ +package overload; + +our $VERSION = '1.07'; + +sub nil {} + +sub OVERLOAD { + $package = shift; + my %arg = @_; + my ($sub, $fb); + $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching. + *{$package . "::()"} = \&nil; # Make it findable via fetchmethod. + for (keys %arg) { + if ($_ eq 'fallback') { + $fb = $arg{$_}; + } else { + $sub = $arg{$_}; + if (not ref $sub and $sub !~ /::/) { + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; + } + #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n"; + *{$package . "::(" . $_} = \&{ $sub }; + } + } + ${$package . "::()"} = $fb; # Make it findable too (fallback only). +} + +sub import { + $package = (caller())[0]; + # *{$package . "::OVERLOAD"} = \&OVERLOAD; + shift; + $package->overload::OVERLOAD(@_); +} + +sub unimport { + $package = (caller())[0]; + ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table + shift; + for (@_) { + if ($_ eq 'fallback') { + undef $ {$package . "::()"}; + } else { + delete $ {$package . "::"}{"(" . $_}; + } + } +} + +sub Overloaded { + my $package = shift; + $package = ref $package if ref $package; + $package->can('()'); +} + +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + return $sub if $sub ne \&nil; + return shift->can($ {*$globref}); +} + +sub OverloadedStringify { + my $package = shift; + $package = ref $package if ref $package; + #$package->can('(""') + ov_method mycan($package, '(""'), $package + or ov_method mycan($package, '(0+'), $package + or ov_method mycan($package, '(bool'), $package + or ov_method mycan($package, '(nomethod'), $package; +} + +sub Method { + my $package = shift; + if(ref $package) { + local $@; + local $!; + require Scalar::Util; + $package = Scalar::Util::blessed($package); + return undef if !defined $package; + } + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; +} + +sub AddrRef { + my $package = ref $_[0]; + return "$_[0]" unless $package; + + local $@; + local $!; + require Scalar::Util; + my $class = Scalar::Util::blessed($_[0]); + my $class_prefix = defined($class) ? "$class=" : ""; + my $type = Scalar::Util::reftype($_[0]); + my $addr = Scalar::Util::refaddr($_[0]); + return sprintf("$class_prefix$type(0x%x)", $addr); +} + +*StrVal = *AddrRef; + +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + + my $mro = mro::get_linear_isa($package); + foreach my $p (@$mro) { + my $fqmeth = $p . q{::} . $meth; + return \*{$fqmeth} if defined &{$fqmeth}; + } + + return undef; +} + +%constants = ( + 'integer' => 0x1000, # HINT_NEW_INTEGER + 'float' => 0x2000, # HINT_NEW_FLOAT + 'binary' => 0x4000, # HINT_NEW_BINARY + 'q' => 0x8000, # HINT_NEW_STRING + 'qr' => 0x10000, # HINT_NEW_RE + ); + +%ops = ( with_assign => "+ - * / % ** << >> x .", + assign => "+= -= *= /= %= **= <<= >>= x= .=", + num_comparison => "< <= > >= == !=", + '3way_comparison'=> "<=> cmp", + str_comparison => "lt le gt ge eq ne", + binary => '& &= | |= ^ ^=', + unary => "neg ! ~", + mutators => '++ --', + func => "atan2 cos sin exp abs log sqrt int", + conversion => 'bool "" 0+', + iterators => '<>', + dereferencing => '${} @{} %{} &{} *{}', + matching => '~~', + special => 'nomethod fallback ='); + +use warnings::register; +sub constant { + # Arguments: what, sub + while (@_) { + if (@_ == 1) { + warnings::warnif ("Odd number of arguments for overload::constant"); + last; + } + elsif (!exists $constants {$_ [0]}) { + warnings::warnif ("`$_[0]' is not an overloadable type"); + } + elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) { + # Can't use C above as code references can be + # blessed, and C would return the package the ref is blessed into. + if (warnings::enabled) { + $_ [1] = "undef" unless defined $_ [1]; + warnings::warn ("`$_[1]' is not a code reference"); + } + } + else { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]}; + } + shift, shift; + } +} + +sub remove_constant { + # Arguments: what, sub + while (@_) { + delete $^H{$_[0]}; + $^H &= ~ $constants{$_[0]}; + shift, shift; + } +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/re.pm b/testsuite/input-files/perllib/re.pm new file mode 100644 index 00000000..c4a020f8 --- /dev/null +++ b/testsuite/input-files/perllib/re.pm @@ -0,0 +1,182 @@ +package re; + +# pragma for controlling the regex engine +use strict; +use warnings; + +our $VERSION = "0.09"; +our @ISA = qw(Exporter); +my @XS_FUNCTIONS = qw(regmust); +my %XS_FUNCTIONS = map { $_ => 1 } @XS_FUNCTIONS; +our @EXPORT_OK = (@XS_FUNCTIONS, + qw(is_regexp regexp_pattern + regname regnames regnames_count)); +our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK; + +# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING *** +# +# If you modify these values see comment below! + +my %bitmask = ( + taint => 0x00100000, # HINT_RE_TAINT + eval => 0x00200000, # HINT_RE_EVAL +); + +# - File::Basename contains a literal for 'taint' as a fallback. If +# taint is changed here, File::Basename must be updated as well. +# +# - ExtUtils::ParseXS uses a hardcoded +# BEGIN { $^H |= 0x00200000 } +# in it to allow re.xs to be built. So if 'eval' is changed here then +# ExtUtils::ParseXS must be changed as well. +# +# *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING *** + +sub setcolor { + eval { # Ignore errors + require Term::Cap; + + my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. + my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; + my @props = split /,/, $props; + my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; + + $colors =~ s/\0//g; + $ENV{PERL_RE_COLORS} = $colors; + }; + if ($@) { + $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t'; + } + +} + +my %flags = ( + COMPILE => 0x0000FF, + PARSE => 0x000001, + OPTIMISE => 0x000002, + TRIEC => 0x000004, + DUMP => 0x000008, + FLAGS => 0x000010, + + EXECUTE => 0x00FF00, + INTUIT => 0x000100, + MATCH => 0x000200, + TRIEE => 0x000400, + + EXTRA => 0xFF0000, + TRIEM => 0x010000, + OFFSETS => 0x020000, + OFFSETSDBG => 0x040000, + STATE => 0x080000, + OPTIMISEM => 0x100000, + STACK => 0x280000, + BUFFERS => 0x400000, +); +$flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS}); +$flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE}; +$flags{Extra} = $flags{EXECUTE} | $flags{COMPILE}; +$flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE}; +$flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE}; +$flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC}; + +my $installed; +my $installed_error; + +sub _do_install { + if ( ! defined($installed) ) { + require XSLoader; + $installed = eval { XSLoader::load('re', $VERSION) } || 0; + $installed_error = $@; + } +} + +sub _load_unload { + my ($on)= @_; + if ($on) { + _do_install(); + if ( ! $installed ) { + die "'re' not installed!? ($installed_error)"; + } else { + # We call install() every time, as if we didn't, we wouldn't + # "see" any changes to the color environment var since + # the last time it was called. + + # install() returns an integer, which if casted properly + # in C resolves to a structure containing the regex + # hooks. Setting it to a random integer will guarantee + # segfaults. + $^H{regcomp} = install(); + } + } else { + delete $^H{regcomp}; + } +} + +sub bits { + my $on = shift; + my $bits = 0; + unless (@_) { + require Carp; + Carp::carp("Useless use of \"re\" pragma"); + } + foreach my $idx (0..$#_){ + my $s=$_[$idx]; + if ($s eq 'Debug' or $s eq 'Debugcolor') { + setcolor() if $s =~/color/i; + ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS}; + for my $idx ($idx+1..$#_) { + if ($flags{$_[$idx]}) { + if ($on) { + ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]}; + } else { + ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]}; + } + } else { + require Carp; + Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ", + join(", ",sort keys %flags ) ); + } + } + _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS}); + last; + } elsif ($s eq 'debug' or $s eq 'debugcolor') { + setcolor() if $s =~/color/i; + _load_unload($on); + last; + } elsif (exists $bitmask{$s}) { + $bits |= $bitmask{$s}; + } elsif ($XS_FUNCTIONS{$s}) { + _do_install(); + if (! $installed) { + require Carp; + Carp::croak("\"re\" function '$s' not available"); + } + require Exporter; + re->export_to_level(2, 're', $s); + } elsif ($EXPORT_OK{$s}) { + require Exporter; + re->export_to_level(2, 're', $s); + } else { + require Carp; + Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ", + join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask), + ")"); + } + } + $bits; +} + +sub import { + shift; + $^H |= bits(1, @_); +} + +sub unimport { + shift; + $^H &= ~ bits(0, @_); +} + +1; + +__END__ + diff --git a/testsuite/input-files/perllib/strict.pm b/testsuite/input-files/perllib/strict.pm new file mode 100644 index 00000000..7928712e --- /dev/null +++ b/testsuite/input-files/perllib/strict.pm @@ -0,0 +1,46 @@ +package strict; + +$strict::VERSION = "1.04"; + +# Verify that we're called correctly so that strictures will work. +unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { + # Can't use Carp, since Carp uses us! + my (undef, $f, $l) = caller; + die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); +} + +my %bitmask = ( +refs => 0x00000002, +subs => 0x00000200, +vars => 0x00000400 +); + +sub bits { + my $bits = 0; + my @wrong; + foreach my $s (@_) { + push @wrong, $s unless exists $bitmask{$s}; + $bits |= $bitmask{$s} || 0; + } + if (@wrong) { + require Carp; + Carp::croak("Unknown 'strict' tag(s) '@wrong'"); + } + $bits; +} + +my $default_bits = bits(qw(refs subs vars)); + +sub import { + shift; + $^H |= @_ ? bits(@_) : $default_bits; +} + +sub unimport { + shift; + $^H &= ~ (@_ ? bits(@_) : $default_bits); +} + +1; +__END__ + diff --git a/testsuite/input-files/perllib/subs.pm b/testsuite/input-files/perllib/subs.pm new file mode 100644 index 00000000..e5a9aa88 --- /dev/null +++ b/testsuite/input-files/perllib/subs.pm @@ -0,0 +1,40 @@ +package subs; + +our $VERSION = '1.00'; + +=head1 NAME + +subs - Perl pragma to predeclare sub names + +=head1 SYNOPSIS + + use subs qw(frob); + frob 3..10; + +=head1 DESCRIPTION + +This will predeclare all the subroutine whose names are +in the list, allowing you to use them without parentheses +even before they're declared. + +Unlike pragmas that affect the C<$^H> hints variable, the C and +C declarations are not BLOCK-scoped. They are thus effective +for the entire file in which they appear. You may not rescind such +declarations with C or C. + +See L and L. + +=cut + +require 5.000; + +sub import { + my $callpack = caller; + my $pack = shift; + my @imports = @_; + foreach $sym (@imports) { + *{"${callpack}::$sym"} = \&{"${callpack}::$sym"}; + } +}; + +1; diff --git a/testsuite/input-files/perllib/vars.pm b/testsuite/input-files/perllib/vars.pm new file mode 100644 index 00000000..589915d8 --- /dev/null +++ b/testsuite/input-files/perllib/vars.pm @@ -0,0 +1,48 @@ +package vars; + +use 5.006; + +our $VERSION = '1.01'; + +use warnings::register; +use strict qw(vars subs); + +sub import { + my $callpack = caller; + my ($pack, @imports) = @_; + my ($sym, $ch); + foreach (@imports) { + if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) { + if ($sym =~ /\W/) { + # time for a more-detailed check-up + if ($sym =~ /^\w+[[{].*[]}]$/) { + require Carp; + Carp::croak("Can't declare individual elements of hash or array"); + } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + warnings::warn("No need to declare built-in vars"); + } elsif (($^H &= strict::bits('vars'))) { + require Carp; + Carp::croak("'$_' is not a valid variable name under strict vars"); + } + } + $sym = "${callpack}::$sym" unless $sym =~ /::/; + *$sym = + ( $ch eq "\$" ? \$$sym + : $ch eq "\@" ? \@$sym + : $ch eq "\%" ? \%$sym + : $ch eq "\*" ? \*$sym + : $ch eq "\&" ? \&$sym + : do { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + }); + } else { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + } + } +}; + +1; +__END__ + diff --git a/testsuite/input-files/perllib/warnings.pm b/testsuite/input-files/perllib/warnings.pm new file mode 100644 index 00000000..3fc9a3db --- /dev/null +++ b/testsuite/input-files/perllib/warnings.pm @@ -0,0 +1,379 @@ +# -*- buffer-read-only: t -*- +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file was created by warnings.pl +# Any changes made here will be lost. +# + +package warnings; + +our $VERSION = '1.06'; + +# Verify that we're called correctly so that warnings will work. +# see also strict.pm. +unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) { + my (undef, $f, $l) = caller; + die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n"); +} + +our %Offsets = ( + + # Warnings Categories added in Perl 5.008 + + 'all' => 0, + 'closure' => 2, + 'deprecated' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'layer' => 16, + 'newline' => 18, + 'pipe' => 20, + 'unopened' => 22, + 'misc' => 24, + 'numeric' => 26, + 'once' => 28, + 'overflow' => 30, + 'pack' => 32, + 'portable' => 34, + 'recursion' => 36, + 'redefine' => 38, + 'regexp' => 40, + 'severe' => 42, + 'debugging' => 44, + 'inplace' => 46, + 'internal' => 48, + 'malloc' => 50, + 'signal' => 52, + 'substr' => 54, + 'syntax' => 56, + 'ambiguous' => 58, + 'bareword' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'threads' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + ); + +our %Bits = ( + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x05", # [0..45] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] + 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] + 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] + 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] + ); + +our %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x0a", # [0..45] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] + 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] + 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25] + 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] + 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] + ); + +$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; +$LAST_BIT = 92 ; +$BYTES = 12 ; + +$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; + +sub Croaker +{ + require Carp::Heavy; # this initializes %CarpInternal + local $Carp::CarpInternal{'warnings'}; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub bits +{ + # called from B::Deparse.pm + + push @_, 'all' unless @_; + + my $mask; + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + return $mask ; +} + +sub import +{ + shift; + + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + my $mask = ${^WARNING_BITS} ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +sub unimport +{ + shift; + + my $catmask ; + my $mask = ${^WARNING_BITS} ; + + if (vec($mask, $Offsets{'all'}, 1)) { + $mask |= $Bits{'all'} ; + $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); + } + + push @_, 'all' unless @_; + + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask &= ~($catmask | $DeadBits{$word} | $All); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + +sub __chk +{ + my $category ; + my $offset ; + my $isobj = 0 ; + + if (@_) { + # check the category supplied. + $category = shift ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; + $isobj = 1 ; + } + $offset = $Offsets{$category}; + Croaker("Unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(1))[0] ; + $offset = $Offsets{$category}; + Croaker("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $this_pkg = (caller(1))[0] ; + my $i = 2 ; + my $pkg ; + + if ($isobj) { + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + else { + $i = _error_loc(); # see where Carp will allocate the error + } + + my $callers_bitmask = (caller($i))[9] ; + return ($callers_bitmask, $offset, $i) ; +} + +sub _error_loc { + require Carp::Heavy; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + +sub enabled +{ + Croaker("Usage: warnings::enabled([category])") + unless @_ == 1 || @_ == 0 ; + + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return 0 unless defined $callers_bitmask ; + return vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1) ; +} + +sub warn +{ + Croaker("Usage: warnings::warn([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + require Carp; + Carp::croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + Carp::carp($message) ; +} + +sub warnif +{ + Croaker("Usage: warnings::warnif([category,] 'message')") + unless @_ == 2 || @_ == 1 ; + + my $message = pop ; + my ($callers_bitmask, $offset, $i) = __chk(@_) ; + + return + unless defined $callers_bitmask && + (vec($callers_bitmask, $offset, 1) || + vec($callers_bitmask, $Offsets{'all'}, 1)) ; + + require Carp; + Carp::croak($message) + if vec($callers_bitmask, $offset+1, 1) || + vec($callers_bitmask, $Offsets{'all'}+1, 1) ; + + Carp::carp($message) ; +} + +1; +# ex: set ro: diff --git a/testsuite/input-files/perllib/warnings/register.pm b/testsuite/input-files/perllib/warnings/register.pm new file mode 100644 index 00000000..65dba3d9 --- /dev/null +++ b/testsuite/input-files/perllib/warnings/register.pm @@ -0,0 +1,32 @@ +package warnings::register; + +our $VERSION = '1.01'; + +require warnings; + +sub mkMask +{ + my ($bit) = @_; + my $mask = ""; + + vec($mask, $bit, 1) = 1; + return $mask; +} + +sub import +{ + shift; + my $package = (caller(0))[0]; + if (! defined $warnings::Bits{$package}) { + $warnings::Bits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::Bits{'all'}, $warnings::LAST_BIT, 1) = 1; + $warnings::Offsets{$package} = $warnings::LAST_BIT ++; + foreach my $k (keys %warnings::Bits) { + vec($warnings::Bits{$k}, $warnings::LAST_BIT, 1) = 0; + } + $warnings::DeadBits{$package} = mkMask($warnings::LAST_BIT); + vec($warnings::DeadBits{'all'}, $warnings::LAST_BIT++, 1) = 1; + } +} + +1; diff --git a/testsuite/tests-to-run/test38.sh b/testsuite/tests-to-run/test38.sh new file mode 100755 index 00000000..8b5ddda2 --- /dev/null +++ b/testsuite/tests-to-run/test38.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +echo '### Test with old perl libs' +# Old libraries are put into input-files/perllib +PERL5LIB=input-files/perllib:../input-files/perllib; export PERL5LIB + +echo '### See if we get compile error' +echo perl | stdout parallel echo +echo '### See if we read modules outside perllib' +echo perl | stdout strace -ff parallel echo | grep open | grep perl | grep -v input-files/perllib + diff --git a/testsuite/wanted-results/test38 b/testsuite/wanted-results/test38 new file mode 100644 index 00000000..7db53ceb --- /dev/null +++ b/testsuite/wanted-results/test38 @@ -0,0 +1,4 @@ +### Test with old perl libs +### See if we get compile error +perl +### See if we read modules outside perllib