t/lib/dumper.t See if Data::Dumper works
t/lib/english.t See if English works
t/lib/env.t See if Env works
+t/lib/env-array.t See if Env works for arrays
t/lib/errno.t See if Errno works
t/lib/fatal.t See if Fatal works
t/lib/fields.t See if base/fields works
=head2 Configure-time Options
-The F<INSTALL> document describes several Configure-time options.
-Some of these will work with Cygwin, others are not yet possible. Also,
-some of these are experimental.
+The F<INSTALL> document describes several Configure-time options. Some of
+these will work with Cygwin, others are not yet possible. Also, some of
+these are experimental. You can either select an option when Configure
+prompts you or you can define (undefine) symbols on the command line.
=over 4
=item * C<-Uusedl>
-If you want to force Perl to be compiled statically, you can either
-choose this when Configure prompts you or you can use the Configure
-command line option.
+Undefining this symbol forces Perl to be compiled statically.
=item * C<-Uusemymalloc>
By default Perl uses the malloc() included with the Perl source. If you
-want to force Perl to build with the system malloc(), you can either
-choose this when Configure prompts you or you can use the Configure
-command line option.
+want to force Perl to build with the system malloc() undefine this symbol.
=item * C<-Dusemultiplicity>
The PerlIO abstraction works with the Cygwin port.
-=item * C<-Duse64bits>
+=item * C<-Duse64bitint>
I<gcc> supports 64-bit integers. However, several additional long long
functions are necessary to use them within Perl (I<{strtol,strtoul}l>).
=item * C<-Duselargefiles>
-Although Win32 supports large files, Cygwin currently uses 32-bit ints
+Although Win32 supports large files, Cygwin currently uses 32-bit integers
for internal size and position calculations.
=back
You should keep the recommended value.
+=item * dlsym
+
+I<ld2> is needed to build dynamic libraries, but it does not exist
+when dlsym() checking occurs (it is not created until `C<make>' runs).
+You will see the following message:
+
+ Checking whether your dlsym() needs a leading underscore ...
+ I can't compile and run the test program.
+ I'm guessing that dlsym doesn't need a leading underscore.
+
+Since the guess is correct, this is not a problem.
+
=item * Win9x and d_eofnblk
Win9x does not correctly report C<EOF> with a non-blocking read on a
This is correct.
+=item * Compiler/Preprocessor defines
+
+The following error occurs because of the Cygwin C<#define> of
+C<_LONG_DOUBLE>:
+
+ Guessing which symbols your C compiler and preprocessor define...
+ try.c:3847: parse error
+
+This failure does not seem to cause any problems.
+
=back
=head1 MAKE
=head1 HISTORY
-Last updated: 25 February 2000
+Last updated: 1 March 2000
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 the reverse order in to they
-were initially loaded.
+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
PUSHMARK(SP);
XPUSHs(sv_2mortal(dl_libref));
PUTBACK;
- call_sv((SV*)sub, G_DISCARD);
+ call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
FREETMPS;
LEAVE;
}
my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
$pkg =~ s#::#/#g;
if (defined($filename = $INC{"$pkg.pm"})) {
- $filename =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+ $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',
# looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
if (-r $filename) {
- unless ($filename =~ m|^/|) {
+ unless ($filename =~ m|^/|s) {
if ($is_dosish) {
- unless ($filename =~ m{^([a-z]:)?[\\/]}i) {
+ unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
$filename = "./$filename";
}
}
while(defined($_ = shift @modules)){
s#::#/#g; # incase specified as ABC::XYZ
s|\\|/|g; # bug in ksh OS/2
- s#^lib/##; # incase specified as lib/*.pm
+ s#^lib/##s; # incase specified as lib/*.pm
if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
- my ($dir,$name) = (/(.*])(.*)/);
- $dir =~ s/.*lib[\.\]]//;
+ my ($dir,$name) = (/(.*])(.*)/s);
+ $dir =~ s/.*lib[\.\]]//s;
$dir =~ s#[\.\]]#/#g;
$_ = $dir . $name;
}
# where to write output files
$autodir ||= "lib/auto";
if ($Is_VMS) {
- ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||;
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
$filename = VMS::Filespec::unixify($filename); # may have dirs
}
unless (-d $autodir){
}
# allow just a package name to be used
- $filename .= ".pm" unless ($filename =~ m/\.pm$/);
+ $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
my($pm_mod_time) = (stat($filename))[9];
for my $dir (keys %outdirs) {
opendir(OUTDIR,$dir);
foreach (sort readdir(OUTDIR)){
- next unless /\.al$/;
+ next unless /\.al\z/;
my($file) = "$dir/$_";
$file = lc $file if $Is83 or $Is_VMS;
next if $outfiles{$file};
sub id {
my $level = shift;
my($pack,$file,$line,$sub) = caller($level);
- my($id) = $file=~m|([^/]+)$|;
+ my($id) = $file=~m|([^/]+)\z|;
return ($file,$line,$id);
}
$id = $file;
($pack,$file) = caller($frame++);
} until !$file;
- ($id) = $id=~m|([^/]+)$|;
+ ($id) = $id=~m|([^/]+)\z|;
return "[$time] $id: ";
}
$pkg =~ s|::|/|g;
if (defined($name=$INC{"$pkg.pm"}))
{
- $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
+ $name =~ s|^(.*)$pkg\.pm\z|$1auto/$pkg/$func.al|s;
$name = undef unless (-r $name);
}
unless (defined $name)
*$autoload = sub {};
$ok = 1;
} else {
- if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
+ if ($name =~ s{(\w{12,})\.al\z}{substr($1,0,11).".al"}e){
eval {local $SIG{__DIE__};require $name};
}
if ($@){
my($entry);
for $entry ($dh->read) {
next if -d MM->catdir($bdir,$entry);
- next unless $entry =~ s/\.pm$//;
+ next unless $entry =~ s/\.pm\z//;
$CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
}
}
sub _binary_extensions {
my($self) = shift @_;
my(@result,$module,%seen,%need,$headerdone);
- my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
+ my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz\z};
for $module ($self->expand('Module','/./')) {
my $file = $module->cpan_file;
next if $file eq "N/A";
$l =~ s|^file:||; # assume they
# meant
# file://localhost
- $l =~ s|^/|| unless -f $l; # e.g. /P:
+ $l =~ s|^/||s unless -f $l; # e.g. /P:
}
if ( -f $l && -r _) {
$Thesite = $i;
utime $now, $now, $aslocal; # download time is more
# important than upload time
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz\z/) {
my $gzurl = "$url.gz";
$CPAN::Frontend->myprint("Fetching with LWP:
$gzurl
$Thesite = $i;
return $aslocal;
}
- if ($aslocal !~ /\.gz$/) {
+ if ($aslocal !~ /\.gz\z/) {
my $gz = "$aslocal.gz";
$CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
}
$Thesite = $i;
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz\z/) {
unlink $aslocal_uncompressed if
-f $aslocal_uncompressed && -s _ == 0;
my $gz = "$aslocal.gz";
$self->debug("Changed directory to tmp") if $CPAN::DEBUG;
if (! $local_file) {
Carp::croak "bad download, can't do anything :-(\n";
- } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
+ } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)\z/i){
$self->untar_me($local_file);
- } elsif ( $local_file =~ /\.zip$/i ) {
+ } elsif ( $local_file =~ /\.zip\z/i ) {
$self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
+ } elsif ( $local_file =~ /\.pm\.(gz|Z)\z/) {
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
# Let's check if the package has its own directory.
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir .: $!");
- my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
+ my @readdir = grep $_ !~ /^\.\.?\z/s, $dh->read; ### MAC??
$dh->close;
my ($distdir,$packagedir);
if (@readdir == 1 && -d $readdir[0]) {
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)$//;
+ $to =~ s/\.(gz|Z)\z//;
if (CPAN::Tarzip->gunzip($local_file,$to)) {
$self->{unwrapped} = "YES";
} else {
my $userid = $self->{CPAN_USERID};
my $cvs_dir = (split '/', $dir)[-1];
- $cvs_dir =~ s/-\d+[^-]+$//;
+ $cvs_dir =~ s/-\d+[^-]+\z//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
my $cvs_site_perl =
$lc_file = CPAN::FTP->localize("authors/id/@local",
"$lc_want.gz",1);
if ($lc_file) {
- $lc_file =~ s/\.gz$//;
+ $lc_file =~ s/\.gz\z//;
CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
} else {
return;
([._-])
(\d{3}(_[0-4][0-9])?)
\.tar[._-]gz
- $
- }x;
+ \z
+ }xs;
"$1.$3";
}
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
- $local_file =~ s/\.pm$/.pod/;
+ $local_file =~ s/\.pm\z/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
qq{Couldn\'t uncompress $file\n}
);
}
- $file =~ s/\.gz$//;
+ $file =~ s/\.gz\z//;
$system = "$CPAN::Config->{tar} xvf $file";
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
if (system($system)==0) {
if ($^O eq 'apollo') { $path = "/".$path; }
# At this point $path may be tainted (if tainting) and chdir would fail.
# To be more useful we untaint it then check that we landed where we started.
- $path = $1 if $path =~ /^(.*)$/; # untaint
+ $path = $1 if $path =~ /^(.*)\z/s; # untaint
CORE::chdir($path) || return undef;
($cdev, $cino) = stat('.');
die "Unstable directory path, current directory changed unexpectedly"
$ENV{'PWD'} = cwd();
}
# Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
- if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
+ if ($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) {
return 0 unless CORE::chdir $newdir;
if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
- if ($newdir =~ m#^/#) {
+ if ($newdir =~ m#^/#s) {
$ENV{'PWD'} = $newdir;
} else {
my @curdir = split(m#/#,$ENV{'PWD'});
=head1 NAME
-Env - perl module that imports environment variables
+Env - perl module that imports environment variables as scalars or arrays
=head1 SYNOPSIS
use Env;
use Env qw(PATH HOME TERM);
+ use Env qw($SHELL @LD_LIBRARY_PATH);
=head1 DESCRIPTION
-Perl maintains environment variables in a pseudo-hash named %ENV. For
+Perl maintains environment variables in a special hash named C<%ENV>. For
when this access method is inconvenient, the Perl module C<Env> allows
-environment variables to be treated as simple variables.
+environment variables to be treated as scalar or array variables.
-The Env::import() function ties environment variables with suitable
+The C<Env::import()> function ties environment variables with suitable
names to global Perl variables with the same names. By default it
-does so with all existing environment variables (C<keys %ENV>). If
-the import function receives arguments, it takes them to be a list of
-environment variables to tie; it's okay if they don't yet exist.
+ties all existing environment variables (C<keys %ENV>) to scalars. If
+the C<import> function receives arguments, it takes them to be a list of
+variables to tie; it's okay if they don't yet exist. The scalar type
+prefix '$' is inferred for any element of this list not prefixed by '$'
+or '@'. Arrays are implemented in terms of C<split> and C<join>, using
+C<$Config::Config{path_sep}> as the delimiter.
After an environment variable is tied, merely use it like a normal variable.
You may access its value
@path = split(/:/, $PATH);
+ print join("\n", @LD_LIBRARY_PATH), "\n";
or modify it
$PATH .= ":.";
+ push @LD_LIBRARY_PATH, $dir;
+
+however you'd like. Bear in mind, however, that each access to a tied array
+variable requires splitting the environment variable's string anew.
+
+The code:
+
+ use Env qw(@PATH);
+ push @PATH, '.';
+
+is equivalent to:
+
+ use Env qw(PATH);
+ $PATH .= ":.";
+
+except that if C<$ENV{PATH}> started out empty, the second approach leaves
+it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
-however you'd like.
To remove a tied environment variable from
the environment, assign it the undefined value
undef $PATH;
+ undef @LD_LIBRARY_PATH;
+
+=head1 LIMITATIONS
+
+On VMS systems, arrays tied to environment variables are read-only. Attempting
+to change anything will cause a warning.
=head1 AUTHOR
Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
+and
+Gregor N. Purdy E<lt>F<gregor@focusresearch.com>E<gt>
=cut
sub import {
my ($callpack) = caller(0);
my $pack = shift;
- my @vars = grep /^[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
+ my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
return unless @vars;
- eval "package $callpack; use vars qw("
- . join(' ', map { '$'.$_ } @vars) . ")";
+ @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
+
+ eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
die $@ if $@;
foreach (@vars) {
- tie ${"${callpack}::$_"}, Env, $_;
+ my ($type, $name) = m/^([\$\@])(.*)$/;
+ if ($type eq '$') {
+ tie ${"${callpack}::$name"}, Env, $name;
+ } else {
+ if ($^O eq 'VMS') {
+ tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
+ } else {
+ tie @{"${callpack}::$name"}, Env::Array, $name;
+ }
+ }
}
}
}
}
+######################################################################
+
+package Env::Array;
+
+use Config;
+use Tie::Array;
+
+@ISA = qw(Tie::Array);
+
+my $sep = $Config::Config{path_sep};
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ return scalar(@temp);
+}
+
+sub STORESIZE {
+ my ($self, $size) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $#temp = $size - 1;
+ $ENV{$$self} = join($sep, @temp);
+}
+
+sub CLEAR {
+ my ($self) = @_;
+ $ENV{$$self} = '';
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return (split($sep, $ENV{$$self}))[$index];
+}
+
+sub STORE {
+ my ($self, $index, $value) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ $temp[$index] = $value;
+ $ENV{$$self} = join($sep, @temp);
+ return $value;
+}
+
+sub PUSH {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ push @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return scalar(@temp);
+}
+
+sub POP {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = pop @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub UNSHIFT {
+ my $self = shift;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = unshift @temp, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SHIFT {
+ my ($self) = @_;
+ my @temp = split($sep, $ENV{$$self});
+ my $result = shift @temp;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+}
+
+sub SPLICE {
+ my $self = shift;
+ my $offset = shift;
+ my $length = shift;
+ my @temp = split($sep, $ENV{$$self});
+ if (wantarray) {
+ my @result = splice @temp, $self, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return @result;
+ } else {
+ my $result = scalar splice @temp, $offset, $length, @_;
+ $ENV{$$self} = join($sep, @temp);
+ return $result;
+ }
+}
+
+######################################################################
+
+package Env::Array::VMS;
+use Tie::Array;
+
+@ISA = qw(Tie::Array);
+
+sub TIEARRAY {
+ bless \($_[1]);
+}
+
+sub FETCHSIZE {
+ my ($self) = @_;
+ my $i = 0;
+ while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
+ return $i;
+}
+
+sub FETCH {
+ my ($self, $index) = @_;
+ return $ENV{$$self . ';' . $index};
+}
+
1;
$dir_pref = "$dir_name/";
if ( $nlink < 0 ) { # must be finddepth, report dirname now
$name = $dir_name;
+ if ( substr($name,-2) eq '/.' ) {
+ $name =~ s|/\.$||;
+ }
$dir = $p_dir;
$_ = ($no_chdir ? $dir_name : $dir_rel );
+ if ( substr($_,-2) eq '/.' ) {
+ s|/\.$||;
+ }
&$wanted_callback;
} else {
push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
}
$fullname = $dir_loc;
$name = $dir_name;
+ if ( substr($name,-2) eq '/.' ) {
+ $name =~ s|/\.$||;
+ }
$dir = $p_dir;
$_ = ($no_chdir ? $dir_name : $dir_rel);
+ if ( substr($_,-2) eq '/.' ) {
+ s|/\.$||;
+ }
+
&$wanted_callback;
} else {
push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth;
require Mac::Files;
my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
&Mac::Files::kSystemFolderType);
- $system =~ s/:.*\z/:/;
+ $system =~ s/:.*\z/:/s;
return $system;
}
my ($volume,$directory,$file) = ('','','');
if ( $nofile ) {
- ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@;
+ ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s;
}
else {
$path =~
my($head,$macro,$tail);
# perform m##g in scalar context so it acts as an iterator
- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) {
+ while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
if ($self->{$2}) {
($head,$macro,$tail) = ($1,$2,$3);
if (ref $self->{$macro}) {
$npath = "$head$macro$tail";
}
}
- if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
+ if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
$npath;
}
my($self,$path,$reduce_ricochet) = @_;
if ($path =~ m|/|) { # Fake Unix
- my $pathify = $path =~ m|/$|;
+ my $pathify = $path =~ m|/\z|;
$path = $self->SUPER::canonpath($path,$reduce_ricochet);
if ($pathify) { return vmspath($path); }
else { return vmsify($path); }
if (@dirs) {
my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
my ($spath,$sdir) = ($path,$dir);
- $spath =~ s/.dir\z//; $sdir =~ s/.dir\z//;
+ $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//;
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/s;
$rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
if (@files) {
my $path = (@files == 1 ? $files[0] : $self->catdir(@files));
my $spath = $path;
- $spath =~ s/.dir\z//;
+ $spath =~ s/\.dir\z//;
if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) {
$rslt = "$spath$file";
}
sub catpath {
my($self,$dev,$dir,$file) = @_;
if ($dev =~ m|^/+([^/]+)|) { $dev =~ "$1:"; }
- else { $dev .= ':' unless $dev eq '' or $dev =~ /:$/; }
+ else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; }
$dir = vmspath($dir);
"$dev$dir$file";
}
if ( $path =~ m{/} ) {
$path =~
m{^ ( (?: /[^/]* )? )
- ( (?: .*/(?:[^/]+.dir)? )? )
+ ( (?: .*/(?:[^/]+\.dir)? )? )
(.*)
}xs;
$volume = $1;
Delete all watch-expressions.
+=item r
+
+Continue until return from the current subroutine, and dump the return value.
+
=item O [opt[=val]] [opt"val"] [opt?]...
Set or query values of options. val defaults to 1. opt can
Compatibility tests for C<sub : attrs> vs the older C<use attrs>.
+=item lib/env
+
+Tests for new environment scalar capability (e.g., C<use Env qw($BAR);>).
+
+=item lib/env-array
+
+Tests for new environment array capability (e.g., C<use Env qw(@PATH);>).
+
=item lib/io_const
IO constants (SEEK_*, _IO*).
$PERL_VERSION now stands for C<$^V> (a string value) rather than for C<$]>
(a numeric value).
+=item Env
+
+Env now supports accessing environment variables like PATH as array
+variables.
+
=item ExtUtils::MakeMaker
change#4135, also needs docs in module pod
--- /dev/null
+#!./perl
+
+$| = 1;
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+}
+
+if ($^O eq 'VMS') {
+ print "1..11\n";
+ foreach (1..11) { print "ok $_ # skipped for VMS\n"; }
+ exit 0;
+}
+
+use Env qw(@FOO);
+use vars qw(@BAR);
+
+sub array_equal
+{
+ my ($a, $b) = @_;
+ return 0 unless scalar(@$a) == scalar(@$b);
+ for my $i (0..scalar(@$a) - 1) {
+ return 0 unless $a->[$i] eq $b->[$i];
+ }
+ return 1;
+}
+
+sub test
+{
+ my ($desc, $code) = @_;
+
+ &$code;
+
+ print "# $desc...\n";
+ print "# FOO = (", join(", ", @FOO), ")\n";
+ print "# BAR = (", join(", ", @BAR), ")\n";
+
+ if (defined $check) { print "not " unless &$check; }
+ else { print "not " unless array_equal(\@FOO, \@BAR); }
+
+ print "ok ", ++$i, "\n";
+}
+
+print "1..11\n";
+
+test "Assignment", sub {
+ @FOO = qw(a B c);
+ @BAR = qw(a B c);
+};
+
+test "Storing", sub {
+ $FOO[1] = 'b';
+ $BAR[1] = 'b';
+};
+
+test "Truncation", sub {
+ $#FOO = 0;
+ $#BAR = 0;
+};
+
+test "Push", sub {
+ push @FOO, 'b', 'c';
+ push @BAR, 'b', 'c';
+};
+
+test "Pop", sub {
+ pop @FOO;
+ pop @BAR;
+};
+
+test "Shift", sub {
+ shift @FOO;
+ shift @BAR;
+};
+
+test "Push", sub {
+ push @FOO, 'c';
+ push @BAR, 'c';
+};
+
+test "Unshift", sub {
+ unshift @FOO, 'a';
+ unshift @BAR, 'a';
+};
+
+test "Reverse", sub {
+ @FOO = reverse @FOO;
+ @BAR = reverse @BAR;
+};
+
+test "Sort", sub {
+ @FOO = sort @FOO;
+ @BAR = sort @BAR;
+};
+
+test "Splice", sub {
+ splice @FOO, 1, 1, 'B';
+ splice @BAR, 1, 1, 'B';
+};
BEGIN {
$ENV{FOO} = "foo";
+ $ENV{BAR} = "bar";
}
-use Env qw(FOO);
+use Env qw(FOO $BAR);
$FOO .= "/bar";
+$BAR .= "/baz";
+
+print "1..2\n";
-print "1..1\n";
print "not " if $FOO ne 'foo/bar';
print "ok 1\n";
+
+print "not " if $BAR ne 'bar/baz';
+print "ok 2\n";
+
unshift @INC, '../lib';
}
-if ( $symlink_exists ) { print "1..59\n"; }
-else { print "1..31\n"; }
+if ( $symlink_exists ) { print "1..117\n"; }
+else { print "1..61\n"; }
use File::Find;
rmdir 'fa';
rmdir 'fb/fba';
rmdir 'fb';
+ chdir '..';
+ rmdir 'for_find';
}
sub Check($) {
$File::Find::prune=1 if $_ eq 'faba';
}
+sub dn_wanted {
+ my $n = $File::Find::name;
+ print "# '$n' => 1\n";
+ my $i = rindex($n,'/');
+ my $OK = exists($Expect{$n});
+ if ( $OK ) {
+ $OK= exists($Expect{substr($n,0,$i)}) if $i >= 0;
+ }
+ Check($OK);
+ delete $Expect{$n};
+}
+
+sub d_wanted {
+ print "# '$_' => 1\n";
+ my $i = rindex($_,'/');
+ my $OK = exists($Expect{$_});
+ if ( $OK ) {
+ $OK= exists($Expect{substr($_,0,$i)}) if $i >= 0;
+ }
+ Check($OK);
+ delete $Expect{$_};
+}
+
+MkDir( 'for_find',0770 );
+CheckDie(chdir(for_find));
MkDir( 'fa',0770 );
MkDir( 'fb',0770 );
touch('fb/fb_ord');
Check( scalar(keys %Expect) == 0 );
+%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1,
+ './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1,
+ './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1,
+ './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1);
+delete $Expect{'./fa/fsl'} unless $symlink_exists;
+File::Find::finddepth( {wanted => \&dn_wanted },'.' );
+Check( scalar(keys %Expect) == 0 );
+
+%Expect=('.' => 1, './fa' => 1, './fa/fsl' => 1, './fa/fa_ord' => 1, './fa/fab' => 1,
+ './fa/fab/fab_ord' => 1, './fa/fab/faba' => 1,
+ './fa/fab/faba/faba_ord' => 1, './fa/faa' => 1, './fa/faa/faa_ord' => 1,
+ './fb' => 1, './fb/fba' => 1, './fb/fba/fba_ord' => 1, './fb/fb_ord' => 1);
+delete $Expect{'./fa/fsl'} unless $symlink_exists;
+File::Find::finddepth( {wanted => \&d_wanted, no_chdir => 1 },'.' );
+Check( scalar(keys %Expect) == 0 );
+
if ( $symlink_exists ) {
%Expect=('.' => 1, 'fa_ord' => 1, 'fsl' => 1, 'fb_ord' => 1, 'fba' => 1,
'fba_ord' => 1, 'fab' => 1, 'fab_ord' => 1, 'faba' => 1, 'faa' => 1,
File::Find::find( {wanted => \&wanted, follow_fast => 1},'fa' );
Check( scalar(keys %Expect) == 0 );
+
%Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1,
'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,
'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,
'fa/faa' => 1, 'fa/faa/faa_ord' => 1);
File::Find::find( {wanted => \&wanted, follow_fast => 1, no_chdir => 1},'fa' );
Check( scalar(keys %Expect) == 0 );
+
+ %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1,
+ 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,
+ 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,
+ 'fa/faa' => 1, 'fa/faa/faa_ord' => 1);
+
+ File::Find::finddepth( {wanted => \&dn_wanted, follow_fast => 1},'fa' );
+ Check( scalar(keys %Expect) == 0 );
+
+ %Expect=('fa' => 1, 'fa/fa_ord' => 1, 'fa/fsl' => 1, 'fa/fsl/fb_ord' => 1,
+ 'fa/fsl/fba' => 1, 'fa/fsl/fba/fba_ord' => 1, 'fa/fab' => 1,
+ 'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1, 'fa/fab/faba/faba_ord' => 1,
+ 'fa/faa' => 1, 'fa/faa/faa_ord' => 1);
+
+ File::Find::finddepth( {wanted => \&d_wanted, follow_fast => 1, no_chdir => 1},'fa' );
+ Check( scalar(keys %Expect) == 0 );
}
print "# of cases: $case\n";
# check bad protections
# should return an empty list, and set ERROR
-if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' or not $>) {
+if ($^O eq 'mpeix' or $^O eq 'MSWin32' or $^O eq 'os2' or $^O eq 'VMS' or $^O eq 'cygwin' or not $>) {
print "ok 6 # skipped\n";
}
else {
projects / p5sagit/p5-mst-13.2.git / commitdiff