From: Jarkko Hietaniemi Date: Wed, 1 Mar 2000 18:16:43 +0000 (+0000) Subject: Integrate with Sarathy. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c739111c01bcc76523dcfc2986f6b0a93da0d494;p=p5sagit%2Fp5-mst-13.2.git Integrate with Sarathy. p4raw-id: //depot/cfgperl@5409 --- diff --git a/MANIFEST b/MANIFEST index d0e88b5..636318c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1231,6 +1231,7 @@ t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data 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 diff --git a/README.cygwin b/README.cygwin index e8d354f..514e013 100644 --- a/README.cygwin +++ b/README.cygwin @@ -193,24 +193,21 @@ Win9x the shm*() functions seem to hang. =head2 Configure-time Options -The F 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 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> @@ -221,7 +218,7 @@ more than one interpreter instance. This works with the Cygwin port. The PerlIO abstraction works with the Cygwin port. -=item * C<-Duse64bits> +=item * C<-Duse64bitint> I supports 64-bit integers. However, several additional long long functions are necessary to use them within Perl (I<{strtol,strtoul}l>). @@ -240,7 +237,7 @@ POSIX threads are B yet implemented in Cygwin. =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 @@ -264,6 +261,18 @@ hint file. You should keep the recommended value. +=item * dlsym + +I is needed to build dynamic libraries, but it does not exist +when dlsym() checking occurs (it is not created until `C' 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 with a non-blocking read on a @@ -287,6 +296,16 @@ Configure reports: 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 @@ -609,4 +628,4 @@ Teun Burgers Eburgers@ecn.nlE. =head1 HISTORY -Last updated: 25 February 2000 +Last updated: 1 March 2000 diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 6a3d4a3..0e0f792 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -654,8 +654,7 @@ 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 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 diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 9423085..5c6bbea 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -45,7 +45,7 @@ dl_unload_all_files(pTHXo_ void *unused) PUSHMARK(SP); XPUSHs(sv_2mortal(dl_libref)); PUTBACK; - call_sv((SV*)sub, G_DISCARD); + call_sv((SV*)sub, G_DISCARD | G_NODEBUG); FREETMPS; LEAVE; } diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index d62ceb0..8fd7d3b 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -36,7 +36,7 @@ AUTOLOAD { 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', @@ -45,9 +45,9 @@ AUTOLOAD { # 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"; } } diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 41d5489..ecdb039 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -175,10 +175,10 @@ sub autosplit_lib_modules{ 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; } @@ -201,7 +201,7 @@ sub autosplit_file { # 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){ @@ -215,7 +215,7 @@ sub autosplit_file { } # 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]; @@ -378,7 +378,7 @@ EOT 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}; diff --git a/lib/CGI/Carp.pm b/lib/CGI/Carp.pm index 8425fa0..90e9552 100644 --- a/lib/CGI/Carp.pm +++ b/lib/CGI/Carp.pm @@ -223,7 +223,7 @@ sub realdie { CORE::die(@_); } 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); } @@ -235,7 +235,7 @@ sub stamp { $id = $file; ($pack,$file) = caller($frame++); } until !$file; - ($id) = $id=~m|([^/]+)$|; + ($id) = $id=~m|([^/]+)\z|; return "[$time] $id: "; } diff --git a/lib/CPAN.pm b/lib/CPAN.pm index bbebf6f..84dfd31 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -293,7 +293,7 @@ sub try_dot_al { $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) @@ -309,7 +309,7 @@ sub try_dot_al { *$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 ($@){ @@ -1253,7 +1253,7 @@ sub b { 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"); } } @@ -1424,7 +1424,7 @@ index re-reads the index files\n}); 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"; @@ -2079,7 +2079,7 @@ sub hosteasy { $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; @@ -2110,7 +2110,7 @@ sub hosteasy { 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 @@ -2147,7 +2147,7 @@ sub hosteasy { $Thesite = $i; return $aslocal; } - if ($aslocal !~ /\.gz$/) { + if ($aslocal !~ /\.gz\z/) { my $gz = "$aslocal.gz"; $CPAN::Frontend->myprint("Fetching with Net::FTP $url.gz @@ -2254,7 +2254,7 @@ Trying with "$funkyftp$source_switch" to get } $Thesite = $i; return $aslocal; - } elsif ($url !~ /\.gz$/) { + } elsif ($url !~ /\.gz\z/) { unlink $aslocal_uncompressed if -f $aslocal_uncompressed && -s _ == 0; my $gz = "$aslocal.gz"; @@ -3078,11 +3078,11 @@ sub get { $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"; @@ -3093,7 +3093,7 @@ sub get { # 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]) { @@ -3183,7 +3183,7 @@ sub pm2dir_me { 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 { @@ -3246,7 +3246,7 @@ sub cvs_import { 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 = @@ -3343,7 +3343,7 @@ sub verifyMD5 { $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; @@ -3468,8 +3468,8 @@ sub isa_perl { ([._-]) (\d{3}(_[0-4][0-9])?) \.tar[._-]gz - $ - }x; + \z + }xs; "$1.$3"; } @@ -4124,7 +4124,7 @@ sub as_string { 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) { @@ -4441,7 +4441,7 @@ sub untar { 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) { diff --git a/lib/Cwd.pm b/lib/Cwd.pm index e3c4590..5ddbbbe 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -142,7 +142,7 @@ sub fastcwd { 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" @@ -170,7 +170,7 @@ sub chdir_init { $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) { @@ -187,7 +187,7 @@ sub chdir { 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'}); diff --git a/lib/Env.pm b/lib/Env.pm index b0afc3b..d1ee071 100644 --- a/lib/Env.pm +++ b/lib/Env.pm @@ -2,57 +2,96 @@ package Env; =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 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 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). 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) to scalars. If +the C 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 and C, 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 EFE +and +Gregor N. Purdy EFE =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; + } + } } } @@ -74,4 +113,121 @@ sub STORE { } } +###################################################################### + +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; diff --git a/lib/File/Find.pm b/lib/File/Find.pm index a5e750e..0fa0032 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -520,8 +520,14 @@ sub _find_dir($$$) { $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; @@ -658,8 +664,15 @@ sub _find_dir_symlnk($$$) { } $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; diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 22682f9..be9a43c 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -150,7 +150,7 @@ sub rootdir { require Mac::Files; my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, &Mac::Files::kSystemFolderType); - $system =~ s/:.*\z/:/; + $system =~ s/:.*\z/:/s; return $system; } @@ -228,7 +228,7 @@ sub splitpath { my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { - ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@; + ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s; } else { $path =~ diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index 1a0330a..52519b9 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -41,7 +41,7 @@ sub eliminate_macros { 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}) { @@ -59,7 +59,7 @@ sub eliminate_macros { $npath = "$head$macro$tail"; } } - if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } $npath; } @@ -135,7 +135,7 @@ sub canonpath { 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); } @@ -165,7 +165,7 @@ sub catdir { 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); @@ -197,7 +197,7 @@ sub catfile { 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"; } @@ -349,7 +349,7 @@ Construct a complete filespec using VMS syntax 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"; } @@ -377,7 +377,7 @@ sub splitpath { if ( $path =~ m{/} ) { $path =~ m{^ ( (?: /[^/]* )? ) - ( (?: .*/(?:[^/]+.dir)? )? ) + ( (?: .*/(?:[^/]+\.dir)? )? ) (.*) }xs; $volume = $1; diff --git a/pod/perldebug.pod b/pod/perldebug.pod index 2431fc4..841ad75 100644 --- a/pod/perldebug.pod +++ b/pod/perldebug.pod @@ -307,6 +307,10 @@ Add a global watch-expression. 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 diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 7345727..53200eb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1320,6 +1320,14 @@ information, see L. Compatibility tests for C vs the older C. +=item lib/env + +Tests for new environment scalar capability (e.g., C). + +=item lib/env-array + +Tests for new environment array capability (e.g., C). + =item lib/io_const IO constants (SEEK_*, _IO*). @@ -1478,6 +1486,11 @@ of Perl variables and data. It is a data debugging tool for the XS programmer. $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 diff --git a/t/lib/env-array.t b/t/lib/env-array.t new file mode 100755 index 0000000..d90d892 --- /dev/null +++ b/t/lib/env-array.t @@ -0,0 +1,100 @@ +#!./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'; +}; diff --git a/t/lib/env.t b/t/lib/env.t index 93d2406..2573164 100755 --- a/t/lib/env.t +++ b/t/lib/env.t @@ -7,12 +7,19 @@ BEGIN { 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"; + diff --git a/t/lib/filefind.t b/t/lib/filefind.t index 8e57aec..89999fd 100755 --- a/t/lib/filefind.t +++ b/t/lib/filefind.t @@ -9,8 +9,8 @@ BEGIN { 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; @@ -29,6 +29,8 @@ END { rmdir 'fa'; rmdir 'fb/fba'; rmdir 'fb'; + chdir '..'; + rmdir 'for_find'; } sub Check($) { @@ -58,6 +60,31 @@ sub wanted { $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'); @@ -87,6 +114,22 @@ File::Find::find( {wanted => \&wanted, no_chdir => 1},'fa' ); 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, @@ -94,12 +137,29 @@ if ( $symlink_exists ) { 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"; diff --git a/t/lib/glob-basic.t b/t/lib/glob-basic.t index 2336fc0..b967e8d 100755 --- a/t/lib/glob-basic.t +++ b/t/lib/glob-basic.t @@ -72,7 +72,7 @@ print "ok 5\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 {