tange/parallel
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/parallel.git synced 2024-12-22 20:57:53 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Released as 20101113. Test to be compatible with old perllibs

Browse source
This commit is contained in:
Ole Tange 2010-11-15 22:46:36 +01:00
parent 4ed346760b
commit f7355734a5
52 changed files with 12844 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
configure vendored
View file

@ -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 <bug-parallel@gnu.org>.
#
@ -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\\"

2
configure.ac
View file

@ -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([

2
src/parallel
View file

@ -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;

2
src/sql
View file

@ -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

198
testsuite/input-files/perllib/AutoLoader.pm Normal file
View file

@ -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<require> 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<require> 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<require> 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__

51
testsuite/input-files/perllib/Carp.pm Normal file
View file

@ -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__

297
testsuite/input-files/perllib/Carp/Heavy.pm Normal file
View file

@ -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;

648
testsuite/input-files/perllib/Cwd.pm Normal file
View file

@ -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 = <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;

713
testsuite/input-files/perllib/Data/Dump.pm Normal file
View file

@ -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 $_ = &quote;
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 C<eval>ed, 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<dump($string)> 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<Data::Dump::Filtered>.
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, C<eval>ing 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<dump> function, your code will
core dump. That's because you just called the builtin C<dump> function
by accident, which intentionally dumps core. Because of this you can
also import the same function as C<pp>, mnemonic for "pretty-print".
=head1 HISTORY
The C<Data::Dump> module grew out of frustration with Sarathy's
in-most-cases-excellent C<Data::Dumper>. Basic ideas and some code
are shared with Sarathy's module.
The C<Data::Dump> module provides a much simpler interface than
C<Data::Dumper>. 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<dump("foo")> simply returns C<'"foo"'>, and C<dump(1..3)> simply
returns C<'(1, 2, 3)'>.
=head1 SEE ALSO
L<Data::Dump::Filtered>, L<Data::Dump::Trace>, L<Data::Dumper>, L<JSON>,
L<Storable>
=head1 AUTHORS
The C<Data::Dump> module is written by Gisle Aas <gisle@aas.no>, based
on C<Data::Dumper> by Gurusamy Sarathy <gsar@umich.edu>.
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

228
testsuite/input-files/perllib/Errno.pm Normal file
View file

@ -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__

99
testsuite/input-files/perllib/Exporter.pm Normal file
View file

@ -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__

237
testsuite/input-files/perllib/Exporter/Heavy.pm Normal file
View file

@ -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;

189
testsuite/input-files/perllib/Fcntl.pm Normal file
View file

@ -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;

402
testsuite/input-files/perllib/File/Basename.pm Normal file
View file

@ -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<NOTE>: C<dirname()> and C<basename()> 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<File::Spec>'s C<splitpath()> and
C<splitdir()> 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<use re 'taint';> 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<fileparse>
X<fileparse>
my($filename, $directories, $suffix) = fileparse($path);
my($filename, $directories, $suffix) = fileparse($path, @suffixes);
my $filename = fileparse($path, @suffixes);
The C<fileparse()> 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<qr//>) 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<fileparse_set_fstype()>) 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<basename>
X<basename> X<filename>
my $filename = basename($path);
my $filename = basename($path, @suffixes);
This function is provided for compatibility with the Unix shell command
C<basename(1)>. It does B<NOT> 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<fileparse()>.
C<basename()> returns the last level of a filepath even if the last
level is clearly directory. In effect, it is acting like C<pop()> for
paths. This differs from C<fileparse()>'s behaviour.
# Both return "bar"
basename("/foo/bar");
basename("/foo/bar/");
@suffixes work as in C<fileparse()> 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<basename()> 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<dirname>
X<dirname>
This function is provided for compatibility with the Unix shell
command C<dirname(1)> and has inherited some of its quirks. In spite of
its name it does B<NOT> always return the directory name as you might
expect. To be safe, if you want the directory name of a path use
C<fileparse()>.
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<dirname()> work like C<fileparse($path)>, returning just the
$directories.
# On VMS and AmigaOS
my $directories = dirname($path);
When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function
which is subtly different from how C<fileparse()> 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<chop()> for file paths.
Also unlike C<fileparse()>, C<dirname()> 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<fileparse_set_fstype>
X<filesystem>
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<dirname(1)>, L<basename(1)>, L<File::Spec>

190
testsuite/input-files/perllib/File/Glob.pm Normal file
View file

@ -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__

895
testsuite/input-files/perllib/File/Path.pm Normal file
View file

@ -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<make_path> function creates the given directories if they don't
exists before, much like the Unix command C<mkdir -p>.
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<umask>. If the
directory already exists (and thus does not need to be created),
the permissions will not be modified.
C<mask> is recognised as an alias for this parameter.
=item verbose => $bool
If present, will cause C<make_path> 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</"ERROR
HANDLING"> 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<eval> 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<remove_tree> function deletes the given directories and any
files and subdirectories they might contain, much like the Unix
command C<rm -r> or C<del /s> 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<remove_tree> 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<remove_tree> 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<verbose> 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</"ERROR
HANDLING"> section for more information.
Removing things is a much more dangerous proposition than
creating things. As such, there are certain conditions that
C<remove_tree> may encounter that are so dangerous that the only
sane action left is to kill the program.
Use C<error> 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<NOTE:>
The following error handling mechanism is considered
experimental and is subject to change pending feedback from
users.
=back
If C<make_path> or C<remove_tree> encounter an error, a diagnostic
message will be printed to C<STDERR> via C<carp> (for non-fatal
errors), or via C<croak> (for fatal errors).
If this behaviour is not desirable, the C<error> 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<File::Path> blindly exports C<mkpath> and C<rmtree> 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<make_path> and C<remove_tree> are B<not> 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<mkpath> and C<rmtree>
are no longer exported at all. This is due to the way the C<Exporter>
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<rmtree> 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<safe> parameter is set (or the
third parameter in the traditional interface is TRUE), should a
C<remove_tree> 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<croak>), since the
problem is so severe that it would be dangerous to continue. (This
can always be trapped with C<eval>, 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 C<carp>ed about. Program execution will not be halted.
=over 4
=item mkdir [path]: [errmsg] (SEVERE)
C<make_path> 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<make_path> 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<make_path> 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<remove_tree> attempted to determine the initial directory by calling
C<Cwd::getcwd>, but the call failed for some reason. No attempt
will be made to delete anything.
=item cannot stat initial working directory: [errmsg]
C<remove_tree> attempted to stat the initial directory (after having
successfully obtained its name via C<getcwd>), however, the call
failed for some reason. No attempt will be made to delete anything.
=item cannot chdir to [dir]: [errmsg]
C<remove_tree> 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<remove_tree> recorded the device and inode of a directory, and then
moved into it. It then performed a C<stat> 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<remove_tree> 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<remove_tree> 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<remove_tree>, 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</some/path/to/here>
and you are attempting to remove an ancestor, such as F</some/path>.
The directory tree is left untouched.
The solution is to C<chdir> 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<remove_tree>, 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<remove_tree> 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<croak>.
=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
When C<remove_tree> 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<remove_tree> 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<remove_tree> 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<remove_tree> 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<remove_tree> 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<remove_tree> 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<remove_tree> 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<File::Remove>
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<File::Path>.
=item *
L<File::Find::Rule>
When removing directory trees, if you want to examine each file to
decide whether to delete it (and possibly leaving large swathes
alone), F<File::Find::Rule> offers a convenient and flexible approach
to examining directory trees.
=back
=head1 BUGS
Please report all bugs on the RT queue:
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
=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
<F<david@landgren.net>>.
=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

27
testsuite/input-files/perllib/File/Spec.pm Normal file
View file

@ -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__

269
testsuite/input-files/perllib/File/Spec/Unix.pm Normal file
View file

@ -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;

2452
testsuite/input-files/perllib/File/Temp.pm Normal file
View file

File diff suppressed because it is too large Load diff

105
testsuite/input-files/perllib/FileHandle.pm Normal file
View file

@ -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__

2504
testsuite/input-files/perllib/Getopt/Long.pm Normal file
View file

File diff suppressed because it is too large Load diff

28
testsuite/input-files/perllib/IO.pm Normal file
View file

@ -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__

82
testsuite/input-files/perllib/IO/File.pm Normal file
View file

@ -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;

376
testsuite/input-files/perllib/IO/Handle.pm Normal file
View file

@ -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/^w(\+?)$/$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;

36
testsuite/input-files/perllib/IO/Seekable.pm Normal file
View file

@ -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 POSIX; use IO::File;> :-(
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;

274
testsuite/input-files/perllib/IPC/Open3.pm Normal file
View file

@ -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 <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
# 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 <perl@adamspiers.org>
#
# $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

233
testsuite/input-files/perllib/List/Util.pm Normal file
View file

@ -0,0 +1,233 @@
# List::Util.pm
#
# Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. 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<List::Util> 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<List::Util> does not export any subroutines. The
subroutines defined are
=over 4
=item first BLOCK LIST
Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
of LIST in turn. C<first> returns the first element where the result from
BLOCK is a true value. If BLOCK never returns true or LIST was empty then
C<undef> 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<reduce> 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<undef> 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<reduce> like this
$foo = reduce { $a > $b ? $a : $b } 1..10
=item maxstr LIST
Similar to C<max>, but treats all the entries in the list as strings
and returns the highest string as defined by the C<gt> operator.
If the list is empty then C<undef> is returned.
$foo = maxstr 'A'..'Z' # 'Z'
$foo = maxstr "hello","world" # "world"
$foo = maxstr @bar, @baz # whatever
This function could be implemented using C<reduce> like this
$foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
=item min LIST
Similar to C<max> but returns the entry in the list with the lowest
numerical value. If the list is empty then C<undef> 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<reduce> like this
$foo = reduce { $a < $b ? $a : $b } 1..10
=item minstr LIST
Similar to C<min>, but treats all the entries in the list as strings
and returns the lowest string as defined by the C<lt> operator.
If the list is empty then C<undef> is returned.
$foo = minstr 'A'..'Z' # 'A'
$foo = minstr "hello","world" # "hello"
$foo = minstr @bar, @baz # whatever
This function could be implemented using C<reduce> 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<undef> 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<reduce> produce an identity value, then
make sure that you always pass that identity value as the first argument to prevent
C<undef> 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<undef> 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<reduce> like this
$foo = reduce { $a + $b } 1..10
If your algorithm requires that C<sum> produce an identity of 0, then
make sure that you always pass C<0> as the first argument to prevent
C<undef> 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<Scalar::Util>, L<List::MoreUtils>
=head1 COPYRIGHT
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

77
testsuite/input-files/perllib/POSIX.pm Normal file
View file

@ -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;

283
testsuite/input-files/perllib/Scalar/Util.pm Normal file
View file

@ -0,0 +1,283 @@
# Scalar::Util.pm
#
# Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. 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<Scalar::Util> 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<Scalar::Util> 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<undef> 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<NOTE>: 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<perlapi/looks_like_number>.
=item openhandle FH
Returns FH if FH may be used as a filehandle and is open, or FH is a tied
handle. Otherwise C<undef> 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<undef> 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<undef> 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<grep()>, 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<isweak> or C<weaken> 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<isvstring> you will need to use a newer release of perl.
=item C<NAME> is only available with the XS version of Scalar::Util
C<Scalar::Util> 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<List::Util>
=head1 COPYRIGHT
Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. 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 <lukka@iki.fi>. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as perl itself.
=cut

22
testsuite/input-files/perllib/SelectSaver.pm Normal file
View file

@ -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;

91
testsuite/input-files/perllib/Symbol.pm Normal file
View file

@ -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;

74
testsuite/input-files/perllib/Tie/Hash.pm Normal file
View file

@ -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;

117
testsuite/input-files/perllib/XSLoader.pm Normal file
View file

@ -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__

BIN
testsuite/input-files/perllib/auto/Cwd/Cwd.so Normal file
View file

Binary file not shown.

BIN
testsuite/input-files/perllib/auto/Fcntl/Fcntl.so Normal file
View file

Binary file not shown.

BIN
testsuite/input-files/perllib/auto/File/Glob/Glob.so Normal file
View file

Binary file not shown.

BIN
testsuite/input-files/perllib/auto/IO/IO.so Normal file
View file

Binary file not shown.

BIN
testsuite/input-files/perllib/auto/List/Util/Util.so Normal file
View file

Binary file not shown.

BIN
testsuite/input-files/perllib/auto/POSIX/POSIX.so Normal file
View file

Binary file not shown.

173
testsuite/input-files/perllib/auto/POSIX/autosplit.ix Normal file
View file

@ -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;

230
testsuite/input-files/perllib/auto/POSIX/load_imports.al Normal file
View file

@ -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;

181
testsuite/input-files/perllib/base.pm Normal file
View file

@ -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(<<ERROR);
Base class package "$base" is empty.
(Perhaps you need to 'use' the module which defines that package first,
or make that module available in \@INC (\@INC contains: @INC).
ERROR
}
$sigdie = $SIG{__DIE__} || undef;
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
${$base.'::VERSION'} = "-1, set by base.pm"
unless defined ${$base.'::VERSION'};
}
push @bases, $base;
if ( has_fields($base) || has_attr($base) ) {
# No multiple fields inheritance *suck*
if ($fields_base) {
require Carp;
Carp::croak("Can't multiply inherit fields");
} else {
$fields_base = $base;
}
}
}
# Save this until the end so it's all or nothing if the above loop croaks.
push @{"$inheritor\::ISA"}, @isa_classes;
push @{"$inheritor\::ISA"}, @bases;
if( defined $fields_base ) {
inherit_fields($inheritor, $fields_base);
}
}
sub inherit_fields {
my($derived, $base) = @_;
return SUCCESS unless $base;
my $battr = get_attr($base);
my $dattr = get_attr($derived);
my $dfields = get_fields($derived);
my $bfields = get_fields($base);
$dattr->[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__

130
testsuite/input-files/perllib/constant.pm Normal file
View file

@ -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__

178
testsuite/input-files/perllib/overload.pm Normal file
View file

@ -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<ref $_[1] eq "CODE"> above as code references can be
# blessed, and C<ref> 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__

182
testsuite/input-files/perllib/re.pm Normal file
View file

@ -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__

46
testsuite/input-files/perllib/strict.pm Normal file
View file

@ -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__

40
testsuite/input-files/perllib/subs.pm Normal file
View file

@ -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<use vars> and
C<use subs> 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<no vars> or C<no subs>.
See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
=cut
require 5.000;
sub import {
my $callpack = caller;
my $pack = shift;
my @imports = @_;
foreach $sym (@imports) {
*{"${callpack}::$sym"} = \&{"${callpack}::$sym"};
}
};
1;

48
testsuite/input-files/perllib/vars.pm Normal file
View file

@ -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__

379
testsuite/input-files/perllib/warnings.pm Normal file
View file

@ -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:

32
testsuite/input-files/perllib/warnings/register.pm Normal file
View file

@ -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;

11
testsuite/tests-to-run/test38.sh Executable file
View file

@ -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

4
testsuite/wanted-results/test38 Normal file
View file

@ -0,0 +1,4 @@
### Test with old perl libs
### See if we get compile error
perl
### See if we read modules outside perllib