Change 33868 by [EMAIL PROTECTED] on 2008/05/19 15:43:18
Integrate:
[ 33114]
Integrate:
[ 32710]
The ext/Cwd/Cwd.xs part of...
Subject: consting Cwd and ExtUtils::ParseXS
From: "Robin Barker" <[EMAIL PROTECTED]>
Date: Sat, 22 Dec 2007 00:52:54 -0000
Message-ID: <[EMAIL PROTECTED]>
lib/ExtUtils/ParseXS.pm had changes already made with change
#32691.
[ 33042]
Upgrade to PathTools-3.27
[ 33717]
Integrate:
[ 33294]
Upgrade to PathTools-3.2701
[ 33673]
Upgrade to Time::HiRes 1.9715
[ 33699]
Upgrade to Digest::SHA 5.46
(but keep core-compliant test preambles)
[except Digest::SHA]
Affected files ...
... //depot/maint-5.8/perl/ext/Cwd/Cwd.xs#12 integrate
... //depot/maint-5.8/perl/ext/Cwd/t/cwd.t#19 integrate
... //depot/maint-5.8/perl/ext/Time/HiRes/Changes#29 integrate
... //depot/maint-5.8/perl/ext/Time/HiRes/HiRes.pm#33 integrate
... //depot/maint-5.8/perl/ext/Time/HiRes/HiRes.xs#18 integrate
... //depot/maint-5.8/perl/ext/Time/HiRes/Makefile.PL#34 integrate
... //depot/maint-5.8/perl/ext/Time/HiRes/t/HiRes.t#17 integrate
... //depot/maint-5.8/perl/lib/Cwd.pm#23 integrate
... //depot/maint-5.8/perl/lib/File/Spec.pm#20 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Cygwin.pm#12 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Epoc.pm#8 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Functions.pm#7 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Mac.pm#13 integrate
... //depot/maint-5.8/perl/lib/File/Spec/OS2.pm#13 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Unix.pm#21 integrate
... //depot/maint-5.8/perl/lib/File/Spec/VMS.pm#16 integrate
... //depot/maint-5.8/perl/lib/File/Spec/Win32.pm#16 integrate
... //depot/maint-5.8/perl/lib/File/Spec/t/Spec.t#16 integrate
... //depot/maint-5.8/perl/lib/File/Spec/t/crossplatform.t#4 integrate
... //depot/maint-5.8/perl/lib/File/Spec/t/tmpdir.t#3 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/Cwd/Cwd.xs#12 (text) ====
Index: perl/ext/Cwd/Cwd.xs
--- perl/ext/Cwd/Cwd.xs#11~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/ext/Cwd/Cwd.xs 2008-05-19 08:43:18.000000000 -0700
@@ -2,7 +2,8 @@
#include "perl.h"
#include "XSUB.h"
#ifndef NO_PPPORT_H
-# define NEED_sv_2pv_nolen
+# define NEED_my_strlcpy
+# define NEED_my_strlcat
# include "ppport.h"
#endif
@@ -10,9 +11,8 @@
# include <unistd.h>
#endif
-/* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4)
+/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
* Renamed here to bsd_realpath() to avoid library conflicts.
- * --jhi 2000-06-20
*/
/* See
@@ -22,11 +22,7 @@
*/
/*
- * Copyright (c) 1994
- * The Regents of the University of California. All rights reserved.
- *
- * This code is derived from software contributed to Berkeley by
- * Jan-Simon Pendry.
+ * Copyright (c) 2003 Constantin S. Svintsoff <[EMAIL PROTECTED]>
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
@@ -36,14 +32,14 @@
* 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.
+ * 3. The names of the authors may not 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
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR 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)
@@ -53,10 +49,6 @@
* SUCH DAMAGE.
*/
-#if defined(LIBC_SCCS) && !defined(lint)
-static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt
Exp $";
-#endif /* LIBC_SCCS and not lint */
-
/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
#ifndef MAXSYMLINKS
@@ -64,7 +56,7 @@
#endif
/*
- * char *realpath(const char *path, char resolved_path[MAXPATHLEN]);
+ * char *realpath(const char *path, char resolved[MAXPATHLEN]);
*
* Find the real name of path, by removing all ".", ".." and symlink
* components. Returns (resolved) on success, or (NULL) on failure,
@@ -79,7 +71,8 @@
return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
#else
int rootd, serrno;
- char *p, *q, wbuf[MAXPATHLEN];
+ const char *p;
+ char *q, wbuf[MAXPATHLEN];
int symlinks = 0;
/* Save the starting point. */
@@ -112,17 +105,18 @@
loop:
q = strrchr(resolved, '/');
if (q != NULL) {
+ const char *dir;
p = q + 1;
if (q == resolved)
- q = "/";
+ dir = "/";
else {
do {
--q;
} while (q > resolved && *q == '/');
q[1] = '\0';
- q = resolved;
+ dir = resolved;
}
- if (chdir(q) < 0)
+ if (chdir(dir) < 0)
goto err1;
} else
p = resolved;
==== //depot/maint-5.8/perl/ext/Cwd/t/cwd.t#19 (text) ====
Index: perl/ext/Cwd/t/cwd.t
--- perl/ext/Cwd/t/cwd.t#18~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/ext/Cwd/t/cwd.t 2008-05-19 08:43:18.000000000 -0700
@@ -135,16 +135,11 @@
# Cwd::chdir should also update $ENV{PWD}
dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' );
my $updir = File::Spec->updir;
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
-Cwd::chdir $updir;
-print "#$ENV{PWD}\n";
+
+for ([EMAIL PROTECTED]) {
+ Cwd::chdir $updir;
+ print "#$ENV{PWD}\n";
+}
rmtree($test_dirs[0], 0, 0);
==== //depot/maint-5.8/perl/ext/Time/HiRes/Changes#29 (text) ====
Index: perl/ext/Time/HiRes/Changes
--- perl/ext/Time/HiRes/Changes#28~32572~ 2007-12-04 06:45:57.000000000
-0800
+++ perl/ext/Time/HiRes/Changes 2008-05-19 08:43:18.000000000 -0700
@@ -1,5 +1,42 @@
Revision history for the Perl extension Time::HiRes.
+1.9715 [2008-04-08]
+ - Silly me: Makefile.PL does need to accept arguments other than mine.
+ Some testing frameworks obviously do this.
+ - Add retrying for tests 34..37, which are the most commonly
+ failing tests. If this helps, consider extending the retry
+ framework to all the tests. [Inspired by Slaven Rezic,
+ [rt.cpan.org #34711] Occasional failures of test 35 or 36 (FreeBSD)]
+
+1.9714 [2008-04-07]
+ - Under Perl 5.6.* NVgf needs to be "g", reported by Zefram,
+ it seems that ppport.h 3.13 gets this wrong.
+ - remove the check in Makefile.PL for 5.7.2, shouldn't be
+ (a) necessary (b) relevant
+ - add logic to Makefile.PL to skip configure/write Makefile
+ step if the "xdefine" file already exists, indicating that
+ the configure step has already been done, one can still
+ force (re)configure by "perl Makefile.PL configure",
+ or of course by "make clean && perl Makefile.PL".
+
+1.9713 [2008-04-04]
+ - for alarm() and ualarm() [Perl] prefer setitimer() [C]
+ instead of ualarm() [C] since ualarm() [C] cannot portably
+ (and standards-compliantly) be used for more than 999_999
+ microseconds (rt.cpan.org #34655)
+ - it seems that HP-UX has started (at least in 11.31 ia64)
+ #defining the CLOCK_REALTIME et alia (instead of having
+ them just as enums)
+ - document all the diagnostics
+
+1.9712 [2008-02-09]
+ - move the sub tick in the test file back to where it used to be
+ - in the "consider upgrading" message recommend at least Perl 5.8.8
+ and make the message to appear only for 5.8.0 since 5.8.1 and
+ later have the problem fixed
+ - VOS tweak for Makefile (core perl change #33259)
+ - since the test #17 seems to fail often, relax its limits a bit
+
1.9711 [2007-11-29]
- lost VMS test skippage from Craig Berry
- reformat the test code a little
==== //depot/maint-5.8/perl/ext/Time/HiRes/HiRes.pm#33 (text) ====
Index: perl/ext/Time/HiRes/HiRes.pm
--- perl/ext/Time/HiRes/HiRes.pm#32~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/Time/HiRes/HiRes.pm 2008-05-19 08:43:18.000000000 -0700
@@ -22,8 +22,8 @@
d_clock d_clock_nanosleep
stat
);
-
-$VERSION = '1.9712';
+
+$VERSION = '1.9715';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -209,6 +209,9 @@
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.
@@ -260,10 +263,14 @@
=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
The C<SIGALRM> signal is sent after the specified number of seconds.
-Implemented using C<ualarm()>. 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.
+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.
@@ -528,6 +535,15 @@
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.
@@ -563,7 +579,8 @@
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
-Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007 Jarkko Hietaniemi. 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.
==== //depot/maint-5.8/perl/ext/Time/HiRes/HiRes.xs#18 (text) ====
Index: perl/ext/Time/HiRes/HiRes.xs
--- perl/ext/Time/HiRes/HiRes.xs#17~32572~ 2007-12-04 06:45:57.000000000
-0800
+++ perl/ext/Time/HiRes/HiRes.xs 2008-05-19 08:43:18.000000000 -0700
@@ -2,7 +2,8 @@
*
* Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
*
- * Copyright (c) 2002,2003,2004,2005,2006,2007 Jarkko Hietaniemi. 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.
@@ -37,6 +38,13 @@
}
#endif
+/* At least ppport.h 3.13 gets this wrong: one really cannot
+ * have NVgf as anything else than "g" under Perl 5.6.x. */
+#if PERL_REVISION == 5 && PERL_VERSION == 6
+# undef NVgf
+# define NVgf "g"
+#endif
+
#define IV_1E6 1000000
#define IV_1E7 10000000
#define IV_1E9 1000000000
@@ -71,9 +79,13 @@
/* HP-UX has CLOCK_XXX values but as enums, not as defines.
* The only way to detect these would be to test compile for each. */
# ifdef __hpux
-# define CLOCK_REALTIME CLOCK_REALTIME
-# define CLOCK_VIRTUAL CLOCK_VIRTUAL
-# define CLOCK_PROFILE CLOCK_PROFILE
+/* However, it seems that at least in HP-UX 11.31 ia64 there *are*
+ * defines for these, so let's try detecting them. */
+# ifndef CLOCK_REALTIME
+# define CLOCK_REALTIME CLOCK_REALTIME
+# define CLOCK_VIRTUAL CLOCK_VIRTUAL
+# define CLOCK_PROFILE CLOCK_PROFILE
+# endif
# endif /* # ifdef __hpux */
#endif /* #if defined(TIME_HIRES_CLOCK_GETTIME) && defined(_STRUCT_ITIMERSPEC)
*/
@@ -462,16 +474,24 @@
#endif /* #if !defined(HAS_USLEEP) && defined(HAS_POLL) */
#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+
+static int
+hrt_ualarm_itimero(struct itimerval* itv, int usec, int uinterval)
+{
+ itv->it_value.tv_sec = usec / IV_1E6;
+ itv->it_value.tv_usec = usec % IV_1E6;
+ itv->it_interval.tv_sec = uinterval / IV_1E6;
+ itv->it_interval.tv_usec = uinterval % IV_1E6;
+ return setitimer(ITIMER_REAL, itv, 0);
+}
+
int
-hrt_ualarm_itimer(int usec, int interval)
+hrt_ualarm_itimer(int usec, int uinterval)
{
- struct itimerval itv;
- itv.it_value.tv_sec = usec / IV_1E6;
- itv.it_value.tv_usec = usec % IV_1E6;
- itv.it_interval.tv_sec = interval / IV_1E6;
- itv.it_interval.tv_usec = interval % IV_1E6;
- return setitimer(ITIMER_REAL, &itv, 0);
+ struct itimerval itv;
+ return hrt_ualarm_itimero(&itv, usec, uinterval);
}
+
#ifdef HAS_UALARM
int
hrt_ualarm(int usec, int interval) /* for binary compat before 1.91 */
@@ -898,21 +918,28 @@
#ifdef HAS_UALARM
-int
-ualarm(useconds,interval=0)
+IV
+ualarm(useconds,uinterval=0)
int useconds
- int interval
+ int uinterval
CODE:
- if (useconds < 0 || interval < 0)
- croak("Time::HiRes::ualarm(%d, %d): negative time not invented
yet", useconds, interval);
- if (useconds >= IV_1E6 || interval >= IV_1E6)
+ if (useconds < 0 || uinterval < 0)
+ croak("Time::HiRes::ualarm(%d, %d): negative time not invented
yet", useconds, uinterval);
+ if (useconds >= IV_1E6 || uinterval >= IV_1E6)
#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
- RETVAL = hrt_ualarm_itimer(useconds, interval);
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = itv.it_value.tv_sec + IV_1E6 * itv.it_value.tv_usec;
+ } else {
+ RETVAL = 0;
+ }
+ }
#else
- croak("Time::HiRes::ualarm(%d, %d): useconds or interval equal
or more than %"IVdf, useconds, interval, IV_1E6);
+ croak("Time::HiRes::ualarm(%d, %d): useconds or uinterval equal
to or more than %"IVdf, useconds, uinterval, IV_1E6);
#endif
else
- RETVAL = ualarm(useconds, interval);
+ RETVAL = ualarm(useconds, uinterval);
OUTPUT:
RETVAL
@@ -924,8 +951,24 @@
CODE:
if (seconds < 0.0 || interval < 0.0)
croak("Time::HiRes::alarm(%"NVgf", %"NVgf"): negative time not
invented yet", seconds, interval);
- RETVAL = (NV)ualarm((IV)(seconds * IV_1E6),
- (IV)(interval * IV_1E6)) / NV_1E6;
+ {
+ IV useconds = IV_1E6 * seconds;
+ IV uinterval = IV_1E6 * interval;
+ if (seconds >= IV_1E6 || interval >= IV_1E6)
+#if defined(HAS_SETITIMER) && defined(ITIMER_REAL)
+ {
+ struct itimerval itv;
+ if (hrt_ualarm_itimero(&itv, useconds, uinterval)) {
+ RETVAL = (NV)itv.it_value.tv_sec + (NV)itv.it_value.tv_usec /
NV_1E6;
+ } else {
+ RETVAL = 0;
+ }
+ }
+#else
+ RETVAL = (NV)ualarm((IV)(seconds * IV_1E6),
+ (IV)(interval * IV_1E6)) / NV_1E6;
+#endif
+ }
OUTPUT:
RETVAL
==== //depot/maint-5.8/perl/ext/Time/HiRes/Makefile.PL#34 (text) ====
Index: perl/ext/Time/HiRes/Makefile.PL
--- perl/ext/Time/HiRes/Makefile.PL#33~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/Time/HiRes/Makefile.PL 2008-05-19 08:43:18.000000000 -0700
@@ -832,20 +832,24 @@
}
sub main {
- print "Configuring Time::HiRes...\n";
- if ($] == 5.007002) {
- die "Cannot Configure Time::HiRes for Perl $], aborting.\n";
- }
-
- if ($^O =~ /Win32/i) {
- DEFINE('SELECT_IS_BROKEN');
- $LIBS = [];
- print "System is $^O, skipping full configure...\n";
+ if (-f "xdefine" && !(@ARGV && $ARGV[0] eq '--configure')) {
+ print qq[$0: The "xdefine" exists, skipping the configure step.\n];
+ print qq[("$0 --configure" to force the configure step)\n];
} else {
- init();
+ print "Configuring Time::HiRes...\n";
+ 1 while unlink("define");
+ if ($^O =~ /Win32/i) {
+ DEFINE('SELECT_IS_BROKEN');
+ $LIBS = [];
+ print "System is $^O, skipping full configure...\n";
+ open(XDEFINE, ">xdefine") or die "$0: Cannot create xdefine: $!\n";
+ close(XDEFINE);
+ } else {
+ init();
+ }
+ doMakefile;
+ doConstants;
}
- doMakefile;
- doConstants;
my $make = $Config{'make'} || "make";
unless (exists $ENV{PERL_CORE} && $ENV{PERL_CORE}) {
print <<EOM;
==== //depot/maint-5.8/perl/ext/Time/HiRes/t/HiRes.t#17 (text) ====
Index: perl/ext/Time/HiRes/t/HiRes.t
--- perl/ext/Time/HiRes/t/HiRes.t#16~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/Time/HiRes/t/HiRes.t 2008-05-19 08:43:18.000000000 -0700
@@ -68,7 +68,7 @@
my $have_alarm = $Config{d_alarm};
my $have_fork = $Config{d_fork};
-my $waitfor = 180; # 30-45 seconds is normal (load affects this).
+my $waitfor = 360; # 30-45 seconds is normal (load affects this).
my $timer_pid;
my $TheEnd;
@@ -502,13 +502,14 @@
};
# Next setup a periodic timer (the two-argument alarm() of
- # Time::HiRes, behind the curtains the libc ualarm()) which has
- # a signal handler that takes so much time (on the first initial
- # invocation) that the first periodic invocation (second invocation)
- # will happen before the first invocation has finished. In Perl 5.8.0
- # the "safe signals" concept was implemented, with unfortunately at least
- # one bug that caused a core dump on reentering the handler. This bug
- # was fixed by the time of Perl 5.8.1.
+ # Time::HiRes, behind the curtains the libc getitimer() or
+ # ualarm()) which has a signal handler that takes so much time (on
+ # the first initial invocation) that the first periodic invocation
+ # (second invocation) will happen before the first invocation has
+ # finished. In Perl 5.8.0 the "safe signals" concept was
+ # implemented, with unfortunately at least one bug that caused a
+ # core dump on reentering the handler. This bug was fixed by the
+ # time of Perl 5.8.1.
# Do not try mixing sleep() and alarm() for testing this.
@@ -620,6 +621,16 @@
skip 33;
}
+sub bellish { # Cheap emulation of a bell curve.
+ my ($min, $max) = @_;
+ my $rand = ($max - $min) / 5;
+ my $sum = 0;
+ for my $i (0..4) {
+ $sum += rand($rand);
+ }
+ return $min + $sum;
+}
+
if ($have_ualarm) {
# 1_100_000 sligthly over 1_000_000,
# 2_200_000 slightly over 2**31/1000,
@@ -629,21 +640,29 @@
[36, 2_200_000],
[37, 4_300_000]) {
my ($i, $n) = @$t;
- my $alarmed = 0;
- local $SIG{ ALRM } = sub { $alarmed++ };
- my $t0 = Time::HiRes::time();
- print "# t0 = $t0\n";
- print "# ualarm($n)\n";
- ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print "# t1 = $t1\n";
- my $dt = $t1 - $t0;
- print "# dt = $dt\n";
- my $r = $dt / ($n/1e6);
- print "# r = $r\n";
- ok $i,
- ($n < 1_000_000 || # Too much noise.
- $r >= 0.8 && $r <= 1.6), "ualarm($n) close enough";
+ my $ok;
+ for my $retry (1..10) {
+ my $alarmed = 0;
+ local $SIG{ ALRM } = sub { $alarmed++ };
+ my $t0 = Time::HiRes::time();
+ print "# t0 = $t0\n";
+ print "# ualarm($n)\n";
+ ualarm($n); 1 while $alarmed == 0;
+ my $t1 = Time::HiRes::time();
+ print "# t1 = $t1\n";
+ my $dt = $t1 - $t0;
+ print "# dt = $dt\n";
+ my $r = $dt / ($n/1e6);
+ print "# r = $r\n";
+ $ok =
+ ($n < 1_000_000 || # Too much noise.
+ ($r >= 0.8 && $r <= 1.6));
+ last if $ok;
+ my $nap = bellish(3, 15);
+ printf "# Retrying in %.1f seconds...\n", $nap;
+ Time::HiRes::sleep($nap);
+ }
+ ok $i, $ok, "ualarm($n) close enough";
}
} else {
print "# No ualarm\n";
==== //depot/maint-5.8/perl/lib/Cwd.pm#23 (text) ====
Index: perl/lib/Cwd.pm
--- perl/lib/Cwd.pm#22~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/Cwd.pm 2008-05-19 08:43:18.000000000 -0700
@@ -171,7 +171,7 @@
use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw/ Exporter /;
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
@@ -540,8 +540,8 @@
local *PARENT;
unless (opendir(PARENT, $dotdots))
{
- _carp("opendir($dotdots): $!");
- return '';
+ # probably a permissions issue. Try the native command.
+ return File::Spec->rel2abs( $start, _backtick_pwd() );
}
unless (@cst = stat($dotdots))
{
@@ -653,6 +653,25 @@
return _vms_abs_path($link_target);
}
+ if (defined &VMS::Filespec::vms_realpath) {
+ my $path = $_[0];
+ if ($path =~ m#(?<=\^)/# ) {
+ # Unix format
+ return VMS::Filespec::vms_realpath($path);
+ }
+
+ # VMS format
+
+ my $new_path = VMS::Filespec::vms_realname($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.
+
# may need to turn foo.dir into [.foo]
my $pathified = VMS::Filespec::pathify($path);
$path = $pathified if defined $pathified;
==== //depot/maint-5.8/perl/lib/File/Spec.pm#20 (text) ====
Index: perl/lib/File/Spec.pm
--- perl/lib/File/Spec.pm#19~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/File/Spec.pm 2008-05-19 08:43:18.000000000 -0700
@@ -3,7 +3,7 @@
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.2701';
$VERSION = eval $VERSION;
my %module = (MacOS => 'Mac',
==== //depot/maint-5.8/perl/lib/File/Spec/Cygwin.pm#12 (text) ====
Index: perl/lib/File/Spec/Cygwin.pm
--- perl/lib/File/Spec/Cygwin.pm#11~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/Cygwin.pm 2008-05-19 08:43:18.000000000 -0700
@@ -4,7 +4,7 @@
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw(File::Spec::Unix);
@@ -39,6 +39,8 @@
sub canonpath {
my($self,$path) = @_;
+ return unless defined $path;
+
$path =~ s|\\|/|g;
# Handle network path names beginning with double slash
@@ -51,6 +53,7 @@
sub catdir {
my $self = shift;
+ return unless @_;
# Don't create something that looks like a //network/path
if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) {
@@ -109,9 +112,9 @@
=cut
sub case_tolerant () {
- if ($^O ne 'cygwin') {
- return 1;
- }
+ return 1 unless $^O eq 'cygwin'
+ and defined &Cygwin::mount_flags;
+
my $drive = shift;
if (! $drive) {
my @flags = split(/,/, Cygwin::mount_flags('/cygwin'));
==== //depot/maint-5.8/perl/lib/File/Spec/Epoc.pm#8 (text) ====
Index: perl/lib/File/Spec/Epoc.pm
--- perl/lib/File/Spec/Epoc.pm#7~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/File/Spec/Epoc.pm 2008-05-19 08:43:18.000000000 -0700
@@ -3,7 +3,7 @@
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.2501';
+$VERSION = '3.2701';
require File::Spec::Unix;
@ISA = qw(File::Spec::Unix);
@@ -45,6 +45,7 @@
sub canonpath {
my ($self,$path) = @_;
+ return unless defined $path;
$path =~ s|/+|/|g; # xx////xx -> xx/xx
$path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx
==== //depot/maint-5.8/perl/lib/File/Spec/Functions.pm#7 (text) ====
Index: perl/lib/File/Spec/Functions.pm
--- perl/lib/File/Spec/Functions.pm#6~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/Functions.pm 2008-05-19 08:43:18.000000000 -0700
@@ -5,7 +5,7 @@
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.2701';
require Exporter;
==== //depot/maint-5.8/perl/lib/File/Spec/Mac.pm#13 (text) ====
Index: perl/lib/File/Spec/Mac.pm
--- perl/lib/File/Spec/Mac.pm#12~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/File/Spec/Mac.pm 2008-05-19 08:43:18.000000000 -0700
@@ -4,7 +4,7 @@
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw(File::Spec::Unix);
@@ -530,7 +530,7 @@
my @result = ();
my ($head, $sep, $tail, $volume, $directories);
- return ('') if ( (!defined($path)) || ($path eq '') );
+ return @result if ( (!defined($path)) || ($path eq '') );
return (':') if ($path eq ':');
( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s;
==== //depot/maint-5.8/perl/lib/File/Spec/OS2.pm#13 (text) ====
Index: perl/lib/File/Spec/OS2.pm
--- perl/lib/File/Spec/OS2.pm#12~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/File/Spec/OS2.pm 2008-05-19 08:43:18.000000000 -0700
@@ -4,7 +4,7 @@
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw(File::Spec::Unix);
@@ -54,6 +54,8 @@
sub canonpath {
my ($self,$path) = @_;
+ return unless defined $path;
+
$path =~ s/^([a-z]:)/\l$1/s;
$path =~ s|\\|/|g;
$path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx
==== //depot/maint-5.8/perl/lib/File/Spec/Unix.pm#21 (text) ====
Index: perl/lib/File/Spec/Unix.pm
--- perl/lib/File/Spec/Unix.pm#20~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/Unix.pm 2008-05-19 08:43:18.000000000 -0700
@@ -3,7 +3,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = '3.2501';
+$VERSION = '3.2701';
=head1 NAME
@@ -41,6 +41,7 @@
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
==== //depot/maint-5.8/perl/lib/File/Spec/VMS.pm#16 (text) ====
Index: perl/lib/File/Spec/VMS.pm
--- perl/lib/File/Spec/VMS.pm#15~33174~ 2008-02-01 12:08:10.000000000 -0800
+++ perl/lib/File/Spec/VMS.pm 2008-05-19 08:43:18.000000000 -0700
@@ -4,7 +4,7 @@
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw(File::Spec::Unix);
==== //depot/maint-5.8/perl/lib/File/Spec/Win32.pm#16 (text) ====
Index: perl/lib/File/Spec/Win32.pm
--- perl/lib/File/Spec/Win32.pm#15~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/Win32.pm 2008-05-19 08:43:18.000000000 -0700
@@ -5,7 +5,7 @@
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.2501';
+$VERSION = '3.2701';
@ISA = qw(File::Spec::Unix);
@@ -126,23 +126,37 @@
=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;
+ shift;
+
+ # Legacy / compatibility support
+ #
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ # Compatibility with File::Spec <= 3.26:
+ # catfile('A:', 'foo') should return 'A:\foo'.
+ return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
+ if $_[0] =~ m{^$DRIVE_RX\z}o;
+
+ return _canon_cat( @_ );
}
sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- tr[/][\\];
- # append a backslash to each argument unless it has one there
- $_ .= "\\" unless m{\\$};
- }
- return $self->canonpath(join('', @args));
+ shift;
+
+ # Legacy / compatibility support
+ #
+ return ""
+ unless @_;
+ shift, return _canon_cat( "/", @_ )
+ if $_[0] eq "";
+
+ # Compatibility with File::Spec <= 3.26:
+ # catdir('A:', 'foo') should return 'A:\foo'.
+ return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
+ if $_[0] =~ m{^$DRIVE_RX\z}o;
+
+ return _canon_cat( @_ );
}
sub path {
@@ -165,25 +179,10 @@
=cut
sub canonpath {
- my ($self,$path) = @_;
-
- $path =~ s/^([a-z]:)/\u$1/s;
- $path =~ s|/|\\|g;
- $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
- $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
- $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
- $path =~ s|\\\Z(?!\n)||
- unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
- # xx1/xx2/xx3/../../xx -> xx1/xx
- $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
- $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
- return $path if $path =~ m|^\.\.|; # skip relative paths
- return $path unless $path =~ /\.\./; # too few .'s to cleanup
- return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
- $path =~ s{^\\\.\.$}{\\}; # \.. -> \
- 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
-
- return $self->_collapse($path);
+ # Legacy / compatibility support
+ #
+ return $_[1] if !defined($_[1]) or $_[1] eq '';
+ return _canon_cat( $_[1] );
}
=item splitpath
@@ -375,4 +374,69 @@
=cut
+
+sub _canon_cat(@) # @path -> path
+{
+ my $first = shift;
+ my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
+ ? ucfirst( $1 ).( $2 ? "\\" : "" )
+ : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
+ (?: [\\/] ([^\\/]+) )?
+ [\\/]? }{}xs # UNC volume
+ ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
+ : $first =~ s{ \A [\\/] }{}x # root dir
+ ? "\\"
+ : "";
+ my $path = join "\\", $first, @_;
+
+ $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
+
+ # xx/././yy --> xx/yy
+ $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ \.
+ (?:\\\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}gx;
+
+ # XXX I do not know whether more dots are supported by the OS supporting
+ # this ... annotation (NetWare or symbian but not MSWin32).
+ # Then .... could easily become ../../.. etc:
+ # Replace \.\.\. by (\.\.\.+) and substitute with
+ # { $1 . ".." . "\\.." x (length($2)-2) }gex
+ # ... --> ../..
+ $path =~ s{ (\A|\\) # at begin or after a slash
+ \.\.\.
+ (?=\\|\z) # at end or followed by slash
+ }{$1..\\..}gx;
+ # xx\yy\..\zz --> xx\zz
+ while ( $path =~ s{(?:
+ (?:\A|\\) # at begin or after a slash
+ [^\\]+ # rip this 'yy' off
+ \\\.\.
+ (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
+ (?<!\\\.\.\\\.\.) # do *not* replace \..\..
+ (?:\\|\z) # at end or followed by slash
+ )+ # performance boost -- I do not know why
+ }{\\}sx ) {}
+
+ $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
+ $path =~ s#\\\z##; # xx\ --> xx
+
+ if ( $volume =~ m#\\\z# )
+ { # <vol>\.. --> <vol>\
+ $path =~ s{ \A # at begin
+ \.\.
+ (?:\\\.\.)* # and more
+ (?:\\|\z) # at end or followed by slash
+ }{}x;
+
+ return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
+ if $path eq ""
+ and $volume =~ m#\A(\\\\.*)\\\z#s;
+ }
+ return $path ne "" || $volume ? $volume.$path : ".";
+}
+
1;
==== //depot/maint-5.8/perl/lib/File/Spec/t/Spec.t#16 (text) ====
Index: perl/lib/File/Spec/t/Spec.t
--- perl/lib/File/Spec/t/Spec.t#15~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/t/Spec.t 2008-05-19 08:43:18.000000000 -0700
@@ -191,10 +191,10 @@
[ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ],
[ "Win32->catdir('\\d1','\\d2')", '\\d1\\d2' ],
[ "Win32->catdir('\\d1','\\d2\\')", '\\d1\\d2' ],
-[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ],
-[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ],
-[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ],
-[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ],
+[ "Win32->catdir('','/d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','','/d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','//d1','d2')", '\\d1\\d2' ],
+[ "Win32->catdir('','','//d1','d2')", '\\d1\\d2' ],
[ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ],
[ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ],
[ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ],
@@ -206,13 +206,16 @@
[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ],
[ "Win32->catdir('A:/')", 'A:\\' ],
[ "Win32->catdir('\\', 'foo')", '\\foo' ],
-
+[ "Win32->catdir('','','..')", '\\' ],
+[ "Win32->catdir('A:', 'foo')", 'A:\\foo' ],
[ "Win32->catfile('a','b','c')", 'a\\b\\c' ],
[ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ],
[ "Win32->catfile('.\\a','b','c')", 'a\\b\\c' ],
[ "Win32->catfile('c')", 'c' ],
[ "Win32->catfile('.\\c')", 'c' ],
+[ "Win32->catfile('a/..','../b')", '..\\b' ],
+[ "Win32->catfile('A:', 'foo')", 'A:\\foo' ],
[ "Win32->canonpath('')", '' ],
@@ -224,9 +227,9 @@
[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ],
[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ],
-[ "Win32->canonpath('////')", '\\\\\\' ],
+[ "Win32->canonpath('////')", '\\' ],
[ "Win32->canonpath('//')", '\\' ],
-[ "Win32->canonpath('/.')", '\\.' ],
+[ "Win32->canonpath('/.')", '\\' ],
[ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('//a/b/c/../d')", '\\\\a\\b\\d' ],
[ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d' ],
@@ -694,6 +697,7 @@
[ "Cygwin->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ],
[ "Cygwin->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ],
[ "Cygwin->rel2abs('/t1','/t1/t2/t3')", '/t1' ],
+[ "Cygwin->rel2abs('//t1/t2/t3','/foo')", '//t1/t2/t3' ],
) ;
==== //depot/maint-5.8/perl/lib/File/Spec/t/crossplatform.t#4 (text) ====
Index: perl/lib/File/Spec/t/crossplatform.t
--- perl/lib/File/Spec/t/crossplatform.t#3~30133~ 2007-02-05
10:05:43.000000000 -0800
+++ perl/lib/File/Spec/t/crossplatform.t 2008-05-19 08:43:18.000000000
-0700
@@ -7,7 +7,7 @@
local $|=1;
my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32);
-my $tests_per_platform = 7;
+my $tests_per_platform = 10;
plan tests => 1 + @platforms * $tests_per_platform;
@@ -56,6 +56,17 @@
is $module->file_name_is_absolute($base), 1, "$base is absolute on
$platform";
+ # splitdir('') -> ()
+ my @result = $module->splitdir('');
+ is @result, 0, "$platform->splitdir('') -> ()";
+
+ # canonpath() -> undef
+ $result = $module->canonpath();
+ is $result, undef, "$platform->canonpath() -> undef";
+
+ # canonpath(undef) -> undef
+ $result = $module->canonpath(undef);
+ is $result, undef, "$platform->canonpath(undef) -> undef";
# abs2rel('A:/foo/bar', 'A:/foo') -> 'bar'
$file = $module->catpath($v, $module->catdir($module->rootdir, 'foo',
'bar'), 'file');
==== //depot/maint-5.8/perl/lib/File/Spec/t/tmpdir.t#3 (text) ====
Index: perl/lib/File/Spec/t/tmpdir.t
--- perl/lib/File/Spec/t/tmpdir.t#2~33174~ 2008-02-01 12:08:10.000000000
-0800
+++ perl/lib/File/Spec/t/tmpdir.t 2008-05-19 08:43:18.000000000 -0700
@@ -14,9 +14,8 @@
ok scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of
%ENV";
if ($^O eq 'VMS') {
- skip('Can\'t make list assignment to \%ENV on this system', 1);
-}
-else {
+ skip("Can't make list assignment to %ENV on this system", 1);
+} else {
local %ENV;
File::Spec::Win32->tmpdir;
ok scalar keys %ENV, 0, "Win32->tmpdir() shouldn't change the contents of
%ENV";
End of Patch.
