=head2 Testing
Type "nmake test". This will run most of the tests from the
-testsuite (many tests will be skipped, and a few tests may fail).
+testsuite (many tests will be skipped, and but no test should fail).
-To get a more detailed breakdown of the tests that failed,
-you may want to say:
+If some tests do fail, it may be because you are using a different command
+shell than the native "cmd.exe". To get a more detailed breakdown of the
+tests that failed, you may want to say:
cd ..\t
.\perl harness
-This should produce a summary of the failed tests. Currently, the
-only known failure is lib\findbin.t:
-
- Failed Test Status Wstat Total Fail Failed List of failed
- ------------------------------------------------------------------------------
- lib/findbin.t 1 1 100.00% 1
- Failed 1/151 test scripts, 99.34% okay. 1/3902 subtests failed, 99.97% okay.
-
-
-Check if any additional tests other than the ones shown here
-failed, and report them as described under L<BUGS AND CAVEATS>.
+Please report any failures as described under L<BUGS AND CAVEATS>.
=head1 BUGS AND CAVEATS
alpha quality software. You can expect changes in virtually all of
these areas: build process, installation structure, supported
utilities/modules, and supported perl functionality. Specifically,
-functionality that supports the Win32 environment may ultimately
+functionality specific to the Win32 environment may ultimately
be supported as either core modules or extensions.
-If you have had prior exposure to Perl on Unix platforms, this port
-may exhibit behavior different from what is documented. Most of the
+If you have had prior exposure to Perl on Unix platforms, you will notice
+this port exhibits behavior different from what is documented. Most of the
differences fall under one of these categories.
=over 8
Nick Ing-Simmons and Gurusamy Sarathy have made numerous and
sundry hacks since then.
-Last updated: 04 April 1997
+Last updated: 05 April 1997
=cut
-
package Cwd;
require 5.000;
require Exporter;
+use Carp;
=head1 NAME
@ISA = qw(Exporter);
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir);
+@EXPORT_OK = qw(chdir abs_path fast_abspath);
# use strict;
-sub _backtick_pwd { # The 'natural and safe form' for UNIX (pwd may be setuid root)
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
my $cwd;
chop($cwd = `pwd`);
$cwd;
-}
+}
# Since some ports may predefine cwd internally (e.g., NT)
# we take care not to override an existing definition for cwd().
1;
}
+# Taken from Cwd.pm It is really getcwd with an optional
+# parameter instead of '.'
+#
+
+sub abs_path
+{
+ my $start = shift || '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ carp "stat($start): $!";
+ return '';
+ }
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ unless (opendir(PARENT, $dotdots))
+ {
+ carp "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ carp "stat($dotdots): $!";
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = '';
+ }
+ 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 = "$dir/$cwd";
+ closedir(PARENT);
+ } while ($dir);
+ chop($cwd); # drop the trailing /
+ $cwd;
+}
+
+sub fast_abspath
+{
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
+ $realpath;
+}
+
# --- PORTING SECTION ---
# VMS: $ENV{'DEFAULT'} points to default directory at all times
# 06-Mar-1996 Charles Bailey bailey@genetics.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
+# 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.
return $ENV{'PWD'};
}
-*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
+*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
sub _msdos_cwd {
$ENV{'PWD'} = `command /c cd`;
*getcwd = \&_vms_cwd;
*fastcwd = \&_vms_cwd;
*fastgetcwd = \&_vms_cwd;
+ *abs_path = \&fast_abspath;
}
elsif ($^O eq 'NT' or $^O eq '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;
+ *cwd = \&_NT_cwd;
+ *getcwd = \&_NT_cwd;
+ *fastcwd = \&_NT_cwd;
+ *fastgetcwd = \&_NT_cwd;
+ *abs_path = \&fast_abspath;
}
elsif ($^O eq 'os2') {
# sys_cwd may keep the builtin command
*getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
*fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *abs_path = \&fast_abspath;
}
elsif ($^O eq 'msdos') {
*cwd = \&_msdos_cwd;
*getcwd = \&_msdos_cwd;
*fastgetcwd = \&_msdos_cwd;
*fastcwd = \&_msdos_cwd;
+ *abs_path = \&fast_abspath;
}
}
use FindBin;
use lib "$FindBin::Bin/../lib";
- or
+ or
use FindBin qw($Bin);
use lib "$Bin/../lib";
use Carp;
require 5.000;
require Exporter;
-use Cwd qw(getcwd);
+use Cwd qw(getcwd abs_path);
+use Config;
+use File::Basename;
@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
-# Taken from Cwd.pm It is really getcwd with an optional
-# parameter instead of '.'
-#
-# another way would be:
-#
-#sub abs_path
-#{
-# my $cwd = getcwd();
-# chdir(shift || '.');
-# my $realpath = getcwd();
-# chdir($cwd);
-# $realpath;
-#}
-
-sub my_abs_path
+sub is_abs_path
{
- my $start = shift || '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
- unless (@cst = stat( $start ))
- {
- warn "stat($start): $!";
- return '';
- }
- $cwd = '';
- $dotdots = $start;
- do
- {
- $dotdots .= '/..';
- @pst = @cst;
- unless (opendir(PARENT, $dotdots))
- {
- warn "opendir($dotdots): $!";
- return '';
- }
- unless (@cst = stat($dotdots))
- {
- warn "stat($dotdots): $!";
- closedir(PARENT);
- return '';
- }
- if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
- {
- $dir = '';
- }
- else
- {
- do
- {
- unless (defined ($dir = readdir(PARENT)))
- {
- warn "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 = "$dir/$cwd";
- closedir(PARENT);
- } while ($dir);
- chop($cwd); # drop the trailing /
- $cwd;
+ local $_ = shift if (@_);
+ if ($^O eq 'MSWin32')
+ {
+ return m#^[a-z]:[\\/]#i;
+ }
+ else
+ {
+ return m#^/#;
+ }
}
-
BEGIN
{
*Dir = \$Bin;
*RealDir = \$RealBin;
- if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath}
- else { *abs_path = \&my_abs_path}
if($0 eq '-e' || $0 eq '-')
{
}
else
{
- unless($script =~ m#/# && -f $script)
+ my $IsWin32 = $^O eq 'MSWin32';
+ unless(($script =~ m#/# || ($IsWin32 && $script =~ m#\\#))
+ && -f $script)
{
my $dir;
-
- foreach $dir (split(/:/,$ENV{PATH}))
+ my $pathvar = ($IsWin32) ? 'Path' : 'PATH';
+
+ foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar}))
{
- if(-x "$dir/$script")
+ if(-r "$dir/$script" && (!$IsWin32 || -x _))
{
$script = "$dir/$script";
-
- if (-f $0)
+
+ if (-f $0)
{
# $script has been found via PATH but perl could have
# been invoked as 'perl file'. Do a dumb check to see
# well we actually only check that it is an ASCII file
# we know its executable so it is probably a script
# of some sort.
-
+
$script = $0 unless(-T $script);
}
last;
}
}
}
-
+
croak("Cannot find current script '$0'") unless(-f $script);
-
+
# Ensure $script contains the complete path incase we C<chdir>
-
- $script = getcwd() . "/" . $script unless($script =~ m,^/,);
-
- ($Bin,$Script) = $script =~ m,^(.*?)/+([^/]+)$,;
-
+
+ $script = getcwd() . "/" . $script unless is_abs_path($script);
+
+ ($Script,$Bin) = fileparse($script);
+
# Resolve $script if it is a link
while(1)
{
my $linktext = readlink($script);
-
- ($RealBin,$RealScript) = $script =~ m,^(.*?)/+([^/]+)$,;
+
+ ($RealScript,$RealBin) = fileparse($script);
last unless defined $linktext;
-
- $script = ($linktext =~ m,^/,)
+
+ $script = (is_abs_path($linktext))
? $linktext
: $RealBin . "/" . $linktext;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff