mirror of
https://git.savannah.gnu.org/git/parallel.git
synced 2024-11-25 07:27:55 +00:00
testsuite for 2GB issues on some Perl versions.
Memory heavy jobs (>2 GB) moved to parallel-local-mem.sh. Passes testsuite.
This commit is contained in:
Ole Tange
parent
9c73947d9f
commit
4ef66ec7f6
|
|
@ -1052,7 +1052,7 @@ sub parse_options {
|
|||
|
||||
sub init_globals {
|
||||
# Defaults:
|
||||
$Global::version = 20150305;
|
||||
$Global::version = 20150306;
|
||||
$Global::progname = 'parallel';
|
||||
$Global::infinity = 2**31;
|
||||
$Global::debug = 0;
|
||||
|
|
|
|||
|
|
@ -82,3 +82,11 @@ timings: tests-to-run/* ../src/parallel
|
|||
stdout bash -x /tmp/timing.script | tee /tmp/timing.out
|
||||
echo + .usr.bin.time_END >>/tmp/timing.out
|
||||
perl -ne '/\+ .usr.bin.time/ and do { print $$last.$$h; $$h=$$_ }; chomp; s/.*\0//;$$last = $$_' /tmp/timing.out |sort -n >timings
|
||||
|
||||
timingbar:
|
||||
vmstat 1 | timestamp --iso > vmstat.timestamp.1 &
|
||||
stdout make 1 | timestamp --iso | tee make.timestamp.1
|
||||
killall vmstat
|
||||
mv vmstat.timestamp.1 vmstat.timestamp
|
||||
mv make.timestamp.1 make.timestamp
|
||||
sort vmstat.timestamp make.timestamp | perl -pe '/tests-to-run(\S+)/ and $$p=$$1; print "$$p "' | field 6,1,2 | perl -ne '/^\d+ / and print' | histogram -i vh
|
||||
|
|
|
|||
429
testsuite/input-files/perl-v5.14.2/lib/AutoLoader.pm
Normal file
429
testsuite/input-files/perl-v5.14.2/lib/AutoLoader.pm
Normal file
|
|
@ -0,0 +1,429 @@
|
|||
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.71';
|
||||
}
|
||||
|
||||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
AutoLoader - load subroutines only on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo;
|
||||
use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
|
||||
|
||||
package Bar;
|
||||
use AutoLoader; # don't import AUTOLOAD, define our own
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
$AutoLoader::AUTOLOAD = "...";
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<AutoLoader> module works with the B<AutoSplit> module and the
|
||||
C<__END__> token to defer the loading of some subroutines until they are
|
||||
used rather than loading them all at once.
|
||||
|
||||
To use B<AutoLoader>, the author of a module has to place the
|
||||
definitions of subroutines to be autoloaded after an C<__END__> token.
|
||||
(See L<perldata>.) The B<AutoSplit> module can then be run manually to
|
||||
extract the definitions into individual files F<auto/funcname.al>.
|
||||
|
||||
B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
|
||||
subroutine in is called in a client module of B<AutoLoader>,
|
||||
B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
|
||||
file with a name related to the location of the file from which the
|
||||
client module was read. As an example, if F<POSIX.pm> is located in
|
||||
F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
|
||||
subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
|
||||
the C<.al> file has the same name as the subroutine, sans package. If
|
||||
such a file exists, AUTOLOAD will read and evaluate it,
|
||||
thus (presumably) defining the needed subroutine. AUTOLOAD will then
|
||||
C<goto> the newly defined subroutine.
|
||||
|
||||
Once this process completes for a given function, it is defined, so
|
||||
future calls to the subroutine will bypass the AUTOLOAD mechanism.
|
||||
|
||||
=head2 Subroutine Stubs
|
||||
|
||||
In order for object method lookup and/or prototype checking to operate
|
||||
correctly even when methods have not yet been defined it is necessary to
|
||||
"forward declare" each subroutine (as in C<sub NAME;>). See
|
||||
L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
|
||||
stubs", which are place holders with no code.
|
||||
|
||||
The AutoSplit and B<AutoLoader> modules automate the creation of forward
|
||||
declarations. The AutoSplit module creates an 'index' file containing
|
||||
forward declarations of all the AutoSplit subroutines. When the
|
||||
AutoLoader module is 'use'd it loads these declarations into its callers
|
||||
package.
|
||||
|
||||
Because of this mechanism it is important that B<AutoLoader> is always
|
||||
C<use>d and not C<require>d.
|
||||
|
||||
=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
|
||||
explicitly import it:
|
||||
|
||||
use AutoLoader 'AUTOLOAD';
|
||||
|
||||
=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
|
||||
|
||||
Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
|
||||
They typically need to check for some special cases (such as constants)
|
||||
and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
|
||||
|
||||
Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
|
||||
Instead, they should define their own AUTOLOAD subroutines along these
|
||||
lines:
|
||||
|
||||
use AutoLoader;
|
||||
use Carp;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $sub = $AUTOLOAD;
|
||||
(my $constname = $sub) =~ s/.*:://;
|
||||
my $val = constant($constname, @_ ? $_[0] : 0);
|
||||
if ($! != 0) {
|
||||
if ($! =~ /Invalid/ || $!{EINVAL}) {
|
||||
$AutoLoader::AUTOLOAD = $sub;
|
||||
goto &AutoLoader::AUTOLOAD;
|
||||
}
|
||||
else {
|
||||
croak "Your vendor has not defined constant $constname";
|
||||
}
|
||||
}
|
||||
*$sub = sub { $val }; # same as: eval "sub $sub { $val }";
|
||||
goto &$sub;
|
||||
}
|
||||
|
||||
If any module's own AUTOLOAD subroutine has no need to fallback to the
|
||||
AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
|
||||
subroutines), then that module should not use B<AutoLoader> at all.
|
||||
|
||||
=head2 Package Lexicals
|
||||
|
||||
Package lexicals declared with C<my> in the main block of a package
|
||||
using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
|
||||
the fact that the given scope ends at the C<__END__> marker. A module
|
||||
using such variables as package globals will not work properly under the
|
||||
B<AutoLoader>.
|
||||
|
||||
The C<vars> pragma (see L<perlmod/"vars">) may be used in such
|
||||
situations as an alternative to explicitly qualifying all globals with
|
||||
the package namespace. Variables pre-declared with this pragma will be
|
||||
visible to any autoloaded routines (but will not be invisible outside
|
||||
the package, unfortunately).
|
||||
|
||||
=head2 Not Using AutoLoader
|
||||
|
||||
You can stop using AutoLoader by simply
|
||||
|
||||
no AutoLoader;
|
||||
|
||||
=head2 B<AutoLoader> vs. B<SelfLoader>
|
||||
|
||||
The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
|
||||
loading of subroutines.
|
||||
|
||||
B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
|
||||
While this avoids the use of a hierarchy of disk files and the
|
||||
associated open/close for each routine loaded, B<SelfLoader> suffers a
|
||||
startup speed disadvantage in the one-time parsing of the lines after
|
||||
C<__DATA__>, after which routines are cached. B<SelfLoader> can also
|
||||
handle multiple packages in a file.
|
||||
|
||||
B<AutoLoader> only reads code as it is requested, and in many cases
|
||||
should be faster, but requires a mechanism like B<AutoSplit> be used to
|
||||
create the individual files. L<ExtUtils::MakeMaker> will invoke
|
||||
B<AutoSplit> automatically if B<AutoLoader> is used in a module source
|
||||
file.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
|
||||
old modules which use B<AutoLoader> should be changed to the new calling
|
||||
style. Typically this just means changing a require to a use, adding
|
||||
the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
|
||||
from C<@ISA>.
|
||||
|
||||
On systems with restrictions on file name length, the file corresponding
|
||||
to a subroutine may have a shorter name that the routine itself. This
|
||||
can lead to conflicting file names. The I<AutoSplit> package warns of
|
||||
these potential conflicts when used to split a module.
|
||||
|
||||
AutoLoader may fail to find the autosplit files (or even find the wrong
|
||||
ones) in cases where C<@INC> contains relative paths, B<and> the program
|
||||
does C<chdir>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<SelfLoader> - an autoloader that doesn't use external files.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
C<AutoLoader> is maintained by the perl5-porters. Please direct
|
||||
any questions to the canonical mailing list. Anything that
|
||||
is applicable to the CPAN release can be sent to its maintainer,
|
||||
though.
|
||||
|
||||
Author and Maintainer: The Perl5-Porters <perl5-porters@perl.org>
|
||||
|
||||
Maintainer of the CPAN release: Steffen Mueller <smueller@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This package has been part of the perl core since the first release
|
||||
of perl5. It has been released separately to CPAN so older installations
|
||||
can benefit from bug fixes.
|
||||
|
||||
This package has the same copyright and license as the perl core:
|
||||
|
||||
Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
|
||||
2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
|
||||
by Larry Wall and others
|
||||
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of either:
|
||||
|
||||
a) the GNU General Public License as published by the Free
|
||||
Software Foundation; either version 1, or (at your option) any
|
||||
later version, or
|
||||
|
||||
b) the "Artistic License" which comes with this Kit.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
|
||||
the GNU General Public License or the Artistic License for more details.
|
||||
|
||||
You should have received a copy of the Artistic License with this
|
||||
Kit, in the file named "Artistic". If not, I'll be glad to provide one.
|
||||
|
||||
You should also have received a copy of the GNU General Public License
|
||||
along with this program in the file named "Copying". If not, write to the
|
||||
Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
|
||||
02111-1307, USA or visit their web page on the internet at
|
||||
http://www.gnu.org/copyleft/gpl.html.
|
||||
|
||||
For those of you that choose to use the GNU General Public License,
|
||||
my interpretation of the GNU General Public License is that no Perl
|
||||
script falls under the terms of the GPL unless you explicitly put
|
||||
said script under the terms of the GPL yourself. Furthermore, any
|
||||
object code linked with perl does not automatically fall under the
|
||||
terms of the GPL, provided such object code only adds definitions
|
||||
of subroutines and variables, and does not otherwise impair the
|
||||
resulting interpreter from executing any standard Perl script. I
|
||||
consider linking in C subroutines in this manner to be the moral
|
||||
equivalent of defining subroutines in the Perl language itself. You
|
||||
may sell such an object file as proprietary provided that you provide
|
||||
or offer to provide the Perl source, as specified by the GNU General
|
||||
Public License. (This is merely an alternate way of specifying input
|
||||
to the program.) You may also sell a binary produced by the dumping of
|
||||
a running Perl script that belongs to you, provided that you provide or
|
||||
offer to provide the Perl source as specified by the GPL. (The
|
||||
fact that a Perl interpreter and your code are in the same binary file
|
||||
is, in this case, a form of mere aggregation.) This is my interpretation
|
||||
of the GPL. If you still have concerns or difficulties understanding
|
||||
my intent, feel free to contact me. Of course, the Artistic License
|
||||
spells all this out for your protection, so you may prefer to use that.
|
||||
|
||||
=cut
|
||||
578
testsuite/input-files/perl-v5.14.2/lib/Carp.pm
Normal file
578
testsuite/input-files/perl-v5.14.2/lib/Carp.pm
Normal file
|
|
@ -0,0 +1,578 @@
|
|||
package Carp;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.20';
|
||||
|
||||
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
|
||||
|
||||
# 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.
|
||||
|
||||
our %CarpInternal;
|
||||
our %Internal;
|
||||
|
||||
# disable these by default, so they can live w/o require Carp
|
||||
$CarpInternal{Carp}++;
|
||||
$CarpInternal{warnings}++;
|
||||
$Internal{Exporter}++;
|
||||
$Internal{'Exporter::Heavy'}++;
|
||||
|
||||
# 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'; @_ }
|
||||
|
||||
sub _cgc {
|
||||
no strict 'refs';
|
||||
return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
|
||||
return;
|
||||
}
|
||||
|
||||
sub longmess {
|
||||
# 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 $cgc = _cgc();
|
||||
my $call_pack = $cgc ? $cgc->() : caller();
|
||||
if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
|
||||
return longmess_heavy(@_);
|
||||
}
|
||||
else {
|
||||
local $CarpLevel = $CarpLevel + 1;
|
||||
return longmess_heavy(@_);
|
||||
}
|
||||
}
|
||||
|
||||
our @CARP_NOT;
|
||||
|
||||
sub shortmess {
|
||||
my $cgc = _cgc();
|
||||
|
||||
# Icky backwards compatibility wrapper. :-(
|
||||
local @CARP_NOT = $cgc ? $cgc->() : caller();
|
||||
shortmess_heavy(@_);
|
||||
}
|
||||
|
||||
sub croak { die shortmess @_ }
|
||||
sub confess { die longmess @_ }
|
||||
sub carp { warn shortmess @_ }
|
||||
sub cluck { warn longmess @_ }
|
||||
|
||||
sub caller_info {
|
||||
my $i = shift(@_) + 1;
|
||||
my %call_info;
|
||||
my $cgc = _cgc();
|
||||
{
|
||||
package DB;
|
||||
@DB::args = \$i; # A sentinel, which no-one else has the address of
|
||||
@call_info{
|
||||
qw(pack file line sub has_args wantarray evaltext is_require) }
|
||||
= $cgc ? $cgc->($i) : caller($i);
|
||||
}
|
||||
|
||||
unless ( defined $call_info{pack} ) {
|
||||
return ();
|
||||
}
|
||||
|
||||
my $sub_name = Carp::get_subname( \%call_info );
|
||||
if ( $call_info{has_args} ) {
|
||||
my @args;
|
||||
if ( @DB::args == 1
|
||||
&& ref $DB::args[0] eq ref \$i
|
||||
&& $DB::args[0] == \$i ) {
|
||||
@DB::args = (); # Don't let anyone see the address of $i
|
||||
local $@;
|
||||
my $where = eval {
|
||||
my $func = $cgc or return '';
|
||||
my $gv = B::svref_2object($func)->GV;
|
||||
my $package = $gv->STASH->NAME;
|
||||
my $subname = $gv->NAME;
|
||||
return unless defined $package && defined $subname;
|
||||
|
||||
# returning CORE::GLOBAL::caller isn't useful for tracing the cause:
|
||||
return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
|
||||
" in &${package}::$subname";
|
||||
} // '';
|
||||
@args
|
||||
= "** Incomplete caller override detected$where; \@DB::args were not set **";
|
||||
}
|
||||
else {
|
||||
@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 =~ /^-?[0-9.]+\z/;
|
||||
} # 0-9, not \d, as \d will try to
|
||||
else { # load Unicode tables
|
||||
$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;
|
||||
{
|
||||
++$i;
|
||||
my $cgc = _cgc();
|
||||
my $pkg = $cgc ? $cgc->($i) : 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 $cgc = _cgc();
|
||||
my $called = $cgc ? $cgc->($i) : caller($i);
|
||||
$i++;
|
||||
my $caller = $cgc ? $cgc->($i) : 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;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Carp - alternative warn and die for modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Carp;
|
||||
|
||||
# warn user (from perspective of caller)
|
||||
carp "string trimmed to 80 chars";
|
||||
|
||||
# die of errors (from perspective of caller)
|
||||
croak "We're outta here!";
|
||||
|
||||
# die of errors with stack backtrace
|
||||
confess "not implemented";
|
||||
|
||||
# cluck not exported by default
|
||||
use Carp qw(cluck);
|
||||
cluck "This is how we got here!";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The Carp routines are useful in your own modules because
|
||||
they act like die() or warn(), but with a message which is more
|
||||
likely to be useful to a user of your module. In the case of
|
||||
cluck, confess, and longmess that context is a summary of every
|
||||
call in the call-stack. For a shorter message you can use C<carp>
|
||||
or C<croak> which report the error as being from where your module
|
||||
was called. There is no guarantee that that is where the error
|
||||
was, but it is a good educated guess.
|
||||
|
||||
You can also alter the way the output and logic of C<Carp> works, by
|
||||
changing some global variables in the C<Carp> namespace. See the
|
||||
section on C<GLOBAL VARIABLES> below.
|
||||
|
||||
Here is a more complete description of how C<carp> and C<croak> work.
|
||||
What they do is search the call-stack for a function call stack where
|
||||
they have not been told that there shouldn't be an error. If every
|
||||
call is marked safe, they give up and give a full stack backtrace
|
||||
instead. In other words they presume that the first likely looking
|
||||
potential suspect is guilty. Their rules for telling whether
|
||||
a call shouldn't generate errors work as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Any call from a package to itself is safe.
|
||||
|
||||
=item 2.
|
||||
|
||||
Packages claim that there won't be errors on calls to or from
|
||||
packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
|
||||
(if that array is empty) C<@ISA>. The ability to override what
|
||||
@ISA says is new in 5.8.
|
||||
|
||||
=item 3.
|
||||
|
||||
The trust in item 2 is transitive. If A trusts B, and B
|
||||
trusts C, then A trusts C. So if you do not override C<@ISA>
|
||||
with C<@CARP_NOT>, then this trust relationship is identical to,
|
||||
"inherits from".
|
||||
|
||||
=item 4.
|
||||
|
||||
Any call from an internal Perl module is safe. (Nothing keeps
|
||||
user modules from marking themselves as internal to Perl, but
|
||||
this practice is discouraged.)
|
||||
|
||||
=item 5.
|
||||
|
||||
Any call to Perl's warning system (eg Carp itself) is safe.
|
||||
(This rule is what keeps it from reporting the error at the
|
||||
point where you call C<carp> or C<croak>.)
|
||||
|
||||
=item 6.
|
||||
|
||||
C<$Carp::CarpLevel> can be set to skip a fixed number of additional
|
||||
call levels. Using this is not recommended because it is very
|
||||
difficult to get it to behave correctly.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Forcing a Stack Trace
|
||||
|
||||
As a debugging aid, you can force Carp to treat a croak as a confess
|
||||
and a carp as a cluck across I<all> modules. In other words, force a
|
||||
detailed stack trace to be given. This can be very helpful when trying
|
||||
to understand why, or from where, a warning or error is being generated.
|
||||
|
||||
This feature is enabled by 'importing' the non-existent symbol
|
||||
'verbose'. You would typically enable it by saying
|
||||
|
||||
perl -MCarp=verbose script.pl
|
||||
|
||||
or by including the string C<-MCarp=verbose> in the PERL5OPT
|
||||
environment variable.
|
||||
|
||||
Alternately, you can set the global variable C<$Carp::Verbose> to true.
|
||||
See the C<GLOBAL VARIABLES> section below.
|
||||
|
||||
=head1 GLOBAL VARIABLES
|
||||
|
||||
=head2 $Carp::MaxEvalLen
|
||||
|
||||
This variable determines how many characters of a string-eval are to
|
||||
be shown in the output. Use a value of C<0> to show all text.
|
||||
|
||||
Defaults to C<0>.
|
||||
|
||||
=head2 $Carp::MaxArgLen
|
||||
|
||||
This variable determines how many characters of each argument to a
|
||||
function to print. Use a value of C<0> to show the full length of the
|
||||
argument.
|
||||
|
||||
Defaults to C<64>.
|
||||
|
||||
=head2 $Carp::MaxArgNums
|
||||
|
||||
This variable determines how many arguments to each function to show.
|
||||
Use a value of C<0> to show all arguments to a function call.
|
||||
|
||||
Defaults to C<8>.
|
||||
|
||||
=head2 $Carp::Verbose
|
||||
|
||||
This variable makes C<carp> and C<croak> generate stack backtraces
|
||||
just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'>
|
||||
is implemented internally.
|
||||
|
||||
Defaults to C<0>.
|
||||
|
||||
=head2 @CARP_NOT
|
||||
|
||||
This variable, I<in your package>, says which packages are I<not> to be
|
||||
considered as the location of an error. The C<carp()> and C<cluck()>
|
||||
functions will skip over callers when reporting where an error occurred.
|
||||
|
||||
NB: This variable must be in the package's symbol table, thus:
|
||||
|
||||
# These work
|
||||
our @CARP_NOT; # file scope
|
||||
use vars qw(@CARP_NOT); # package scope
|
||||
@My::Package::CARP_NOT = ... ; # explicit package variable
|
||||
|
||||
# These don't work
|
||||
sub xyz { ... @CARP_NOT = ... } # w/o declarations above
|
||||
my @CARP_NOT; # even at top-level
|
||||
|
||||
Example of use:
|
||||
|
||||
package My::Carping::Package;
|
||||
use Carp;
|
||||
our @CARP_NOT;
|
||||
sub bar { .... or _error('Wrong input') }
|
||||
sub _error {
|
||||
# temporary control of where'ness, __PACKAGE__ is implicit
|
||||
local @CARP_NOT = qw(My::Friendly::Caller);
|
||||
carp(@_)
|
||||
}
|
||||
|
||||
This would make C<Carp> report the error as coming from a caller not
|
||||
in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
|
||||
|
||||
Also read the L</DESCRIPTION> section above, about how C<Carp> decides
|
||||
where the error is reported from.
|
||||
|
||||
Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
|
||||
|
||||
Overrides C<Carp>'s use of C<@ISA>.
|
||||
|
||||
=head2 %Carp::Internal
|
||||
|
||||
This says what packages are internal to Perl. C<Carp> will never
|
||||
report an error as being from a line in a package that is internal to
|
||||
Perl. For example:
|
||||
|
||||
$Carp::Internal{ (__PACKAGE__) }++;
|
||||
# time passes...
|
||||
sub foo { ... or confess("whatever") };
|
||||
|
||||
would give a full stack backtrace starting from the first caller
|
||||
outside of __PACKAGE__. (Unless that package was also internal to
|
||||
Perl.)
|
||||
|
||||
=head2 %Carp::CarpInternal
|
||||
|
||||
This says which packages are internal to Perl's warning system. For
|
||||
generating a full stack backtrace this is the same as being internal
|
||||
to Perl, the stack backtrace will not start inside packages that are
|
||||
listed in C<%Carp::CarpInternal>. But it is slightly different for
|
||||
the summary message generated by C<carp> or C<croak>. There errors
|
||||
will not be reported on any lines that are calling packages in
|
||||
C<%Carp::CarpInternal>.
|
||||
|
||||
For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
|
||||
Therefore the full stack backtrace from C<confess> will not start
|
||||
inside of C<Carp>, and the short message from calling C<croak> is
|
||||
not placed on the line where C<croak> was called.
|
||||
|
||||
=head2 $Carp::CarpLevel
|
||||
|
||||
This variable determines how many additional call frames are to be
|
||||
skipped that would not otherwise be when reporting where an error
|
||||
occurred on a call to one of C<Carp>'s functions. It is fairly easy
|
||||
to count these call frames on calls that generate a full stack
|
||||
backtrace. However it is much harder to do this accounting for calls
|
||||
that generate a short message. Usually people skip too many call
|
||||
frames. If they are lucky they skip enough that C<Carp> goes all of
|
||||
the way through the call stack, realizes that something is wrong, and
|
||||
then generates a full stack backtrace. If they are unlucky then the
|
||||
error is reported from somewhere misleading very high in the call
|
||||
stack.
|
||||
|
||||
Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
|
||||
C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
|
||||
|
||||
Defaults to C<0>.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
The Carp routines don't handle exception objects currently.
|
||||
If called with a first argument that is a reference, they simply
|
||||
call die() or warn(), as appropriate.
|
||||
|
||||
10
testsuite/input-files/perl-v5.14.2/lib/Carp/Heavy.pm
Normal file
10
testsuite/input-files/perl-v5.14.2/lib/Carp/Heavy.pm
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
package Carp;
|
||||
|
||||
# On one line so MakeMaker will see it.
|
||||
use Carp; our $VERSION = $Carp::VERSION;
|
||||
|
||||
1;
|
||||
|
||||
# Most of the machinery of Carp used to be there.
|
||||
# It has been moved in Carp.pm now, but this placeholder remains for
|
||||
# the benefit of modules that like to preload Carp::Heavy directly.
|
||||
110
testsuite/input-files/perl-v5.14.2/lib/Config.pm
Normal file
110
testsuite/input-files/perl-v5.14.2/lib/Config.pm
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
# This file was created by configpm when Perl was built. Any changes
|
||||
# made to this file will be lost the next time perl is built.
|
||||
|
||||
# for a description of the variables, please have a look at the
|
||||
# Glossary file, as written in the Porting folder, or use the url:
|
||||
# http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
|
||||
|
||||
package Config;
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars '%Config';
|
||||
|
||||
# Skip @Config::EXPORT because it only contains %Config, which we special
|
||||
# case below as it's not a function. @Config::EXPORT won't change in the
|
||||
# lifetime of Perl 5.
|
||||
my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
|
||||
config_re => 1, compile_date => 1, local_patches => 1,
|
||||
bincompat_options => 1, non_bincompat_options => 1,
|
||||
header_files => 1);
|
||||
|
||||
@Config::EXPORT = qw(%Config);
|
||||
@Config::EXPORT_OK = keys %Export_Cache;
|
||||
|
||||
# Need to stub all the functions to make code such as print Config::config_sh
|
||||
# keep working
|
||||
|
||||
sub bincompat_options;
|
||||
sub compile_date;
|
||||
sub config_re;
|
||||
sub config_sh;
|
||||
sub config_vars;
|
||||
sub header_files;
|
||||
sub local_patches;
|
||||
sub myconfig;
|
||||
sub non_bincompat_options;
|
||||
|
||||
# Define our own import method to avoid pulling in the full Exporter:
|
||||
sub import {
|
||||
shift;
|
||||
@_ = @Config::EXPORT unless @_;
|
||||
|
||||
my @funcs = grep $_ ne '%Config', @_;
|
||||
my $export_Config = @funcs < @_ ? 1 : 0;
|
||||
|
||||
no strict 'refs';
|
||||
my $callpkg = caller(0);
|
||||
foreach my $func (@funcs) {
|
||||
die qq{"$func" is not exported by the Config module\n}
|
||||
unless $Export_Cache{$func};
|
||||
*{$callpkg.'::'.$func} = \&{$func};
|
||||
}
|
||||
|
||||
*{"$callpkg\::Config"} = \%Config if $export_Config;
|
||||
return;
|
||||
}
|
||||
|
||||
die "Perl lib version (5.14.2) doesn't match executable '$0' version ($])"
|
||||
unless $^V;
|
||||
|
||||
$^V eq 5.14.2
|
||||
or die "Perl lib version (5.14.2) doesn't match executable '$0' version (" .
|
||||
sprintf("v%vd",$^V) . ")";
|
||||
|
||||
|
||||
sub FETCH {
|
||||
my($self, $key) = @_;
|
||||
|
||||
# check for cached value (which may be undef so we use exists not defined)
|
||||
return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
|
||||
}
|
||||
|
||||
sub TIEHASH {
|
||||
bless $_[1], $_[0];
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub AUTOLOAD {
|
||||
require 'Config_heavy.pl';
|
||||
goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
|
||||
die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
|
||||
}
|
||||
|
||||
# tie returns the object, so the value returned to require will be true.
|
||||
tie %Config, 'Config', {
|
||||
archlibexp => '/usr/local/lib/perl5/5.14.2/x86_64-linux',
|
||||
archname => 'x86_64-linux',
|
||||
cc => 'cc',
|
||||
d_readlink => 'define',
|
||||
d_symlink => 'define',
|
||||
dlext => 'so',
|
||||
dlsrc => 'dl_dlopen.xs',
|
||||
dont_use_nlink => undef,
|
||||
exe_ext => '',
|
||||
inc_version_list => ' ',
|
||||
intsize => '4',
|
||||
ldlibpthname => 'LD_LIBRARY_PATH',
|
||||
libpth => '/usr/local/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib /usr/lib',
|
||||
osname => 'linux',
|
||||
osvers => '3.13.0-43-lowlatency',
|
||||
path_sep => ':',
|
||||
privlibexp => '/usr/local/lib/perl5/5.14.2',
|
||||
scriptdir => '/usr/local/bin',
|
||||
sitearchexp => '/usr/local/lib/perl5/site_perl/5.14.2/x86_64-linux',
|
||||
sitelibexp => '/usr/local/lib/perl5/site_perl/5.14.2',
|
||||
so => 'so',
|
||||
useithreads => undef,
|
||||
usevendorprefix => undef,
|
||||
version => '5.14.2',
|
||||
};
|
||||
831
testsuite/input-files/perl-v5.14.2/lib/Cwd.pm
Normal file
831
testsuite/input-files/perl-v5.14.2/lib/Cwd.pm
Normal file
|
|
@ -0,0 +1,831 @@
|
|||
package Cwd;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Cwd - get pathname of current working directory
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Cwd;
|
||||
my $dir = getcwd;
|
||||
|
||||
use Cwd 'abs_path';
|
||||
my $abs_path = abs_path($file);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides functions for determining the pathname of the
|
||||
current working directory. It is recommended that getcwd (or another
|
||||
*cwd() function) be used in I<all> code to ensure portability.
|
||||
|
||||
By default, it exports the functions cwd(), getcwd(), fastcwd(), and
|
||||
fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
|
||||
|
||||
|
||||
=head2 getcwd and friends
|
||||
|
||||
Each of these functions are called without arguments and return the
|
||||
absolute path of the current working directory.
|
||||
|
||||
=over 4
|
||||
|
||||
=item getcwd
|
||||
|
||||
my $cwd = getcwd();
|
||||
|
||||
Returns the current working directory.
|
||||
|
||||
Exposes the POSIX function getcwd(3) or re-implements it if it's not
|
||||
available.
|
||||
|
||||
=item cwd
|
||||
|
||||
my $cwd = cwd();
|
||||
|
||||
The cwd() is the most natural form for the current architecture. For
|
||||
most systems it is identical to `pwd` (but without the trailing line
|
||||
terminator).
|
||||
|
||||
=item fastcwd
|
||||
|
||||
my $cwd = fastcwd();
|
||||
|
||||
A more dangerous version of getcwd(), but potentially faster.
|
||||
|
||||
It might conceivably chdir() you out of a directory that it can't
|
||||
chdir() you back into. If fastcwd encounters a problem it will return
|
||||
undef but will probably leave you in a different directory. For a
|
||||
measure of extra security, if everything appears to have worked, the
|
||||
fastcwd() function will check that it leaves you in the same directory
|
||||
that it started in. If it has changed it will C<die> with the message
|
||||
"Unstable directory path, current directory changed
|
||||
unexpectedly". That should never happen.
|
||||
|
||||
=item fastgetcwd
|
||||
|
||||
my $cwd = fastgetcwd();
|
||||
|
||||
The fastgetcwd() function is provided as a synonym for cwd().
|
||||
|
||||
=item getdcwd
|
||||
|
||||
my $cwd = getdcwd();
|
||||
my $cwd = getdcwd('C:');
|
||||
|
||||
The getdcwd() function is also provided on Win32 to get the current working
|
||||
directory on the specified drive, since Windows maintains a separate current
|
||||
working directory for each drive. If no drive is specified then the current
|
||||
drive is assumed.
|
||||
|
||||
This function simply calls the Microsoft C library _getdcwd() function.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 abs_path and friends
|
||||
|
||||
These functions are exported only on request. They each take a single
|
||||
argument and return the absolute pathname for it. If no argument is
|
||||
given they'll use the current working directory.
|
||||
|
||||
=over 4
|
||||
|
||||
=item abs_path
|
||||
|
||||
my $abs_path = abs_path($file);
|
||||
|
||||
Uses the same algorithm as getcwd(). Symbolic links and relative-path
|
||||
components ("." and "..") are resolved to return the canonical
|
||||
pathname, just like realpath(3).
|
||||
|
||||
=item realpath
|
||||
|
||||
my $abs_path = realpath($file);
|
||||
|
||||
A synonym for abs_path().
|
||||
|
||||
=item fast_abs_path
|
||||
|
||||
my $abs_path = fast_abs_path($file);
|
||||
|
||||
A more dangerous, but potentially faster version of abs_path.
|
||||
|
||||
=back
|
||||
|
||||
=head2 $ENV{PWD}
|
||||
|
||||
If you ask to override your chdir() built-in function,
|
||||
|
||||
use Cwd qw(chdir);
|
||||
|
||||
then your PWD environment variable will be kept up to date. Note that
|
||||
it will only be kept up to date if all packages which use chdir import
|
||||
it from Cwd.
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Since the path separators are different on some operating systems ('/'
|
||||
on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
|
||||
modules wherever portability is a concern.
|
||||
|
||||
=item *
|
||||
|
||||
Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
|
||||
functions are all aliases for the C<cwd()> function, which, on Mac OS,
|
||||
calls `pwd`. Likewise, the C<abs_path()> function is an alias for
|
||||
C<fast_abs_path()>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Originally by the perl5-porters.
|
||||
|
||||
Maintained by Ken Williams <KWILLIAMS@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
Portions of the C code in this library are copyright (c) 1994 by the
|
||||
Regents of the University of California. All rights reserved. The
|
||||
license on this code is compatible with the licensing of the rest of
|
||||
the distribution - please see the source code in F<Cwd.xs> for the
|
||||
details.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::chdir>
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
|
||||
|
||||
$VERSION = '3.36';
|
||||
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_simple {
|
||||
$ENV{'PWD'} = `cd`;
|
||||
chomp $ENV{'PWD'};
|
||||
$ENV{'PWD'} =~ s:\\:/:g ;
|
||||
return $ENV{'PWD'};
|
||||
}
|
||||
|
||||
sub _win32_cwd {
|
||||
if (eval '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 : \&_win32_cwd_simple;
|
||||
|
||||
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;
|
||||
753
testsuite/input-files/perl-v5.14.2/lib/DynaLoader.pm
Normal file
753
testsuite/input-files/perl-v5.14.2/lib/DynaLoader.pm
Normal file
|
|
@ -0,0 +1,753 @@
|
|||
|
||||
# Generated from DynaLoader_pm.PL
|
||||
|
||||
package DynaLoader;
|
||||
|
||||
# And Gandalf said: 'Many folk like to know beforehand what is to
|
||||
# be set on the table; but those who have laboured to prepare the
|
||||
# feast like to keep their secret; for wonder makes the words of
|
||||
# praise louder.'
|
||||
|
||||
# (Quote from Tolkien suggested by Anno Siegel.)
|
||||
#
|
||||
# See pod text at end of file for documentation.
|
||||
# See also ext/DynaLoader/README in source tree for other information.
|
||||
#
|
||||
# Tim.Bunce@ig.co.uk, August 1994
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '1.13';
|
||||
}
|
||||
|
||||
use Config;
|
||||
|
||||
# enable debug/trace messages from DynaLoader perl code
|
||||
$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
|
||||
|
||||
#
|
||||
# Flags to alter dl_load_file behaviour. Assigned bits:
|
||||
# 0x01 make symbols available for linking later dl_load_file's.
|
||||
# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
|
||||
# (ignored under VMS; effect is built-in to image linking)
|
||||
#
|
||||
# This is called as a class method $module->dl_load_flags. The
|
||||
# definition here will be inherited and result on "default" loading
|
||||
# behaviour unless a sub-class of DynaLoader defines its own version.
|
||||
#
|
||||
|
||||
sub dl_load_flags { 0x00 }
|
||||
|
||||
($dl_dlext, $dl_so, $dlsrc) = @Config::Config{qw(dlext so dlsrc)};
|
||||
|
||||
|
||||
$do_expand = 0;
|
||||
|
||||
@dl_require_symbols = (); # names of symbols we need
|
||||
@dl_resolve_using = (); # names of files to link with
|
||||
@dl_library_path = (); # path to look for files
|
||||
|
||||
#XSLoader.pm may have added elements before we were required
|
||||
#@dl_shared_objects = (); # shared objects for symbols we have
|
||||
#@dl_librefs = (); # things we have loaded
|
||||
#@dl_modules = (); # Modules we have loaded
|
||||
|
||||
# This is a fix to support DLD's unfortunate desire to relink -lc
|
||||
@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
|
||||
|
||||
# Initialise @dl_library_path with the 'standard' library path
|
||||
# for this platform as determined by Configure.
|
||||
|
||||
push(@dl_library_path, split(' ', $Config::Config{libpth}));
|
||||
|
||||
|
||||
my $ldlibpthname = $Config::Config{ldlibpthname};
|
||||
my $ldlibpthname_defined = defined $Config::Config{ldlibpthname};
|
||||
my $pthsep = $Config::Config{path_sep};
|
||||
|
||||
# Add to @dl_library_path any extra directories we can gather from environment
|
||||
# during runtime.
|
||||
|
||||
if ($ldlibpthname_defined &&
|
||||
exists $ENV{$ldlibpthname}) {
|
||||
push(@dl_library_path, split(/$pthsep/, $ENV{$ldlibpthname}));
|
||||
}
|
||||
|
||||
# E.g. HP-UX supports both its native SHLIB_PATH *and* LD_LIBRARY_PATH.
|
||||
|
||||
if ($ldlibpthname_defined &&
|
||||
$ldlibpthname ne 'LD_LIBRARY_PATH' &&
|
||||
exists $ENV{LD_LIBRARY_PATH}) {
|
||||
push(@dl_library_path, split(/$pthsep/, $ENV{LD_LIBRARY_PATH}));
|
||||
}
|
||||
|
||||
|
||||
# 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);
|
||||
|
||||
if ($dl_debug) {
|
||||
print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
|
||||
print STDERR "DynaLoader not linked into this perl\n"
|
||||
unless defined(&boot_DynaLoader);
|
||||
}
|
||||
|
||||
1; # End of main code
|
||||
|
||||
|
||||
sub croak { require Carp; Carp::croak(@_) }
|
||||
|
||||
sub bootstrap_inherit {
|
||||
my $module = $_[0];
|
||||
local *isa = *{"$module\::ISA"};
|
||||
local @isa = (@isa, 'DynaLoader');
|
||||
# Cannot goto due to delocalization. Will report errors on a wrong line?
|
||||
bootstrap(@_);
|
||||
}
|
||||
|
||||
sub bootstrap {
|
||||
# use local vars to enable $module.bs script to edit values
|
||||
local(@args) = @_;
|
||||
local($module) = $args[0];
|
||||
local(@dirs, $file);
|
||||
|
||||
unless ($module) {
|
||||
require Carp;
|
||||
Carp::confess("Usage: DynaLoader::bootstrap(module)");
|
||||
}
|
||||
|
||||
# A common error on platforms which don't support dynamic loading.
|
||||
# Since it's fatal and potentially confusing we give a detailed message.
|
||||
croak("Can't load module $module, dynamic loading not available in this perl.\n".
|
||||
" (You may need to build a new perl executable which either supports\n".
|
||||
" dynamic loading or has the $module module statically linked into it.)\n")
|
||||
unless defined(&dl_load_file);
|
||||
|
||||
|
||||
|
||||
my @modparts = split(/::/,$module);
|
||||
my $modfname = $modparts[-1];
|
||||
|
||||
# Some systems have restrictions on files names for DLL's etc.
|
||||
# mod2fname returns appropriate file base name (typically truncated)
|
||||
# It may also edit @modparts if required.
|
||||
$modfname = &mod2fname(\@modparts) if defined &mod2fname;
|
||||
|
||||
|
||||
|
||||
my $modpname = join('/',@modparts);
|
||||
|
||||
print STDERR "DynaLoader::bootstrap for $module ",
|
||||
"(auto/$modpname/$modfname.$dl_dlext)\n"
|
||||
if $dl_debug;
|
||||
|
||||
foreach (@INC) {
|
||||
|
||||
my $dir = "$_/auto/$modpname";
|
||||
|
||||
next unless -d $dir; # skip over uninteresting directories
|
||||
|
||||
# check for common cases to avoid autoload of dl_findfile
|
||||
my $try = "$dir/$modfname.$dl_dlext";
|
||||
last if $file = ($do_expand) ? dl_expandspec($try) : ((-f $try) && $try);
|
||||
|
||||
# no luck here, save dir for possible later dl_findfile search
|
||||
push @dirs, $dir;
|
||||
}
|
||||
# last resort, let dl_findfile have a go in all known locations
|
||||
$file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
|
||||
|
||||
croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
|
||||
unless $file; # wording similar to error from 'require'
|
||||
|
||||
|
||||
my $bootname = "boot_$module";
|
||||
$bootname =~ s/\W/_/g;
|
||||
@dl_require_symbols = ($bootname);
|
||||
|
||||
# Execute optional '.bootstrap' perl script for this module.
|
||||
# The .bs file can be used to configure @dl_resolve_using etc to
|
||||
# match the needs of the individual module on this architecture.
|
||||
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 $@;
|
||||
}
|
||||
|
||||
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, $module->dl_load_flags) or
|
||||
croak("Can't load '$file' for module $module: ".dl_error());
|
||||
|
||||
push(@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
|
||||
croak("Can't find '$bootname' symbol in $file\n");
|
||||
|
||||
push(@dl_modules, $module); # record loaded module
|
||||
|
||||
boot:
|
||||
my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
|
||||
|
||||
# See comment block above
|
||||
|
||||
push(@dl_shared_objects, $file); # record files loaded
|
||||
|
||||
&$xs(@args);
|
||||
}
|
||||
|
||||
sub dl_findfile {
|
||||
# Read ext/DynaLoader/DynaLoader.doc for detailed information.
|
||||
# This function does not automatically consider the architecture
|
||||
# or the perl library auto directories.
|
||||
my (@args) = @_;
|
||||
my (@dirs, $dir); # which directories to search
|
||||
my (@found); # full paths to real files we have found
|
||||
#my $dl_ext= 'so'; # $Config::Config{'dlext'} suffix for perl extensions
|
||||
#my $dl_so = 'so'; # $Config::Config{'so'} suffix for shared libraries
|
||||
|
||||
print STDERR "dl_findfile(@args)\n" if $dl_debug;
|
||||
|
||||
# accumulate directories but process files as they appear
|
||||
arg: foreach(@args) {
|
||||
# Special fast case: full filepath requires no search
|
||||
|
||||
|
||||
if (m:/: && -f $_) {
|
||||
push(@found,$_);
|
||||
last arg unless wantarray;
|
||||
next;
|
||||
}
|
||||
|
||||
|
||||
# Deal with directories first:
|
||||
# Using a -L prefix is the preferred option (faster and more robust)
|
||||
if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
|
||||
|
||||
# Otherwise we try to try to spot directories by a heuristic
|
||||
# (this is a more complicated issue than it first appears)
|
||||
if (m:/: && -d $_) { push(@dirs, $_); next; }
|
||||
|
||||
|
||||
|
||||
# Only files should get this far...
|
||||
my(@names, $name); # what filenames to look for
|
||||
if (m:-l: ) { # convert -lname to appropriate library name
|
||||
s/-l//;
|
||||
push(@names,"lib$_.$dl_so");
|
||||
push(@names,"lib$_.a");
|
||||
} else { # Umm, a bare name. Try various alternatives:
|
||||
# these should be ordered with the most likely first
|
||||
push(@names,"$_.$dl_dlext") unless m/\.$dl_dlext$/o;
|
||||
push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
|
||||
|
||||
push(@names,"lib$_.$dl_so") unless m:/:;
|
||||
push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
|
||||
push(@names, $_);
|
||||
}
|
||||
my $dirsep = '/';
|
||||
|
||||
foreach $dir (@dirs, @dl_library_path) {
|
||||
next unless -d $dir;
|
||||
|
||||
foreach $name (@names) {
|
||||
my($file) = "$dir$dirsep$name";
|
||||
print STDERR " checking in $dir for $name\n" if $dl_debug;
|
||||
$file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
|
||||
#$file = _check_file($file);
|
||||
if ($file) {
|
||||
push(@found, $file);
|
||||
next arg; # no need to look any further
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($dl_debug) {
|
||||
foreach(@dirs) {
|
||||
print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
|
||||
}
|
||||
print STDERR "dl_findfile found: @found\n";
|
||||
}
|
||||
return $found[0] unless wantarray;
|
||||
@found;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub dl_expandspec {
|
||||
my($spec) = @_;
|
||||
# Optional function invoked if DynaLoader.pm sets $do_expand.
|
||||
# Most systems do not require or use this function.
|
||||
# Some systems may implement it in the dl_*.xs file in which case
|
||||
# this Perl version should be excluded at build time.
|
||||
|
||||
# This function is designed to deal with systems which treat some
|
||||
# 'filenames' in a special way. For example VMS 'Logical Names'
|
||||
# (something like unix environment variables - but different).
|
||||
# This function should recognise such names and expand them into
|
||||
# full file paths.
|
||||
# Must return undef if $spec is invalid or file does not exist.
|
||||
|
||||
my $file = $spec; # default output to input
|
||||
|
||||
return undef unless -f $file;
|
||||
print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
|
||||
$file;
|
||||
}
|
||||
|
||||
sub dl_find_symbol_anywhere
|
||||
{
|
||||
my $sym = shift;
|
||||
my $libref;
|
||||
foreach $libref (@dl_librefs) {
|
||||
my $symref = dl_find_symbol($libref,$sym);
|
||||
return $symref if $symref;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
DynaLoader - Dynamically load C libraries into Perl code
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package YourPackage;
|
||||
require DynaLoader;
|
||||
@ISA = qw(... DynaLoader ...);
|
||||
bootstrap YourPackage;
|
||||
|
||||
# optional method for 'global' loading
|
||||
sub dl_load_flags { 0x01 }
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This document defines a standard generic interface to the dynamic
|
||||
linking mechanisms available on many platforms. Its primary purpose is
|
||||
to implement automatic dynamic loading of Perl modules.
|
||||
|
||||
This document serves as both a specification for anyone wishing to
|
||||
implement the DynaLoader for a new platform and as a guide for
|
||||
anyone wishing to use the DynaLoader directly in an application.
|
||||
|
||||
The DynaLoader is designed to be a very simple high-level
|
||||
interface that is sufficiently general to cover the requirements
|
||||
of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
|
||||
|
||||
It is also hoped that the interface will cover the needs of OS/2, NT
|
||||
etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
|
||||
|
||||
It must be stressed that the DynaLoader, by itself, is practically
|
||||
useless for accessing non-Perl libraries because it provides almost no
|
||||
Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
|
||||
library function or supplying arguments. A C::DynaLib module
|
||||
is available from CPAN sites which performs that function for some
|
||||
common system types. And since the year 2000, there's also Inline::C,
|
||||
a module that allows you to write Perl subroutines in C. Also available
|
||||
from your local CPAN site.
|
||||
|
||||
DynaLoader Interface Summary
|
||||
|
||||
@dl_library_path
|
||||
@dl_resolve_using
|
||||
@dl_require_symbols
|
||||
$dl_debug
|
||||
@dl_librefs
|
||||
@dl_modules
|
||||
@dl_shared_objects
|
||||
Implemented in:
|
||||
bootstrap($modulename) Perl
|
||||
@filepaths = dl_findfile(@names) Perl
|
||||
$flags = $modulename->dl_load_flags Perl
|
||||
$symref = dl_find_symbol_anywhere($symbol) Perl
|
||||
|
||||
$libref = dl_load_file($filename, $flags) C
|
||||
$status = dl_unload_file($libref) C
|
||||
$symref = dl_find_symbol($libref, $symbol) C
|
||||
@symbols = dl_undef_symbols() C
|
||||
dl_install_xsub($name, $symref [, $filename]) C
|
||||
$message = dl_error C
|
||||
|
||||
=over 4
|
||||
|
||||
=item @dl_library_path
|
||||
|
||||
The standard/default list of directories in which dl_findfile() will
|
||||
search for libraries etc. Directories are searched in order:
|
||||
$dl_library_path[0], [1], ... etc
|
||||
|
||||
@dl_library_path is initialised to hold the list of 'normal' directories
|
||||
(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
|
||||
ensure portability across a wide range of platforms.
|
||||
|
||||
@dl_library_path should also be initialised with any other directories
|
||||
that can be determined from the environment at runtime (such as
|
||||
LD_LIBRARY_PATH for SunOS).
|
||||
|
||||
After initialisation @dl_library_path can be manipulated by an
|
||||
application using push and unshift before calling dl_findfile().
|
||||
Unshift can be used to add directories to the front of the search order
|
||||
either to save search time or to override libraries with the same name
|
||||
in the 'normal' directories.
|
||||
|
||||
The load function that dl_load_file() calls may require an absolute
|
||||
pathname. The dl_findfile() function and @dl_library_path can be
|
||||
used to search for and return the absolute pathname for the
|
||||
library/object that you wish to load.
|
||||
|
||||
=item @dl_resolve_using
|
||||
|
||||
A list of additional libraries or other shared objects which can be
|
||||
used to resolve any undefined symbols that might be generated by a
|
||||
later call to load_file().
|
||||
|
||||
This is only required on some platforms which do not handle dependent
|
||||
libraries automatically. For example the Socket Perl extension
|
||||
library (F<auto/Socket/Socket.so>) contains references to many socket
|
||||
functions which need to be resolved when it's loaded. Most platforms
|
||||
will automatically know where to find the 'dependent' library (e.g.,
|
||||
F</usr/lib/libsocket.so>). A few platforms need to be told the
|
||||
location of the dependent library explicitly. Use @dl_resolve_using
|
||||
for this.
|
||||
|
||||
Example usage:
|
||||
|
||||
@dl_resolve_using = dl_findfile('-lsocket');
|
||||
|
||||
=item @dl_require_symbols
|
||||
|
||||
A list of one or more symbol names that are in the library/object file
|
||||
to be dynamically loaded. This is only required on some platforms.
|
||||
|
||||
=item @dl_librefs
|
||||
|
||||
An array of the handles returned by successful calls to dl_load_file(),
|
||||
made by bootstrap, in the order in which they were loaded.
|
||||
Can be used with dl_find_symbol() to look for a symbol in any of
|
||||
the loaded files.
|
||||
|
||||
=item @dl_modules
|
||||
|
||||
An array of module (package) names that have been bootstrap'ed.
|
||||
|
||||
=item @dl_shared_objects
|
||||
|
||||
An array of file names for the shared objects that were loaded.
|
||||
|
||||
=item dl_error()
|
||||
|
||||
Syntax:
|
||||
|
||||
$message = dl_error();
|
||||
|
||||
Error message text from the last failed DynaLoader function. Note
|
||||
that, similar to errno in unix, a successful function call does not
|
||||
reset this message.
|
||||
|
||||
Implementations should detect the error as soon as it occurs in any of
|
||||
the other functions and save the corresponding message for later
|
||||
retrieval. This will avoid problems on some platforms (such as SunOS)
|
||||
where the error message is very temporary (e.g., dlerror()).
|
||||
|
||||
=item $dl_debug
|
||||
|
||||
Internal debugging messages are enabled when $dl_debug is set true.
|
||||
Currently setting $dl_debug only affects the Perl side of the
|
||||
DynaLoader. These messages should help an application developer to
|
||||
resolve any DynaLoader usage problems.
|
||||
|
||||
$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
|
||||
|
||||
For the DynaLoader developer/porter there is a similar debugging
|
||||
variable added to the C code (see dlutils.c) and enabled if Perl was
|
||||
built with the B<-DDEBUGGING> flag. This can also be set via the
|
||||
PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
|
||||
higher for more.
|
||||
|
||||
=item dl_findfile()
|
||||
|
||||
Syntax:
|
||||
|
||||
@filepaths = dl_findfile(@names)
|
||||
|
||||
Determine the full paths (including file suffix) of one or more
|
||||
loadable files given their generic names and optionally one or more
|
||||
directories. Searches directories in @dl_library_path by default and
|
||||
returns an empty list if no files were found.
|
||||
|
||||
Names can be specified in a variety of platform independent forms. Any
|
||||
names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
|
||||
an appropriate suffix for the platform.
|
||||
|
||||
If a name does not already have a suitable prefix and/or suffix then
|
||||
the corresponding file will be searched for by trying combinations of
|
||||
prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
|
||||
and "$name".
|
||||
|
||||
If any directories are included in @names they are searched before
|
||||
@dl_library_path. Directories may be specified as B<-Ldir>. Any other
|
||||
names are treated as filenames to be searched for.
|
||||
|
||||
Using arguments of the form C<-Ldir> and C<-lname> is recommended.
|
||||
|
||||
Example:
|
||||
|
||||
@dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
|
||||
|
||||
|
||||
=item dl_expandspec()
|
||||
|
||||
Syntax:
|
||||
|
||||
$filepath = dl_expandspec($spec)
|
||||
|
||||
Some unusual systems, such as VMS, require special filename handling in
|
||||
order to deal with symbolic names for files (i.e., VMS's Logical Names).
|
||||
|
||||
To support these systems a dl_expandspec() function can be implemented
|
||||
either in the F<dl_*.xs> file or code can be added to the dl_expandspec()
|
||||
function in F<DynaLoader.pm>. See F<DynaLoader_pm.PL> for more information.
|
||||
|
||||
=item dl_load_file()
|
||||
|
||||
Syntax:
|
||||
|
||||
$libref = dl_load_file($filename, $flags)
|
||||
|
||||
Dynamically load $filename, which must be the path to a shared object
|
||||
or library. An opaque 'library reference' is returned as a handle for
|
||||
the loaded object. Returns undef on error.
|
||||
|
||||
The $flags argument to alters dl_load_file behaviour.
|
||||
Assigned bits:
|
||||
|
||||
0x01 make symbols available for linking later dl_load_file's.
|
||||
(only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
|
||||
(ignored under VMS; this is a normal part of image linking)
|
||||
|
||||
(On systems that provide a handle for the loaded object such as SunOS
|
||||
and HPUX, $libref will be that handle. On other systems $libref will
|
||||
typically be $filename or a pointer to a buffer containing $filename.
|
||||
The application should not examine or alter $libref in any way.)
|
||||
|
||||
This is the function that does the real work. It should use the
|
||||
current values of @dl_require_symbols and @dl_resolve_using if required.
|
||||
|
||||
SunOS: dlopen($filename)
|
||||
HP-UX: shl_load($filename)
|
||||
Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
|
||||
NeXT: rld_load($filename, @dl_resolve_using)
|
||||
VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
|
||||
|
||||
(The dlopen() function is also used by Solaris and some versions of
|
||||
Linux, and is a common choice when providing a "wrapper" on other
|
||||
mechanisms as is done in the OS/2 port.)
|
||||
|
||||
=item dl_unload_file()
|
||||
|
||||
Syntax:
|
||||
|
||||
$status = dl_unload_file($libref)
|
||||
|
||||
Dynamically unload $libref, which must be an opaque 'library reference' as
|
||||
returned from dl_load_file. Returns one on success and zero on failure.
|
||||
|
||||
This function is optional and may not necessarily be provided on all platforms.
|
||||
If it is defined, it is called automatically when the interpreter exits for
|
||||
every shared object or library loaded by DynaLoader::bootstrap. All such
|
||||
library references are stored in @dl_librefs by DynaLoader::Bootstrap as it
|
||||
loads the libraries. The files are unloaded in last-in, first-out order.
|
||||
|
||||
This unloading is usually necessary when embedding a shared-object perl (e.g.
|
||||
one configured with -Duseshrplib) within a larger application, and the perl
|
||||
interpreter is created and destroyed several times within the lifetime of the
|
||||
application. In this case it is possible that the system dynamic linker will
|
||||
unload and then subsequently reload the shared libperl without relocating any
|
||||
references to it from any files DynaLoaded by the previous incarnation of the
|
||||
interpreter. As a result, any shared objects opened by DynaLoader may point to
|
||||
a now invalid 'ghost' of the libperl shared object, causing apparently random
|
||||
memory corruption and crashes. This behaviour is most commonly seen when using
|
||||
Apache and mod_perl built with the APXS mechanism.
|
||||
|
||||
SunOS: dlclose($libref)
|
||||
HP-UX: ???
|
||||
Linux: ???
|
||||
NeXT: ???
|
||||
VMS: ???
|
||||
|
||||
(The dlclose() function is also used by Solaris and some versions of
|
||||
Linux, and is a common choice when providing a "wrapper" on other
|
||||
mechanisms as is done in the OS/2 port.)
|
||||
|
||||
=item dl_load_flags()
|
||||
|
||||
Syntax:
|
||||
|
||||
$flags = dl_load_flags $modulename;
|
||||
|
||||
Designed to be a method call, and to be overridden by a derived class
|
||||
(i.e. a class which has DynaLoader in its @ISA). The definition in
|
||||
DynaLoader itself returns 0, which produces standard behavior from
|
||||
dl_load_file().
|
||||
|
||||
=item dl_find_symbol()
|
||||
|
||||
Syntax:
|
||||
|
||||
$symref = dl_find_symbol($libref, $symbol)
|
||||
|
||||
Return the address of the symbol $symbol or C<undef> if not found. If the
|
||||
target system has separate functions to search for symbols of different
|
||||
types then dl_find_symbol() should search for function symbols first and
|
||||
then other types.
|
||||
|
||||
The exact manner in which the address is returned in $symref is not
|
||||
currently defined. The only initial requirement is that $symref can
|
||||
be passed to, and understood by, dl_install_xsub().
|
||||
|
||||
SunOS: dlsym($libref, $symbol)
|
||||
HP-UX: shl_findsym($libref, $symbol)
|
||||
Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
|
||||
NeXT: rld_lookup("_$symbol")
|
||||
VMS: lib$find_image_symbol($libref,$symbol)
|
||||
|
||||
|
||||
=item dl_find_symbol_anywhere()
|
||||
|
||||
Syntax:
|
||||
|
||||
$symref = dl_find_symbol_anywhere($symbol)
|
||||
|
||||
Applies dl_find_symbol() to the members of @dl_librefs and returns
|
||||
the first match found.
|
||||
|
||||
=item dl_undef_symbols()
|
||||
|
||||
Example
|
||||
|
||||
@symbols = dl_undef_symbols()
|
||||
|
||||
Return a list of symbol names which remain undefined after load_file().
|
||||
Returns C<()> if not known. Don't worry if your platform does not provide
|
||||
a mechanism for this. Most do not need it and hence do not provide it,
|
||||
they just return an empty list.
|
||||
|
||||
|
||||
=item dl_install_xsub()
|
||||
|
||||
Syntax:
|
||||
|
||||
dl_install_xsub($perl_name, $symref [, $filename])
|
||||
|
||||
Create a new Perl external subroutine named $perl_name using $symref as
|
||||
a pointer to the function which implements the routine. This is simply
|
||||
a direct call to newXSUB(). Returns a reference to the installed
|
||||
function.
|
||||
|
||||
The $filename parameter is used by Perl to identify the source file for
|
||||
the function if required by die(), caller() or the debugger. If
|
||||
$filename is not defined then "DynaLoader" will be used.
|
||||
|
||||
|
||||
=item bootstrap()
|
||||
|
||||
Syntax:
|
||||
|
||||
bootstrap($module [...])
|
||||
|
||||
This is the normal entry point for automatic dynamic loading in Perl.
|
||||
|
||||
It performs the following actions:
|
||||
|
||||
=over 8
|
||||
|
||||
=item *
|
||||
|
||||
locates an auto/$module directory by searching @INC
|
||||
|
||||
=item *
|
||||
|
||||
uses dl_findfile() to determine the filename to load
|
||||
|
||||
=item *
|
||||
|
||||
sets @dl_require_symbols to C<("boot_$module")>
|
||||
|
||||
=item *
|
||||
|
||||
executes an F<auto/$module/$module.bs> file if it exists
|
||||
(typically used to add to @dl_resolve_using any files which
|
||||
are required to load the module on the current platform)
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_load_flags() to determine how to load the file.
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_load_file() to load the file
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_undef_symbols() and warns if any symbols are undefined
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_find_symbol() for "boot_$module"
|
||||
|
||||
=item *
|
||||
|
||||
calls dl_install_xsub() to install it as "${module}::bootstrap"
|
||||
|
||||
=item *
|
||||
|
||||
calls &{"${module}::bootstrap"} to bootstrap the module (actually
|
||||
it uses the function reference returned by dl_install_xsub for speed)
|
||||
|
||||
=back
|
||||
|
||||
All arguments to bootstrap() are passed to the module's bootstrap function.
|
||||
The default code generated by F<xsubpp> expects $module [, $version]
|
||||
If the optional $version argument is not given, it defaults to
|
||||
C<$XS_VERSION // $VERSION> in the module's symbol table. The default code
|
||||
compares the Perl-space version with the version of the compiled XS code,
|
||||
and croaks with an error if they do not match.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tim Bunce, 11 August 1994.
|
||||
|
||||
This interface is based on the work and comments of (in no particular
|
||||
order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
|
||||
Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
|
||||
|
||||
Larry Wall designed the elegant inherited bootstrap mechanism and
|
||||
implemented the first Perl 5 dynamic loader using it.
|
||||
|
||||
Solaris global loading added by Nick Ing-Simmons with design/coding
|
||||
assistance from Tim Bunce, January 1996.
|
||||
|
||||
=cut
|
||||
283
testsuite/input-files/perl-v5.14.2/lib/Errno.pm
Normal file
283
testsuite/input-files/perl-v5.14.2/lib/Errno.pm
Normal file
|
|
@ -0,0 +1,283 @@
|
|||
# -*- buffer-read-only: t -*-
|
||||
#
|
||||
# This file is auto-generated. ***ANY*** changes here will be lost
|
||||
#
|
||||
|
||||
package Errno;
|
||||
require Exporter;
|
||||
use Config;
|
||||
use strict;
|
||||
|
||||
"$Config{'archname'}-$Config{'osvers'}" eq
|
||||
"x86_64-linux-3.13.0-43-lowlatency" or
|
||||
die "Errno architecture (x86_64-linux-3.13.0-43-lowlatency) does not match executable architecture ($Config{'archname'}-$Config{'osvers'})";
|
||||
|
||||
our $VERSION = "1.13";
|
||||
$VERSION = eval $VERSION;
|
||||
our @ISA = 'Exporter';
|
||||
|
||||
my %err;
|
||||
|
||||
BEGIN {
|
||||
%err = (
|
||||
EPERM => 1,
|
||||
ENOENT => 2,
|
||||
ESRCH => 3,
|
||||
EINTR => 4,
|
||||
EIO => 5,
|
||||
ENXIO => 6,
|
||||
E2BIG => 7,
|
||||
ENOEXEC => 8,
|
||||
EBADF => 9,
|
||||
ECHILD => 10,
|
||||
EWOULDBLOCK => 11,
|
||||
EAGAIN => 11,
|
||||
ENOMEM => 12,
|
||||
EACCES => 13,
|
||||
EFAULT => 14,
|
||||
ENOTBLK => 15,
|
||||
EBUSY => 16,
|
||||
EEXIST => 17,
|
||||
EXDEV => 18,
|
||||
ENODEV => 19,
|
||||
ENOTDIR => 20,
|
||||
EISDIR => 21,
|
||||
EINVAL => 22,
|
||||
ENFILE => 23,
|
||||
EMFILE => 24,
|
||||
ENOTTY => 25,
|
||||
ETXTBSY => 26,
|
||||
EFBIG => 27,
|
||||
ENOSPC => 28,
|
||||
ESPIPE => 29,
|
||||
EROFS => 30,
|
||||
EMLINK => 31,
|
||||
EPIPE => 32,
|
||||
EDOM => 33,
|
||||
ERANGE => 34,
|
||||
EDEADLOCK => 35,
|
||||
EDEADLK => 35,
|
||||
ENAMETOOLONG => 36,
|
||||
ENOLCK => 37,
|
||||
ENOSYS => 38,
|
||||
ENOTEMPTY => 39,
|
||||
ELOOP => 40,
|
||||
ENOMSG => 42,
|
||||
EIDRM => 43,
|
||||
ECHRNG => 44,
|
||||
EL2NSYNC => 45,
|
||||
EL3HLT => 46,
|
||||
EL3RST => 47,
|
||||
ELNRNG => 48,
|
||||
EUNATCH => 49,
|
||||
ENOCSI => 50,
|
||||
EL2HLT => 51,
|
||||
EBADE => 52,
|
||||
EBADR => 53,
|
||||
EXFULL => 54,
|
||||
ENOANO => 55,
|
||||
EBADRQC => 56,
|
||||
EBADSLT => 57,
|
||||
EBFONT => 59,
|
||||
ENOSTR => 60,
|
||||
ENODATA => 61,
|
||||
ETIME => 62,
|
||||
ENOSR => 63,
|
||||
ENONET => 64,
|
||||
ENOPKG => 65,
|
||||
EREMOTE => 66,
|
||||
ENOLINK => 67,
|
||||
EADV => 68,
|
||||
ESRMNT => 69,
|
||||
ECOMM => 70,
|
||||
EPROTO => 71,
|
||||
EMULTIHOP => 72,
|
||||
EDOTDOT => 73,
|
||||
EBADMSG => 74,
|
||||
EOVERFLOW => 75,
|
||||
ENOTUNIQ => 76,
|
||||
EBADFD => 77,
|
||||
EREMCHG => 78,
|
||||
ELIBACC => 79,
|
||||
ELIBBAD => 80,
|
||||
ELIBSCN => 81,
|
||||
ELIBMAX => 82,
|
||||
ELIBEXEC => 83,
|
||||
EILSEQ => 84,
|
||||
ERESTART => 85,
|
||||
ESTRPIPE => 86,
|
||||
EUSERS => 87,
|
||||
ENOTSOCK => 88,
|
||||
EDESTADDRREQ => 89,
|
||||
EMSGSIZE => 90,
|
||||
EPROTOTYPE => 91,
|
||||
ENOPROTOOPT => 92,
|
||||
EPROTONOSUPPORT => 93,
|
||||
ESOCKTNOSUPPORT => 94,
|
||||
ENOTSUP => 95,
|
||||
EOPNOTSUPP => 95,
|
||||
EPFNOSUPPORT => 96,
|
||||
EAFNOSUPPORT => 97,
|
||||
EADDRINUSE => 98,
|
||||
EADDRNOTAVAIL => 99,
|
||||
ENETDOWN => 100,
|
||||
ENETUNREACH => 101,
|
||||
ENETRESET => 102,
|
||||
ECONNABORTED => 103,
|
||||
ECONNRESET => 104,
|
||||
ENOBUFS => 105,
|
||||
EISCONN => 106,
|
||||
ENOTCONN => 107,
|
||||
ESHUTDOWN => 108,
|
||||
ETOOMANYREFS => 109,
|
||||
ETIMEDOUT => 110,
|
||||
ECONNREFUSED => 111,
|
||||
EHOSTDOWN => 112,
|
||||
EHOSTUNREACH => 113,
|
||||
EALREADY => 114,
|
||||
EINPROGRESS => 115,
|
||||
ESTALE => 116,
|
||||
EUCLEAN => 117,
|
||||
ENOTNAM => 118,
|
||||
ENAVAIL => 119,
|
||||
EISNAM => 120,
|
||||
EREMOTEIO => 121,
|
||||
EDQUOT => 122,
|
||||
ENOMEDIUM => 123,
|
||||
EMEDIUMTYPE => 124,
|
||||
ECANCELED => 125,
|
||||
ENOKEY => 126,
|
||||
EKEYEXPIRED => 127,
|
||||
EKEYREVOKED => 128,
|
||||
EKEYREJECTED => 129,
|
||||
EOWNERDEAD => 130,
|
||||
ENOTRECOVERABLE => 131,
|
||||
ERFKILL => 132,
|
||||
EHWPOISON => 133,
|
||||
);
|
||||
# Generate proxy constant subroutines for all the values.
|
||||
# Well, almost all the values. Unfortunately we can't assume that at this
|
||||
# point that our symbol table is empty, as code such as if the parser has
|
||||
# seen code such as C<exists &Errno::EINVAL>, it will have created the
|
||||
# typeglob.
|
||||
# Doing this before defining @EXPORT_OK etc means that even if a platform is
|
||||
# crazy enough to define EXPORT_OK as an error constant, everything will
|
||||
# still work, because the parser will upgrade the PCS to a real typeglob.
|
||||
# We rely on the subroutine definitions below to update the internal caches.
|
||||
# Don't use %each, as we don't want a copy of the value.
|
||||
foreach my $name (keys %err) {
|
||||
if ($Errno::{$name}) {
|
||||
# We expect this to be reached fairly rarely, so take an approach
|
||||
# which uses the least compile time effort in the common case:
|
||||
eval "sub $name() { $err{$name} }; 1" or die $@;
|
||||
} else {
|
||||
$Errno::{$name} = \$err{$name};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
our @EXPORT_OK = keys %err;
|
||||
|
||||
our %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 TIEHASH { bless \%err }
|
||||
|
||||
sub FETCH {
|
||||
my (undef, $errname) = @_;
|
||||
return "" unless exists $err{$errname};
|
||||
my $errno = $err{$errname};
|
||||
return $errno == $! ? $errno : 0;
|
||||
}
|
||||
|
||||
sub STORE {
|
||||
require Carp;
|
||||
Carp::confess("ERRNO hash is read only!");
|
||||
}
|
||||
|
||||
*CLEAR = *DELETE = \*STORE; # Typeglob aliasing uses less space
|
||||
|
||||
sub NEXTKEY {
|
||||
each %err;
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $s = scalar keys %err; # initialize iterator
|
||||
each %err;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my (undef, $errname) = @_;
|
||||
exists $err{$errname};
|
||||
}
|
||||
|
||||
tie %!, __PACKAGE__; # Returns an object, objects are true.
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Errno - System errno constants
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Errno qw(EINTR EIO :POSIX);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Errno> defines and conditionally exports all the error constants
|
||||
defined in your system C<errno.h> include file. It has a single export
|
||||
tag, C<:POSIX>, which will export all POSIX defined error numbers.
|
||||
|
||||
C<Errno> also makes C<%!> magic such that each element of C<%!> has a
|
||||
non-zero value only if C<$!> is set to that value. For example:
|
||||
|
||||
use Errno;
|
||||
|
||||
unless (open(FH, "/fangorn/spouse")) {
|
||||
if ($!{ENOENT}) {
|
||||
warn "Get a wife!\n";
|
||||
} else {
|
||||
warn "This path is barred: $!";
|
||||
}
|
||||
}
|
||||
|
||||
If a specified constant C<EFOO> does not exist on the system, C<$!{EFOO}>
|
||||
returns C<"">. You may use C<exists $!{EFOO}> to check whether the
|
||||
constant is available on the system.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Importing a particular constant may not be very portable, because the
|
||||
import will fail on platforms that do not have that constant. A more
|
||||
portable way to set C<$!> to a valid value is to use:
|
||||
|
||||
if (exists &Errno::EFOO) {
|
||||
$! = &Errno::EFOO;
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Graham Barr <gbarr@pobox.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1997-8 Graham Barr. All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
# ex: set ro:
|
||||
587
testsuite/input-files/perl-v5.14.2/lib/Exporter.pm
Normal file
587
testsuite/input-files/perl-v5.14.2/lib/Exporter.pm
Normal file
|
|
@ -0,0 +1,587 @@
|
|||
package Exporter;
|
||||
|
||||
require 5.006;
|
||||
|
||||
# Be lean.
|
||||
#use strict;
|
||||
#no strict 'refs';
|
||||
|
||||
our $Debug = 0;
|
||||
our $ExportLevel = 0;
|
||||
our $Verbose ||= 0;
|
||||
our $VERSION = '5.64_03';
|
||||
our (%Cache);
|
||||
|
||||
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 = \@{"$pkg\::EXPORT"};
|
||||
# But, avoid creating things if they don't exist, which saves a couple of
|
||||
# hundred bytes per package processed.
|
||||
my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"};
|
||||
return export $pkg, $callpkg, @_
|
||||
if $Verbose or $Debug or $fail && @$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 @$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} if not $SIG{__WARN__};
|
||||
# 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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exporter - Implements default import method for modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
In module F<YourModule.pm>:
|
||||
|
||||
package YourModule;
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
|
||||
or
|
||||
|
||||
package YourModule;
|
||||
use Exporter 'import'; # gives you Exporter's import() method directly
|
||||
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
|
||||
In other files which wish to use C<YourModule>:
|
||||
|
||||
use YourModule qw(frobnicate); # import listed symbols
|
||||
frobnicate ($left, $right) # calls YourModule::frobnicate
|
||||
|
||||
Take a look at L</Good Practices> for some variants
|
||||
you will like to use in modern Perl code.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The Exporter module implements an C<import> method which allows a module
|
||||
to export functions and variables to its users' namespaces. Many modules
|
||||
use Exporter rather than implementing their own C<import> method because
|
||||
Exporter provides a highly flexible interface, with an implementation optimised
|
||||
for the common case.
|
||||
|
||||
Perl automatically calls the C<import> method when processing a
|
||||
C<use> statement for a module. Modules and C<use> are documented
|
||||
in L<perlfunc> and L<perlmod>. Understanding the concept of
|
||||
modules and how the C<use> statement operates is important to
|
||||
understanding the Exporter.
|
||||
|
||||
=head2 How to Export
|
||||
|
||||
The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of
|
||||
symbols that are going to be exported into the users name space by
|
||||
default, or which they can request to be exported, respectively. The
|
||||
symbols can represent functions, scalars, arrays, hashes, or typeglobs.
|
||||
The symbols must be given by full name with the exception that the
|
||||
ampersand in front of a function is optional, e.g.
|
||||
|
||||
@EXPORT = qw(afunc $scalar @array); # afunc is a function
|
||||
@EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc
|
||||
|
||||
If you are only exporting function names it is recommended to omit the
|
||||
ampersand, as the implementation is faster this way.
|
||||
|
||||
=head2 Selecting What To Export
|
||||
|
||||
Do B<not> export method names!
|
||||
|
||||
Do B<not> export anything else by default without a good reason!
|
||||
|
||||
Exports pollute the namespace of the module user. If you must export
|
||||
try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or
|
||||
common symbol names to reduce the risk of name clashes.
|
||||
|
||||
Generally anything not exported is still accessible from outside the
|
||||
module using the C<YourModule::item_name> (or C<< $blessed_ref->method >>)
|
||||
syntax. By convention you can use a leading underscore on names to
|
||||
informally indicate that they are 'internal' and not for public use.
|
||||
|
||||
(It is actually possible to get private functions by saying:
|
||||
|
||||
my $subref = sub { ... };
|
||||
$subref->(@args); # Call it as a function
|
||||
$obj->$subref(@args); # Use it as a method
|
||||
|
||||
However if you use them for methods it is up to you to figure out
|
||||
how to make inheritance work.)
|
||||
|
||||
As a general rule, if the module is trying to be object oriented
|
||||
then export nothing. If it's just a collection of functions then
|
||||
C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and
|
||||
method names use barewords in preference to names prefixed with
|
||||
ampersands for the export lists.
|
||||
|
||||
Other module design guidelines can be found in L<perlmod>.
|
||||
|
||||
=head2 How to Import
|
||||
|
||||
In other files which wish to use your module there are three basic ways for
|
||||
them to load your module and import its symbols:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<use YourModule;>
|
||||
|
||||
This imports all the symbols from YourModule's C<@EXPORT> into the namespace
|
||||
of the C<use> statement.
|
||||
|
||||
=item C<use YourModule ();>
|
||||
|
||||
This causes perl to load your module but does not import any symbols.
|
||||
|
||||
=item C<use YourModule qw(...);>
|
||||
|
||||
This imports only the symbols listed by the caller into their namespace.
|
||||
All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error
|
||||
occurs. The advanced export features of Exporter are accessed like this,
|
||||
but with list entries that are syntactically distinct from symbol names.
|
||||
|
||||
=back
|
||||
|
||||
Unless you want to use its advanced features, this is probably all you
|
||||
need to know to use Exporter.
|
||||
|
||||
=head1 Advanced features
|
||||
|
||||
=head2 Specialised Import Lists
|
||||
|
||||
If any of the entries in an import list begins with !, : or / then
|
||||
the list is treated as a series of specifications which either add to
|
||||
or delete from the list of names to import. They are processed left to
|
||||
right. Specifications are in the form:
|
||||
|
||||
[!]name This name only
|
||||
[!]:DEFAULT All names in @EXPORT
|
||||
[!]:tag All names in $EXPORT_TAGS{tag} anonymous list
|
||||
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
|
||||
|
||||
A leading ! indicates that matching names should be deleted from the
|
||||
list of names to import. If the first specification is a deletion it
|
||||
is treated as though preceded by :DEFAULT. If you just want to import
|
||||
extra names in addition to the default set you will still need to
|
||||
include :DEFAULT explicitly.
|
||||
|
||||
e.g., F<Module.pm> defines:
|
||||
|
||||
@EXPORT = qw(A1 A2 A3 A4 A5);
|
||||
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
|
||||
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
|
||||
|
||||
Note that you cannot use tags in @EXPORT or @EXPORT_OK.
|
||||
Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
|
||||
|
||||
An application using Module can say something like:
|
||||
|
||||
use Module qw(:DEFAULT :T2 !B3 A3);
|
||||
|
||||
Other examples include:
|
||||
|
||||
use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
|
||||
use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
|
||||
|
||||
Remember that most patterns (using //) will need to be anchored
|
||||
with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
|
||||
|
||||
You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
|
||||
specifications are being processed and what is actually being imported
|
||||
into modules.
|
||||
|
||||
=head2 Exporting without using Exporter's import method
|
||||
|
||||
Exporter has a special method, 'export_to_level' which is used in situations
|
||||
where you can't directly call Exporter's import method. The export_to_level
|
||||
method looks like:
|
||||
|
||||
MyPackage->export_to_level($where_to_export, $package, @what_to_export);
|
||||
|
||||
where C<$where_to_export> is an integer telling how far up the calling stack
|
||||
to export your symbols, and C<@what_to_export> is an array telling what
|
||||
symbols *to* export (usually this is C<@_>). The C<$package> argument is
|
||||
currently unused.
|
||||
|
||||
For example, suppose that you have a module, A, which already has an
|
||||
import function:
|
||||
|
||||
package A;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw ($b);
|
||||
|
||||
sub import
|
||||
{
|
||||
$A::b = 1; # not a very useful import method
|
||||
}
|
||||
|
||||
and you want to Export symbol C<$A::b> back to the module that called
|
||||
package A. Since Exporter relies on the import method to work, via
|
||||
inheritance, as it stands Exporter::import() will never get called.
|
||||
Instead, say the following:
|
||||
|
||||
package A;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw ($b);
|
||||
|
||||
sub import
|
||||
{
|
||||
$A::b = 1;
|
||||
A->export_to_level(1, @_);
|
||||
}
|
||||
|
||||
This will export the symbols one level 'above' the current package - ie: to
|
||||
the program or module that used package A.
|
||||
|
||||
Note: Be careful not to modify C<@_> at all before you call export_to_level
|
||||
- or people using your package will get very unexplained results!
|
||||
|
||||
=head2 Exporting without inheriting from Exporter
|
||||
|
||||
By including Exporter in your C<@ISA> you inherit an Exporter's import() method
|
||||
but you also inherit several other helper methods which you probably don't
|
||||
want. To avoid this you can do
|
||||
|
||||
package YourModule;
|
||||
use Exporter qw( import );
|
||||
|
||||
which will export Exporter's own import() method into YourModule.
|
||||
Everything will work as before but you won't need to include Exporter in
|
||||
C<@YourModule::ISA>.
|
||||
|
||||
Note: This feature was introduced in version 5.57
|
||||
of Exporter, released with perl 5.8.3.
|
||||
|
||||
=head2 Module Version Checking
|
||||
|
||||
The Exporter module will convert an attempt to import a number from a
|
||||
module into a call to C<< $module_name->require_version($value) >>. This can
|
||||
be used to validate that the version of the module being used is
|
||||
greater than or equal to the required version.
|
||||
|
||||
The Exporter module supplies a default C<require_version> method which
|
||||
checks the value of C<$VERSION> in the exporting module.
|
||||
|
||||
Since the default C<require_version> method treats the C<$VERSION> number as
|
||||
a simple numeric value it will regard version 1.10 as lower than
|
||||
1.9. For this reason it is strongly recommended that you use numbers
|
||||
with at least two decimal places, e.g., 1.09.
|
||||
|
||||
=head2 Managing Unknown Symbols
|
||||
|
||||
In some situations you may want to prevent certain symbols from being
|
||||
exported. Typically this applies to extensions which have functions
|
||||
or constants that may not exist on some systems.
|
||||
|
||||
The names of any symbols that cannot be exported should be listed
|
||||
in the C<@EXPORT_FAIL> array.
|
||||
|
||||
If a module attempts to import any of these symbols the Exporter
|
||||
will give the module an opportunity to handle the situation before
|
||||
generating an error. The Exporter will call an export_fail method
|
||||
with a list of the failed symbols:
|
||||
|
||||
@failed_symbols = $module_name->export_fail(@failed_symbols);
|
||||
|
||||
If the C<export_fail> method returns an empty list then no error is
|
||||
recorded and all the requested symbols are exported. If the returned
|
||||
list is not empty then an error is generated for each symbol and the
|
||||
export fails. The Exporter provides a default C<export_fail> method which
|
||||
simply returns the list unchanged.
|
||||
|
||||
Uses for the C<export_fail> method include giving better error messages
|
||||
for some symbols and performing lazy architectural checks (put more
|
||||
symbols into C<@EXPORT_FAIL> by default and then take them out if someone
|
||||
actually tries to use them and an expensive check shows that they are
|
||||
usable on that platform).
|
||||
|
||||
=head2 Tag Handling Utility Functions
|
||||
|
||||
Since the symbols listed within C<%EXPORT_TAGS> must also appear in either
|
||||
C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow
|
||||
you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>:
|
||||
|
||||
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
|
||||
|
||||
Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
|
||||
Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
|
||||
|
||||
Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK>
|
||||
unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
|
||||
names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions
|
||||
may make this a fatal error.
|
||||
|
||||
=head2 Generating combined tags
|
||||
|
||||
If several symbol categories exist in C<%EXPORT_TAGS>, it's usually
|
||||
useful to create the utility ":all" to simplify "use" statements.
|
||||
|
||||
The simplest way to do this is:
|
||||
|
||||
%EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
|
||||
|
||||
# add all the other ":class" tags to the ":all" class,
|
||||
# deleting duplicates
|
||||
{
|
||||
my %seen;
|
||||
|
||||
push @{$EXPORT_TAGS{all}},
|
||||
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
|
||||
}
|
||||
|
||||
F<CGI.pm> creates an ":all" tag which contains some (but not really
|
||||
all) of its categories. That could be done with one small
|
||||
change:
|
||||
|
||||
# add some of the other ":class" tags to the ":all" class,
|
||||
# deleting duplicates
|
||||
{
|
||||
my %seen;
|
||||
|
||||
push @{$EXPORT_TAGS{all}},
|
||||
grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}}
|
||||
foreach qw/html2 html3 netscape form cgi internal/;
|
||||
}
|
||||
|
||||
Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'.
|
||||
|
||||
=head2 C<AUTOLOAD>ed Constants
|
||||
|
||||
Many modules make use of C<AUTOLOAD>ing for constant subroutines to
|
||||
avoid having to compile and waste memory on rarely used values (see
|
||||
L<perlsub> for details on constant subroutines). Calls to such
|
||||
constant subroutines are not optimized away at compile time because
|
||||
they can't be checked at compile time for constancy.
|
||||
|
||||
Even if a prototype is available at compile time, the body of the
|
||||
subroutine is not (it hasn't been C<AUTOLOAD>ed yet). perl needs to
|
||||
examine both the C<()> prototype and the body of a subroutine at
|
||||
compile time to detect that it can safely replace calls to that
|
||||
subroutine with the constant value.
|
||||
|
||||
A workaround for this is to call the constants once in a C<BEGIN> block:
|
||||
|
||||
package My ;
|
||||
|
||||
use Socket ;
|
||||
|
||||
foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime
|
||||
BEGIN { SO_LINGER }
|
||||
foo( SO_LINGER ); ## SO_LINGER optimized away at compile time.
|
||||
|
||||
This forces the C<AUTOLOAD> for C<SO_LINGER> to take place before
|
||||
SO_LINGER is encountered later in C<My> package.
|
||||
|
||||
If you are writing a package that C<AUTOLOAD>s, consider forcing
|
||||
an C<AUTOLOAD> for any constants explicitly imported by other packages
|
||||
or which are usually used when your package is C<use>d.
|
||||
|
||||
=head1 Good Practices
|
||||
|
||||
=head2 Declaring C<@EXPORT_OK> and Friends
|
||||
|
||||
When using C<Exporter> with the standard C<strict> and C<warnings>
|
||||
pragmas, the C<our> keyword is needed to declare the package
|
||||
variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc.
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(munge frobnicate);
|
||||
|
||||
If backward compatibility for Perls under 5.6 is important,
|
||||
one must write instead a C<use vars> statement.
|
||||
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(munge frobnicate);
|
||||
|
||||
=head2 Playing Safe
|
||||
|
||||
There are some caveats with the use of runtime statements
|
||||
like C<require Exporter> and the assignment to package
|
||||
variables, which can very subtle for the unaware programmer.
|
||||
This may happen for instance with mutually recursive
|
||||
modules, which are affected by the time the relevant
|
||||
constructions are executed.
|
||||
|
||||
The ideal (but a bit ugly) way to never have to think
|
||||
about that is to use C<BEGIN> blocks. So the first part
|
||||
of the L</SYNOPSIS> code could be rewritten as:
|
||||
|
||||
package YourModule;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our (@ISA, @EXPORT_OK);
|
||||
BEGIN {
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(munge frobnicate); # symbols to export on request
|
||||
}
|
||||
|
||||
The C<BEGIN> will assure that the loading of F<Exporter.pm>
|
||||
and the assignments to C<@ISA> and C<@EXPORT_OK> happen
|
||||
immediately, leaving no room for something to get awry
|
||||
or just plain wrong.
|
||||
|
||||
With respect to loading C<Exporter> and inheriting, there
|
||||
are alternatives with the use of modules like C<base> and C<parent>.
|
||||
|
||||
use base qw( Exporter );
|
||||
# or
|
||||
use parent qw( Exporter );
|
||||
|
||||
Any of these statements are nice replacements for
|
||||
C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
|
||||
with the same compile-time effect. The basic difference
|
||||
is that C<base> code interacts with declared C<fields>
|
||||
while C<parent> is a streamlined version of the older
|
||||
C<base> code to just establish the IS-A relationship.
|
||||
|
||||
For more details, see the documentation and code of
|
||||
L<base> and L<parent>.
|
||||
|
||||
Another thorough remedy to that runtime vs.
|
||||
compile-time trap is to use L<Exporter::Easy>,
|
||||
which is a wrapper of Exporter that allows all
|
||||
boilerplate code at a single gulp in the
|
||||
use statement.
|
||||
|
||||
use Exporter::Easy (
|
||||
OK => [ qw(munge frobnicate) ],
|
||||
);
|
||||
# @ISA setup is automatic
|
||||
# all assignments happen at compile time
|
||||
|
||||
=head2 What not to Export
|
||||
|
||||
You have been warned already in L</Selecting What To Export>
|
||||
to not export:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
method names (because you don't need to
|
||||
and that's likely to not do what you want),
|
||||
|
||||
=item *
|
||||
|
||||
anything by default (because you don't want to surprise your users...
|
||||
badly)
|
||||
|
||||
=item *
|
||||
|
||||
anything you don't need to (because less is more)
|
||||
|
||||
=back
|
||||
|
||||
There's one more item to add to this list. Do B<not>
|
||||
export variable names. Just because C<Exporter> lets you
|
||||
do that, it does not mean you should.
|
||||
|
||||
@EXPORT_OK = qw( $svar @avar %hvar ); # DON'T!
|
||||
|
||||
Exporting variables is not a good idea. They can
|
||||
change under the hood, provoking horrible
|
||||
effects at-a-distance, that are too hard to track
|
||||
and to fix. Trust me: they are not worth it.
|
||||
|
||||
To provide the capability to set/get class-wide
|
||||
settings, it is best instead to provide accessors
|
||||
as subroutines or class methods instead.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
C<Exporter> is definitely not the only module with
|
||||
symbol exporter capabilities. At CPAN, you may find
|
||||
a bunch of them. Some are lighter. Some
|
||||
provide improved APIs and features. Peek the one
|
||||
that fits your needs. The following is
|
||||
a sample list of such modules.
|
||||
|
||||
Exporter::Easy
|
||||
Exporter::Lite
|
||||
Exporter::Renaming
|
||||
Exporter::Tidy
|
||||
Sub::Exporter / Sub::Installer
|
||||
Perl6::Export / Perl6::Export::Attrs
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software. You can redistribute it
|
||||
and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
248
testsuite/input-files/perl-v5.14.2/lib/Exporter/Heavy.pm
Normal file
248
testsuite/input-files/perl-v5.14.2/lib/Exporter/Heavy.pm
Normal file
|
|
@ -0,0 +1,248 @@
|
|||
package Exporter::Heavy;
|
||||
|
||||
use strict;
|
||||
no strict 'refs';
|
||||
|
||||
# On one line so MakeMaker will see it.
|
||||
require Exporter; our $VERSION = $Exporter::VERSION;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exporter::Heavy - Exporter guts
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
(internal use only)
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
No user-serviceable parts inside.
|
||||
|
||||
=cut
|
||||
|
||||
#
|
||||
# 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;
|
||||
186
testsuite/input-files/perl-v5.14.2/lib/Fcntl.pm
Normal file
186
testsuite/input-files/perl-v5.14.2/lib/Fcntl.pm
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
package Fcntl;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Fcntl - load the C Fcntl.h defines
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Fcntl;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is just a translation of the C F<fcntl.h> file.
|
||||
Unlike the old mechanism of requiring a translated F<fcntl.ph>
|
||||
file, this uses the B<h2xs> program (see the Perl source distribution)
|
||||
and your native C compiler. This means that it has a
|
||||
far more likely chance of getting the numbers right.
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
Only C<#define> symbols get translated; you must still correctly
|
||||
pack up your own arguments to pass as args for locking functions, etc.
|
||||
|
||||
=head1 EXPORTED SYMBOLS
|
||||
|
||||
By default your system's F_* and O_* constants (eg, F_DUPFD and
|
||||
O_CREAT) and the FD_CLOEXEC constant are exported into your namespace.
|
||||
|
||||
You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB
|
||||
and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>.
|
||||
|
||||
You can request that the old constants (FAPPEND, FASYNC, FCREAT,
|
||||
FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for
|
||||
compatibility reasons by using the tag C<:Fcompat>. For new
|
||||
applications the newer versions of these constants are suggested
|
||||
(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK,
|
||||
O_SYNC, O_TRUNC).
|
||||
|
||||
For ease of use also the SEEK_* constants (for seek() and sysseek(),
|
||||
e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are
|
||||
available for import. They can be imported either separately or using
|
||||
the tags C<:seek> and C<:mode>.
|
||||
|
||||
Please refer to your native fcntl(2), open(2), fseek(3), lseek(2)
|
||||
(equal to Perl's seek() and sysseek(), respectively), and chmod(2)
|
||||
documentation to see what constants are implemented in your system.
|
||||
|
||||
See L<perlopentut> to learn about the uses of the O_* constants
|
||||
with sysopen().
|
||||
|
||||
See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants.
|
||||
|
||||
See L<perlfunc/stat> about the S_I* constants.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
||||
|
||||
require Exporter;
|
||||
require XSLoader;
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = '1.11';
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
# 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
|
||||
)],
|
||||
);
|
||||
|
||||
# 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
|
||||
F_GETLEASE
|
||||
F_GETSIG
|
||||
F_NOTIFY
|
||||
F_SETLEASE
|
||||
F_SETSIG
|
||||
LOCK_MAND
|
||||
LOCK_READ
|
||||
LOCK_RW
|
||||
LOCK_WRITE
|
||||
O_IGNORE_CTTY
|
||||
O_NOATIME
|
||||
O_NOLINK
|
||||
O_NOTRANS
|
||||
), map {@{$_}} values %EXPORT_TAGS);
|
||||
|
||||
1;
|
||||
402
testsuite/input-files/perl-v5.14.2/lib/File/Basename.pm
Normal file
402
testsuite/input-files/perl-v5.14.2/lib/File/Basename.pm
Normal 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;
|
||||
|
||||
# File::Basename is used during the Perl build, when the re extension may
|
||||
# not be available, but we only actually need it if running under tainting.
|
||||
BEGIN {
|
||||
if (${^TAINT}) {
|
||||
require re;
|
||||
re->import('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.82";
|
||||
|
||||
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 propagated 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>
|
||||
437
testsuite/input-files/perl-v5.14.2/lib/File/Glob.pm
Normal file
437
testsuite/input-files/perl-v5.14.2/lib/File/Glob.pm
Normal file
|
|
@ -0,0 +1,437 @@
|
|||
package File::Glob;
|
||||
|
||||
use strict;
|
||||
our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
|
||||
|
||||
require XSLoader;
|
||||
use feature 'switch';
|
||||
|
||||
@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_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
|
||||
) ],
|
||||
);
|
||||
|
||||
@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
|
||||
|
||||
$VERSION = '1.13';
|
||||
|
||||
sub import {
|
||||
require Exporter;
|
||||
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
|
||||
Exporter::import(grep {
|
||||
my $passthrough;
|
||||
given ($_) {
|
||||
$DEFAULT_FLAGS &= ~GLOB_NOCASE() when ':case';
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE() when ':nocase';
|
||||
when (':globally') {
|
||||
no warnings 'redefine';
|
||||
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
|
||||
}
|
||||
$passthrough = 1;
|
||||
}
|
||||
$passthrough;
|
||||
} @_);
|
||||
}
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
$DEFAULT_FLAGS = GLOB_CSH();
|
||||
if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) {
|
||||
$DEFAULT_FLAGS |= GLOB_NOCASE();
|
||||
}
|
||||
|
||||
# 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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Glob - Perl extension for BSD glob routine
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Glob ':glob';
|
||||
|
||||
@list = bsd_glob('*.[ch]');
|
||||
$homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR);
|
||||
|
||||
if (GLOB_ERROR) {
|
||||
# an error occurred reading $homedir
|
||||
}
|
||||
|
||||
## override the core glob (CORE::glob() does this automatically
|
||||
## by default anyway, since v5.6.0)
|
||||
use File::Glob ':globally';
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## override the core glob, forcing case sensitivity
|
||||
use File::Glob qw(:globally :case);
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## override the core glob forcing case insensitivity
|
||||
use File::Glob qw(:globally :nocase);
|
||||
my @sources = <*.{c,h,y}>;
|
||||
|
||||
## glob on all files in home directory
|
||||
use File::Glob ':globally';
|
||||
my @sources = <~gnat/*>;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The glob angle-bracket operator C<< <> >> is a pathname generator that
|
||||
implements the rules for file name pattern matching used by Unix-like shells
|
||||
such as the Bourne shell or C shell.
|
||||
|
||||
File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is
|
||||
a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2").
|
||||
bsd_glob() takes a mandatory C<pattern> argument, and an optional
|
||||
C<flags> argument, and returns a list of filenames matching the
|
||||
pattern, with interpretation of the pattern modified by the C<flags>
|
||||
variable.
|
||||
|
||||
Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob().
|
||||
Note that they don't share the same prototype--CORE::glob() only accepts
|
||||
a single argument. Due to historical reasons, CORE::glob() will also
|
||||
split its argument on whitespace, treating it as multiple patterns,
|
||||
whereas bsd_glob() considers them as one pattern.
|
||||
|
||||
=head2 META CHARACTERS
|
||||
|
||||
\ Quote the next metacharacter
|
||||
[] Character class
|
||||
{} Multiple pattern
|
||||
* Match any string of characters
|
||||
? Match any single character
|
||||
~ User name home directory
|
||||
|
||||
The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to
|
||||
right order is preserved, with results of matches being sorted separately
|
||||
at a low level to preserve this order. As a special case C<{>, C<}>, and
|
||||
C<{}> are passed undisturbed.
|
||||
|
||||
=head2 POSIX FLAGS
|
||||
|
||||
The POSIX defined flags for bsd_glob() are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_ERR>
|
||||
|
||||
Force bsd_glob() to return an error when it encounters a directory it
|
||||
cannot open or read. Ordinarily bsd_glob() continues to find matches.
|
||||
|
||||
=item C<GLOB_LIMIT>
|
||||
|
||||
Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands
|
||||
to a size bigger than the system constant C<ARG_MAX> (usually found in
|
||||
limits.h). If your system does not define this constant, bsd_glob() uses
|
||||
C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that
|
||||
order). You can inspect these values using the standard C<POSIX>
|
||||
extension.
|
||||
|
||||
=item C<GLOB_MARK>
|
||||
|
||||
Each pathname that is a directory that matches the pattern has a slash
|
||||
appended.
|
||||
|
||||
=item C<GLOB_NOCASE>
|
||||
|
||||
By default, file names are assumed to be case sensitive; this flag
|
||||
makes bsd_glob() treat case differences as not significant.
|
||||
|
||||
=item C<GLOB_NOCHECK>
|
||||
|
||||
If the pattern does not match any pathname, then bsd_glob() returns a list
|
||||
consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect
|
||||
is present in the pattern returned.
|
||||
|
||||
=item C<GLOB_NOSORT>
|
||||
|
||||
By default, the pathnames are sorted in ascending ASCII order; this
|
||||
flag prevents that sorting (speeding up bsd_glob()).
|
||||
|
||||
=back
|
||||
|
||||
The FreeBSD extensions to the POSIX standard are the following flags:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_BRACE>
|
||||
|
||||
Pre-process the string to expand C<{pat,pat,...}> strings like csh(1).
|
||||
The pattern '{}' is left unexpanded for historical reasons (and csh(1)
|
||||
does the same thing to ease typing of find(1) patterns).
|
||||
|
||||
=item C<GLOB_NOMAGIC>
|
||||
|
||||
Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not
|
||||
contain any of the special characters "*", "?" or "[". C<NOMAGIC> is
|
||||
provided to simplify implementing the historic csh(1) globbing
|
||||
behaviour and should probably not be used anywhere else.
|
||||
|
||||
=item C<GLOB_QUOTE>
|
||||
|
||||
Use the backslash ('\') character for quoting: every occurrence of a
|
||||
backslash followed by a character in the pattern is replaced by that
|
||||
character, avoiding any special interpretation of the character.
|
||||
(But see below for exceptions on DOSISH systems).
|
||||
|
||||
=item C<GLOB_TILDE>
|
||||
|
||||
Expand patterns that start with '~' to user name home directories.
|
||||
|
||||
=item C<GLOB_CSH>
|
||||
|
||||
For convenience, C<GLOB_CSH> is a synonym for
|
||||
C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>.
|
||||
|
||||
=back
|
||||
|
||||
The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD
|
||||
extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been
|
||||
implemented in the Perl version because they involve more complex
|
||||
interaction with the underlying C structures.
|
||||
|
||||
The following flag has been added in the Perl implementation for
|
||||
csh compatibility:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_ALPHASORT>
|
||||
|
||||
If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical
|
||||
order (case does not matter) rather than in ASCII order.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
bsd_glob() returns a list of matching paths, possibly zero length. If an
|
||||
error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be
|
||||
set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred,
|
||||
or one of the following values otherwise:
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<GLOB_NOSPACE>
|
||||
|
||||
An attempt to allocate memory failed.
|
||||
|
||||
=item C<GLOB_ABEND>
|
||||
|
||||
The glob was stopped because an error was encountered.
|
||||
|
||||
=back
|
||||
|
||||
In the case where bsd_glob() has found some matching paths, but is
|
||||
interrupted by an error, it will return a list of filenames B<and>
|
||||
set &File::Glob::ERROR.
|
||||
|
||||
Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour
|
||||
by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will
|
||||
continue processing despite those errors, unless the C<GLOB_ERR> flag is
|
||||
set.
|
||||
|
||||
Be aware that all filenames returned from File::Glob are tainted.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should
|
||||
probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because
|
||||
the argument to bsd_glob() isn't subjected to parsing by the C shell.
|
||||
Remember that you can use a backslash to escape things.
|
||||
|
||||
=item *
|
||||
|
||||
On DOSISH systems, backslash is a valid directory separator character.
|
||||
In this case, use of backslash as a quoting character (via GLOB_QUOTE)
|
||||
interferes with the use of backslash as a directory separator. The
|
||||
best (simplest, most portable) solution is to use forward slashes for
|
||||
directory separators, and backslashes for quoting. However, this does
|
||||
not match "normal practice" on these systems. As a concession to user
|
||||
expectation, therefore, backslashes (under GLOB_QUOTE) only quote the
|
||||
glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself.
|
||||
All other backslashes are passed through unchanged.
|
||||
|
||||
=item *
|
||||
|
||||
Win32 users should use the real slash. If you really want to use
|
||||
backslashes, consider using Sarathy's File::DosGlob, which comes with
|
||||
the standard Perl distribution.
|
||||
|
||||
=item *
|
||||
|
||||
Mac OS (Classic) users should note a few differences. Since
|
||||
Mac OS is not Unix, when the glob code encounters a tilde glob (e.g.
|
||||
~user) and the C<GLOB_TILDE> flag is used, it simply returns that
|
||||
pattern without doing any expansion.
|
||||
|
||||
Glob on Mac OS is case-insensitive by default (if you don't use any
|
||||
flags). If you specify any flags at all and still want glob
|
||||
to be case-insensitive, you must include C<GLOB_NOCASE> in the flags.
|
||||
|
||||
The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users
|
||||
should be careful about specifying relative pathnames. While a full path
|
||||
always begins with a volume name, a relative pathname should always
|
||||
begin with a ':'. If specifying a volume name only, a trailing ':' is
|
||||
required.
|
||||
|
||||
The specification of pathnames in glob patterns adheres to the usual Mac
|
||||
OS conventions: The path separator is a colon ':', not a slash '/'. A
|
||||
full path always begins with a volume name. A relative pathname on Mac
|
||||
OS must always begin with a ':', except when specifying a file or
|
||||
directory name in the current working directory, where the leading colon
|
||||
is optional. If specifying a volume name only, a trailing ':' is
|
||||
required. Due to these rules, a glob like E<lt>*:E<gt> will find all
|
||||
mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
|
||||
all files and directories in the current directory.
|
||||
|
||||
Note that updirs in the glob pattern are resolved before the matching begins,
|
||||
i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
|
||||
that a single trailing ':' in the pattern is ignored (unless it's a volume
|
||||
name pattern like "*HD:"), i.e. a glob like E<lt>:*:E<gt> will find both
|
||||
directories I<and> files (and not, as one might expect, only directories).
|
||||
You can, however, use the C<GLOB_MARK> flag to distinguish (without a file
|
||||
test) directory names from file names.
|
||||
|
||||
If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended.
|
||||
Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS,
|
||||
both a leading and a trailing colon will be added, when the directory name in
|
||||
question doesn't contain any colons (e.g. 'lib' becomes ':lib:').
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc/glob>, glob(3)
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>,
|
||||
and is released under the artistic license. Further modifications were
|
||||
made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy
|
||||
E<lt>gsar@activestate.comE<gt>, and Thomas Wegner
|
||||
E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the
|
||||
following copyright:
|
||||
|
||||
Copyright (c) 1989, 1993 The Regents of the University of California.
|
||||
All rights reserved.
|
||||
|
||||
This code is derived from software contributed to Berkeley by
|
||||
Guido van Rossum.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions
|
||||
are met:
|
||||
|
||||
1. Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
2. Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in the
|
||||
documentation and/or other materials provided with the distribution.
|
||||
3. Neither the name of the University nor the names of its contributors
|
||||
may be used to endorse or promote products derived from this software
|
||||
without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
|
||||
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
|
||||
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||||
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||||
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||||
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
|
||||
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
|
||||
SUCH DAMAGE.
|
||||
|
||||
=cut
|
||||
981
testsuite/input-files/perl-v5.14.2/lib/File/Path.pm
Normal file
981
testsuite/input-files/perl-v5.14.2/lib/File/Path.pm
Normal file
|
|
@ -0,0 +1,981 @@
|
|||
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.08_01';
|
||||
@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};
|
||||
$arg->{owner} = delete $arg->{user} if exists $arg->{user};
|
||||
$arg->{owner} = delete $arg->{uid} if exists $arg->{uid};
|
||||
if (exists $arg->{owner} and $arg->{owner} =~ /\D/) {
|
||||
my $uid = (getpwnam $arg->{owner})[2];
|
||||
if (defined $uid) {
|
||||
$arg->{owner} = $uid;
|
||||
}
|
||||
else {
|
||||
_error($arg, "unable to map $arg->{owner} to a uid, ownership not changed");
|
||||
delete $arg->{owner};
|
||||
}
|
||||
}
|
||||
if (exists $arg->{group} and $arg->{group} =~ /\D/) {
|
||||
my $gid = (getgrnam $arg->{group})[2];
|
||||
if (defined $gid) {
|
||||
$arg->{group} = $gid;
|
||||
}
|
||||
else {
|
||||
_error($arg, "unable to map $arg->{group} to a gid, group ownership not changed");
|
||||
delete $arg->{group};
|
||||
}
|
||||
}
|
||||
if (exists $arg->{owner} and not exists $arg->{group}) {
|
||||
$arg->{group} = -1; # chown will leave group unchanged
|
||||
}
|
||||
if (exists $arg->{group} and not exists $arg->{owner}) {
|
||||
$arg->{owner} = -1; # chown will leave owner unchanged
|
||||
}
|
||||
$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);
|
||||
if (exists $arg->{owner}) {
|
||||
# NB: $arg->{group} guaranteed to be set during initialisation
|
||||
if (!chown $arg->{owner}, $arg->{group}, $path) {
|
||||
_error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}");
|
||||
}
|
||||
}
|
||||
}
|
||||
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::vmspath(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;
|
||||
}
|
||||
|
||||
@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.08 of File::Path, released
|
||||
2009-10-04.
|
||||
|
||||
=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.
|
||||
|
||||
=item owner => $owner
|
||||
|
||||
=item user => $owner
|
||||
|
||||
=item uid => $owner
|
||||
|
||||
If present, will cause any created directory to be owned by C<$owner>.
|
||||
If the value is numeric, it will be interpreted as a uid, otherwise
|
||||
as username is assumed. An error will be issued if the username cannot be
|
||||
mapped to a uid, or the uid does not exist, or the process lacks the
|
||||
privileges to change ownership.
|
||||
|
||||
Ownwership of directories that already exist will not be changed.
|
||||
|
||||
C<user> and C<uid> are aliases of C<owner>.
|
||||
|
||||
=item group => $group
|
||||
|
||||
If present, will cause any created directory to be owned by the group C<$group>.
|
||||
If the value is numeric, it will be interpreted as a gid, otherwise
|
||||
as group name is assumed. An error will be issued if the group name cannot be
|
||||
mapped to a gid, or the gid does not exist, or the process lacks the
|
||||
privileges to change group ownership.
|
||||
|
||||
Group ownwership of directories that already exist will not be changed.
|
||||
|
||||
make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
|
||||
|
||||
=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 API CHANGES
|
||||
|
||||
The API was changed in the 2.0 branch. For a time, C<mkpath> and
|
||||
C<rmtree> tried, unsuccessfully, to deal with the two different
|
||||
calling mechanisms. This approach was considered a failure.
|
||||
|
||||
The new semantics are now only available with C<make_path> and
|
||||
C<remove_tree>. The old semantics are only available through
|
||||
C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
|
||||
to at least 2.08 in order to avoid surprises.
|
||||
|
||||
=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).
|
||||
|
||||
=item unable to map [owner] to a uid, ownership not changed");
|
||||
|
||||
C<make_path> was instructed to give the ownership of created
|
||||
directories to the symbolic name [owner], but C<getpwnam> did
|
||||
not return the corresponding numeric uid. The directory will
|
||||
be created, but ownership will not be changed.
|
||||
|
||||
=item unable to map [group] to a gid, group ownership not changed
|
||||
|
||||
C<make_path> was instructed to give the group ownership of created
|
||||
directories to the symbolic name [group], but C<getgrnam> did
|
||||
not return the corresponding numeric gid. The directory will
|
||||
be created, but group ownership will not be changed.
|
||||
|
||||
=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-2009. 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
|
||||
337
testsuite/input-files/perl-v5.14.2/lib/File/Spec.pm
Normal file
337
testsuite/input-files/perl-v5.14.2/lib/File/Spec.pm
Normal file
|
|
@ -0,0 +1,337 @@
|
|||
package File::Spec;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION);
|
||||
|
||||
$VERSION = '3.33';
|
||||
$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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec - portably perform operations on file names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Spec;
|
||||
|
||||
$x=File::Spec->catfile('a', 'b', 'c');
|
||||
|
||||
which returns 'a/b/c' under Unix. Or:
|
||||
|
||||
use File::Spec::Functions;
|
||||
|
||||
$x = catfile('a', 'b', 'c');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to support operations commonly performed on file
|
||||
specifications (usually called "file names", but not to be confused with the
|
||||
contents of a file, or Perl's file handles), such as concatenating several
|
||||
directory and file names into a single path, or determining whether a path
|
||||
is rooted. It is based on code directly taken from MakeMaker 5.17, code
|
||||
written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
|
||||
Zakharevich, Paul Schinder, and others.
|
||||
|
||||
Since these functions are different for most operating systems, each set of
|
||||
OS specific routines is available in a separate module, including:
|
||||
|
||||
File::Spec::Unix
|
||||
File::Spec::Mac
|
||||
File::Spec::OS2
|
||||
File::Spec::Win32
|
||||
File::Spec::VMS
|
||||
|
||||
The module appropriate for the current OS is automatically loaded by
|
||||
File::Spec. Since some modules (like VMS) make use of facilities available
|
||||
only under that OS, it may not be possible to load all modules under all
|
||||
operating systems.
|
||||
|
||||
Since File::Spec is object oriented, subroutines should not be called directly,
|
||||
as in:
|
||||
|
||||
File::Spec::catfile('a','b');
|
||||
|
||||
but rather as class methods:
|
||||
|
||||
File::Spec->catfile('a','b');
|
||||
|
||||
For simple uses, L<File::Spec::Functions> provides convenient functional
|
||||
forms of these methods.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item canonpath
|
||||
X<canonpath>
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path.
|
||||
|
||||
$cpath = File::Spec->canonpath( $path ) ;
|
||||
|
||||
Note that this does *not* collapse F<x/../y> sections into F<y>. This
|
||||
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
|
||||
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
|
||||
F<../>-removal would give you. If you want to do this kind of
|
||||
processing, you probably want C<Cwd>'s C<realpath()> function to
|
||||
actually traverse the filesystem cleaning up paths like this.
|
||||
|
||||
=item catdir
|
||||
X<catdir>
|
||||
|
||||
Concatenate two or more directory names to form a complete path ending
|
||||
with a directory. But remove the trailing slash from the resulting
|
||||
string, because it doesn't look good, isn't necessary and confuses
|
||||
OS/2. Of course, if this is the root directory, don't cut off the
|
||||
trailing slash :-)
|
||||
|
||||
$path = File::Spec->catdir( @directories );
|
||||
|
||||
=item catfile
|
||||
X<catfile>
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename
|
||||
|
||||
$path = File::Spec->catfile( @directories, $filename );
|
||||
|
||||
=item curdir
|
||||
X<curdir>
|
||||
|
||||
Returns a string representation of the current directory.
|
||||
|
||||
$curdir = File::Spec->curdir();
|
||||
|
||||
=item devnull
|
||||
X<devnull>
|
||||
|
||||
Returns a string representation of the null device.
|
||||
|
||||
$devnull = File::Spec->devnull();
|
||||
|
||||
=item rootdir
|
||||
X<rootdir>
|
||||
|
||||
Returns a string representation of the root directory.
|
||||
|
||||
$rootdir = File::Spec->rootdir();
|
||||
|
||||
=item tmpdir
|
||||
X<tmpdir>
|
||||
|
||||
Returns a string representation of the first writable directory from a
|
||||
list of possible temporary directories. Returns the current directory
|
||||
if no writable temporary directories are found. The list of directories
|
||||
checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
|
||||
(unless taint is on) and F</tmp>.
|
||||
|
||||
$tmpdir = File::Spec->tmpdir();
|
||||
|
||||
=item updir
|
||||
X<updir>
|
||||
|
||||
Returns a string representation of the parent directory.
|
||||
|
||||
$updir = File::Spec->updir();
|
||||
|
||||
=item no_upwards
|
||||
|
||||
Given a list of file names, strip out those that refer to a parent
|
||||
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
|
||||
|
||||
@paths = File::Spec->no_upwards( @paths );
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
Returns a true or false value indicating, respectively, that alphabetic
|
||||
case is not or is significant when comparing file specifications.
|
||||
Cygwin and Win32 accept an optional drive argument.
|
||||
|
||||
$is_case_tolerant = File::Spec->case_tolerant();
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Takes as its argument a path, and returns true if it is an absolute path.
|
||||
|
||||
$is_absolute = File::Spec->file_name_is_absolute( $path );
|
||||
|
||||
This does not consult the local filesystem on Unix, Win32, OS/2, or
|
||||
Mac OS (Classic). It does consult the working environment for VMS
|
||||
(see L<File::Spec::VMS/file_name_is_absolute>).
|
||||
|
||||
=item path
|
||||
X<path>
|
||||
|
||||
Takes no argument. Returns the environment variable C<PATH> (or the local
|
||||
platform's equivalent) as a list.
|
||||
|
||||
@PATH = File::Spec->path();
|
||||
|
||||
=item join
|
||||
X<join, path>
|
||||
|
||||
join is the same as catfile.
|
||||
|
||||
=item splitpath
|
||||
X<splitpath> X<split, path>
|
||||
|
||||
Splits a path in to volume, directory, and filename portions. On systems
|
||||
with no concept of volume, returns '' for volume.
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
|
||||
|
||||
For systems with no syntax differentiating filenames from directories,
|
||||
assumes that the last file is a path unless C<$no_file> is true or a
|
||||
trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
|
||||
true makes this return ( '', $path, '' ).
|
||||
|
||||
The directory portion may or may not be returned with a trailing '/'.
|
||||
|
||||
The results can be passed to L</catpath()> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
=item splitdir
|
||||
X<splitdir> X<split, dir>
|
||||
|
||||
The opposite of L</catdir>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
C<$directories> must be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories.
|
||||
|
||||
Unlike just splitting the directories on the separator, empty
|
||||
directory names (C<''>) can be returned, because these are significant
|
||||
on some OSes.
|
||||
|
||||
=item catpath()
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. Under
|
||||
Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
|
||||
inserted if need be. On other OSes, C<$volume> is significant.
|
||||
|
||||
$full_path = File::Spec->catpath( $volume, $directory, $file );
|
||||
|
||||
=item abs2rel
|
||||
X<abs2rel> X<absolute, path> X<relative, path>
|
||||
|
||||
Takes a destination path and an optional base path returns a relative path
|
||||
from the base path to the destination path:
|
||||
|
||||
$rel_path = File::Spec->abs2rel( $path ) ;
|
||||
$rel_path = File::Spec->abs2rel( $path, $base ) ;
|
||||
|
||||
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<Cwd::cwd()|Cwd>.
|
||||
|
||||
On systems with the concept of volume, if C<$path> and C<$base> appear to be
|
||||
on two different volumes, we will not attempt to resolve the two
|
||||
paths, and we will instead simply return C<$path>. Note that previous
|
||||
versions of this module ignored the volume of C<$base>, which resulted in
|
||||
garbage results part of the time.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
C<$base> filename as well. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
|
||||
This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=item rel2abs()
|
||||
X<rel2abs> X<absolute, path> X<relative, path>
|
||||
|
||||
Converts a relative path to an absolute path.
|
||||
|
||||
$abs_path = File::Spec->rel2abs( $path ) ;
|
||||
$abs_path = File::Spec->rel2abs( $path, $base ) ;
|
||||
|
||||
If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
|
||||
then it is converted to absolute form using L</rel2abs()>. This means that it
|
||||
is taken to be relative to L<Cwd::cwd()|Cwd>.
|
||||
|
||||
On systems with the concept of volume, if C<$path> and C<$base> appear to be
|
||||
on two different volumes, we will not attempt to resolve the two
|
||||
paths, and we will instead simply return C<$path>. Note that previous
|
||||
versions of this module ignored the volume of C<$base>, which resulted in
|
||||
garbage results part of the time.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
C<$base> filename as well. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=back
|
||||
|
||||
For further information, please see L<File::Spec::Unix>,
|
||||
L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
|
||||
L<File::Spec::VMS>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
|
||||
L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
|
||||
L<ExtUtils::MakeMaker>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>.
|
||||
|
||||
The vast majority of the code was written by
|
||||
Kenneth Albanowski C<< <kjahds@kjahds.com> >>,
|
||||
Andy Dougherty C<< <doughera@lafayette.edu> >>,
|
||||
Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>,
|
||||
Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>.
|
||||
VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>.
|
||||
OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>.
|
||||
Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and
|
||||
Thomas Wegner C<< <wegner_thomas@yahoo.com> >>.
|
||||
abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>,
|
||||
modified by Barrie Slaymaker C<< <barries@slaysys.com> >>.
|
||||
splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004-2010 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
521
testsuite/input-files/perl-v5.14.2/lib/File/Spec/Unix.pm
Normal file
521
testsuite/input-files/perl-v5.14.2/lib/File/Spec/Unix.pm
Normal file
|
|
@ -0,0 +1,521 @@
|
|||
package File::Spec::Unix;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = '3.33';
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
require File::Spec::Unix; # Done automatically by File::Spec
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Methods for manipulating file specifications. Other File::Spec
|
||||
modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
|
||||
override specific methods.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 2
|
||||
|
||||
=item canonpath()
|
||||
|
||||
No physical check on the filesystem, but a logical cleanup of a
|
||||
path. On UNIX eliminates successive slashes and successive "/.".
|
||||
|
||||
$cpath = File::Spec->canonpath( $path ) ;
|
||||
|
||||
Note that this does *not* collapse F<x/../y> sections into F<y>. This
|
||||
is by design. If F</foo> on your system is a symlink to F</bar/baz>,
|
||||
then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
|
||||
F<../>-removal would give you. If you want to do this kind of
|
||||
processing, you probably want C<Cwd>'s C<realpath()> function to
|
||||
actually traverse the filesystem cleaning up paths like this.
|
||||
|
||||
=cut
|
||||
|
||||
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";
|
||||
}
|
||||
|
||||
=item catdir()
|
||||
|
||||
Concatenate two or more directory names to form a complete path ending
|
||||
with a directory. But remove the trailing slash from the resulting
|
||||
string, because it doesn't look good, isn't necessary and confuses
|
||||
OS2. Of course, if this is the root directory, don't cut off the
|
||||
trailing slash :-)
|
||||
|
||||
=cut
|
||||
|
||||
sub catdir {
|
||||
my $self = shift;
|
||||
|
||||
$self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
|
||||
}
|
||||
|
||||
=item catfile
|
||||
|
||||
Concatenate one or more directory names and a filename to form a
|
||||
complete path ending with a filename
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
=item curdir
|
||||
|
||||
Returns a string representation of the current directory. "." on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub curdir { '.' }
|
||||
|
||||
=item devnull
|
||||
|
||||
Returns a string representation of the null device. "/dev/null" on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub devnull { '/dev/null' }
|
||||
|
||||
=item rootdir
|
||||
|
||||
Returns a string representation of the root directory. "/" on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub rootdir { '/' }
|
||||
|
||||
=item tmpdir
|
||||
|
||||
Returns a string representation of the first writable directory from
|
||||
the following list or the current directory if none from the list are
|
||||
writable:
|
||||
|
||||
$ENV{TMPDIR}
|
||||
/tmp
|
||||
|
||||
Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR}
|
||||
is tainted, it is not used.
|
||||
|
||||
=cut
|
||||
|
||||
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" );
|
||||
}
|
||||
|
||||
=item updir
|
||||
|
||||
Returns a string representation of the parent directory. ".." on UNIX.
|
||||
|
||||
=cut
|
||||
|
||||
sub updir { '..' }
|
||||
|
||||
=item no_upwards
|
||||
|
||||
Given a list of file names, strip out those that refer to a parent
|
||||
directory. (Does not strip symlinks, only '.', '..', and equivalents.)
|
||||
|
||||
=cut
|
||||
|
||||
sub no_upwards {
|
||||
my $self = shift;
|
||||
return grep(!/^\.{1,2}\z/s, @_);
|
||||
}
|
||||
|
||||
=item case_tolerant
|
||||
|
||||
Returns a true or false value indicating, respectively, that alphabetic
|
||||
is not or is significant when comparing file specifications.
|
||||
|
||||
=cut
|
||||
|
||||
sub case_tolerant { 0 }
|
||||
|
||||
=item file_name_is_absolute
|
||||
|
||||
Takes as argument a path and returns true if it is an absolute path.
|
||||
|
||||
This does not consult the local filesystem on Unix, Win32, OS/2 or Mac
|
||||
OS (Classic). It does consult the working environment for VMS (see
|
||||
L<File::Spec::VMS/file_name_is_absolute>).
|
||||
|
||||
=cut
|
||||
|
||||
sub file_name_is_absolute {
|
||||
my ($self,$file) = @_;
|
||||
return scalar($file =~ m:^/:s);
|
||||
}
|
||||
|
||||
=item path
|
||||
|
||||
Takes no argument, returns the environment variable PATH as an array.
|
||||
|
||||
=cut
|
||||
|
||||
sub path {
|
||||
return () unless exists $ENV{PATH};
|
||||
my @path = split(':', $ENV{PATH});
|
||||
foreach (@path) { $_ = '.' if $_ eq '' }
|
||||
return @path;
|
||||
}
|
||||
|
||||
=item join
|
||||
|
||||
join is the same as catfile.
|
||||
|
||||
=cut
|
||||
|
||||
sub join {
|
||||
my $self = shift;
|
||||
return $self->catfile(@_);
|
||||
}
|
||||
|
||||
=item splitpath
|
||||
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path );
|
||||
($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
|
||||
|
||||
Splits a path into volume, directory, and filename portions. On systems
|
||||
with no concept of volume, returns '' for volume.
|
||||
|
||||
For systems with no syntax differentiating filenames from directories,
|
||||
assumes that the last file is a path unless $no_file is true or a
|
||||
trailing separator or /. or /.. is present. On Unix this means that $no_file
|
||||
true makes this return ( '', $path, '' ).
|
||||
|
||||
The directory portion may or may not be returned with a trailing '/'.
|
||||
|
||||
The results can be passed to L</catpath()> to get back a path equivalent to
|
||||
(usually identical to) the original path.
|
||||
|
||||
=cut
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
|
||||
=item splitdir
|
||||
|
||||
The opposite of L</catdir()>.
|
||||
|
||||
@dirs = File::Spec->splitdir( $directories );
|
||||
|
||||
$directories must be only the directory portion of the path on systems
|
||||
that have the concept of a volume or that have path syntax that differentiates
|
||||
files from directories.
|
||||
|
||||
Unlike just splitting the directories on the separator, empty
|
||||
directory names (C<''>) can be returned, because these are significant
|
||||
on some OSs.
|
||||
|
||||
On Unix,
|
||||
|
||||
File::Spec->splitdir( "/a/b//c/" );
|
||||
|
||||
Yields:
|
||||
|
||||
( '', 'a', 'b', '', 'c', '' )
|
||||
|
||||
=cut
|
||||
|
||||
sub splitdir {
|
||||
return split m|/|, $_[1], -1; # Preserve trailing fields
|
||||
}
|
||||
|
||||
|
||||
=item catpath()
|
||||
|
||||
Takes volume, directory and file portions and returns an entire path. Under
|
||||
Unix, $volume is ignored, and directory and file are concatenated. A '/' is
|
||||
inserted if needed (though if the directory portion doesn't start with
|
||||
'/' it is not added). On other OSs, $volume is significant.
|
||||
|
||||
=cut
|
||||
|
||||
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 ;
|
||||
}
|
||||
|
||||
=item abs2rel
|
||||
|
||||
Takes a destination path and an optional base path returns a relative path
|
||||
from the base path to the destination path:
|
||||
|
||||
$rel_path = File::Spec->abs2rel( $path ) ;
|
||||
$rel_path = File::Spec->abs2rel( $path, $base ) ;
|
||||
|
||||
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<cwd()|Cwd>.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores the
|
||||
$base filename. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If $path is relative, it is converted to absolute form using L</rel2abs()>.
|
||||
This means that it is taken to be relative to L<cwd()|Cwd>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=cut
|
||||
|
||||
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];
|
||||
}
|
||||
|
||||
=item rel2abs()
|
||||
|
||||
Converts a relative path to an absolute path.
|
||||
|
||||
$abs_path = File::Spec->rel2abs( $path ) ;
|
||||
$abs_path = File::Spec->rel2abs( $path, $base ) ;
|
||||
|
||||
If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
|
||||
relative, then it is converted to absolute form using
|
||||
L</rel2abs()>. This means that it is taken to be relative to
|
||||
L<cwd()|Cwd>.
|
||||
|
||||
On systems that have a grammar that indicates filenames, this ignores
|
||||
the $base filename. Otherwise all path components are assumed to be
|
||||
directories.
|
||||
|
||||
If $path is absolute, it is cleaned up and returned using L</canonpath()>.
|
||||
|
||||
No checks against the filesystem are made. On VMS, there is
|
||||
interaction with the working environment, as logicals and
|
||||
macros are expanded.
|
||||
|
||||
Based on code written by Shigio Yamaguchi.
|
||||
|
||||
=cut
|
||||
|
||||
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 ) ;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<File::Spec>
|
||||
|
||||
=cut
|
||||
|
||||
# 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/perl-v5.14.2/lib/File/Temp.pm
Normal file
2452
testsuite/input-files/perl-v5.14.2/lib/File/Temp.pm
Normal file
File diff suppressed because it is too large
Load diff
262
testsuite/input-files/perl-v5.14.2/lib/FileHandle.pm
Normal file
262
testsuite/input-files/perl-v5.14.2/lib/FileHandle.pm
Normal file
|
|
@ -0,0 +1,262 @@
|
|||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
FileHandle - supply object methods for filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use FileHandle;
|
||||
|
||||
$fh = FileHandle->new;
|
||||
if ($fh->open("< file")) {
|
||||
print <$fh>;
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = FileHandle->new("> FOO");
|
||||
if (defined $fh) {
|
||||
print $fh "bar\n";
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = FileHandle->new("file", "r");
|
||||
if (defined $fh) {
|
||||
print <$fh>;
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
$fh = FileHandle->new("file", O_WRONLY|O_APPEND);
|
||||
if (defined $fh) {
|
||||
print $fh "corge\n";
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
$pos = $fh->getpos;
|
||||
$fh->setpos($pos);
|
||||
|
||||
$fh->setvbuf($buffer_var, _IOLBF, 1024);
|
||||
|
||||
($readfh, $writefh) = FileHandle::pipe;
|
||||
|
||||
autoflush STDOUT 1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
NOTE: This class is now a front-end to the IO::* classes.
|
||||
|
||||
C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
|
||||
newly created symbol (see the C<Symbol> package). If it receives any
|
||||
parameters, they are passed to C<FileHandle::open>; if the open fails,
|
||||
the C<FileHandle> object is destroyed. Otherwise, it is returned to
|
||||
the caller.
|
||||
|
||||
C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
|
||||
It requires two parameters, which are passed to C<FileHandle::fdopen>;
|
||||
if the fdopen fails, the C<FileHandle> object is destroyed.
|
||||
Otherwise, it is returned to the caller.
|
||||
|
||||
C<FileHandle::open> accepts one parameter or two. With one parameter,
|
||||
it is just a front end for the built-in C<open> function. With two
|
||||
parameters, the first parameter is a filename that may include
|
||||
whitespace or other special characters, and the second parameter is
|
||||
the open mode, optionally followed by a file permission value.
|
||||
|
||||
If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
|
||||
or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
|
||||
Perl C<open> operator.
|
||||
|
||||
If C<FileHandle::open> is given a numeric mode, it passes that mode
|
||||
and the optional permissions value to the Perl C<sysopen> operator.
|
||||
For convenience, C<FileHandle::import> tries to import the O_XXX
|
||||
constants from the Fcntl module. If dynamic loading is not available,
|
||||
this may fail, but the rest of FileHandle will still work.
|
||||
|
||||
C<FileHandle::fdopen> is like C<open> except that its first parameter
|
||||
is not a filename but rather a file handle name, a FileHandle object,
|
||||
or a file descriptor number.
|
||||
|
||||
If the C functions fgetpos() and fsetpos() are available, then
|
||||
C<FileHandle::getpos> returns an opaque value that represents the
|
||||
current position of the FileHandle, and C<FileHandle::setpos> uses
|
||||
that value to return to a previously visited position.
|
||||
|
||||
If the C function setvbuf() is available, then C<FileHandle::setvbuf>
|
||||
sets the buffering policy for the FileHandle. The calling sequence
|
||||
for the Perl function is the same as its C counterpart, including the
|
||||
macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
|
||||
parameter specifies a scalar variable to use as a buffer. WARNING: A
|
||||
variable used as a buffer by C<FileHandle::setvbuf> must not be
|
||||
modified in any way until the FileHandle is closed or until
|
||||
C<FileHandle::setvbuf> is called again, or memory corruption may
|
||||
result!
|
||||
|
||||
See L<perlfunc> for complete descriptions of each of the following
|
||||
supported C<FileHandle> methods, which are just front ends for the
|
||||
corresponding built-in functions:
|
||||
|
||||
close
|
||||
fileno
|
||||
getc
|
||||
gets
|
||||
eof
|
||||
clearerr
|
||||
seek
|
||||
tell
|
||||
|
||||
See L<perlvar> for complete descriptions of each of the following
|
||||
supported C<FileHandle> methods:
|
||||
|
||||
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
|
||||
|
||||
Furthermore, for doing normal I/O you might need these:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $fh->print
|
||||
|
||||
See L<perlfunc/print>.
|
||||
|
||||
=item $fh->printf
|
||||
|
||||
See L<perlfunc/printf>.
|
||||
|
||||
=item $fh->getline
|
||||
|
||||
This works like <$fh> described in L<perlop/"I/O Operators">
|
||||
except that it's more readable and can be safely called in a
|
||||
list context but still returns just one line.
|
||||
|
||||
=item $fh->getlines
|
||||
|
||||
This works like <$fh> when called in a list context to
|
||||
read all the remaining lines in a file, except that it's more readable.
|
||||
It will also croak() if accidentally called in a scalar context.
|
||||
|
||||
=back
|
||||
|
||||
There are many other functions available since FileHandle is descended
|
||||
from IO::File, IO::Seekable, and IO::Handle. Please see those
|
||||
respective pages for documentation on more functions.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
The B<IO> extension,
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">.
|
||||
|
||||
=cut
|
||||
2649
testsuite/input-files/perl-v5.14.2/lib/Getopt/Long.pm
Normal file
2649
testsuite/input-files/perl-v5.14.2/lib/Getopt/Long.pm
Normal file
File diff suppressed because it is too large
Load diff
68
testsuite/input-files/perl-v5.14.2/lib/IO.pm
Normal file
68
testsuite/input-files/perl-v5.14.2/lib/IO.pm
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
#
|
||||
|
||||
package IO;
|
||||
|
||||
use XSLoader ();
|
||||
use Carp;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = "1.25_04";
|
||||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO - load various IO modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File
|
||||
use IO; # DEPRECATED
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO> provides a simple mechanism to load several of the IO modules
|
||||
in one go. The IO modules belonging to the core are:
|
||||
|
||||
IO::Handle
|
||||
IO::Seekable
|
||||
IO::File
|
||||
IO::Pipe
|
||||
IO::Socket
|
||||
IO::Dir
|
||||
IO::Select
|
||||
IO::Poll
|
||||
|
||||
Some other IO modules don't belong to the perl core but can be loaded
|
||||
as well if they have been installed from CPAN. You can discover which
|
||||
ones exist by searching for "^IO::" on http://search.cpan.org.
|
||||
|
||||
For more information on any of these modules, please see its respective
|
||||
documentation.
|
||||
|
||||
=head1 DEPRECATED
|
||||
|
||||
use IO; # loads all the modules listed below
|
||||
|
||||
The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe,
|
||||
IO::Socket, IO::Dir. You should instead explicitly import the IO
|
||||
modules you want.
|
||||
|
||||
=cut
|
||||
|
||||
204
testsuite/input-files/perl-v5.14.2/lib/IO/File.pm
Normal file
204
testsuite/input-files/perl-v5.14.2/lib/IO/File.pm
Normal file
|
|
@ -0,0 +1,204 @@
|
|||
#
|
||||
|
||||
package IO::File;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::File - supply object methods for filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::File;
|
||||
|
||||
$fh = IO::File->new();
|
||||
if ($fh->open("< file")) {
|
||||
print <$fh>;
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = IO::File->new("> file");
|
||||
if (defined $fh) {
|
||||
print $fh "bar\n";
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$fh = IO::File->new("file", "r");
|
||||
if (defined $fh) {
|
||||
print <$fh>;
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
$fh = IO::File->new("file", O_WRONLY|O_APPEND);
|
||||
if (defined $fh) {
|
||||
print $fh "corge\n";
|
||||
|
||||
$pos = $fh->getpos;
|
||||
$fh->setpos($pos);
|
||||
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
autoflush STDOUT 1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
|
||||
these classes with methods that are specific to file handles.
|
||||
|
||||
=head1 CONSTRUCTOR
|
||||
|
||||
=over 4
|
||||
|
||||
=item new ( FILENAME [,MODE [,PERMS]] )
|
||||
|
||||
Creates an C<IO::File>. If it receives any parameters, they are passed to
|
||||
the method C<open>; if the open fails, the object is destroyed. Otherwise,
|
||||
it is returned to the caller.
|
||||
|
||||
=item new_tmpfile
|
||||
|
||||
Creates an C<IO::File> opened for read/write on a newly created temporary
|
||||
file. On systems where this is possible, the temporary file is anonymous
|
||||
(i.e. it is unlinked after creation, but held open). If the temporary
|
||||
file cannot be created or opened, the C<IO::File> object is destroyed.
|
||||
Otherwise, it is returned to the caller.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item open( FILENAME [,MODE [,PERMS]] )
|
||||
|
||||
=item open( FILENAME, IOLAYERS )
|
||||
|
||||
C<open> accepts one, two or three parameters. With one parameter,
|
||||
it is just a front end for the built-in C<open> function. With two or three
|
||||
parameters, the first parameter is a filename that may include
|
||||
whitespace or other special characters, and the second parameter is
|
||||
the open mode, optionally followed by a file permission value.
|
||||
|
||||
If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
|
||||
or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic
|
||||
Perl C<open> operator (but protects any special characters).
|
||||
|
||||
If C<IO::File::open> is given a numeric mode, it passes that mode
|
||||
and the optional permissions value to the Perl C<sysopen> operator.
|
||||
The permissions default to 0666.
|
||||
|
||||
If C<IO::File::open> is given a mode that includes the C<:> character,
|
||||
it passes all the three arguments to the three-argument C<open> operator.
|
||||
|
||||
For convenience, C<IO::File> exports the O_XXX constants from the
|
||||
Fcntl module, if this module is available.
|
||||
|
||||
=item binmode( [LAYER] )
|
||||
|
||||
C<binmode> sets C<binmode> on the underlying C<IO> object, as documented
|
||||
in C<perldoc -f binmode>.
|
||||
|
||||
C<binmode> accepts one optional parameter, which is the layer to be
|
||||
passed on to the C<binmode> call.
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
Some operating systems may perform C<IO::File::new()> or C<IO::File::open()>
|
||||
on a directory without errors. This behavior is not portable and not
|
||||
suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are
|
||||
suggested instead.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">,
|
||||
L<IO::Handle>,
|
||||
L<IO::Seekable>,
|
||||
L<IO::Dir>
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>.
|
||||
|
||||
=cut
|
||||
|
||||
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.15";
|
||||
|
||||
@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: $class->new([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;
|
||||
646
testsuite/input-files/perl-v5.14.2/lib/IO/Handle.pm
Normal file
646
testsuite/input-files/perl-v5.14.2/lib/IO/Handle.pm
Normal file
|
|
@ -0,0 +1,646 @@
|
|||
package IO::Handle;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Handle - supply object methods for I/O handles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Handle;
|
||||
|
||||
$io = IO::Handle->new();
|
||||
if ($io->fdopen(fileno(STDIN),"r")) {
|
||||
print $io->getline;
|
||||
$io->close;
|
||||
}
|
||||
|
||||
$io = IO::Handle->new();
|
||||
if ($io->fdopen(fileno(STDOUT),"w")) {
|
||||
$io->print("Some text\n");
|
||||
}
|
||||
|
||||
# setvbuf is not available by default on Perls 5.8.0 and later.
|
||||
use IO::Handle '_IOLBF';
|
||||
$io->setvbuf($buffer_var, _IOLBF, 1024);
|
||||
|
||||
undef $io; # automatically closes the file if it's open
|
||||
|
||||
autoflush STDOUT 1;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO::Handle> is the base class for all other IO handle classes. It is
|
||||
not intended that objects of C<IO::Handle> would be created directly,
|
||||
but instead C<IO::Handle> is inherited from by several other classes
|
||||
in the IO hierarchy.
|
||||
|
||||
If you are reading this documentation, looking for a replacement for
|
||||
the C<FileHandle> package, then I suggest you read the documentation
|
||||
for C<IO::File> too.
|
||||
|
||||
=head1 CONSTRUCTOR
|
||||
|
||||
=over 4
|
||||
|
||||
=item new ()
|
||||
|
||||
Creates a new C<IO::Handle> object.
|
||||
|
||||
=item new_from_fd ( FD, MODE )
|
||||
|
||||
Creates an C<IO::Handle> like C<new> does.
|
||||
It requires two parameters, which are passed to the method C<fdopen>;
|
||||
if the fdopen fails, the object is destroyed. Otherwise, it is returned
|
||||
to the caller.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
See L<perlfunc> for complete descriptions of each of the following
|
||||
supported C<IO::Handle> methods, which are just front ends for the
|
||||
corresponding built-in functions:
|
||||
|
||||
$io->close
|
||||
$io->eof
|
||||
$io->fcntl( FUNCTION, SCALAR )
|
||||
$io->fileno
|
||||
$io->format_write( [FORMAT_NAME] )
|
||||
$io->getc
|
||||
$io->ioctl( FUNCTION, SCALAR )
|
||||
$io->read ( BUF, LEN, [OFFSET] )
|
||||
$io->print ( ARGS )
|
||||
$io->printf ( FMT, [ARGS] )
|
||||
$io->say ( ARGS )
|
||||
$io->stat
|
||||
$io->sysread ( BUF, LEN, [OFFSET] )
|
||||
$io->syswrite ( BUF, [LEN, [OFFSET]] )
|
||||
$io->truncate ( LEN )
|
||||
|
||||
See L<perlvar> for complete descriptions of each of the following
|
||||
supported C<IO::Handle> methods. All of them return the previous
|
||||
value of the attribute and takes an optional single argument that when
|
||||
given will set the value. If no argument is given the previous value
|
||||
is unchanged (except for $io->autoflush will actually turn ON
|
||||
autoflush by default).
|
||||
|
||||
$io->autoflush ( [BOOL] ) $|
|
||||
$io->format_page_number( [NUM] ) $%
|
||||
$io->format_lines_per_page( [NUM] ) $=
|
||||
$io->format_lines_left( [NUM] ) $-
|
||||
$io->format_name( [STR] ) $~
|
||||
$io->format_top_name( [STR] ) $^
|
||||
$io->input_line_number( [NUM]) $.
|
||||
|
||||
The following methods are not supported on a per-filehandle basis.
|
||||
|
||||
IO::Handle->format_line_break_characters( [STR] ) $:
|
||||
IO::Handle->format_formfeed( [STR]) $^L
|
||||
IO::Handle->output_field_separator( [STR] ) $,
|
||||
IO::Handle->output_record_separator( [STR] ) $\
|
||||
|
||||
IO::Handle->input_record_separator( [STR] ) $/
|
||||
|
||||
Furthermore, for doing normal I/O you might need these:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $io->fdopen ( FD, MODE )
|
||||
|
||||
C<fdopen> is like an ordinary C<open> except that its first parameter
|
||||
is not a filename but rather a file handle name, an IO::Handle object,
|
||||
or a file descriptor number. (For the documentation of the C<open>
|
||||
method, see L<IO::File>.)
|
||||
|
||||
=item $io->opened
|
||||
|
||||
Returns true if the object is currently a valid file descriptor, false
|
||||
otherwise.
|
||||
|
||||
=item $io->getline
|
||||
|
||||
This works like <$io> described in L<perlop/"I/O Operators">
|
||||
except that it's more readable and can be safely called in a
|
||||
list context but still returns just one line. If used as the conditional
|
||||
+within a C<while> or C-style C<for> loop, however, you will need to
|
||||
+emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>.
|
||||
|
||||
=item $io->getlines
|
||||
|
||||
This works like <$io> when called in a list context to read all
|
||||
the remaining lines in a file, except that it's more readable.
|
||||
It will also croak() if accidentally called in a scalar context.
|
||||
|
||||
=item $io->ungetc ( ORD )
|
||||
|
||||
Pushes a character with the given ordinal value back onto the given
|
||||
handle's input stream. Only one character of pushback per handle is
|
||||
guaranteed.
|
||||
|
||||
=item $io->write ( BUF, LEN [, OFFSET ] )
|
||||
|
||||
This C<write> is like C<write> found in C, that is it is the
|
||||
opposite of read. The wrapper for the perl C<write> function is
|
||||
called C<format_write>.
|
||||
|
||||
=item $io->error
|
||||
|
||||
Returns a true value if the given handle has experienced any errors
|
||||
since it was opened or since the last call to C<clearerr>, or if the
|
||||
handle is invalid. It only returns false for a valid handle with no
|
||||
outstanding errors.
|
||||
|
||||
=item $io->clearerr
|
||||
|
||||
Clear the given handle's error indicator. Returns -1 if the handle is
|
||||
invalid, 0 otherwise.
|
||||
|
||||
=item $io->sync
|
||||
|
||||
C<sync> synchronizes a file's in-memory state with that on the
|
||||
physical medium. C<sync> does not operate at the perlio api level, but
|
||||
operates on the file descriptor (similar to sysread, sysseek and
|
||||
systell). This means that any data held at the perlio api level will not
|
||||
be synchronized. To synchronize data that is buffered at the perlio api
|
||||
level you must use the flush method. C<sync> is not implemented on all
|
||||
platforms. Returns "0 but true" on success, C<undef> on error, C<undef>
|
||||
for an invalid handle. See L<fsync(3c)>.
|
||||
|
||||
=item $io->flush
|
||||
|
||||
C<flush> causes perl to flush any buffered data at the perlio api level.
|
||||
Any unread data in the buffer will be discarded, and any unwritten data
|
||||
will be written to the underlying file descriptor. Returns "0 but true"
|
||||
on success, C<undef> on error.
|
||||
|
||||
=item $io->printflush ( ARGS )
|
||||
|
||||
Turns on autoflush, print ARGS and then restores the autoflush status of the
|
||||
C<IO::Handle> object. Returns the return value from print.
|
||||
|
||||
=item $io->blocking ( [ BOOL ] )
|
||||
|
||||
If called with an argument C<blocking> will turn on non-blocking IO if
|
||||
C<BOOL> is false, and turn it off if C<BOOL> is true.
|
||||
|
||||
C<blocking> will return the value of the previous setting, or the
|
||||
current setting if C<BOOL> is not given.
|
||||
|
||||
If an error occurs C<blocking> will return undef and C<$!> will be set.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
If the C functions setbuf() and/or setvbuf() are available, then
|
||||
C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
|
||||
policy for an IO::Handle. The calling sequences for the Perl functions
|
||||
are the same as their C counterparts--including the constants C<_IOFBF>,
|
||||
C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
|
||||
specifies a scalar variable to use as a buffer. You should only
|
||||
change the buffer before any I/O, or immediately after calling flush.
|
||||
|
||||
WARNING: The IO::Handle::setvbuf() is not available by default on
|
||||
Perls 5.8.0 and later because setvbuf() is rather specific to using
|
||||
the stdio library, while Perl prefers the new perlio subsystem instead.
|
||||
|
||||
WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not
|
||||
be modified> in any way until the IO::Handle is closed or C<setbuf> or
|
||||
C<setvbuf> is called again, or memory corruption may result! Remember that
|
||||
the order of global destruction is undefined, so even if your buffer
|
||||
variable remains in scope until program termination, it may be undefined
|
||||
before the file IO::Handle is closed. Note that you need to import the
|
||||
constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf
|
||||
returns nothing. setvbuf returns "0 but true", on success, C<undef> on
|
||||
failure.
|
||||
|
||||
Lastly, there is a special method for working under B<-T> and setuid/gid
|
||||
scripts:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $io->untaint
|
||||
|
||||
Marks the object as taint-clean, and as such data read from it will also
|
||||
be considered taint-clean. Note that this is a very trusting action to
|
||||
take, and appropriate consideration for the data source and potential
|
||||
vulnerability should be kept in mind. Returns 0 on success, -1 if setting
|
||||
the taint-clean flag failed. (eg invalid handle)
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
An C<IO::Handle> object is a reference to a symbol/GLOB reference (see
|
||||
the C<Symbol> package). Some modules that
|
||||
inherit from C<IO::Handle> may want to keep object related variables
|
||||
in the hash table part of the GLOB. In an attempt to prevent modules
|
||||
trampling on each other I propose the that any such module should prefix
|
||||
its variables with its own name separated by _'s. For example the IO::Socket
|
||||
module keeps a C<timeout> variable in 'io_socket_timeout'.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">,
|
||||
L<IO::File>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Due to backwards compatibility, all filehandles resemble objects
|
||||
of class C<IO::Handle>, or actually classes derived from that class.
|
||||
They actually aren't. Which means you can't derive your own
|
||||
class from C<IO::Handle> and inherit those methods.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
|
||||
|
||||
=cut
|
||||
|
||||
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.31";
|
||||
$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";
|
||||
if (@_ != 1) {
|
||||
# Since perl will automatically require IO::File if needed, but
|
||||
# also initialises IO::File's @ISA as part of the core we must
|
||||
# ensure IO::File is loaded if IO::Handle is. This avoids effect-
|
||||
# ively "half-loading" IO::File.
|
||||
if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) {
|
||||
require IO::File;
|
||||
shift;
|
||||
return IO::File::->new(@_);
|
||||
}
|
||||
croak "usage: $class->new()";
|
||||
}
|
||||
my $io = gensym;
|
||||
bless $io, $class;
|
||||
}
|
||||
|
||||
sub new_from_fd {
|
||||
my $class = ref($_[0]) || $_[0] || "IO::Handle";
|
||||
@_ == 3 or croak "usage: $class->new_from_fd(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 compatibility with older releases of IO that used
|
||||
# a sub called constant to determine 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;
|
||||
128
testsuite/input-files/perl-v5.14.2/lib/IO/Seekable.pm
Normal file
128
testsuite/input-files/perl-v5.14.2/lib/IO/Seekable.pm
Normal file
|
|
@ -0,0 +1,128 @@
|
|||
#
|
||||
|
||||
package IO::Seekable;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Seekable - supply seek based methods for I/O objects
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Seekable;
|
||||
package IO::Something;
|
||||
@ISA = qw(IO::Seekable);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO::Seekable> does not have a constructor of its own as it is intended to
|
||||
be inherited by other C<IO::Handle> based objects. It provides methods
|
||||
which allow seeking of the file descriptors.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $io->getpos
|
||||
|
||||
Returns an opaque value that represents the current position of the
|
||||
IO::File, or C<undef> if this is not possible (eg an unseekable stream such
|
||||
as a terminal, pipe or socket). If the fgetpos() function is available in
|
||||
your C library it is used to implements getpos, else perl emulates getpos
|
||||
using C's ftell() function.
|
||||
|
||||
=item $io->setpos
|
||||
|
||||
Uses the value of a previous getpos call to return to a previously visited
|
||||
position. Returns "0 but true" on success, C<undef> on failure.
|
||||
|
||||
=back
|
||||
|
||||
See L<perlfunc> for complete descriptions of each of the following
|
||||
supported C<IO::Seekable> methods, which are just front ends for the
|
||||
corresponding built-in functions:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $io->seek ( POS, WHENCE )
|
||||
|
||||
Seek the IO::File to position POS, relative to WHENCE:
|
||||
|
||||
=over 8
|
||||
|
||||
=item WHENCE=0 (SEEK_SET)
|
||||
|
||||
POS is absolute position. (Seek relative to the start of the file)
|
||||
|
||||
=item WHENCE=1 (SEEK_CUR)
|
||||
|
||||
POS is an offset from the current position. (Seek relative to current)
|
||||
|
||||
=item WHENCE=2 (SEEK_END)
|
||||
|
||||
POS is an offset from the end of the file. (Seek relative to end)
|
||||
|
||||
=back
|
||||
|
||||
The SEEK_* constants can be imported from the C<Fcntl> module if you
|
||||
don't wish to use the numbers C<0> C<1> or C<2> in your code.
|
||||
|
||||
Returns C<1> upon success, C<0> otherwise.
|
||||
|
||||
=item $io->sysseek( POS, WHENCE )
|
||||
|
||||
Similar to $io->seek, but sets the IO::File's position using the system
|
||||
call lseek(2) directly, so will confuse most perl IO operators except
|
||||
sysread and syswrite (see L<perlfunc> for full details)
|
||||
|
||||
Returns the new position, or C<undef> on failure. A position
|
||||
of zero is returned as the string C<"0 but true">
|
||||
|
||||
=item $io->tell
|
||||
|
||||
Returns the IO::File's current position, or -1 on error.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perlfunc>,
|
||||
L<perlop/"I/O Operators">,
|
||||
L<IO::Handle>
|
||||
L<IO::File>
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt>
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
421
testsuite/input-files/perl-v5.14.2/lib/IPC/Open3.pm
Normal file
421
testsuite/input-files/perl-v5.14.2/lib/IPC/Open3.pm
Normal file
|
|
@ -0,0 +1,421 @@
|
|||
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.09;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(open3);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Open3 - open a process for reading, writing, and error handling using open3()
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
|
||||
'some cmd and args', 'optarg', ...);
|
||||
|
||||
my($wtr, $rdr, $err);
|
||||
use Symbol 'gensym'; $err = gensym;
|
||||
$pid = open3($wtr, $rdr, $err,
|
||||
'some cmd and args', 'optarg', ...);
|
||||
|
||||
waitpid( $pid, 0 );
|
||||
my $child_exit_status = $? >> 8;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Extremely similar to open2(), open3() spawns the given $cmd and
|
||||
connects CHLD_OUT for reading from the child, CHLD_IN for writing to
|
||||
the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the
|
||||
same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
|
||||
are on the same filehandle (this means that an autovivified lexical
|
||||
cannot be used for the STDERR filehandle, see SYNOPSIS). The CHLD_IN
|
||||
will have autoflush turned on.
|
||||
|
||||
If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
|
||||
parent, and the child will read from it directly. If CHLD_OUT or
|
||||
CHLD_ERR begins with C<< >& >>, then the child will send output
|
||||
directly to that filehandle. In both cases, there will be a dup(2)
|
||||
instead of a pipe(2) made.
|
||||
|
||||
If either reader or writer is the null string, this will be replaced
|
||||
by an autogenerated filehandle. If so, you must pass a valid lvalue
|
||||
in the parameter slot so it can be overwritten in the caller, or
|
||||
an exception will be raised.
|
||||
|
||||
The filehandles may also be integers, in which case they are understood
|
||||
as file descriptors.
|
||||
|
||||
open3() returns the process ID of the child process. It doesn't return on
|
||||
failure: it just raises an exception matching C</^open3:/>. However,
|
||||
C<exec> failures in the child (such as no such file or permission denied),
|
||||
are just reported to CHLD_ERR, as it is not possible to trap them.
|
||||
|
||||
If the child process dies for any reason, the next write to CHLD_IN is
|
||||
likely to generate a SIGPIPE in the parent, which is fatal by default.
|
||||
So you may wish to handle this signal.
|
||||
|
||||
Note if you specify C<-> as the command, in an analogous fashion to
|
||||
C<open(FOO, "-|")> the child process will just be the forked Perl
|
||||
process rather than an external command. This feature isn't yet
|
||||
supported on Win32 platforms.
|
||||
|
||||
open3() does not wait for and reap the child process after it exits.
|
||||
Except for short programs where it's acceptable to let the operating system
|
||||
take care of this, you need to do this yourself. This is normally as
|
||||
simple as calling C<waitpid $pid, 0> when you're done with the process.
|
||||
Failing to do this can result in an accumulation of defunct or "zombie"
|
||||
processes. See L<perlfunc/waitpid> for more information.
|
||||
|
||||
If you try to read from the child's stdout writer and their stderr
|
||||
writer, you'll have problems with blocking, which means you'll want
|
||||
to use select() or the IO::Select, which means you'd best use
|
||||
sysread() instead of readline() for normal stuff.
|
||||
|
||||
This is very dangerous, as you may block forever. It assumes it's
|
||||
going to talk to something like B<bc>, both writing to it and reading
|
||||
from it. This is presumably safe because you "know" that commands
|
||||
like B<bc> will read a line at a time and output a line at a time.
|
||||
Programs like B<sort> that read their entire input stream first,
|
||||
however, are quite apt to cause deadlock.
|
||||
|
||||
The big problem with this approach is that if you don't have control
|
||||
over source code being run in the child process, you can't control
|
||||
what it does with pipe buffering. Thus you can't just open a pipe to
|
||||
C<cat -v> and continually read and write a line from it.
|
||||
|
||||
=head1 See Also
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<IPC::Open2>
|
||||
|
||||
Like Open3 but without STDERR catpure.
|
||||
|
||||
=item L<IPC::Run>
|
||||
|
||||
This is a CPAN module that has better error handling and more facilities
|
||||
than Open3.
|
||||
|
||||
=back
|
||||
|
||||
=head1 WARNING
|
||||
|
||||
The order of arguments differs from that of open2().
|
||||
|
||||
=cut
|
||||
|
||||
# &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>
|
||||
#
|
||||
# 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: $!";
|
||||
}
|
||||
|
||||
sub xpipe_anon {
|
||||
pipe $_[0], $_[1] or croak "$Me: pipe failed: $!";
|
||||
}
|
||||
|
||||
sub xclose_on_exec {
|
||||
require Fcntl;
|
||||
my $flags = fcntl($_[0], &Fcntl::F_GETFD, 0)
|
||||
or croak "$Me: fcntl failed: $!";
|
||||
fcntl($_[0], &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC)
|
||||
or croak "$Me: fcntl failed: $!";
|
||||
}
|
||||
|
||||
# I tried using a * prototype character for the filehandle but it still
|
||||
# disallows a bareword while compiling under strict subs.
|
||||
|
||||
sub xopen {
|
||||
open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
|
||||
}
|
||||
|
||||
sub xclose {
|
||||
$_[0] =~ /\A=?(\d+)\z/ ? eval { require POSIX; POSIX::close($1); } : close $_[0]
|
||||
}
|
||||
|
||||
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];
|
||||
}
|
||||
|
||||
use constant 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;
|
||||
|
||||
if (!DO_SPAWN) {
|
||||
# Used to communicate exec failures.
|
||||
xpipe my $stat_r, my $stat_w;
|
||||
|
||||
$kidpid = xfork;
|
||||
if ($kidpid == 0) { # Kid
|
||||
eval {
|
||||
# A tie in the parent should not be allowed to cause problems.
|
||||
untie *STDIN;
|
||||
untie *STDOUT;
|
||||
|
||||
close $stat_r;
|
||||
xclose_on_exec $stat_w;
|
||||
|
||||
# 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 '-');
|
||||
exec @cmd or do {
|
||||
local($")=(" ");
|
||||
croak "$Me: exec of @cmd failed";
|
||||
};
|
||||
};
|
||||
|
||||
my $bang = 0+$!;
|
||||
my $err = $@;
|
||||
utf8::encode $err if $] >= 5.008;
|
||||
print $stat_w pack('IIa*', $bang, length($err), $err);
|
||||
close $stat_w;
|
||||
|
||||
eval { require POSIX; POSIX::_exit(255); };
|
||||
exit 255;
|
||||
}
|
||||
else { # Parent
|
||||
close $stat_w;
|
||||
my $to_read = length(pack('I', 0)) * 2;
|
||||
my $bytes_read = read($stat_r, my $buf = '', $to_read);
|
||||
if ($bytes_read) {
|
||||
(my $bang, $to_read) = unpack('II', $buf);
|
||||
read($stat_r, my $err = '', $to_read);
|
||||
if ($err) {
|
||||
utf8::decode $err if $] >= 5.008;
|
||||
} else {
|
||||
$err = "$Me: " . ($! = $bang);
|
||||
}
|
||||
$! = $bang;
|
||||
die($err);
|
||||
}
|
||||
}
|
||||
}
|
||||
else { # 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
|
||||
1037
testsuite/input-files/perl-v5.14.2/lib/POSIX.pm
Normal file
1037
testsuite/input-files/perl-v5.14.2/lib/POSIX.pm
Normal file
File diff suppressed because it is too large
Load diff
54
testsuite/input-files/perl-v5.14.2/lib/SelectSaver.pm
Normal file
54
testsuite/input-files/perl-v5.14.2/lib/SelectSaver.pm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
package SelectSaver;
|
||||
|
||||
our $VERSION = '1.02';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
SelectSaver - save and restore selected file handle
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use SelectSaver;
|
||||
|
||||
{
|
||||
my $saver = SelectSaver->new(FILEHANDLE);
|
||||
# FILEHANDLE is selected
|
||||
}
|
||||
# previous handle is selected
|
||||
|
||||
{
|
||||
my $saver = SelectSaver->new;
|
||||
# new handle may be selected, or not
|
||||
}
|
||||
# previous handle is selected
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A C<SelectSaver> object contains a reference to the file handle that
|
||||
was selected when it was created. If its C<new> method gets an extra
|
||||
parameter, then that parameter is selected; otherwise, the selected
|
||||
file handle remains unchanged.
|
||||
|
||||
When a C<SelectSaver> is destroyed, it re-selects the file handle
|
||||
that was selected when it was created.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
170
testsuite/input-files/perl-v5.14.2/lib/Symbol.pm
Normal file
170
testsuite/input-files/perl-v5.14.2/lib/Symbol.pm
Normal file
|
|
@ -0,0 +1,170 @@
|
|||
package Symbol;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Symbol - manipulate Perl symbols and their names
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Symbol;
|
||||
|
||||
$sym = gensym;
|
||||
open($sym, "filename");
|
||||
$_ = <$sym>;
|
||||
# etc.
|
||||
|
||||
ungensym $sym; # no effect
|
||||
|
||||
# replace *FOO{IO} handle but not $FOO, %FOO, etc.
|
||||
*FOO = geniosym;
|
||||
|
||||
print qualify("x"), "\n"; # "main::x"
|
||||
print qualify("x", "FOO"), "\n"; # "FOO::x"
|
||||
print qualify("BAR::x"), "\n"; # "BAR::x"
|
||||
print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
|
||||
print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
|
||||
print qualify(\*x), "\n"; # returns \*x
|
||||
print qualify(\*x, "FOO"), "\n"; # returns \*x
|
||||
|
||||
use strict refs;
|
||||
print { qualify_to_ref $fh } "foo!\n";
|
||||
$ref = qualify_to_ref $name, $pkg;
|
||||
|
||||
use Symbol qw(delete_package);
|
||||
delete_package('Foo::Bar');
|
||||
print "deleted\n" unless exists $Foo::{'Bar::'};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<Symbol::gensym> creates an anonymous glob and returns a reference
|
||||
to it. Such a glob reference can be used as a file or directory
|
||||
handle.
|
||||
|
||||
For backward compatibility with older implementations that didn't
|
||||
support anonymous globs, C<Symbol::ungensym> is also provided.
|
||||
But it doesn't do anything.
|
||||
|
||||
C<Symbol::geniosym> creates an anonymous IO handle. This can be
|
||||
assigned into an existing glob without affecting the non-IO portions
|
||||
of the glob.
|
||||
|
||||
C<Symbol::qualify> turns unqualified symbol names into qualified
|
||||
variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
|
||||
second parameter, C<qualify> uses it as the default package;
|
||||
otherwise, it uses the package of its caller. Regardless, global
|
||||
variable names (e.g. "STDOUT", "ENV", "SIG") are always qualified with
|
||||
"main::".
|
||||
|
||||
Qualification applies only to symbol names (strings). References are
|
||||
left unchanged under the assumption that they are glob references,
|
||||
which are qualified by their nature.
|
||||
|
||||
C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
|
||||
returns a glob ref rather than a symbol name, so you can use the result
|
||||
even if C<use strict 'refs'> is in effect.
|
||||
|
||||
C<Symbol::delete_package> wipes out a whole package namespace. Note
|
||||
this routine is not exported by default--you may want to import it
|
||||
explicitly.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
C<Symbol::delete_package> is a bit too powerful. It undefines every symbol that
|
||||
lives in the specified package. Since perl, for performance reasons, does not
|
||||
perform a symbol table lookup each time a function is called or a global
|
||||
variable is accessed, some code that has already been loaded and that makes use
|
||||
of symbols in package C<Foo> may stop working after you delete C<Foo>, even if
|
||||
you reload the C<Foo> module afterwards.
|
||||
|
||||
=cut
|
||||
|
||||
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;
|
||||
268
testsuite/input-files/perl-v5.14.2/lib/Tie/Hash.pm
Normal file
268
testsuite/input-files/perl-v5.14.2/lib/Tie/Hash.pm
Normal file
|
|
@ -0,0 +1,268 @@
|
|||
package Tie::Hash;
|
||||
|
||||
our $VERSION = '1.04';
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Tie::Hash, Tie::StdHash, Tie::ExtraHash - base class definitions for tied hashes
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package NewHash;
|
||||
require Tie::Hash;
|
||||
|
||||
@ISA = qw(Tie::Hash);
|
||||
|
||||
sub DELETE { ... } # Provides needed method
|
||||
sub CLEAR { ... } # Overrides inherited method
|
||||
|
||||
|
||||
package NewStdHash;
|
||||
require Tie::Hash;
|
||||
|
||||
@ISA = qw(Tie::StdHash);
|
||||
|
||||
# All methods provided by default, define only those needing overrides
|
||||
# Accessors access the storage in %{$_[0]};
|
||||
# TIEHASH should return a reference to the actual storage
|
||||
sub DELETE { ... }
|
||||
|
||||
package NewExtraHash;
|
||||
require Tie::Hash;
|
||||
|
||||
@ISA = qw(Tie::ExtraHash);
|
||||
|
||||
# All methods provided by default, define only those needing overrides
|
||||
# Accessors access the storage in %{$_[0][0]};
|
||||
# TIEHASH should return an array reference with the first element being
|
||||
# the reference to the actual storage
|
||||
sub DELETE {
|
||||
$_[0][1]->('del', $_[0][0], $_[1]); # Call the report writer
|
||||
delete $_[0][0]->{$_[1]}; # $_[0]->SUPER::DELETE($_[1])
|
||||
}
|
||||
|
||||
|
||||
package main;
|
||||
|
||||
tie %new_hash, 'NewHash';
|
||||
tie %new_std_hash, 'NewStdHash';
|
||||
tie %new_extra_hash, 'NewExtraHash',
|
||||
sub {warn "Doing \U$_[1]\E of $_[2].\n"};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides some skeletal methods for hash-tying classes. See
|
||||
L<perltie> for a list of the functions required in order to tie a hash
|
||||
to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
|
||||
as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and
|
||||
B<Tie::ExtraHash> packages
|
||||
provide most methods for hashes described in L<perltie> (the exceptions
|
||||
are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes,
|
||||
and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the
|
||||
C<new> method: it is used if C<TIEHASH> is not defined
|
||||
in the case a class forgets to include a C<TIEHASH> method.
|
||||
|
||||
For developers wishing to write their own tied hashes, the required methods
|
||||
are briefly defined below. See the L<perltie> section for more detailed
|
||||
descriptive, as well as example code:
|
||||
|
||||
=over 4
|
||||
|
||||
=item TIEHASH classname, LIST
|
||||
|
||||
The method invoked by the command C<tie %hash, classname>. Associates a new
|
||||
hash instance with the specified class. C<LIST> would represent additional
|
||||
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
|
||||
complete the association.
|
||||
|
||||
=item STORE this, key, value
|
||||
|
||||
Store datum I<value> into I<key> for the tied hash I<this>.
|
||||
|
||||
=item FETCH this, key
|
||||
|
||||
Retrieve the datum in I<key> for the tied hash I<this>.
|
||||
|
||||
=item FIRSTKEY this
|
||||
|
||||
Return the first key in the hash.
|
||||
|
||||
=item NEXTKEY this, lastkey
|
||||
|
||||
Return the next key in the hash.
|
||||
|
||||
=item EXISTS this, key
|
||||
|
||||
Verify that I<key> exists with the tied hash I<this>.
|
||||
|
||||
The B<Tie::Hash> implementation is a stub that simply croaks.
|
||||
|
||||
=item DELETE this, key
|
||||
|
||||
Delete the key I<key> from the tied hash I<this>.
|
||||
|
||||
=item CLEAR this
|
||||
|
||||
Clear all values from the tied hash I<this>.
|
||||
|
||||
=item SCALAR this
|
||||
|
||||
Returns what evaluating the hash in scalar context yields.
|
||||
|
||||
B<Tie::Hash> does not implement this method (but B<Tie::StdHash>
|
||||
and B<Tie::ExtraHash> do).
|
||||
|
||||
=back
|
||||
|
||||
=head1 Inheriting from B<Tie::StdHash>
|
||||
|
||||
The accessor methods assume that the actual storage for the data in the tied
|
||||
hash is in the hash referenced by C<tied(%tiedhash)>. Thus overwritten
|
||||
C<TIEHASH> method should return a hash reference, and the remaining methods
|
||||
should operate on the hash referenced by the first argument:
|
||||
|
||||
package ReportHash;
|
||||
our @ISA = 'Tie::StdHash';
|
||||
|
||||
sub TIEHASH {
|
||||
my $storage = bless {}, shift;
|
||||
warn "New ReportHash created, stored in $storage.\n";
|
||||
$storage
|
||||
}
|
||||
sub STORE {
|
||||
warn "Storing data with key $_[1] at $_[0].\n";
|
||||
$_[0]{$_[1]} = $_[2]
|
||||
}
|
||||
|
||||
|
||||
=head1 Inheriting from B<Tie::ExtraHash>
|
||||
|
||||
The accessor methods assume that the actual storage for the data in the tied
|
||||
hash is in the hash referenced by C<(tied(%tiedhash))-E<gt>[0]>. Thus overwritten
|
||||
C<TIEHASH> method should return an array reference with the first
|
||||
element being a hash reference, and the remaining methods should operate on the
|
||||
hash C<< %{ $_[0]->[0] } >>:
|
||||
|
||||
package ReportHash;
|
||||
our @ISA = 'Tie::ExtraHash';
|
||||
|
||||
sub TIEHASH {
|
||||
my $class = shift;
|
||||
my $storage = bless [{}, @_], $class;
|
||||
warn "New ReportHash created, stored in $storage.\n";
|
||||
$storage;
|
||||
}
|
||||
sub STORE {
|
||||
warn "Storing data with key $_[1] at $_[0].\n";
|
||||
$_[0][0]{$_[1]} = $_[2]
|
||||
}
|
||||
|
||||
The default C<TIEHASH> method stores "extra" arguments to tie() starting
|
||||
from offset 1 in the array referenced by C<tied(%tiedhash)>; this is the
|
||||
same storage algorithm as in TIEHASH subroutine above. Hence, a typical
|
||||
package inheriting from B<Tie::ExtraHash> does not need to overwrite this
|
||||
method.
|
||||
|
||||
=head1 C<SCALAR>, C<UNTIE> and C<DESTROY>
|
||||
|
||||
The methods C<UNTIE> and C<DESTROY> are not defined in B<Tie::Hash>,
|
||||
B<Tie::StdHash>, or B<Tie::ExtraHash>. Tied hashes do not require
|
||||
presence of these methods, but if defined, the methods will be called in
|
||||
proper time, see L<perltie>.
|
||||
|
||||
C<SCALAR> is only defined in B<Tie::StdHash> and B<Tie::ExtraHash>.
|
||||
|
||||
If needed, these methods should be defined by the package inheriting from
|
||||
B<Tie::Hash>, B<Tie::StdHash>, or B<Tie::ExtraHash>. See L<perltie/"SCALAR">
|
||||
to find out what happens when C<SCALAR> does not exist.
|
||||
|
||||
=head1 MORE INFORMATION
|
||||
|
||||
The packages relating to various DBM-related implementations (F<DB_File>,
|
||||
F<NDBM_File>, etc.) show examples of general tied hashes, as does the
|
||||
L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
|
||||
good working examples.
|
||||
|
||||
=cut
|
||||
|
||||
use Carp;
|
||||
use warnings::register;
|
||||
|
||||
sub new {
|
||||
my $pkg = shift;
|
||||
$pkg->TIEHASH(@_);
|
||||
}
|
||||
|
||||
# Grandfather "new"
|
||||
|
||||
sub TIEHASH {
|
||||
my $pkg = shift;
|
||||
my $pkg_new = $pkg -> can ('new');
|
||||
|
||||
if ($pkg_new and $pkg ne __PACKAGE__) {
|
||||
my $my_new = __PACKAGE__ -> can ('new');
|
||||
if ($pkg_new == $my_new) {
|
||||
#
|
||||
# Prevent recursion
|
||||
#
|
||||
croak "$pkg must define either a TIEHASH() or a new() method";
|
||||
}
|
||||
|
||||
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;
|
||||
591
testsuite/input-files/perl-v5.14.2/lib/Time/HiRes.pm
Normal file
591
testsuite/input-files/perl-v5.14.2/lib/Time/HiRes.pm
Normal file
|
|
@ -0,0 +1,591 @@
|
|||
package Time::HiRes;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
|
||||
|
||||
require Exporter;
|
||||
require DynaLoader;
|
||||
|
||||
@ISA = qw(Exporter DynaLoader);
|
||||
|
||||
@EXPORT = qw( );
|
||||
@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
|
||||
getitimer setitimer nanosleep clock_gettime clock_getres
|
||||
clock clock_nanosleep
|
||||
CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
|
||||
CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
|
||||
CLOCK_TIMEOFDAY CLOCKS_PER_SEC
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
TIMER_ABSTIME
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep d_clock_gettime d_clock_getres
|
||||
d_clock d_clock_nanosleep
|
||||
stat
|
||||
);
|
||||
|
||||
$VERSION = '1.9721_01';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($constname = $AUTOLOAD) =~ s/.*:://;
|
||||
# print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
|
||||
die "&Time::HiRes::constant not defined" if $constname eq 'constant';
|
||||
my ($error, $val) = constant($constname);
|
||||
# print "AUTOLOAD: error = $error, val = $val\n";
|
||||
if ($error) {
|
||||
my (undef,$file,$line) = caller;
|
||||
die "$error at $file line $line.\n";
|
||||
}
|
||||
{
|
||||
no strict 'refs';
|
||||
*$AUTOLOAD = sub { $val };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $this = shift;
|
||||
for my $i (@_) {
|
||||
if (($i eq 'clock_getres' && !&d_clock_getres) ||
|
||||
($i eq 'clock_gettime' && !&d_clock_gettime) ||
|
||||
($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
|
||||
($i eq 'clock' && !&d_clock) ||
|
||||
($i eq 'nanosleep' && !&d_nanosleep) ||
|
||||
($i eq 'usleep' && !&d_usleep) ||
|
||||
($i eq 'ualarm' && !&d_ualarm)) {
|
||||
require Carp;
|
||||
Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
|
||||
}
|
||||
}
|
||||
Time::HiRes->export_to_level(1, $this, @_);
|
||||
}
|
||||
|
||||
bootstrap Time::HiRes;
|
||||
|
||||
# Preloaded methods go here.
|
||||
|
||||
sub tv_interval {
|
||||
# probably could have been done in C
|
||||
my ($a, $b) = @_;
|
||||
$b = [gettimeofday()] unless defined($b);
|
||||
(${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
|
||||
}
|
||||
|
||||
# Autoload methods go after =cut, and are processed by the autosplit program.
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
|
||||
clock_gettime clock_getres clock_nanosleep clock
|
||||
stat );
|
||||
|
||||
usleep ($microseconds);
|
||||
nanosleep ($nanoseconds);
|
||||
|
||||
ualarm ($microseconds);
|
||||
ualarm ($microseconds, $interval_microseconds);
|
||||
|
||||
$t0 = [gettimeofday];
|
||||
($seconds, $microseconds) = gettimeofday;
|
||||
|
||||
$elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
|
||||
$elapsed = tv_interval ( $t0, [gettimeofday]);
|
||||
$elapsed = tv_interval ( $t0 );
|
||||
|
||||
use Time::HiRes qw ( time alarm sleep );
|
||||
|
||||
$now_fractions = time;
|
||||
sleep ($floating_seconds);
|
||||
alarm ($floating_seconds);
|
||||
alarm ($floating_seconds, $floating_interval);
|
||||
|
||||
use Time::HiRes qw( setitimer getitimer );
|
||||
|
||||
setitimer ($which, $floating_seconds, $floating_interval );
|
||||
getitimer ($which);
|
||||
|
||||
use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
|
||||
|
||||
$realtime = clock_gettime(CLOCK_REALTIME);
|
||||
$resolution = clock_getres(CLOCK_REALTIME);
|
||||
|
||||
clock_nanosleep(CLOCK_REALTIME, 1.5e9);
|
||||
clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME);
|
||||
|
||||
my $ticktock = clock();
|
||||
|
||||
use Time::HiRes qw( stat );
|
||||
|
||||
my @stat = stat("file");
|
||||
my @stat = stat(FH);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the
|
||||
C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
|
||||
C<setitimer>/C<getitimer> system calls, in other words, high
|
||||
resolution time and timers. See the L</EXAMPLES> section below and the
|
||||
test scripts for usage; see your system documentation for the
|
||||
description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
|
||||
C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
|
||||
|
||||
If your system lacks C<gettimeofday()> or an emulation of it you don't
|
||||
get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
|
||||
If your system lacks all of C<nanosleep()>, C<usleep()>,
|
||||
C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
|
||||
C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
|
||||
If your system lacks both C<ualarm()> and C<setitimer()> you don't get
|
||||
C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
|
||||
|
||||
If you try to import an unimplemented function in the C<use> statement
|
||||
it will fail at compile time.
|
||||
|
||||
If your subsecond sleeping is implemented with C<nanosleep()> instead
|
||||
of C<usleep()>, you can mix subsecond sleeping with signals since
|
||||
C<nanosleep()> does not use signals. This, however, is not portable,
|
||||
and you should first check for the truth value of
|
||||
C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
|
||||
then carefully read your C<nanosleep()> C API documentation for any
|
||||
peculiarities.
|
||||
|
||||
If you are using C<nanosleep> for something else than mixing sleeping
|
||||
with signals, give some thought to whether Perl is the tool you should
|
||||
be using for work requiring nanosecond accuracies.
|
||||
|
||||
Remember that unless you are working on a I<hard realtime> system,
|
||||
any clocks and timers will be imprecise, especially so if you are working
|
||||
in a pre-emptive multiuser system. Understand the difference between
|
||||
I<wallclock time> and process time (in UNIX-like systems the sum of
|
||||
I<user> and I<system> times). Any attempt to sleep for X seconds will
|
||||
most probably end up sleeping B<more> than that, but don't be surpised
|
||||
if you end up sleeping slightly B<less>.
|
||||
|
||||
The following functions can be imported from this module.
|
||||
No functions are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item gettimeofday ()
|
||||
|
||||
In array context returns a two-element array with the seconds and
|
||||
microseconds since the epoch. In scalar context returns floating
|
||||
seconds like C<Time::HiRes::time()> (see below).
|
||||
|
||||
=item usleep ( $useconds )
|
||||
|
||||
Sleeps for the number of microseconds (millionths of a second)
|
||||
specified. Returns the number of microseconds actually slept.
|
||||
Can sleep for more than one second, unlike the C<usleep> system call.
|
||||
Can also sleep for zero seconds, which often works like a I<thread yield>.
|
||||
See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
|
||||
C<Time::HiRes::clock_nanosleep()>.
|
||||
|
||||
Do not expect usleep() to be exact down to one microsecond.
|
||||
|
||||
=item nanosleep ( $nanoseconds )
|
||||
|
||||
Sleeps for the number of nanoseconds (1e9ths of a second) specified.
|
||||
Returns the number of nanoseconds actually slept (accurate only to
|
||||
microseconds, the nearest thousand of them). Can sleep for more than
|
||||
one second. Can also sleep for zero seconds, which often works like
|
||||
a I<thread yield>. See also C<Time::HiRes::sleep()>,
|
||||
C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
|
||||
|
||||
Do not expect nanosleep() to be exact down to one nanosecond.
|
||||
Getting even accuracy of one thousand nanoseconds is good.
|
||||
|
||||
=item ualarm ( $useconds [, $interval_useconds ] )
|
||||
|
||||
Issues a C<ualarm> call; the C<$interval_useconds> is optional and
|
||||
will be zero if unspecified, resulting in C<alarm>-like behaviour.
|
||||
|
||||
Returns the remaining time in the alarm in microseconds, or C<undef>
|
||||
if an error occurred.
|
||||
|
||||
ualarm(0) will cancel an outstanding ualarm().
|
||||
|
||||
Note that the interaction between alarms and sleeps is unspecified.
|
||||
|
||||
=item tv_interval
|
||||
|
||||
tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
|
||||
|
||||
Returns the floating seconds between the two times, which should have
|
||||
been returned by C<gettimeofday()>. If the second argument is omitted,
|
||||
then the current time is used.
|
||||
|
||||
=item time ()
|
||||
|
||||
Returns a floating seconds since the epoch. This function can be
|
||||
imported, resulting in a nice drop-in replacement for the C<time>
|
||||
provided with core Perl; see the L</EXAMPLES> below.
|
||||
|
||||
B<NOTE 1>: This higher resolution timer can return values either less
|
||||
or more than the core C<time()>, depending on whether your platform
|
||||
rounds the higher resolution timer values up, down, or to the nearest second
|
||||
to get the core C<time()>, but naturally the difference should be never
|
||||
more than half a second. See also L</clock_getres>, if available
|
||||
in your system.
|
||||
|
||||
B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
|
||||
the C<time()> seconds since epoch rolled over to 1_000_000_000, the
|
||||
default floating point format of Perl and the seconds since epoch have
|
||||
conspired to produce an apparent bug: if you print the value of
|
||||
C<Time::HiRes::time()> you seem to be getting only five decimals, not
|
||||
six as promised (microseconds). Not to worry, the microseconds are
|
||||
there (assuming your platform supports such granularity in the first
|
||||
place). What is going on is that the default floating point format of
|
||||
Perl only outputs 15 digits. In this case that means ten digits
|
||||
before the decimal separator and five after. To see the microseconds
|
||||
you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
|
||||
C<gettimeofday()> function in list context, which will give you the
|
||||
seconds and microseconds as two separate values.
|
||||
|
||||
=item sleep ( $floating_seconds )
|
||||
|
||||
Sleeps for the specified amount of seconds. Returns the number of
|
||||
seconds actually slept (a floating point value). This function can
|
||||
be imported, resulting in a nice drop-in replacement for the C<sleep>
|
||||
provided with perl, see the L</EXAMPLES> below.
|
||||
|
||||
Note that the interaction between alarms and sleeps is unspecified.
|
||||
|
||||
=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
|
||||
|
||||
The C<SIGALRM> signal is sent after the specified number of seconds.
|
||||
Implemented using C<setitimer()> if available, C<ualarm()> if not.
|
||||
The C<$interval_floating_seconds> argument is optional and will be
|
||||
zero if unspecified, resulting in C<alarm()>-like behaviour. This
|
||||
function can be imported, resulting in a nice drop-in replacement for
|
||||
the C<alarm> provided with perl, see the L</EXAMPLES> below.
|
||||
|
||||
Returns the remaining time in the alarm in seconds, or C<undef>
|
||||
if an error occurred.
|
||||
|
||||
B<NOTE 1>: With some combinations of operating systems and Perl
|
||||
releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
|
||||
This means that an C<alarm()> followed by a C<select()> may together
|
||||
take the sum of the times specified for the the C<alarm()> and the
|
||||
C<select()>, not just the time of the C<alarm()>.
|
||||
|
||||
Note that the interaction between alarms and sleeps is unspecified.
|
||||
|
||||
=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
|
||||
|
||||
Start up an interval timer: after a certain time, a signal ($which) arrives,
|
||||
and more signals may keep arriving at certain intervals. To disable
|
||||
an "itimer", use C<$floating_seconds> of zero. If the
|
||||
C<$interval_floating_seconds> is set to zero (or unspecified), the
|
||||
timer is disabled B<after> the next delivered signal.
|
||||
|
||||
Use of interval timers may interfere with C<alarm()>, C<sleep()>,
|
||||
and C<usleep()>. In standard-speak the "interaction is unspecified",
|
||||
which means that I<anything> may happen: it may work, it may not.
|
||||
|
||||
In scalar context, the remaining time in the timer is returned.
|
||||
|
||||
In list context, both the remaining time and the interval are returned.
|
||||
|
||||
There are usually three or four interval timers (signals) available: the
|
||||
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
|
||||
C<ITIMER_REALPROF>. Note that which ones are available depends: true
|
||||
UNIX platforms usually have the first three, but only Solaris seems to
|
||||
have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
|
||||
Win32 unfortunately does not haveinterval timers.
|
||||
|
||||
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
|
||||
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
|
||||
the timer expires.
|
||||
|
||||
C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
|
||||
only when the process is running. In multiprocessor/user/CPU systems
|
||||
this may be more or less than real or wallclock time. (This time is
|
||||
also known as the I<user time>.) C<SIGVTALRM> is delivered when the
|
||||
timer expires.
|
||||
|
||||
C<ITIMER_PROF> counts time when either the process virtual time or when
|
||||
the operating system is running on behalf of the process (such as I/O).
|
||||
(This time is also known as the I<system time>.) (The sum of user
|
||||
time and system time is known as the I<CPU time>.) C<SIGPROF> is
|
||||
delivered when the timer expires. C<SIGPROF> can interrupt system calls.
|
||||
|
||||
The semantics of interval timers for multithreaded programs are
|
||||
system-specific, and some systems may support additional interval
|
||||
timers. For example, it is unspecified which thread gets the signals.
|
||||
See your C<setitimer()> documentation.
|
||||
|
||||
=item getitimer ( $which )
|
||||
|
||||
Return the remaining time in the interval timer specified by C<$which>.
|
||||
|
||||
In scalar context, the remaining time is returned.
|
||||
|
||||
In list context, both the remaining time and the interval are returned.
|
||||
The interval is always what you put in using C<setitimer()>.
|
||||
|
||||
=item clock_gettime ( $which )
|
||||
|
||||
Return as seconds the current value of the POSIX high resolution timer
|
||||
specified by C<$which>. All implementations that support POSIX high
|
||||
resolution timers are supposed to support at least the C<$which> value
|
||||
of C<CLOCK_REALTIME>, which is supposed to return results close to the
|
||||
results of C<gettimeofday>, or the number of seconds since 00:00:00:00
|
||||
January 1, 1970 Greenwich Mean Time (GMT). Do not assume that
|
||||
CLOCK_REALTIME is zero, it might be one, or something else.
|
||||
Another potentially useful (but not available everywhere) value is
|
||||
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
|
||||
value (unlike time() or gettimeofday(), which can be adjusted).
|
||||
See your system documentation for other possibly supported values.
|
||||
|
||||
=item clock_getres ( $which )
|
||||
|
||||
Return as seconds the resolution of the POSIX high resolution timer
|
||||
specified by C<$which>. All implementations that support POSIX high
|
||||
resolution timers are supposed to support at least the C<$which> value
|
||||
of C<CLOCK_REALTIME>, see L</clock_gettime>.
|
||||
|
||||
=item clock_nanosleep ( $which, $nanoseconds, $flags = 0)
|
||||
|
||||
Sleeps for the number of nanoseconds (1e9ths of a second) specified.
|
||||
Returns the number of nanoseconds actually slept. The $which is the
|
||||
"clock id", as with clock_gettime() and clock_getres(). The flags
|
||||
default to zero but C<TIMER_ABSTIME> can specified (must be exported
|
||||
explicitly) which means that C<$nanoseconds> is not a time interval
|
||||
(as is the default) but instead an absolute time. Can sleep for more
|
||||
than one second. Can also sleep for zero seconds, which often works
|
||||
like a I<thread yield>. See also C<Time::HiRes::sleep()>,
|
||||
C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
|
||||
|
||||
Do not expect clock_nanosleep() to be exact down to one nanosecond.
|
||||
Getting even accuracy of one thousand nanoseconds is good.
|
||||
|
||||
=item clock()
|
||||
|
||||
Return as seconds the I<process time> (user + system time) spent by
|
||||
the process since the first call to clock() (the definition is B<not>
|
||||
"since the start of the process", though if you are lucky these times
|
||||
may be quite close to each other, depending on the system). What this
|
||||
means is that you probably need to store the result of your first call
|
||||
to clock(), and subtract that value from the following results of clock().
|
||||
|
||||
The time returned also includes the process times of the terminated
|
||||
child processes for which wait() has been executed. This value is
|
||||
somewhat like the second value returned by the times() of core Perl,
|
||||
but not necessarily identical. Note that due to backward
|
||||
compatibility limitations the returned value may wrap around at about
|
||||
2147 seconds or at about 36 minutes.
|
||||
|
||||
=item stat
|
||||
|
||||
=item stat FH
|
||||
|
||||
=item stat EXPR
|
||||
|
||||
As L<perlfunc/stat> but with the access/modify/change file timestamps
|
||||
in subsecond resolution, if the operating system and the filesystem
|
||||
both support such timestamps. To override the standard stat():
|
||||
|
||||
use Time::HiRes qw(stat);
|
||||
|
||||
Test for the value of &Time::HiRes::d_hires_stat to find out whether
|
||||
the operating system supports subsecond file timestamps: a value
|
||||
larger than zero means yes. There are unfortunately no easy
|
||||
ways to find out whether the filesystem supports such timestamps.
|
||||
UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp
|
||||
granularity is B<two> seconds).
|
||||
|
||||
A zero return value of &Time::HiRes::d_hires_stat means that
|
||||
Time::HiRes::stat is a no-op passthrough for CORE::stat(),
|
||||
and therefore the timestamps will stay integers. The same
|
||||
thing will happen if the filesystem does not do subsecond timestamps,
|
||||
even if the &Time::HiRes::d_hires_stat is non-zero.
|
||||
|
||||
In any case do not expect nanosecond resolution, or even a microsecond
|
||||
resolution. Also note that the modify/access timestamps might have
|
||||
different resolutions, and that they need not be synchronized, e.g.
|
||||
if the operations are
|
||||
|
||||
write
|
||||
stat # t1
|
||||
read
|
||||
stat # t2
|
||||
|
||||
the access time stamp from t2 need not be greater-than the modify
|
||||
time stamp from t1: it may be equal or I<less>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
|
||||
|
||||
$microseconds = 750_000;
|
||||
usleep($microseconds);
|
||||
|
||||
# signal alarm in 2.5s & every .1s thereafter
|
||||
ualarm(2_500_000, 100_000);
|
||||
# cancel that ualarm
|
||||
ualarm(0);
|
||||
|
||||
# get seconds and microseconds since the epoch
|
||||
($s, $usec) = gettimeofday();
|
||||
|
||||
# measure elapsed time
|
||||
# (could also do by subtracting 2 gettimeofday return values)
|
||||
$t0 = [gettimeofday];
|
||||
# do bunch of stuff here
|
||||
$t1 = [gettimeofday];
|
||||
# do more stuff here
|
||||
$t0_t1 = tv_interval $t0, $t1;
|
||||
|
||||
$elapsed = tv_interval ($t0, [gettimeofday]);
|
||||
$elapsed = tv_interval ($t0); # equivalent code
|
||||
|
||||
#
|
||||
# replacements for time, alarm and sleep that know about
|
||||
# floating seconds
|
||||
#
|
||||
use Time::HiRes;
|
||||
$now_fractions = Time::HiRes::time;
|
||||
Time::HiRes::sleep (2.5);
|
||||
Time::HiRes::alarm (10.6666666);
|
||||
|
||||
use Time::HiRes qw ( time alarm sleep );
|
||||
$now_fractions = time;
|
||||
sleep (2.5);
|
||||
alarm (10.6666666);
|
||||
|
||||
# Arm an interval timer to go off first at 10 seconds and
|
||||
# after that every 2.5 seconds, in process virtual time
|
||||
|
||||
use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
|
||||
|
||||
$SIG{VTALRM} = sub { print time, "\n" };
|
||||
setitimer(ITIMER_VIRTUAL, 10, 2.5);
|
||||
|
||||
use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
|
||||
# Read the POSIX high resolution timer.
|
||||
my $high = clock_getres(CLOCK_REALTIME);
|
||||
# But how accurate we can be, really?
|
||||
my $reso = clock_getres(CLOCK_REALTIME);
|
||||
|
||||
use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
|
||||
clock_nanosleep(CLOCK_REALTIME, 1e6);
|
||||
clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
|
||||
|
||||
use Time::HiRes qw( clock );
|
||||
my $clock0 = clock();
|
||||
... # Do something.
|
||||
my $clock1 = clock();
|
||||
my $clockd = $clock1 - $clock0;
|
||||
|
||||
use Time::HiRes qw( stat );
|
||||
my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10];
|
||||
|
||||
=head1 C API
|
||||
|
||||
In addition to the perl API described above, a C API is available for
|
||||
extension writers. The following C functions are available in the
|
||||
modglobal hash:
|
||||
|
||||
name C prototype
|
||||
--------------- ----------------------
|
||||
Time::NVtime double (*)()
|
||||
Time::U2time void (*)(pTHX_ UV ret[2])
|
||||
|
||||
Both functions return equivalent information (like C<gettimeofday>)
|
||||
but with different representations. The names C<NVtime> and C<U2time>
|
||||
were selected mainly because they are operating system independent.
|
||||
(C<gettimeofday> is Unix-centric, though some platforms like Win32 and
|
||||
VMS have emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)(); /* Returns -1 on failure. */
|
||||
SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
|
||||
if (!svp) croak("Time::HiRes is required");
|
||||
if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
|
||||
myNVtime = INT2PTR(double(*)(), SvIV(*svp));
|
||||
printf("The current time is: %f\n", (*myNVtime)());
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=head2 useconds or interval more than ...
|
||||
|
||||
In ualarm() you tried to use number of microseconds or interval (also
|
||||
in microseconds) more than 1_000_000 and setitimer() is not available
|
||||
in your system to emulate that case.
|
||||
|
||||
=head2 negative time not invented yet
|
||||
|
||||
You tried to use a negative time argument.
|
||||
|
||||
=head2 internal error: useconds < 0 (unsigned ... signed ...)
|
||||
|
||||
Something went horribly wrong-- the number of microseconds that cannot
|
||||
become negative just became negative. Maybe your compiler is broken?
|
||||
|
||||
=head2 useconds or uinterval equal to or more than 1000000
|
||||
|
||||
In some platforms it is not possible to get an alarm with subsecond
|
||||
resolution and later than one second.
|
||||
|
||||
=head2 unimplemented in this platform
|
||||
|
||||
Some calls simply aren't available, real or emulated, on every platform.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Notice that the core C<time()> maybe rounding rather than truncating.
|
||||
What this means is that the core C<time()> may be reporting the time
|
||||
as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
|
||||
|
||||
Adjusting the system clock (either manually or by services like ntp)
|
||||
may cause problems, especially for long running programs that assume
|
||||
a monotonously increasing time (note that all platforms do not adjust
|
||||
time as gracefully as UNIX ntp does). For example in Win32 (and derived
|
||||
platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
|
||||
drift off from the system clock (and the original time()) by up to 0.5
|
||||
seconds. Time::HiRes will notice this eventually and recalibrate.
|
||||
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
|
||||
might help in this (in case your system supports CLOCK_MONOTONIC).
|
||||
|
||||
Some systems have APIs but not implementations: for example QNX and Haiku
|
||||
have the interval timer APIs but not the functionality.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Perl modules L<BSD::Resource>, L<Time::TAI64>.
|
||||
|
||||
Your system documentation for C<clock>, C<clock_gettime>,
|
||||
C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>,
|
||||
C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
|
||||
All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
352
testsuite/input-files/perl-v5.14.2/lib/XSLoader.pm
Normal file
352
testsuite/input-files/perl-v5.14.2/lib/XSLoader.pm
Normal file
|
|
@ -0,0 +1,352 @@
|
|||
# Generated from XSLoader.pm.PL (resolved %Config::Config value)
|
||||
|
||||
package XSLoader;
|
||||
|
||||
$VERSION = "0.13";
|
||||
|
||||
#use strict;
|
||||
|
||||
# enable debug/trace messages from DynaLoader perl code
|
||||
# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
|
||||
|
||||
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;
|
||||
|
||||
my ($module, $modlibname) = caller();
|
||||
|
||||
if (@_) {
|
||||
$module = $_[0];
|
||||
} else {
|
||||
$_[0] = $module;
|
||||
}
|
||||
|
||||
# work with static linking too
|
||||
my $boots = "$module\::bootstrap";
|
||||
goto &$boots if defined &$boots;
|
||||
|
||||
goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file;
|
||||
|
||||
my @modparts = split(/::/,$module);
|
||||
my $modfname = $modparts[-1];
|
||||
|
||||
my $modpname = join('/',@modparts);
|
||||
my $c = @modparts;
|
||||
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
|
||||
my $file = "$modlibname/auto/$modpname/$modfname.so";
|
||||
|
||||
# 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 \&XSLoader::bootstrap_inherit 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(@_);
|
||||
}
|
||||
|
||||
sub bootstrap_inherit {
|
||||
require DynaLoader;
|
||||
goto \&DynaLoader::bootstrap_inherit;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XSLoader - Dynamically load C libraries into Perl code
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 0.13
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package YourPackage;
|
||||
require XSLoader;
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module defines a standard I<simplified> interface to the dynamic
|
||||
linking mechanisms available on many platforms. Its primary purpose is
|
||||
to implement cheap automatic dynamic loading of Perl modules.
|
||||
|
||||
For a more complicated interface, see L<DynaLoader>. Many (most)
|
||||
features of C<DynaLoader> are not implemented in C<XSLoader>, like for
|
||||
example the C<dl_load_flags>, not honored by C<XSLoader>.
|
||||
|
||||
=head2 Migration from C<DynaLoader>
|
||||
|
||||
A typical module using L<DynaLoader|DynaLoader> starts like this:
|
||||
|
||||
package YourPackage;
|
||||
require DynaLoader;
|
||||
|
||||
our @ISA = qw( OnePackage OtherPackage DynaLoader );
|
||||
our $VERSION = '0.01';
|
||||
bootstrap YourPackage $VERSION;
|
||||
|
||||
Change this to
|
||||
|
||||
package YourPackage;
|
||||
use XSLoader;
|
||||
|
||||
our @ISA = qw( OnePackage OtherPackage );
|
||||
our $VERSION = '0.01';
|
||||
XSLoader::load 'YourPackage', $VERSION;
|
||||
|
||||
In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
|
||||
C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
|
||||
forget to quote the name of your package on the C<XSLoader::load> line,
|
||||
and add comma (C<,>) before the arguments (C<$VERSION> above).
|
||||
|
||||
Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
|
||||
the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
|
||||
more backward-compatible
|
||||
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
|
||||
|
||||
If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
|
||||
|
||||
XSLoader::load 'YourPackage';
|
||||
|
||||
If the call to C<load> is from the YourPackage, then that can be further
|
||||
simplified to
|
||||
|
||||
XSLoader::load();
|
||||
|
||||
as C<load> will use C<caller> to determine the package.
|
||||
|
||||
=head2 Backward compatible boilerplate
|
||||
|
||||
If you want to have your cake and eat it too, you need a more complicated
|
||||
boilerplate.
|
||||
|
||||
package YourPackage;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
@ISA = qw( OnePackage OtherPackage );
|
||||
$VERSION = '0.01';
|
||||
eval {
|
||||
require XSLoader;
|
||||
XSLoader::load('YourPackage', $VERSION);
|
||||
1;
|
||||
} or do {
|
||||
require DynaLoader;
|
||||
push @ISA, 'DynaLoader';
|
||||
bootstrap YourPackage $VERSION;
|
||||
};
|
||||
|
||||
The parentheses about C<XSLoader::load()> arguments are needed since we replaced
|
||||
C<use XSLoader> by C<require>, so the compiler does not know that a function
|
||||
C<XSLoader::load()> is present.
|
||||
|
||||
This boilerplate uses the low-overhead C<XSLoader> if present; if used with
|
||||
an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
|
||||
|
||||
=head1 Order of initialization: early load()
|
||||
|
||||
I<Skip this section if the XSUB functions are supposed to be called from other
|
||||
modules only; read it only if you call your XSUBs from the code in your module,
|
||||
or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
|
||||
What is described here is equally applicable to the L<DynaLoader|DynaLoader>
|
||||
interface.>
|
||||
|
||||
A sufficiently complicated module using XS would have both Perl code (defined
|
||||
in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
|
||||
Perl code makes calls into this XS code, and/or this XS code makes calls to
|
||||
the Perl code, one should be careful with the order of initialization.
|
||||
|
||||
The call to C<XSLoader::load()> (or C<bootstrap()>) calls the module's
|
||||
bootstrap code. For modules build by F<xsubpp> (nearly all modules) this
|
||||
has three side effects:
|
||||
|
||||
=over
|
||||
|
||||
=item *
|
||||
|
||||
A sanity check is done to ensure that the versions of the F<.pm> and the
|
||||
(compiled) F<.xs> parts are compatible. If C<$VERSION> was specified, this
|
||||
is used for the check. If not specified, it defaults to
|
||||
C<$XS_VERSION // $VERSION> (in the module's namespace)
|
||||
|
||||
=item *
|
||||
|
||||
the XSUBs are made accessible from Perl
|
||||
|
||||
=item *
|
||||
|
||||
if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
|
||||
|
||||
=back
|
||||
|
||||
Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
|
||||
convenient to have XSUBs installed before the Perl code is defined; for
|
||||
example, this makes prototypes for XSUBs visible to this Perl code.
|
||||
Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
|
||||
uses Perl variables) defined in the F<.pm> file, they must be defined prior to
|
||||
the call to C<XSLoader::load()> (or C<bootstrap()>).
|
||||
|
||||
The first situation being much more frequent, it makes sense to rewrite the
|
||||
boilerplate as
|
||||
|
||||
package YourPackage;
|
||||
use XSLoader;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
BEGIN {
|
||||
@ISA = qw( OnePackage OtherPackage );
|
||||
$VERSION = '0.01';
|
||||
|
||||
# Put Perl code used in the BOOT: section here
|
||||
|
||||
XSLoader::load 'YourPackage', $VERSION;
|
||||
}
|
||||
|
||||
# Put Perl code making calls into XSUBs here
|
||||
|
||||
=head2 The most hairy case
|
||||
|
||||
If the interdependence of your C<BOOT:> section and Perl code is
|
||||
more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
|
||||
functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
|
||||
section altogether. Replace it with a function C<onBOOT()>, and call it like
|
||||
this:
|
||||
|
||||
package YourPackage;
|
||||
use XSLoader;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
BEGIN {
|
||||
@ISA = qw( OnePackage OtherPackage );
|
||||
$VERSION = '0.01';
|
||||
XSLoader::load 'YourPackage', $VERSION;
|
||||
}
|
||||
|
||||
# Put Perl code used in onBOOT() function here; calls to XSUBs are
|
||||
# prototype-checked.
|
||||
|
||||
onBOOT;
|
||||
|
||||
# Put Perl initialization code assuming that XS is initialized here
|
||||
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over
|
||||
|
||||
=item C<Can't find '%s' symbol in %s>
|
||||
|
||||
B<(F)> The bootstrap symbol could not be found in the extension module.
|
||||
|
||||
=item C<Can't load '%s' for module %s: %s>
|
||||
|
||||
B<(F)> The loading or initialisation of the extension module failed.
|
||||
The detailed error follows.
|
||||
|
||||
=item C<Undefined symbols present after loading %s: %s>
|
||||
|
||||
B<(W)> As the message says, some symbols stay undefined although the
|
||||
extension module was correctly loaded and initialised. The list of undefined
|
||||
symbols follows.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
To reduce the overhead as much as possible, only one possible location
|
||||
is checked to find the extension DLL (this location is where C<make install>
|
||||
would put the DLL). If not found, the search for the DLL is transparently
|
||||
delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
|
||||
|
||||
In particular, this is applicable to the structure of C<@INC> used for testing
|
||||
not-yet-installed extensions. This means that running uninstalled extensions
|
||||
may have much more overhead than running the same extensions after
|
||||
C<make install>.
|
||||
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests via the perlbug(1) utility.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DynaLoader>
|
||||
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
|
||||
|
||||
CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
|
||||
E<lt>sebastien@aperghis.netE<gt>.
|
||||
|
||||
Previous maintainer was Michael G Schwern <schwern@pobox.com>.
|
||||
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (C) 1990-2007 by Larry Wall and others.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Cwd/Cwd.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Cwd/Cwd.so
Executable file
Binary file not shown.
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Fcntl/Fcntl.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Fcntl/Fcntl.so
Executable file
Binary file not shown.
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/File/Glob/Glob.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/File/Glob/Glob.so
Executable file
Binary file not shown.
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/IO/IO.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/IO/IO.so
Executable file
Binary file not shown.
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/POSIX/POSIX.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/POSIX/POSIX.so
Executable file
Binary file not shown.
173
testsuite/input-files/perl-v5.14.2/lib/auto/POSIX/autosplit.ix
Normal file
173
testsuite/input-files/perl-v5.14.2/lib/auto/POSIX/autosplit.ix
Normal 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;
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
# NOTE: Derived from ../../lib/POSIX.pm.
|
||||
# Changes made here will be lost when autosplit is run again.
|
||||
# See AutoSplit.pm.
|
||||
package POSIX;
|
||||
|
||||
#line 753 "../../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 SIGBUS
|
||||
SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ
|
||||
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 scalars, 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;
|
||||
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Time/HiRes/HiRes.so
Executable file
BIN
testsuite/input-files/perl-v5.14.2/lib/auto/Time/HiRes/HiRes.so
Executable file
Binary file not shown.
265
testsuite/input-files/perl-v5.14.2/lib/base.pm
Normal file
265
testsuite/input-files/perl-v5.14.2/lib/base.pm
Normal file
|
|
@ -0,0 +1,265 @@
|
|||
package base;
|
||||
|
||||
use strict 'vars';
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '2.16';
|
||||
$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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
base - Establish an ISA relationship with base classes at compile time
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Baz;
|
||||
use base qw(Foo Bar);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Unless you are using the C<fields> pragma, consider this module discouraged
|
||||
in favor of the lighter-weight C<parent>.
|
||||
|
||||
Allows you to both load one or more modules, while setting up inheritance from
|
||||
those modules at the same time. Roughly similar in effect to
|
||||
|
||||
package Baz;
|
||||
BEGIN {
|
||||
require Foo;
|
||||
require Bar;
|
||||
push @ISA, qw(Foo Bar);
|
||||
}
|
||||
|
||||
C<base> employs some heuristics to determine if a module has already been
|
||||
loaded, if it has it doesn't try again. If C<base> tries to C<require> the
|
||||
module it will not die if it cannot find the module's file, but will die on any
|
||||
other error. After all this, should your base class be empty, containing no
|
||||
symbols, it will die. This is useful for inheriting from classes in the same
|
||||
file as yourself, like so:
|
||||
|
||||
package Foo;
|
||||
sub exclaim { "I can have such a thing?!" }
|
||||
|
||||
package Bar;
|
||||
use base "Foo";
|
||||
|
||||
If $VERSION is not detected even after loading it, <base> will define $VERSION
|
||||
in the base package, setting it to the string C<-1, set by base.pm>.
|
||||
|
||||
C<base> will also initialize the fields if one of the base classes has it.
|
||||
Multiple inheritance of fields is B<NOT> supported, if two or more base classes
|
||||
each have inheritable fields the 'base' pragma will croak. See L<fields>,
|
||||
L<public> and L<protected> for a description of this feature.
|
||||
|
||||
The base class' C<import> method is B<not> called.
|
||||
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Base class package "%s" is empty.
|
||||
|
||||
base.pm was unable to require the base package, because it was not
|
||||
found in your path.
|
||||
|
||||
=item Class 'Foo' tried to inherit from itself
|
||||
|
||||
Attempting to inherit from yourself generates a warning.
|
||||
|
||||
package Foo;
|
||||
use base 'Foo';
|
||||
|
||||
=back
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
This module was introduced with Perl 5.004_04.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Due to the limitations of the implementation, you must use
|
||||
base I<before> you declare any of your own fields.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<fields>
|
||||
|
||||
=cut
|
||||
397
testsuite/input-files/perl-v5.14.2/lib/constant.pm
Normal file
397
testsuite/input-files/perl-v5.14.2/lib/constant.pm
Normal file
|
|
@ -0,0 +1,397 @@
|
|||
package constant;
|
||||
use 5.005;
|
||||
use strict;
|
||||
use warnings::register;
|
||||
|
||||
use vars qw($VERSION %declared);
|
||||
$VERSION = '1.21';
|
||||
|
||||
#=======================================================================
|
||||
|
||||
# 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);
|
||||
|
||||
my $str_end = $] >= 5.006 ? "\\z" : "\\Z";
|
||||
my $normal_constant_name = qr/^_?[^\W_0-9]\w*$str_end/;
|
||||
my $tolerable = qr/^[A-Za-z_]\w*$str_end/;
|
||||
my $boolean = qr/^[01]?$str_end/;
|
||||
|
||||
BEGIN {
|
||||
# We'd like to do use constant _CAN_PCS => $] > 5.009002
|
||||
# but that's a bit tricky before we load the constant module :-)
|
||||
# By doing this, we save 1 run time check for *every* call to import.
|
||||
no strict 'refs';
|
||||
my $const = $] > 5.009002;
|
||||
*_CAN_PCS = sub () {$const};
|
||||
}
|
||||
|
||||
#=======================================================================
|
||||
# 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 $flush_mro;
|
||||
my $symtab;
|
||||
|
||||
if (_CAN_PCS) {
|
||||
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 {
|
||||
unless (defined $_[0]) {
|
||||
require Carp;
|
||||
Carp::croak("Can't use undef as constant name");
|
||||
}
|
||||
$constants->{+shift} = undef;
|
||||
}
|
||||
|
||||
foreach my $name ( keys %$constants ) {
|
||||
# Normal constant name
|
||||
if ($name =~ $normal_constant_name 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 =~ $tolerable) {
|
||||
# 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 =~ $boolean) {
|
||||
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];
|
||||
|
||||
# Work around perl bug #xxxxx: Sub names (actually glob
|
||||
# names in general) ignore the UTF8 flag. So we have to
|
||||
# turn it off to get the "right" symbol table entry.
|
||||
utf8::is_utf8 $name and utf8::encode $name;
|
||||
|
||||
# The constant serves to optimise this entire block out on
|
||||
# 5.8 and earlier.
|
||||
if (_CAN_PCS && $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;
|
||||
++$flush_mro;
|
||||
} else {
|
||||
*$full_name = sub () { $scalar };
|
||||
}
|
||||
} elsif (@_) {
|
||||
my @list = @_;
|
||||
*$full_name = sub () { @list };
|
||||
} else {
|
||||
*$full_name = sub () { };
|
||||
}
|
||||
}
|
||||
}
|
||||
# Flush the cache exactly once if we make any direct symbol table changes.
|
||||
mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
constant - Perl pragma to declare constants
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use constant PI => 4 * atan2(1, 1);
|
||||
use constant DEBUG => 0;
|
||||
|
||||
print "Pi equals ", PI, "...\n" if DEBUG;
|
||||
|
||||
use constant {
|
||||
SEC => 0,
|
||||
MIN => 1,
|
||||
HOUR => 2,
|
||||
MDAY => 3,
|
||||
MON => 4,
|
||||
YEAR => 5,
|
||||
WDAY => 6,
|
||||
YDAY => 7,
|
||||
ISDST => 8,
|
||||
};
|
||||
|
||||
use constant WEEKDAYS => qw(
|
||||
Sunday Monday Tuesday Wednesday Thursday Friday Saturday
|
||||
);
|
||||
|
||||
print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This pragma allows you to declare constants at compile-time.
|
||||
|
||||
When you declare a constant such as C<PI> using the method shown
|
||||
above, each machine your script runs upon can have as many digits
|
||||
of accuracy as it can use. Also, your program will be easier to
|
||||
read, more likely to be maintained (and maintained correctly), and
|
||||
far less likely to send a space probe to the wrong planet because
|
||||
nobody noticed the one equation in which you wrote C<3.14195>.
|
||||
|
||||
When a constant is used in an expression, Perl replaces it with its
|
||||
value at compile time, and may then optimize the expression further.
|
||||
In particular, any code in an C<if (CONSTANT)> block will be optimized
|
||||
away if the constant is false.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
As with all C<use> directives, defining a constant happens at
|
||||
compile time. Thus, it's probably not correct to put a constant
|
||||
declaration inside of a conditional statement (like C<if ($foo)
|
||||
{ use constant ... }>).
|
||||
|
||||
Constants defined using this module cannot be interpolated into
|
||||
strings like variables. However, concatenation works just fine:
|
||||
|
||||
print "Pi equals PI...\n"; # WRONG: does not expand "PI"
|
||||
print "Pi equals ".PI."...\n"; # right
|
||||
|
||||
Even though a reference may be declared as a constant, the reference may
|
||||
point to data which may be changed, as this code shows.
|
||||
|
||||
use constant ARRAY => [ 1,2,3,4 ];
|
||||
print ARRAY->[1];
|
||||
ARRAY->[1] = " be changed";
|
||||
print ARRAY->[1];
|
||||
|
||||
Dereferencing constant references incorrectly (such as using an array
|
||||
subscript on a constant hash reference, or vice versa) will be trapped at
|
||||
compile time.
|
||||
|
||||
Constants belong to the package they are defined in. To refer to a
|
||||
constant defined in another package, specify the full package name, as
|
||||
in C<Some::Package::CONSTANT>. Constants may be exported by modules,
|
||||
and may also be called as either class or instance methods, that is,
|
||||
as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where
|
||||
C<$obj> is an instance of C<Some::Package>. Subclasses may define
|
||||
their own constants to override those in their base class.
|
||||
|
||||
The use of all caps for constant names is merely a convention,
|
||||
although it is recommended in order to make constants stand out
|
||||
and to help avoid collisions with other barewords, keywords, and
|
||||
subroutine names. Constant names must begin with a letter or
|
||||
underscore. Names beginning with a double underscore are reserved. Some
|
||||
poor choices for names will generate warnings, if warnings are enabled at
|
||||
compile time.
|
||||
|
||||
=head2 List constants
|
||||
|
||||
Constants may be lists of more (or less) than one value. A constant
|
||||
with no values evaluates to C<undef> in scalar context. Note that
|
||||
constants with more than one value do I<not> return their last value in
|
||||
scalar context as one might expect. They currently return the number
|
||||
of values, but B<this may change in the future>. Do not use constants
|
||||
with multiple values in scalar context.
|
||||
|
||||
B<NOTE:> This implies that the expression defining the value of a
|
||||
constant is evaluated in list context. This may produce surprises:
|
||||
|
||||
use constant TIMESTAMP => localtime; # WRONG!
|
||||
use constant TIMESTAMP => scalar localtime; # right
|
||||
|
||||
The first line above defines C<TIMESTAMP> as a 9-element list, as
|
||||
returned by C<localtime()> in list context. To set it to the string
|
||||
returned by C<localtime()> in scalar context, an explicit C<scalar>
|
||||
keyword is required.
|
||||
|
||||
List constants are lists, not arrays. To index or slice them, they
|
||||
must be placed in parentheses.
|
||||
|
||||
my @workdays = WEEKDAYS[1 .. 5]; # WRONG!
|
||||
my @workdays = (WEEKDAYS)[1 .. 5]; # right
|
||||
|
||||
=head2 Defining multiple constants at once
|
||||
|
||||
Instead of writing multiple C<use constant> statements, you may define
|
||||
multiple constants in a single statement by giving, instead of the
|
||||
constant name, a reference to a hash where the keys are the names of
|
||||
the constants to be defined. Obviously, all constants defined using
|
||||
this method must have a single value.
|
||||
|
||||
use constant {
|
||||
FOO => "A single value",
|
||||
BAR => "This", "won't", "work!", # Error!
|
||||
};
|
||||
|
||||
This is a fundamental limitation of the way hashes are constructed in
|
||||
Perl. The error messages produced when this happens will often be
|
||||
quite cryptic -- in the worst case there may be none at all, and
|
||||
you'll only later find that something is broken.
|
||||
|
||||
When defining multiple constants, you cannot use the values of other
|
||||
constants defined in the same declaration. This is because the
|
||||
calling package doesn't know about any constant within that group
|
||||
until I<after> the C<use> statement is finished.
|
||||
|
||||
use constant {
|
||||
BITMASK => 0xAFBAEBA8,
|
||||
NEGMASK => ~BITMASK, # Error!
|
||||
};
|
||||
|
||||
=head2 Magic constants
|
||||
|
||||
Magical values and references can be made into constants at compile
|
||||
time, allowing for way cool stuff like this. (These error numbers
|
||||
aren't totally portable, alas.)
|
||||
|
||||
use constant E2BIG => ($! = 7);
|
||||
print E2BIG, "\n"; # something like "Arg list too long"
|
||||
print 0+E2BIG, "\n"; # "7"
|
||||
|
||||
You can't produce a tied constant by giving a tied scalar as the
|
||||
value. References to tied variables, however, can be used as
|
||||
constants without any problems.
|
||||
|
||||
=head1 TECHNICAL NOTES
|
||||
|
||||
In the current implementation, scalar constants are actually
|
||||
inlinable subroutines. As of version 5.004 of Perl, the appropriate
|
||||
scalar constant is inserted directly in place of some subroutine
|
||||
calls, thereby saving the overhead of a subroutine call. See
|
||||
L<perlsub/"Constant Functions"> for details about how and when this
|
||||
happens.
|
||||
|
||||
In the rare case in which you need to discover at run time whether a
|
||||
particular constant has been declared via this module, you may use
|
||||
this function to examine the hash C<%constant::declared>. If the given
|
||||
constant name does not include a package name, the current package is
|
||||
used.
|
||||
|
||||
sub declared ($) {
|
||||
use constant 1.01; # don't omit this!
|
||||
my $name = shift;
|
||||
$name =~ s/^::/main::/;
|
||||
my $pkg = caller;
|
||||
my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
|
||||
$constant::declared{$full_name};
|
||||
}
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
In the current version of Perl, list constants are not inlined
|
||||
and some symbols may be redefined without generating a warning.
|
||||
|
||||
It is not possible to have a subroutine or a keyword with the same
|
||||
name as a constant in the same package. This is probably a Good Thing.
|
||||
|
||||
A constant with a name in the list C<STDIN STDOUT STDERR ARGV ARGVOUT
|
||||
ENV INC SIG> is not allowed anywhere but in package C<main::>, for
|
||||
technical reasons.
|
||||
|
||||
Unlike constants in some languages, these cannot be overridden
|
||||
on the command line or via environment variables.
|
||||
|
||||
You can get into trouble if you use constants in a context which
|
||||
automatically quotes barewords (as is true for any subroutine call).
|
||||
For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
|
||||
be interpreted as a string. Use C<$hash{CONSTANT()}> or
|
||||
C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
|
||||
kicking in. Similarly, since the C<< => >> operator quotes a bareword
|
||||
immediately to its left, you have to say C<< CONSTANT() => 'value' >>
|
||||
(or simply use a comma in place of the big arrow) instead of
|
||||
C<< CONSTANT => 'value' >>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Readonly> - Facility for creating read-only scalars, arrays, hashes.
|
||||
|
||||
L<Const> - Facility for creating read-only variables. Similar to C<Readonly>,
|
||||
but uses C<SvREADONLY> instead of C<tie>.
|
||||
|
||||
L<Attribute::Constant> - Make read-only variables via attribute
|
||||
|
||||
L<Scalar::Readonly> - Perl extension to the C<SvREADONLY> scalar flag
|
||||
|
||||
L<Hash::Util> - A selection of general-utility hash subroutines (mostly
|
||||
to lock/unlock keys and values)
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests via the perlbug(1) utility.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
|
||||
many other folks.
|
||||
|
||||
Multiple constant declarations at once added by Casey West,
|
||||
E<lt>F<casey@geeknest.com>E<gt>.
|
||||
|
||||
Documentation mostly rewritten by Ilmari Karonen,
|
||||
E<lt>F<perl@itz.pp.sci.fi>E<gt>.
|
||||
|
||||
This program is maintained by the Perl 5 Porters.
|
||||
The CPAN distribution is maintained by SE<eacute>bastien Aperghis-Tramoni
|
||||
E<lt>F<sebastien@aperghis.net>E<gt>.
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (C) 1997, 1999 Tom Phoenix
|
||||
|
||||
This module is free software; you can redistribute it or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
249
testsuite/input-files/perl-v5.14.2/lib/feature.pm
Normal file
249
testsuite/input-files/perl-v5.14.2/lib/feature.pm
Normal file
|
|
@ -0,0 +1,249 @@
|
|||
package feature;
|
||||
|
||||
our $VERSION = '1.20';
|
||||
|
||||
# (feature name) => (internal name, used in %^H)
|
||||
my %feature = (
|
||||
switch => 'feature_switch',
|
||||
say => "feature_say",
|
||||
state => "feature_state",
|
||||
unicode_strings => "feature_unicode",
|
||||
);
|
||||
|
||||
# This gets set (for now) in $^H as well as in %^H,
|
||||
# for runtime speed of the uc/lc/ucfirst/lcfirst functions.
|
||||
# See HINT_UNI_8_BIT in perl.h.
|
||||
our $hint_uni8bit = 0x00000800;
|
||||
|
||||
# NB. the latest bundle must be loaded by the -E switch (see toke.c)
|
||||
|
||||
my %feature_bundle = (
|
||||
"5.10" => [qw(switch say state)],
|
||||
"5.11" => [qw(switch say state unicode_strings)],
|
||||
"5.12" => [qw(switch say state unicode_strings)],
|
||||
"5.13" => [qw(switch say state unicode_strings)],
|
||||
"5.14" => [qw(switch say state unicode_strings)],
|
||||
);
|
||||
|
||||
# special case
|
||||
$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"};
|
||||
|
||||
# TODO:
|
||||
# - think about versioned features (use feature switch => 2)
|
||||
|
||||
=head1 NAME
|
||||
|
||||
feature - Perl pragma to enable new features
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use feature qw(switch say);
|
||||
given ($foo) {
|
||||
when (1) { say "\$foo == 1" }
|
||||
when ([2,3]) { say "\$foo == 2 || \$foo == 3" }
|
||||
when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" }
|
||||
when ($_ > 100) { say "\$foo > 100" }
|
||||
default { say "None of the above" }
|
||||
}
|
||||
|
||||
use feature ':5.10'; # loads all features available in perl 5.10
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is usually impossible to add new syntax to Perl without breaking
|
||||
some existing programs. This pragma provides a way to minimize that
|
||||
risk. New syntactic constructs, or new semantic meanings to older
|
||||
constructs, can be enabled by C<use feature 'foo'>, and will be parsed
|
||||
only when the appropriate feature pragma is in scope.
|
||||
|
||||
=head2 Lexical effect
|
||||
|
||||
Like other pragmas (C<use strict>, for example), features have a lexical
|
||||
effect. C<use feature qw(foo)> will only make the feature "foo" available
|
||||
from that point to the end of the enclosing block.
|
||||
|
||||
{
|
||||
use feature 'say';
|
||||
say "say is available here";
|
||||
}
|
||||
print "But not here.\n";
|
||||
|
||||
=head2 C<no feature>
|
||||
|
||||
Features can also be turned off by using C<no feature "foo">. This too
|
||||
has lexical effect.
|
||||
|
||||
use feature 'say';
|
||||
say "say is available here";
|
||||
{
|
||||
no feature 'say';
|
||||
print "But not here.\n";
|
||||
}
|
||||
say "Yet it is here.";
|
||||
|
||||
C<no feature> with no features specified will turn off all features.
|
||||
|
||||
=head2 The 'switch' feature
|
||||
|
||||
C<use feature 'switch'> tells the compiler to enable the Perl 6
|
||||
given/when construct.
|
||||
|
||||
See L<perlsyn/"Switch statements"> for details.
|
||||
|
||||
=head2 The 'say' feature
|
||||
|
||||
C<use feature 'say'> tells the compiler to enable the Perl 6
|
||||
C<say> function.
|
||||
|
||||
See L<perlfunc/say> for details.
|
||||
|
||||
=head2 the 'state' feature
|
||||
|
||||
C<use feature 'state'> tells the compiler to enable C<state>
|
||||
variables.
|
||||
|
||||
See L<perlsub/"Persistent Private Variables"> for details.
|
||||
|
||||
=head2 the 'unicode_strings' feature
|
||||
|
||||
C<use feature 'unicode_strings'> tells the compiler to use Unicode semantics
|
||||
in all string operations executed within its scope (unless they are also
|
||||
within the scope of either C<use locale> or C<use bytes>). The same applies
|
||||
to all regular expressions compiled within the scope, even if executed outside
|
||||
it.
|
||||
|
||||
C<no feature 'unicode_strings'> tells the compiler to use the traditional
|
||||
Perl semantics wherein the native character set semantics is used unless it is
|
||||
clear to Perl that Unicode is desired. This can lead to some surprises
|
||||
when the behavior suddenly changes. (See
|
||||
L<perlunicode/The "Unicode Bug"> for details.) For this reason, if you are
|
||||
potentially using Unicode in your program, the
|
||||
C<use feature 'unicode_strings'> subpragma is B<strongly> recommended.
|
||||
|
||||
This subpragma is available starting with Perl 5.11.3, but was not fully
|
||||
implemented until 5.13.8.
|
||||
|
||||
=head1 FEATURE BUNDLES
|
||||
|
||||
It's possible to load a whole slew of features in one go, using
|
||||
a I<feature bundle>. The name of a feature bundle is prefixed with
|
||||
a colon, to distinguish it from an actual feature. At present, the
|
||||
only feature bundle is C<use feature ":5.10"> which is equivalent
|
||||
to C<use feature qw(switch say state)>.
|
||||
|
||||
Specifying sub-versions such as the C<0> in C<5.10.0> in feature bundles has
|
||||
no effect: feature bundles are guaranteed to be the same for all sub-versions.
|
||||
|
||||
=head1 IMPLICIT LOADING
|
||||
|
||||
There are two ways to load the C<feature> pragma implicitly :
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
By using the C<-E> switch on the command-line instead of C<-e>. It enables
|
||||
all available features in the main compilation unit (that is, the one-liner.)
|
||||
|
||||
=item *
|
||||
|
||||
By requiring explicitly a minimal Perl version number for your program, with
|
||||
the C<use VERSION> construct, and when the version is higher than or equal to
|
||||
5.10.0. That is,
|
||||
|
||||
use 5.10.0;
|
||||
|
||||
will do an implicit
|
||||
|
||||
use feature ':5.10';
|
||||
|
||||
and so on. Note how the trailing sub-version is automatically stripped from the
|
||||
version.
|
||||
|
||||
But to avoid portability warnings (see L<perlfunc/use>), you may prefer:
|
||||
|
||||
use 5.010;
|
||||
|
||||
with the same effect.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
if (@_ == 0) {
|
||||
croak("No features specified");
|
||||
}
|
||||
while (@_) {
|
||||
my $name = shift(@_);
|
||||
if (substr($name, 0, 1) eq ":") {
|
||||
my $v = substr($name, 1);
|
||||
if (!exists $feature_bundle{$v}) {
|
||||
$v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
|
||||
if (!exists $feature_bundle{$v}) {
|
||||
unknown_feature_bundle(substr($name, 1));
|
||||
}
|
||||
}
|
||||
unshift @_, @{$feature_bundle{$v}};
|
||||
next;
|
||||
}
|
||||
if (!exists $feature{$name}) {
|
||||
unknown_feature($name);
|
||||
}
|
||||
$^H{$feature{$name}} = 1;
|
||||
$^H |= $hint_uni8bit if $name eq 'unicode_strings';
|
||||
}
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $class = shift;
|
||||
|
||||
# A bare C<no feature> should disable *all* features
|
||||
if (!@_) {
|
||||
delete @^H{ values(%feature) };
|
||||
$^H &= ~ $hint_uni8bit;
|
||||
return;
|
||||
}
|
||||
|
||||
while (@_) {
|
||||
my $name = shift;
|
||||
if (substr($name, 0, 1) eq ":") {
|
||||
my $v = substr($name, 1);
|
||||
if (!exists $feature_bundle{$v}) {
|
||||
$v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/;
|
||||
if (!exists $feature_bundle{$v}) {
|
||||
unknown_feature_bundle(substr($name, 1));
|
||||
}
|
||||
}
|
||||
unshift @_, @{$feature_bundle{$v}};
|
||||
next;
|
||||
}
|
||||
if (!exists($feature{$name})) {
|
||||
unknown_feature($name);
|
||||
}
|
||||
else {
|
||||
delete $^H{$feature{$name}};
|
||||
$^H &= ~ $hint_uni8bit if $name eq 'unicode_strings';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub unknown_feature {
|
||||
my $feature = shift;
|
||||
croak(sprintf('Feature "%s" is not supported by Perl %vd',
|
||||
$feature, $^V));
|
||||
}
|
||||
|
||||
sub unknown_feature_bundle {
|
||||
my $feature = shift;
|
||||
croak(sprintf('Feature bundle "%s" is not supported by Perl %vd',
|
||||
$feature, $^V));
|
||||
}
|
||||
|
||||
sub croak {
|
||||
require Carp;
|
||||
Carp::croak(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
1701
testsuite/input-files/perl-v5.14.2/lib/overload.pm
Normal file
1701
testsuite/input-files/perl-v5.14.2/lib/overload.pm
Normal file
File diff suppressed because it is too large
Load diff
147
testsuite/input-files/perl-v5.14.2/lib/strict.pm
Normal file
147
testsuite/input-files/perl-v5.14.2/lib/strict.pm
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
strict - Perl pragma to restrict unsafe constructs
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
|
||||
use strict "vars";
|
||||
use strict "refs";
|
||||
use strict "subs";
|
||||
|
||||
use strict;
|
||||
no strict "vars";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
If no import list is supplied, all possible restrictions are assumed.
|
||||
(This is the safest mode to operate in, but is sometimes too strict for
|
||||
casual programming.) Currently, there are three possible things to be
|
||||
strict about: "subs", "vars", and "refs".
|
||||
|
||||
=over 6
|
||||
|
||||
=item C<strict refs>
|
||||
|
||||
This generates a runtime error if you
|
||||
use symbolic references (see L<perlref>).
|
||||
|
||||
use strict 'refs';
|
||||
$ref = \$foo;
|
||||
print $$ref; # ok
|
||||
$ref = "foo";
|
||||
print $$ref; # runtime error; normally ok
|
||||
$file = "STDOUT";
|
||||
print $file "Hi!"; # error; note: no comma after $file
|
||||
|
||||
There is one exception to this rule:
|
||||
|
||||
$bar = \&{'foo'};
|
||||
&$bar;
|
||||
|
||||
is allowed so that C<goto &$AUTOLOAD> would not break under stricture.
|
||||
|
||||
|
||||
=item C<strict vars>
|
||||
|
||||
This generates a compile-time error if you access a variable that wasn't
|
||||
declared via C<our> or C<use vars>,
|
||||
localized via C<my()>, or wasn't fully qualified. Because this is to avoid
|
||||
variable suicide problems and subtle dynamic scoping issues, a merely
|
||||
local() variable isn't good enough. See L<perlfunc/my> and
|
||||
L<perlfunc/local>.
|
||||
|
||||
use strict 'vars';
|
||||
$X::foo = 1; # ok, fully qualified
|
||||
my $foo = 10; # ok, my() var
|
||||
local $foo = 9; # blows up
|
||||
|
||||
package Cinna;
|
||||
our $bar; # Declares $bar in current package
|
||||
$bar = 'HgS'; # ok, global declared via pragma
|
||||
|
||||
The local() generated a compile-time error because you just touched a global
|
||||
name without fully qualifying it.
|
||||
|
||||
Because of their special use by sort(), the variables $a and $b are
|
||||
exempted from this check.
|
||||
|
||||
=item C<strict subs>
|
||||
|
||||
This disables the poetry optimization, generating a compile-time error if
|
||||
you try to use a bareword identifier that's not a subroutine, unless it
|
||||
is a simple identifier (no colons) and that it appears in curly braces or
|
||||
on the left hand side of the C<< => >> symbol.
|
||||
|
||||
use strict 'subs';
|
||||
$SIG{PIPE} = Plumber; # blows up
|
||||
$SIG{PIPE} = "Plumber"; # just fine: quoted string is always ok
|
||||
$SIG{PIPE} = \&Plumber; # preferred form
|
||||
|
||||
=back
|
||||
|
||||
See L<perlmodlib/Pragmatic Modules>.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
C<strict 'subs'>, with Perl 5.6.1, erroneously permitted to use an unquoted
|
||||
compound identifier (e.g. C<Foo::Bar>) as a hash key (before C<< => >> or
|
||||
inside curlies), but without forcing it always to a literal string.
|
||||
|
||||
Starting with Perl 5.8.1 strict is strict about its restrictions:
|
||||
if unknown restrictions are used, the strict pragma will abort with
|
||||
|
||||
Unknown 'strict' tag(s) '...'
|
||||
|
||||
As of version 1.04 (Perl 5.10), strict verifies that it is used as
|
||||
"strict" to avoid the dreaded Strict trap on case insensitive file
|
||||
systems.
|
||||
|
||||
=cut
|
||||
82
testsuite/input-files/perl-v5.14.2/lib/vars.pm
Normal file
82
testsuite/input-files/perl-v5.14.2/lib/vars.pm
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
package vars;
|
||||
|
||||
use 5.006;
|
||||
|
||||
our $VERSION = '1.02';
|
||||
|
||||
use warnings::register;
|
||||
use strict qw(vars subs);
|
||||
|
||||
sub import {
|
||||
my $callpack = caller;
|
||||
my (undef, @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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
vars - Perl pragma to predeclare global variable names (obsolete)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use vars qw($frob @mung %seen);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
NOTE: For variables in the current package, the functionality provided
|
||||
by this pragma has been superseded by C<our> declarations, available
|
||||
in Perl v5.6.0 or later. See L<perlfunc/our>.
|
||||
|
||||
This will predeclare all the variables whose names are
|
||||
in the list, allowing you to use them under "use strict", and
|
||||
disabling any typo warnings.
|
||||
|
||||
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>.
|
||||
|
||||
Packages such as the B<AutoLoader> and B<SelfLoader> that delay
|
||||
loading of subroutines within packages can create problems with
|
||||
package lexicals defined using C<my()>. While the B<vars> pragma
|
||||
cannot duplicate the effect of package lexicals (total transparency
|
||||
outside of the package), it can act as an acceptable substitute by
|
||||
pre-declaring global symbols, ensuring their availability to the
|
||||
later-loaded routines.
|
||||
|
||||
See L<perlmodlib/Pragmatic Modules>.
|
||||
|
||||
=cut
|
||||
567
testsuite/input-files/perl-v5.14.2/lib/warnings.pm
Normal file
567
testsuite/input-files/perl-v5.14.2/lib/warnings.pm
Normal file
|
|
@ -0,0 +1,567 @@
|
|||
# -*- buffer-read-only: t -*-
|
||||
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
|
||||
# This file is built by regen/warnings.pl.
|
||||
# Any changes made here will be lost!
|
||||
|
||||
package warnings;
|
||||
|
||||
our $VERSION = '1.12';
|
||||
|
||||
# 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");
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
warnings - Perl pragma to control optional warnings
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use warnings;
|
||||
no warnings;
|
||||
|
||||
use warnings "all";
|
||||
no warnings "all";
|
||||
|
||||
use warnings::register;
|
||||
if (warnings::enabled()) {
|
||||
warnings::warn("some warning");
|
||||
}
|
||||
|
||||
if (warnings::enabled("void")) {
|
||||
warnings::warn("void", "some warning");
|
||||
}
|
||||
|
||||
if (warnings::enabled($object)) {
|
||||
warnings::warn($object, "some warning");
|
||||
}
|
||||
|
||||
warnings::warnif("some warning");
|
||||
warnings::warnif("void", "some warning");
|
||||
warnings::warnif($object, "some warning");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<warnings> pragma is a replacement for the command line flag C<-w>,
|
||||
but the pragma is limited to the enclosing block, while the flag is global.
|
||||
See L<perllexwarn> for more information.
|
||||
|
||||
If no import list is supplied, all possible warnings are either enabled
|
||||
or disabled.
|
||||
|
||||
A number of functions are provided to assist module authors.
|
||||
|
||||
=over 4
|
||||
|
||||
=item use warnings::register
|
||||
|
||||
Creates a new warnings category with the same name as the package where
|
||||
the call to the pragma is used.
|
||||
|
||||
=item warnings::enabled()
|
||||
|
||||
Use the warnings category with the same name as the current package.
|
||||
|
||||
Return TRUE if that warnings category is enabled in the calling module.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::enabled($category)
|
||||
|
||||
Return TRUE if the warnings category, C<$category>, is enabled in the
|
||||
calling module.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::enabled($object)
|
||||
|
||||
Use the name of the class for the object reference, C<$object>, as the
|
||||
warnings category.
|
||||
|
||||
Return TRUE if that warnings category is enabled in the first scope
|
||||
where the object is used.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::fatal_enabled()
|
||||
|
||||
Return TRUE if the warnings category with the same name as the current
|
||||
package has been set to FATAL in the calling module.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::fatal_enabled($category)
|
||||
|
||||
Return TRUE if the warnings category C<$category> has been set to FATAL in
|
||||
the calling module.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::fatal_enabled($object)
|
||||
|
||||
Use the name of the class for the object reference, C<$object>, as the
|
||||
warnings category.
|
||||
|
||||
Return TRUE if that warnings category has been set to FATAL in the first
|
||||
scope where the object is used.
|
||||
Otherwise returns FALSE.
|
||||
|
||||
=item warnings::warn($message)
|
||||
|
||||
Print C<$message> to STDERR.
|
||||
|
||||
Use the warnings category with the same name as the current package.
|
||||
|
||||
If that warnings category has been set to "FATAL" in the calling module
|
||||
then die. Otherwise return.
|
||||
|
||||
=item warnings::warn($category, $message)
|
||||
|
||||
Print C<$message> to STDERR.
|
||||
|
||||
If the warnings category, C<$category>, has been set to "FATAL" in the
|
||||
calling module then die. Otherwise return.
|
||||
|
||||
=item warnings::warn($object, $message)
|
||||
|
||||
Print C<$message> to STDERR.
|
||||
|
||||
Use the name of the class for the object reference, C<$object>, as the
|
||||
warnings category.
|
||||
|
||||
If that warnings category has been set to "FATAL" in the scope where C<$object>
|
||||
is first used then die. Otherwise return.
|
||||
|
||||
|
||||
=item warnings::warnif($message)
|
||||
|
||||
Equivalent to:
|
||||
|
||||
if (warnings::enabled())
|
||||
{ warnings::warn($message) }
|
||||
|
||||
=item warnings::warnif($category, $message)
|
||||
|
||||
Equivalent to:
|
||||
|
||||
if (warnings::enabled($category))
|
||||
{ warnings::warn($category, $message) }
|
||||
|
||||
=item warnings::warnif($object, $message)
|
||||
|
||||
Equivalent to:
|
||||
|
||||
if (warnings::enabled($object))
|
||||
{ warnings::warn($object, $message) }
|
||||
|
||||
=item warnings::register_categories(@names)
|
||||
|
||||
This registers warning categories for the given names and is primarily for
|
||||
use by the warnings::register pragma, for which see L<perllexwarn>.
|
||||
|
||||
=back
|
||||
|
||||
See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
|
||||
|
||||
=cut
|
||||
|
||||
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,
|
||||
|
||||
# Warnings Categories added in Perl 5.011
|
||||
|
||||
'imprecision' => 92,
|
||||
'illegalproto' => 94,
|
||||
|
||||
# Warnings Categories added in Perl 5.013
|
||||
|
||||
'non_unicode' => 96,
|
||||
'nonchar' => 98,
|
||||
'surrogate' => 100,
|
||||
);
|
||||
|
||||
our %Bits = (
|
||||
'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..50]
|
||||
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [29]
|
||||
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [30]
|
||||
'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
|
||||
'closure' => "\x04\x00\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\x00", # [22]
|
||||
'deprecated' => "\x10\x00\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\x00", # [31]
|
||||
'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
|
||||
'exiting' => "\x40\x00\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\x00", # [4]
|
||||
'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [47]
|
||||
'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [46]
|
||||
'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [23]
|
||||
'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [24]
|
||||
'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
|
||||
'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
|
||||
'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [25]
|
||||
'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
|
||||
'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
|
||||
'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [48]
|
||||
'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [49]
|
||||
'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
|
||||
'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
|
||||
'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
|
||||
'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
|
||||
'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [32]
|
||||
'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
|
||||
'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
|
||||
'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [33]
|
||||
'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [34]
|
||||
'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [35]
|
||||
'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [36]
|
||||
'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
|
||||
'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
|
||||
'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [20]
|
||||
'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [37]
|
||||
'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [38]
|
||||
'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00", # [21..25]
|
||||
'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [26]
|
||||
'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [27]
|
||||
'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [50]
|
||||
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00", # [28..38,47]
|
||||
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [39]
|
||||
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [40]
|
||||
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [41]
|
||||
'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
|
||||
'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [42]
|
||||
'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [43]
|
||||
'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15", # [44,48..50]
|
||||
'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [45]
|
||||
);
|
||||
|
||||
our %DeadBits = (
|
||||
'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..50]
|
||||
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [29]
|
||||
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [30]
|
||||
'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
|
||||
'closure' => "\x08\x00\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\x00", # [22]
|
||||
'deprecated' => "\x20\x00\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\x00", # [31]
|
||||
'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
|
||||
'exiting' => "\x80\x00\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\x00", # [4]
|
||||
'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [47]
|
||||
'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [46]
|
||||
'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [23]
|
||||
'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [24]
|
||||
'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
|
||||
'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
|
||||
'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [25]
|
||||
'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
|
||||
'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
|
||||
'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [48]
|
||||
'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [49]
|
||||
'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
|
||||
'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
|
||||
'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
|
||||
'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [16]
|
||||
'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [32]
|
||||
'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
|
||||
'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [17]
|
||||
'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [33]
|
||||
'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [34]
|
||||
'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [35]
|
||||
'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [36]
|
||||
'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [18]
|
||||
'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [19]
|
||||
'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [20]
|
||||
'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [37]
|
||||
'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [38]
|
||||
'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00", # [21..25]
|
||||
'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [26]
|
||||
'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [27]
|
||||
'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [50]
|
||||
'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00", # [28..38,47]
|
||||
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [39]
|
||||
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [40]
|
||||
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [41]
|
||||
'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
|
||||
'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [42]
|
||||
'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [43]
|
||||
'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a", # [44,48..50]
|
||||
'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [45]
|
||||
);
|
||||
|
||||
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
|
||||
$LAST_BIT = 102 ;
|
||||
$BYTES = 13 ;
|
||||
|
||||
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
|
||||
|
||||
sub Croaker
|
||||
{
|
||||
require Carp; # this initializes %CarpInternal
|
||||
local $Carp::CarpInternal{'warnings'};
|
||||
delete $Carp::CarpInternal{'warnings'};
|
||||
Carp::croak(@_);
|
||||
}
|
||||
|
||||
sub _bits {
|
||||
my $mask = shift ;
|
||||
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 bits
|
||||
{
|
||||
# called from B::Deparse.pm
|
||||
push @_, 'all' unless @_ ;
|
||||
return _bits(undef, @_) ;
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
shift;
|
||||
|
||||
my $mask = ${^WARNING_BITS} ;
|
||||
|
||||
if (vec($mask, $Offsets{'all'}, 1)) {
|
||||
$mask |= $Bits{'all'} ;
|
||||
$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
|
||||
}
|
||||
|
||||
# Empty @_ is equivalent to @_ = 'all' ;
|
||||
${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
|
||||
}
|
||||
|
||||
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 MESSAGE () { 4 };
|
||||
sub FATAL () { 2 };
|
||||
sub NORMAL () { 1 };
|
||||
|
||||
sub __chk
|
||||
{
|
||||
my $category ;
|
||||
my $offset ;
|
||||
my $isobj = 0 ;
|
||||
my $wanted = shift;
|
||||
my $has_message = $wanted & MESSAGE;
|
||||
|
||||
unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
|
||||
my $sub = (caller 1)[3];
|
||||
my $syntax = $has_message ? "[category,] 'message'" : '[category]';
|
||||
Croaker("Usage: $sub($syntax)");
|
||||
}
|
||||
|
||||
my $message = pop if $has_message;
|
||||
|
||||
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 $i;
|
||||
|
||||
if ($isobj) {
|
||||
my $pkg;
|
||||
$i = 2;
|
||||
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
|
||||
}
|
||||
|
||||
# Defaulting this to 0 reduces complexity in code paths below.
|
||||
my $callers_bitmask = (caller($i))[9] || 0 ;
|
||||
|
||||
my @results;
|
||||
foreach my $type (FATAL, NORMAL) {
|
||||
next unless $wanted & $type;
|
||||
|
||||
push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
|
||||
vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
|
||||
}
|
||||
|
||||
# &enabled and &fatal_enabled
|
||||
return $results[0] unless $has_message;
|
||||
|
||||
# &warnif, and the category is neither enabled as warning nor as fatal
|
||||
return if $wanted == (NORMAL | FATAL | MESSAGE)
|
||||
&& !($results[0] || $results[1]);
|
||||
|
||||
require Carp;
|
||||
Carp::croak($message) if $results[0];
|
||||
# will always get here for &warn. will only get here for &warnif if the
|
||||
# category is enabled
|
||||
Carp::carp($message);
|
||||
}
|
||||
|
||||
sub _mkMask
|
||||
{
|
||||
my ($bit) = @_;
|
||||
my $mask = "";
|
||||
|
||||
vec($mask, $bit, 1) = 1;
|
||||
return $mask;
|
||||
}
|
||||
|
||||
sub register_categories
|
||||
{
|
||||
my @names = @_;
|
||||
|
||||
for my $name (@names) {
|
||||
if (! defined $Bits{$name}) {
|
||||
$Bits{$name} = _mkMask($LAST_BIT);
|
||||
vec($Bits{'all'}, $LAST_BIT, 1) = 1;
|
||||
$Offsets{$name} = $LAST_BIT ++;
|
||||
foreach my $k (keys %Bits) {
|
||||
vec($Bits{$k}, $LAST_BIT, 1) = 0;
|
||||
}
|
||||
$DeadBits{$name} = _mkMask($LAST_BIT);
|
||||
vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _error_loc {
|
||||
require Carp;
|
||||
goto &Carp::short_error_loc; # don't introduce another stack frame
|
||||
}
|
||||
|
||||
sub enabled
|
||||
{
|
||||
return __chk(NORMAL, @_);
|
||||
}
|
||||
|
||||
sub fatal_enabled
|
||||
{
|
||||
return __chk(FATAL, @_);
|
||||
}
|
||||
|
||||
sub warn
|
||||
{
|
||||
return __chk(FATAL | MESSAGE, @_);
|
||||
}
|
||||
|
||||
sub warnif
|
||||
{
|
||||
return __chk(NORMAL | FATAL | MESSAGE, @_);
|
||||
}
|
||||
|
||||
# These are not part of any public interface, so we can delete them to save
|
||||
# space.
|
||||
delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
|
||||
|
||||
1;
|
||||
|
||||
# ex: set ro:
|
||||
48
testsuite/input-files/perl-v5.14.2/lib/warnings/register.pm
Normal file
48
testsuite/input-files/perl-v5.14.2/lib/warnings/register.pm
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
package warnings::register;
|
||||
|
||||
our $VERSION = '1.02';
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
warnings::register - warnings import function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use warnings::register;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Creates a warnings category with the same name as the current package.
|
||||
|
||||
See L<warnings> and L<perllexwarn> for more information on this module's
|
||||
usage.
|
||||
|
||||
=cut
|
||||
|
||||
require warnings;
|
||||
|
||||
# left here as cruft in case other users were using this undocumented routine
|
||||
# -- rjbs, 2010-09-08
|
||||
sub mkMask
|
||||
{
|
||||
my ($bit) = @_;
|
||||
my $mask = "";
|
||||
|
||||
vec($mask, $bit, 1) = 1;
|
||||
return $mask;
|
||||
}
|
||||
|
||||
sub import
|
||||
{
|
||||
shift;
|
||||
my @categories = @_;
|
||||
|
||||
my $package = (caller(0))[0];
|
||||
warnings::register_categories($package);
|
||||
|
||||
warnings::register_categories($package . "::$_") for @categories;
|
||||
}
|
||||
|
||||
1;
|
||||
BIN
testsuite/input-files/perl-v5.14.2/perl
Executable file
BIN
testsuite/input-files/perl-v5.14.2/perl
Executable file
Binary file not shown.
|
|
@ -32,7 +32,7 @@ echo '### -N and --noswap. Must give 0'
|
|||
EOF
|
||||
|
||||
# force load > 10
|
||||
while uptime | grep -v age:.[1-9][0-9].[0-9][0-9] >/dev/null ; do (timeout 5 nice burnP6 2>/dev/null &) done
|
||||
while uptime | egrep -v 'age:.[1-9][0-9]?[0-9].[0-9][0-9]' >/dev/null ; do (timeout 5 nice burnP6 2>/dev/null &) done
|
||||
|
||||
cat <<'EOF' | sed -e 's/;$/; /;s/$SERVER1/'$SERVER1'/;s/$SERVER2/'$SERVER2'/' | stdout parallel -vj0 --joblog /tmp/jl-`basename $0` -L1
|
||||
echo '### -H and --hard'
|
||||
|
|
@ -50,4 +50,5 @@ EOF
|
|||
#sleep 3 &
|
||||
#nice-load -v -p $!
|
||||
|
||||
killall freepl 2>/dev/null
|
||||
|
||||
|
|
|
|||
39
testsuite/tests-to-run/parallel-local-mem.sh
Normal file
39
testsuite/tests-to-run/parallel-local-mem.sh
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
#!/bin/bash
|
||||
|
||||
# Jobs that eat more than 2 GB RAM
|
||||
cat <<'EOF' | sed -e 's/;$/; /;s/$SERVER1/'$SERVER1'/;s/$SERVER2/'$SERVER2'/' | stdout parallel -vj1 -k --joblog /tmp/jl-`basename $0` -L1
|
||||
echo '### Trouble reading a record > 2 GB for certain versions of Perl (substr($a,0,2G+1)="fails")'
|
||||
echo '### perl -e $buf=("x"x(2**31))."x"; substr($buf,0,2**31+1)=""; print length $buf'
|
||||
'
|
||||
echo 'Eats 2.5 GB'
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo ged) |
|
||||
PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` -k --block 2G --pipe --recend ged md5sum
|
||||
echo 'Eats 2.5 GB'
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo ged) |
|
||||
PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` -k --block 2G --pipe --recend ged cat | wc -c
|
||||
|
||||
echo '**'
|
||||
|
||||
echo '### bug #44358: 2 GB records cause problems for -N'
|
||||
echo '5 GB version: Eats 12.5 GB'
|
||||
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 3000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 1000000000;) |
|
||||
PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl
|
||||
`which parallel` --pipe --recend FOO -N2 --block 1g -k LANG=c wc -c
|
||||
|
||||
echo '2 GB version: eats 10 GB'
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 2300M; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 1000M;) |
|
||||
PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl
|
||||
`which parallel` --pipe --recend FOO -N2 --block 1g -k LANG=c wc -c
|
||||
|
||||
echo '### -L >4GB'
|
||||
(head -c 5000000000 /dev/zero; echo FOO;
|
||||
head -c 3000000000 /dev/zero; echo FOO;
|
||||
head -c 1000000000 /dev/zero;) |
|
||||
parallel --pipe -L2 --block 1g -k LANG=c wc -c
|
||||
|
||||
EOF
|
||||
|
|
@ -1,12 +1,6 @@
|
|||
#!/bin/bash
|
||||
|
||||
cat <<'EOF' | sed -e 's/;$/; /;s/$SERVER1/'$SERVER1'/;s/$SERVER2/'$SERVER2'/' | stdout parallel -vj0 -k --joblog /tmp/jl-`basename $0` -L1
|
||||
echo '### bug #44358: 2 GB records cause problems for -N2'
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 3000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 1000000000;) |
|
||||
parallel --pipe --recend FOO'\n' --block 1g -k LANG=c wc -c
|
||||
|
||||
echo "### --line-buffer"
|
||||
seq 10 | parallel -j20 --line-buffer 'seq {} 10 | pv -qL 10' > /tmp/parallel_l$$;
|
||||
seq 10 | parallel -j20 'seq {} 10 | pv -qL 10' > /tmp/parallel_$$;
|
||||
|
|
|
|||
|
|
@ -29,12 +29,6 @@ ls | parallel -kv rm -- {.}/abc-{.}-{} 2>&1
|
|||
|
||||
# -L1 will join lines ending in ' '
|
||||
cat <<'EOF' | sed -e s/\$SERVER1/$SERVER1/\;s/\$SERVER2/$SERVER2/ | nice parallel -vj0 -k -L1
|
||||
echo '### bug #44358: 2 GB records cause problems for -N2'
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 3000000000; echo FOO;
|
||||
yes "`echo {1..100}`" | head -c 1000000000;) |
|
||||
parallel --pipe --recend FOO'\n' -N2 --block 1g -k LANG=c wc -c
|
||||
|
||||
echo '### Test compress'
|
||||
seq 5 | parallel -j2 --tag --compress 'seq {} | pv -q -L 10'
|
||||
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ echo '### added transfersize/returnsize to local jobs'
|
|||
echo '### --tmux test - check termination'
|
||||
perl -e 'map {printf "$_%o%c\n",$_,$_}1..255' |
|
||||
stdout parallel --tmux echo {} :::: - ::: a b |
|
||||
perl -pe 's:tmp.par.*tms:tmp/parXXXXX.tms:; s/\d/0/g'
|
||||
perl -pe 's:tmp.par.*tms:tmp/parXXXXX.tms:; s/\d+/0/g'
|
||||
|
||||
EOF
|
||||
|
||||
|
|
|
|||
|
|
@ -6,12 +6,6 @@ seq 1 1000000 >/tmp/parallel-seq
|
|||
shuf --random-source=/tmp/parallel-seq /tmp/parallel-seq >/tmp/blocktest
|
||||
|
||||
cat <<'EOF' | sed -e s/\$SERVER1/$SERVER1/\;s/\$SERVER2/$SERVER2/ | parallel -vj2 -k --joblog /tmp/jl-`basename $0` -L1
|
||||
echo '### -L >4GB'
|
||||
(head -c 5000000000 /dev/zero; echo FOO;
|
||||
head -c 3000000000 /dev/zero; echo FOO;
|
||||
head -c 1000000000 /dev/zero;) |
|
||||
parallel --pipe -L2 --block 1g -k LANG=c wc -c
|
||||
|
||||
echo '### Test 200M records with too small block';
|
||||
(
|
||||
echo start;
|
||||
|
|
|
|||
46
testsuite/wanted-results/parallel-local-mem
Normal file
46
testsuite/wanted-results/parallel-local-mem
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
echo '### Trouble reading a record > 2 GB for certain versions of Perl (substr($a,0,2G+1)="fails")'
|
||||
### Trouble reading a record > 2 GB for certain versions of Perl (substr($a,0,2G+1)="fails")
|
||||
echo '### perl -e $buf=("x"x(2**31))."x"; substr($buf,0,2**31+1)=""; print length $buf'
|
||||
### perl -e $buf=("x"x(2**31))."x"; substr($buf,0,2**31+1)=""; print length $buf
|
||||
'
|
||||
/bin/bash: -c: line 0: unexpected EOF while looking for matching `''
|
||||
/bin/bash: -c: line 1: syntax error: unexpected end of file
|
||||
echo 'Eats 2.5 GB'
|
||||
Eats 2.5 GB
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo ged) | PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` -k --block 2G --pipe --recend ged md5sum
|
||||
131cbd7a7f1d19de3dabb379c716396b -
|
||||
68b329da9893e34099c7d8ad5cb9c940 -
|
||||
parallel: Warning: --blocksize >= 2G causes problems. Using 2G-1
|
||||
echo 'Eats 2.5 GB'
|
||||
Eats 2.5 GB
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo ged) | PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` -k --block 2G --pipe --recend ged cat | wc -c
|
||||
2411724804
|
||||
parallel: Warning: --blocksize >= 2G causes problems. Using 2G-1
|
||||
echo '**'
|
||||
**
|
||||
echo '### bug #44358: 2 GB records cause problems for -N'
|
||||
### bug #44358: 2 GB records cause problems for -N
|
||||
echo '5 GB version: Eats 12.5 GB'
|
||||
5 GB version: Eats 12.5 GB
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO; yes "`echo {1..100}`" | head -c 3000000000; echo FOO; yes "`echo {1..100}`" | head -c 1000000000;) | PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` --pipe --recend FOO -N2 --block 1g -k LANG=c wc -c
|
||||
8000000007
|
||||
1000000001
|
||||
parallel: Warning: A record was longer than 1000000000. Increasing to --blocksize 1300000001
|
||||
parallel: Warning: A record was longer than 1300000001. Increasing to --blocksize 1690000003
|
||||
parallel: Warning: A record was longer than 1690000003. Increasing to --blocksize 2147483647
|
||||
echo '2 GB version: eats 10 GB'
|
||||
2 GB version: eats 10 GB
|
||||
(yes "`echo {1..100}`" | head -c 2300M; echo FOO; yes "`echo {1..100}`" | head -c 2300M; echo FOO; yes "`echo {1..100}`" | head -c 1000M;) | PERL5LIB=input-files/perl-v5.14.2/lib input-files/perl-v5.14.2/perl `which parallel` --pipe --recend FOO -N2 --block 1g -k LANG=c wc -c
|
||||
4823449607
|
||||
1048576001
|
||||
parallel: Warning: A record was longer than 1000000000. Increasing to --blocksize 1300000001
|
||||
parallel: Warning: A record was longer than 1300000001. Increasing to --blocksize 1690000003
|
||||
parallel: Warning: A record was longer than 1690000003. Increasing to --blocksize 2147483647
|
||||
echo '### -L >4GB'
|
||||
### -L >4GB
|
||||
(head -c 5000000000 /dev/zero; echo FOO; head -c 3000000000 /dev/zero; echo FOO; head -c 1000000000 /dev/zero;) | parallel --pipe -L2 --block 1g -k LANG=c wc -c
|
||||
8000000008
|
||||
1000000000
|
||||
parallel: Warning: A record was longer than 1000000000. Increasing to --blocksize 1300000001
|
||||
parallel: Warning: A record was longer than 1300000001. Increasing to --blocksize 1690000003
|
||||
parallel: Warning: A record was longer than 1690000003. Increasing to --blocksize 2147483647
|
||||
|
|
@ -1,12 +1,3 @@
|
|||
echo '### bug #44358: 2 GB records cause problems for -N2'
|
||||
### bug #44358: 2 GB records cause problems for -N2
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO; yes "`echo {1..100}`" | head -c 3000000000; echo FOO; yes "`echo {1..100}`" | head -c 1000000000;) | parallel --pipe --recend FOO'\n' --block 1g -k LANG=c wc -c
|
||||
5000000004
|
||||
3000000004
|
||||
1000000000
|
||||
parallel: Warning: A record was longer than 1000000000. Increasing to --blocksize 1300000001
|
||||
parallel: Warning: A record was longer than 1300000001. Increasing to --blocksize 1690000003
|
||||
parallel: Warning: A record was longer than 1690000003. Increasing to --blocksize 2147483647
|
||||
echo "### --line-buffer"
|
||||
### --line-buffer
|
||||
seq 10 | parallel -j20 --line-buffer 'seq {} 10 | pv -qL 10' > /tmp/parallel_l$$; seq 10 | parallel -j20 'seq {} 10 | pv -qL 10' > /tmp/parallel_$$; cat /tmp/parallel_l$$ | wc; diff /tmp/parallel_$$ /tmp/parallel_l$$ >/dev/null ; echo These must diff: $?; rm /tmp/parallel_l$$ /tmp/parallel_$$
|
||||
|
|
|
|||
|
|
@ -55,11 +55,6 @@ rm -- 2-col/abc-2-col-2-col.txt
|
|||
rm -- a/abc-a-a
|
||||
rm -- b/abc-b-b
|
||||
rm -- \ä\¸\\å\›\½\ \(Zh\Å\<5C>nggu\Ã\³\)/abc-\ä\¸\\å\›\½\ \(Zh\Å\<5C>nggu\Ã\³\)-\ä\¸\\å\›\½\ \(Zh\Å\<5C>nggu\Ã\³\)
|
||||
echo '### bug #44358: 2 GB records cause problems for -N2'
|
||||
### bug #44358: 2 GB records cause problems for -N2
|
||||
(yes "`echo {1..100}`" | head -c 5000000000; echo FOO; yes "`echo {1..100}`" | head -c 3000000000; echo FOO; yes "`echo {1..100}`" | head -c 1000000000;) | parallel --pipe --recend FOO'\n' -N2 --block 1g -k LANG=c wc -c
|
||||
8000000008
|
||||
1000000000
|
||||
echo '### Test compress'
|
||||
### Test compress
|
||||
seq 5 | parallel -j2 --tag --compress 'seq {} | pv -q -L 10'
|
||||
|
|
|
|||
|
|
@ -353,5 +353,5 @@ Send Receive Exitval
|
|||
Send Receive Exitval
|
||||
echo '### --tmux test - check termination'
|
||||
### --tmux test - check termination
|
||||
perl -e 'map {printf "$_%o%c\n",$_,$_}1..255' | stdout parallel --tmux echo {} :::: - ::: a b | perl -pe 's:tmp.par.*tms:tmp/parXXXXX.tms:; s/\d/0/g'
|
||||
See output with: tmux -S /tmp/parXXXXX.tms attach -t p000000
|
||||
perl -e 'map {printf "$_%o%c\n",$_,$_}1..255' | stdout parallel --tmux echo {} :::: - ::: a b | perl -pe 's:tmp.par.*tms:tmp/parXXXXX.tms:; s/\d+/0/g'
|
||||
See output with: tmux -S /tmp/parXXXXX.tms attach -t p0
|
||||
|
|
|
|||
|
|
@ -91,8 +91,8 @@ echo '### bug #39360: --joblog does not work with --pipe'
|
|||
### bug #39360: --joblog does not work with --pipe
|
||||
seq 100 | parallel --joblog - --pipe wc | tr '0-9' 'X'
|
||||
Seq Host Starttime JobRuntime Send Receive Exitval Signal Command
|
||||
X : XXXXXXXXXX.XXX X.XXX X X X X wc
|
||||
XXX XXX XXX
|
||||
X : XXXXXXXXXX.XXX X.XXX XXX XX X X wc
|
||||
echo '### bug #39572: --tty and --joblog do not work'
|
||||
### bug #39572: --tty and --joblog do not work
|
||||
seq 1 | parallel --joblog - -u true | tr '0-9' 'X'
|
||||
|
|
|
|||
|
|
@ -1,9 +1,4 @@
|
|||
### Test --pipe
|
||||
echo '### -L >4GB'
|
||||
### -L >4GB
|
||||
(head -c 5000000000 /dev/zero; echo FOO; head -c 3000000000 /dev/zero; echo FOO; head -c 1000000000 /dev/zero;) | parallel --pipe -L2 --block 1g -k LANG=c wc -c
|
||||
8000000008
|
||||
1000000000
|
||||
echo '### Test 200M records with too small block'; ( echo start; seq 1 44 | parallel -uj1 cat /tmp/blocktest\;true; echo end; echo start; seq 1 44 | parallel -uj1 cat /tmp/blocktest\;true; echo end; echo start; seq 1 44 | parallel -uj1 cat /tmp/blocktest\;true; echo end; ) | stdout parallel -k --block 200m -j2 --pipe --recend 'end\n' wc -c | egrep -v '^0$'
|
||||
### Test 200M records with too small block
|
||||
parallel: Warning: A record was longer than 200000000. Increasing to --blocksize 260000001
|
||||
|
|
|
|||
Loading…
Reference in a new issue