Change 17651: Integrate maint-5.6/perl
[email protected] (Chris Nandor) Tue, 23 Jul 2002 14:54:52 -0400
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05111b0ab96356ee2fac@[10.0.1.177]> |
Change 17651 by pudge@pudge-mobile on 2002/07/23 03:24:35
Integrate maint-5.6/perl
Affected files ...
.... //depot/maint-5.6/macperl/MANIFEST#4 integrate
.... //depot/maint-5.6/macperl/XSUB.h#2 integrate
.... //depot/maint-5.6/macperl/doio.c#4 integrate
.... //depot/maint-5.6/macperl/embed.h#3 integrate
.... //depot/maint-5.6/macperl/embed.pl#2 integrate
.... //depot/maint-5.6/macperl/ext/DB_File/DB_File.pm#2 integrate
.... //depot/maint-5.6/macperl/ext/Fcntl/Fcntl.pm#2 integrate
.... //depot/maint-5.6/macperl/ext/File/Glob/Glob.pm#4 integrate
.... //depot/maint-5.6/macperl/ext/GDBM_File/GDBM_File.pm#2 integrate
.... //depot/maint-5.6/macperl/ext/IO/lib/IO/Pipe.pm#2 integrate
.... //depot/maint-5.6/macperl/ext/IO/poll.c#2 integrate
.... //depot/maint-5.6/macperl/ext/Socket/Socket.pm#2 integrate
.... //depot/maint-5.6/macperl/ext/Sys/Syslog/Syslog.pm#2 integrate
.... //depot/maint-5.6/macperl/global.sym#2 integrate
.... //depot/maint-5.6/macperl/globals.c#2 integrate
.... //depot/maint-5.6/macperl/iperlsys.h#3 integrate
.... //depot/maint-5.6/macperl/lib/AutoLoader.pm#3 integrate
.... //depot/maint-5.6/macperl/lib/Win32.pod#2 integrate
.... //depot/maint-5.6/macperl/makedef.pl#4 integrate
.... //depot/maint-5.6/macperl/mg.c#4 integrate
.... //depot/maint-5.6/macperl/objXSUB.h#2 integrate
.... //depot/maint-5.6/macperl/op.c#7 integrate
.... //depot/maint-5.6/macperl/perl.c#9 integrate
.... //depot/maint-5.6/macperl/perlapi.c#2 integrate
.... //depot/maint-5.6/macperl/pp_sys.c#3 integrate
.... //depot/maint-5.6/macperl/proto.h#3 integrate
.... //depot/maint-5.6/macperl/sv.c#4 integrate
.... //depot/maint-5.6/macperl/t/harness#4 integrate
.... //depot/maint-5.6/macperl/t/op/magic.t#3 integrate
.... //depot/maint-5.6/macperl/t/win32/longpath.t#1 branch
.... //depot/maint-5.6/macperl/toke.c#7 integrate
.... //depot/maint-5.6/macperl/util.c#9 integrate
.... //depot/maint-5.6/macperl/utils/h2xs.PL#2 integrate
.... //depot/maint-5.6/macperl/win32/perlhost.h#6 integrate
.... //depot/maint-5.6/macperl/win32/win32.c#9 integrate
.... //depot/maint-5.6/macperl/win32/win32.h#3 integrate
Differences ...
==== //depot/maint-5.6/macperl/MANIFEST#4 (text) ====
Index: macperl/MANIFEST
--- macperl/MANIFEST#3~12819~ Fri Nov 2 13:21:56 2001
+++ macperl/MANIFEST Mon Jul 22 20:24:35 2002
@@ -1598,6 +1598,7 @@
t/pragma/warn/util Tests for util.c for warnings.t
t/pragma/warnings.t See if warning controls work
t/run/runenv.t Test if perl honors its environment variables.
+t/win32/longpath.t Test if Win32::GetLongPathName() works
taint.c Tainting code
thrdvar.h Per-thread variables
thread.h Threading header
==== //depot/maint-5.6/macperl/XSUB.h#2 (text) ====
Index: macperl/XSUB.h
--- macperl/XSUB.h#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/XSUB.h Mon Jul 22 20:24:35 2002
@@ -394,6 +394,18 @@
# define shutdown PerlSock_shutdown
# define socket PerlSock_socket
# define socketpair PerlSock_socketpair
+# ifdef USE_SOCKETS_AS_HANDLES
+# undef fd_set
+# undef FD_SET
+# undef FD_CLR
+# undef FD_ISSET
+# undef FD_ZERO
+# define fd_set Perl_fd_set
+# define FD_SET(n,p) PERL_FD_SET(n,p)
+# define FD_CLR(n,p) PERL_FD_CLR(n,p)
+# define FD_ISSET(n,p) PERL_FD_ISSET(n,p)
+# define FD_ZERO(p) PERL_FD_ZERO(p)
+# endif /* USE_SOCKETS_AS_HANDLES */
# endif /* NO_XSLOCKS */
#endif /* PERL_CAPI */
==== //depot/maint-5.6/macperl/doio.c#4 (text) ====
Index: macperl/doio.c
--- macperl/doio.c#3~14904~ Wed Feb 27 13:25:39 2002
+++ macperl/doio.c Mon Jul 22 20:24:35 2002
@@ -51,6 +51,61 @@
#include <signal.h>
#endif
+#if defined(USE_ITHREADS)
+STATIC void
+S_invalidate_fileno(pTHX_ PerlIO *f)
+{
+ int fd = PerlIO_fileno(f);
+ PerlIO_flush(f);
+# if defined(USE_SFIO)
+# error "dont know how to set FILE.fileno under sfio"
+# endif
+ /* XXX this could use PerlIO_canset_fileno() and
+ * PerlIO_set_fileno() support from Configure */
+# if defined(__GLIBC__)
+ ((FILE*)f)->_fileno = -1;
+# elif defined(__sun__)
+ /* _file is just a char :-( */
+ ((FILE*)f)->_file = PerlLIO_dup(fd);
+# elif defined(__hpux)
+ ((FILE*)f)->__fileH = 0xff;
+ ((FILE*)f)->__fileL = 0xff;
+# elif defined(__FreeBSD__)
+ ((FILE*)f)->_file = -1;
+# elif defined(WIN32)
+# if defined(__BORLANDC__)
+ ((FILE*)f)->fd = PerlLIO_dup(fd);
+# else
+ ((FILE*)f)->_file = -1;
+# endif
+# else
+# error "dont know how to set FILE.fileno on your platform"
+# endif
+}
+#endif
+
+STATIC int
+S_io_sock_close(pTHX_ IO *io)
+{
+ int result;
+
+#if defined(USE_ITHREADS)
+ /* Avoid race condition: without this, the second fclose() will
+ * attempt to close() the same fd, and that fd could have been
+ * allocated by another thread between the two fclose() calls.
+ * It is potentially better to keep the two fds separate by making
+ * one a dup() of the other, but doing so muddies the perl-level
+ * semantics more than this hack. What should fileno(SOCK) return
+ * in that case? How about fcntl(SOCK,...)? Etc. */
+ if (PerlIO_fileno(IoIFP(io)) == PerlIO_fileno(IoOFP(io)))
+ invalidate_fileno(IoIFP(io));
+#endif
+ result = PerlIO_close(IoOFP(io));
+ PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
+
+ return result;
+}
+
bool
Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp)
@@ -99,10 +154,8 @@
else if (IoTYPE(io) == IoTYPE_PIPE)
result = PerlProc_pclose(IoIFP(io));
else if (IoIFP(io) != IoOFP(io)) {
- if (IoOFP(io)) {
- result = PerlIO_close(IoOFP(io));
- PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
- }
+ if (IoOFP(io))
+ result = io_sock_close(io);
else
result = PerlIO_close(IoIFP(io));
}
@@ -458,6 +511,10 @@
if (saveofp) {
PerlIO_flush(saveofp); /* emulate PerlIO_close() */
if (saveofp != saveifp) { /* was a socket? */
+#if defined(USE_ITHREADS)
+ if (fd == PerlIO_fileno(saveofp))
+ invalidate_fileno(saveofp);
+#endif
PerlIO_close(saveofp);
}
}
@@ -496,11 +553,21 @@
if (was_fdopen) {
/* need to close fp without closing underlying fd */
+#if defined(USE_THREADS)
+ /* we do do this only in the non-ithreads case because of
+ * the platform-specific nature of invalidate_fileno() */
+ invalidate_fileno(fp);
+ PerlIO_close(fp);
+#else
int ofd = PerlIO_fileno(fp);
int dupfd = PerlLIO_dup(ofd);
PerlIO_close(fp);
+ /* there is a race condition here that makes this code
+ * thread-unsafe. ofd could have been allocated by
+ * another thread at this point. */
PerlLIO_dup2(dupfd,ofd);
PerlLIO_close(dupfd);
+#endif
}
else
PerlIO_close(fp);
@@ -785,6 +852,7 @@
goto badexit;
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
IoTYPE(wstio) = IoTYPE_WRONLY;
@@ -858,10 +926,8 @@
else if (IoTYPE(io) == IoTYPE_STD)
retval = TRUE;
else {
- if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
- retval = (PerlIO_close(IoOFP(io)) != EOF);
- PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
- }
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) /* a socket */
+ retval = (io_sock_close(io) != EOF);
else
retval = (PerlIO_close(IoIFP(io)) != EOF);
}
@@ -1399,7 +1465,7 @@
while (*t && isSPACE(*t))
++t;
- if (!*t && (dup2(1,2) != -1)) {
+ if (!*t && (PerlLIO_dup2(1,2) != -1)) {
s[-2] = '\0';
break;
}
==== //depot/maint-5.6/macperl/embed.h#3 (text+w) ====
Index: macperl/embed.h
--- macperl/embed.h#2~14395~ Wed Jan 23 12:01:43 2002
+++ macperl/embed.h Mon Jul 22 20:24:35 2002
@@ -166,6 +166,11 @@
#define do_close Perl_do_close
#define do_eof Perl_do_eof
#define do_exec Perl_do_exec
+#if defined(WIN32)
+#define do_aspawn Perl_do_aspawn
+#define do_spawn Perl_do_spawn
+#define do_spawn_nowait Perl_do_spawn_nowait
+#endif
#if !defined(WIN32)
#define do_exec3 Perl_do_exec3
#endif
@@ -863,6 +868,12 @@
#define avhv_index_sv S_avhv_index_sv
#define avhv_index S_avhv_index
#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#define io_sock_close S_io_sock_close
+#if defined(USE_ITHREADS)
+#define invalidate_fileno S_invalidate_fileno
+#endif
+#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#define do_trans_simple S_do_trans_simple
#define do_trans_count S_do_trans_count
@@ -1637,6 +1648,11 @@
#define do_close(a,b) Perl_do_close(aTHX_ a,b)
#define do_eof(a) Perl_do_eof(aTHX_ a)
#define do_exec(a) Perl_do_exec(aTHX_ a)
+#if defined(WIN32)
+#define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c)
+#define do_spawn(a) Perl_do_spawn(aTHX_ a)
+#define do_spawn_nowait(a) Perl_do_spawn_nowait(aTHX_ a)
+#endif
#if !defined(WIN32)
#define do_exec3(a,b,c) Perl_do_exec3(aTHX_ a,b,c)
#endif
@@ -2322,6 +2338,12 @@
#define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a)
#define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c)
#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#define io_sock_close(a) S_io_sock_close(aTHX_ a)
+#if defined(USE_ITHREADS)
+#define invalidate_fileno(a) S_invalidate_fileno(aTHX_ a)
+#endif
+#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#define do_trans_simple(a) S_do_trans_simple(aTHX_ a)
#define do_trans_count(a) S_do_trans_count(aTHX_ a)
@@ -3212,6 +3234,14 @@
#define do_eof Perl_do_eof
#define Perl_do_exec CPerlObj::Perl_do_exec
#define do_exec Perl_do_exec
+#if defined(WIN32)
+#define Perl_do_aspawn CPerlObj::Perl_do_aspawn
+#define do_aspawn Perl_do_aspawn
+#define Perl_do_spawn CPerlObj::Perl_do_spawn
+#define do_spawn Perl_do_spawn
+#define Perl_do_spawn_nowait CPerlObj::Perl_do_spawn_nowait
+#define do_spawn_nowait Perl_do_spawn_nowait
+#endif
#if !defined(WIN32)
#define Perl_do_exec3 CPerlObj::Perl_do_exec3
#define do_exec3 Perl_do_exec3
@@ -4545,6 +4575,14 @@
#define avhv_index_sv S_avhv_index_sv
#define S_avhv_index CPerlObj::S_avhv_index
#define avhv_index S_avhv_index
+#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#define S_io_sock_close CPerlObj::S_io_sock_close
+#define io_sock_close S_io_sock_close
+#if defined(USE_ITHREADS)
+#define S_invalidate_fileno CPerlObj::S_invalidate_fileno
+#define invalidate_fileno S_invalidate_fileno
+#endif
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#define S_do_trans_simple CPerlObj::S_do_trans_simple
==== //depot/maint-5.6/macperl/embed.pl#2 (xtext) ====
Index: macperl/embed.pl
--- macperl/embed.pl#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/embed.pl Mon Jul 22 20:24:35 2002
@@ -1486,7 +1486,12 @@
p |void |do_chop |SV* asv|SV* sv
Ap |bool |do_close |GV* gv|bool not_implicit
p |bool |do_eof |GV* gv
-p |bool |do_exec |char* cmd
+Ap |bool |do_exec |char* cmd
+#if defined(WIN32)
+Ap |int |do_aspawn |SV* really|SV** mark|SV** sp
+Ap |int |do_spawn |char* cmd
+Ap |int |do_spawn_nowait|char* cmd
+#endif
#if !defined(WIN32)
p |bool |do_exec3 |char* cmd|int fd|int flag
#endif
@@ -2230,6 +2235,13 @@
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
s |I32 |avhv_index_sv |SV* sv
s |I32 |avhv_index |AV* av|SV* sv|U32 hash
+#endif
+
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+s |int |io_sock_close |IO *io
+#if defined(USE_ITHREADS)
+s |void |invalidate_fileno|PerlIO *f
+#endif
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.6/macperl/ext/DB_File/DB_File.pm#2 (text) ====
Index: macperl/ext/DB_File/DB_File.pm
--- macperl/ext/DB_File/DB_File.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/DB_File/DB_File.pm Mon Jul 22 20:24:35 2002
@@ -210,6 +210,7 @@
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
==== //depot/maint-5.6/macperl/ext/Fcntl/Fcntl.pm#2 (text) ====
Index: macperl/ext/Fcntl/Fcntl.pm
--- macperl/ext/Fcntl/Fcntl.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/Fcntl/Fcntl.pm Mon Jul 22 20:24:35 2002
@@ -201,6 +201,7 @@
sub AUTOLOAD {
(my $constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
==== //depot/maint-5.6/macperl/ext/File/Glob/Glob.pm#4 (text) ====
Index: macperl/ext/File/Glob/Glob.pm
--- macperl/ext/File/Glob/Glob.pm#3~14282~ Tue Jan 15 07:21:18 2002
+++ macperl/ext/File/Glob/Glob.pm Mon Jul 22 20:24:35 2002
@@ -86,6 +86,7 @@
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/) {
==== //depot/maint-5.6/macperl/ext/GDBM_File/GDBM_File.pm#2 (text) ====
Index: macperl/ext/GDBM_File/GDBM_File.pm
--- macperl/ext/GDBM_File/GDBM_File.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/GDBM_File/GDBM_File.pm Mon Jul 22 20:24:35 2002
@@ -66,6 +66,7 @@
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
==== //depot/maint-5.6/macperl/ext/IO/lib/IO/Pipe.pm#2 (text) ====
Index: macperl/ext/IO/lib/IO/Pipe.pm
--- macperl/ext/IO/lib/IO/Pipe.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/IO/lib/IO/Pipe.pm Mon Jul 22 20:24:35 2002
@@ -38,7 +38,7 @@
(IO::Pipe::End->new(), IO::Pipe::End->new());
}
-my $do_spawn = $^O eq 'os2';
+my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
sub _doit {
my $me = shift;
@@ -56,8 +56,11 @@
if ($do_spawn) {
require Fcntl;
$save = IO::Handle->new_from_fd($io, $mode);
+ my $handle = shift;
# Close in child:
- fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
+ unless ($^O eq 'MSWin32') {
+ fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
+ }
$fh = $rw ? ${*$me}[0] : ${*$me}[1];
} else {
shift;
==== //depot/maint-5.6/macperl/ext/IO/poll.c#2 (text) ====
Index: macperl/ext/IO/poll.c
--- macperl/ext/IO/poll.c#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/IO/poll.c Mon Jul 22 20:24:35 2002
@@ -12,6 +12,8 @@
#include "EXTERN.h"
#include "perl.h"
+#include "XSUB.h"
+
#include "poll.h"
#ifdef I_SYS_TIME
# include <sys/time.h>
==== //depot/maint-5.6/macperl/ext/Socket/Socket.pm#2 (text) ====
Index: macperl/ext/Socket/Socket.pm
--- macperl/ext/Socket/Socket.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/Socket/Socket.pm Mon Jul 22 20:24:35 2002
@@ -439,6 +439,7 @@
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
my ($pack,$file,$line) = caller;
==== //depot/maint-5.6/macperl/ext/Sys/Syslog/Syslog.pm#2 (text) ====
Index: macperl/ext/Sys/Syslog/Syslog.pm
--- macperl/ext/Sys/Syslog/Syslog.pm#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/ext/Sys/Syslog/Syslog.pm Mon Jul 22 20:24:35 2002
@@ -129,6 +129,7 @@
our $AUTOLOAD;
($constname = $AUTOLOAD) =~ s/.*:://;
croak "& not defined" if $constname eq 'constant';
+ local $! = 0;
my $val = constant($constname);
if ($! != 0) {
croak "Your vendor has not defined Sys::Syslog macro $constname";
==== //depot/maint-5.6/macperl/global.sym#2 (text+w) ====
Index: macperl/global.sym
--- macperl/global.sym#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/global.sym Mon Jul 22 20:24:35 2002
@@ -89,6 +89,10 @@
Perl_dounwind
Perl_do_binmode
Perl_do_close
+Perl_do_exec
+Perl_do_aspawn
+Perl_do_spawn
+Perl_do_spawn_nowait
Perl_do_join
Perl_do_open
Perl_do_open9
==== //depot/maint-5.6/macperl/globals.c#2 (text) ====
Index: macperl/globals.c
--- macperl/globals.c#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/globals.c Mon Jul 22 20:24:35 2002
@@ -54,20 +54,6 @@
}
#endif
-#ifdef WIN32 /* XXX why are these needed? */
-bool
-Perl_do_exec(char *cmd)
-{
- return PerlProc_Cmd(cmd);
-}
-
-int
-CPerlObj::do_aspawn(void *vreally, void **vmark, void **vsp)
-{
- return PerlProc_aspawn(vreally, vmark, vsp);
-}
-#endif /* WIN32 */
-
#endif /* PERL_OBJECT */
int
==== //depot/maint-5.6/macperl/iperlsys.h#3 (text) ====
Index: macperl/iperlsys.h
--- macperl/iperlsys.h#2~12699~ Fri Oct 26 13:49:00 2001
+++ macperl/iperlsys.h Mon Jul 22 20:24:35 2002
@@ -1056,12 +1056,8 @@
typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*);
typedef void (*LPProcGetOSError)(struct IPerlProc*,
SV* sv, DWORD dwErr);
-typedef void (*LPProcFreeBuf)(struct IPerlProc*, char*);
-typedef BOOL (*LPProcDoCmd)(struct IPerlProc*, char*);
-typedef int (*LPProcSpawn)(struct IPerlProc*, char*);
typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*,
const char*const*);
-typedef int (*LPProcASpawn)(struct IPerlProc*, void*, void**, void**);
#endif
struct IPerlProc
@@ -1096,10 +1092,10 @@
#ifdef WIN32
LPProcDynaLoader pDynaLoader;
LPProcGetOSError pGetOSError;
- LPProcDoCmd pDoCmd;
- LPProcSpawn pSpawn;
- LPProcSpawnvp pSpawnvp;
- LPProcASpawn pASpawn;
+ void * __unused1; /* XXX unused, retained for bincompat */
+ void * __unused2;
+ LPProcSpawnvp pSpawnvp; /* XXX unused, retained for bincompat */
+ void * __unused3; /* XXX unused, retained for bincompat */
#endif
};
@@ -1171,14 +1167,8 @@
(*PL_Proc->pDynaLoader)(PL_Proc, (f))
#define PerlProc_GetOSError(s,e) \
(*PL_Proc->pGetOSError)(PL_Proc, (s), (e))
-#define PerlProc_Cmd(s) \
- (*PL_Proc->pDoCmd)(PL_Proc, (s))
-#define do_spawn(s) \
- (*PL_Proc->pSpawn)(PL_Proc, (s))
-#define do_spawnvp(m, c, a) \
+#define PerlProc_spawnvp(m, c, a) \
(*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a))
-#define PerlProc_aspawn(m,c,a) \
- (*PL_Proc->pASpawn)(PL_Proc, (m), (c), (a))
#endif
#else /* PERL_IMPLICIT_SYS */
@@ -1219,6 +1209,8 @@
win32_dynaload((f))
#define PerlProc_GetOSError(s,e) \
win32_str_os_error((s), (e))
+#define PerlProc_spawnvp(m, c, a) \
+ win32_spawnvp((m), (c), (a))
#endif
#endif /* PERL_IMPLICIT_SYS */
==== //depot/maint-5.6/macperl/lib/AutoLoader.pm#3 (text) ====
Index: macperl/lib/AutoLoader.pm
--- macperl/lib/AutoLoader.pm#2~11193~ Sat Jul 7 10:26:28 2001
+++ macperl/lib/AutoLoader.pm Mon Jul 22 20:24:35 2002
@@ -252,6 +252,7 @@
sub AUTOLOAD {
my $sub = $AUTOLOAD;
(my $constname = $sub) =~ s/.*:://;
+ local $! = 0;
my $val = constant($constname, @_ ? $_[0] : 0);
if ($! != 0) {
if ($! =~ /Invalid/ || $!{EINVAL}) {
==== //depot/maint-5.6/macperl/lib/Win32.pod#2 (text) ====
Index: macperl/lib/Win32.pod
--- macperl/lib/Win32.pod#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/lib/Win32.pod Mon Jul 22 20:24:35 2002
@@ -253,6 +253,20 @@
[EXT] Loads the DLL LIBRARYNAME and calls the function DllRegisterServer.
+=item Win32::SetChildShowWindow(SHOWWINDOW)
+
+[CORE] Sets the I<ShowMode> of child processes started by system().
+By default system() will create a new console window for child
+processes if Perl itself is not running from a console. Calling
+SetChildShowWindow(0) will make these new console windows invisible.
+Calling SetChildShowWindow() without arguments reverts system() to the
+default behavior. The return value of SetChildShowWindow() is the
+previous setting or C<undef>.
+
+[EXT] The following symbolic constants for SHOWWINDOW are available
+(but not exported) from the Win32 module: SW_HIDE, SW_SHOWNORMAL,
+SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED and SW_SHOWNOACTIVATE.
+
=item Win32::SetCwd(NEWDIRECTORY)
[CORE] Sets the current active drive and directory. This function does not
==== //depot/maint-5.6/macperl/makedef.pl#4 (xtext) ====
Index: macperl/makedef.pl
--- macperl/makedef.pl#3~12699~ Fri Oct 26 13:49:00 2001
+++ macperl/makedef.pl Mon Jul 22 20:24:35 2002
@@ -241,13 +241,19 @@
PL_cshlen
PL_cshname
PL_opsave
- Perl_do_exec
Perl_getenv_len
Perl_my_pclose
Perl_my_popen
)];
}
-elsif ($PLATFORM eq 'aix') {
+else {
+ skip_symbols [qw(
+ Perl_do_spawn
+ Perl_do_spawn_nowait
+ Perl_do_aspawn
+ )];
+}
+if ($PLATFORM eq 'aix') {
skip_symbols([qw(
Perl_dump_fds
Perl_ErrorNo
==== //depot/maint-5.6/macperl/mg.c#4 (text) ====
Index: macperl/mg.c
--- macperl/mg.c#3~12699~ Fri Oct 26 13:49:00 2001
+++ macperl/mg.c Mon Jul 22 20:24:35 2002
@@ -906,7 +906,12 @@
PerlEnv_clearenv();
# else
#if !defined(MACOS_TRADITIONAL)
-# ifndef PERL_USE_SAFE_PUTENV
+# if defined(USE_ITHREADS)
+ /* only the parent thread can clobber the process environment */
+ if (PL_curinterp == aTHX)
+# endif
+ {
+# ifndef PERL_USE_SAFE_PUTENV
I32 i;
if (environ == PL_origenviron)
@@ -914,10 +919,10 @@
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
-# endif /* PERL_USE_SAFE_PUTENV */
+# endif /* PERL_USE_SAFE_PUTENV */
environ[0] = Nullch;
-
+ }
#endif /* !defined(MACOS_TRADITIONAL) */
# endif /* PERL_IMPLICIT_SYS */
#endif /* VMS */
@@ -2023,9 +2028,13 @@
break;
}
/* can grab env area too? */
- if (PL_origenviron && (PL_origenviron[0] == s + 1
+ if (PL_origenviron
+#ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+#endif
+ && (PL_origenviron[0] == s + 1
#ifdef OS2
- || (PL_origenviron[0] == s + 9 && (s += 8))
+ || (PL_origenviron[0] == s + 9 && (s += 8))
#endif
)) {
my_setenv("NoNe SuCh", Nullch);
@@ -2055,8 +2064,7 @@
s = PL_origargv[0]+i;
*s++ = '\0';
while (++i < (I32)PL_origalen)
- *s++ = ' ';
- s = PL_origargv[0]+i;
+ *s++ = '\0';
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = Nullch;
}
==== //depot/maint-5.6/macperl/objXSUB.h#2 (text+w) ====
Index: macperl/objXSUB.h
--- macperl/objXSUB.h#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/objXSUB.h Mon Jul 22 20:24:35 2002
@@ -313,6 +313,24 @@
#define Perl_do_close pPerl->Perl_do_close
#undef do_close
#define do_close Perl_do_close
+#undef Perl_do_exec
+#define Perl_do_exec pPerl->Perl_do_exec
+#undef do_exec
+#define do_exec Perl_do_exec
+#if defined(WIN32)
+#undef Perl_do_aspawn
+#define Perl_do_aspawn pPerl->Perl_do_aspawn
+#undef do_aspawn
+#define do_aspawn Perl_do_aspawn
+#undef Perl_do_spawn
+#define Perl_do_spawn pPerl->Perl_do_spawn
+#undef do_spawn
+#define do_spawn Perl_do_spawn
+#undef Perl_do_spawn_nowait
+#define Perl_do_spawn_nowait pPerl->Perl_do_spawn_nowait
+#undef do_spawn_nowait
+#define do_spawn_nowait Perl_do_spawn_nowait
+#endif
#if !defined(WIN32)
#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -2267,6 +2285,10 @@
#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
+#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#if defined(USE_ITHREADS)
+#endif
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#endif
==== //depot/maint-5.6/macperl/op.c#7 (text) ====
Index: macperl/op.c
--- macperl/op.c#6~14904~ Wed Feb 27 13:25:39 2002
+++ macperl/op.c Mon Jul 22 20:24:35 2002
@@ -4132,7 +4132,8 @@
if (SvREFCNT(CvPADLIST(cv))) {
AV *padlist = CvPADLIST(cv);
I32 ix;
- if (is_eval) {
+ /* pads may be cleared out already during global destruction */
+ if (is_eval && !PL_dirty) {
/* inner references to eval's cv must be fixed up */
AV *comppad_name = (AV*)AvARRAY(padlist)[0];
AV *comppad = (AV*)AvARRAY(padlist)[1];
==== //depot/maint-5.6/macperl/perl.c#9 (text) ====
Index: macperl/perl.c
--- macperl/perl.c#8~14396~ Wed Jan 23 12:02:45 2002
+++ macperl/perl.c Mon Jul 22 20:24:35 2002
@@ -440,7 +440,13 @@
/* jettison our possibly duplicated environment */
#ifdef USE_ENVIRON_ARRAY
- if (environ != PL_origenviron) {
+ if (environ != PL_origenviron
+#ifdef USE_ITHREADS
+ /* only main thread can free environ[0] contents */
+ && PL_curinterp == aTHX
+#endif
+ )
+ {
I32 i;
for (i = 0; environ[i]; i++)
@@ -3329,8 +3335,14 @@
*/
if (!env)
env = environ;
- if (env != environ)
+ if (env != environ
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
+ }
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
{
char **env_base;
==== //depot/maint-5.6/macperl/perlapi.c#2 (text+w) ====
Index: macperl/perlapi.c
--- macperl/perlapi.c#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/perlapi.c Mon Jul 22 20:24:35 2002
@@ -632,6 +632,36 @@
{
return ((CPerlObj*)pPerl)->Perl_do_close(gv, not_implicit);
}
+
+#undef Perl_do_exec
+bool
+Perl_do_exec(pTHXo_ char* cmd)
+{
+ return ((CPerlObj*)pPerl)->Perl_do_exec(cmd);
+}
+#if defined(WIN32)
+
+#undef Perl_do_aspawn
+int
+Perl_do_aspawn(pTHXo_ SV* really, SV** mark, SV** sp)
+{
+ return ((CPerlObj*)pPerl)->Perl_do_aspawn(really, mark, sp);
+}
+
+#undef Perl_do_spawn
+int
+Perl_do_spawn(pTHXo_ char* cmd)
+{
+ return ((CPerlObj*)pPerl)->Perl_do_spawn(cmd);
+}
+
+#undef Perl_do_spawn_nowait
+int
+Perl_do_spawn_nowait(pTHXo_ char* cmd)
+{
+ return ((CPerlObj*)pPerl)->Perl_do_spawn_nowait(cmd);
+}
+#endif
#if !defined(WIN32)
#endif
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -4081,6 +4111,10 @@
#else
#endif
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
+#endif
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+#if defined(USE_ITHREADS)
+#endif
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
#endif
==== //depot/maint-5.6/macperl/pp_sys.c#3 (text) ====
Index: macperl/pp_sys.c
--- macperl/pp_sys.c#2~12173~ Mon Sep 24 05:56:13 2001
+++ macperl/pp_sys.c Mon Jul 22 20:24:35 2002
@@ -591,6 +591,7 @@
IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoOFP(rstio) = IoIFP(rstio);
IoIFP(wstio) = IoOFP(wstio);
IoTYPE(rstio) = IoTYPE_RDONLY;
IoTYPE(wstio) = IoTYPE_WRONLY;
@@ -3864,10 +3865,10 @@
result = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *really = *++MARK;
- value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
+ value = (I32)do_aspawn(really, MARK, SP);
}
else if (SP - MARK != 1)
- value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
+ value = (I32)do_aspawn(Nullsv, MARK, SP);
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
}
==== //depot/maint-5.6/macperl/proto.h#3 (text+w) ====
Index: macperl/proto.h
--- macperl/proto.h#2~14395~ Wed Jan 23 12:01:43 2002
+++ macperl/proto.h Mon Jul 22 20:24:35 2002
@@ -224,6 +224,11 @@
PERL_CALLCONV bool Perl_do_close(pTHX_ GV* gv, bool not_implicit);
PERL_CALLCONV bool Perl_do_eof(pTHX_ GV* gv);
PERL_CALLCONV bool Perl_do_exec(pTHX_ char* cmd);
+#if defined(WIN32)
+PERL_CALLCONV int Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp);
+PERL_CALLCONV int Perl_do_spawn(pTHX_ char* cmd);
+PERL_CALLCONV int Perl_do_spawn_nowait(pTHX_ char* cmd);
+#endif
#if !defined(WIN32)
PERL_CALLCONV bool Perl_do_exec3(pTHX_ char* cmd, int fd, int flag);
#endif
@@ -970,6 +975,13 @@
#if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
STATIC I32 S_avhv_index_sv(pTHX_ SV* sv);
STATIC I32 S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash);
+#endif
+
+#if defined(PERL_IN_DOIO_C) || defined(PERL_DECL_PROT)
+STATIC int S_io_sock_close(pTHX_ IO *io);
+#if defined(USE_ITHREADS)
+STATIC void S_invalidate_fileno(pTHX_ PerlIO *f);
+#endif
#endif
#if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.6/macperl/sv.c#4 (text) ====
Index: macperl/sv.c
--- macperl/sv.c#3~12173~ Mon Sep 24 05:56:13 2001
+++ macperl/sv.c Mon Jul 22 20:24:35 2002
@@ -5109,8 +5109,14 @@
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifdef USE_ENVIRON_ARRAY
- if (gv == PL_envgv)
+ if (gv == PL_envgv
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
+ }
#endif
}
}
==== //depot/maint-5.6/macperl/t/harness#4 (xtext) ====
Index: macperl/t/harness
--- macperl/t/harness#3~11500~ Mon Jul 30 05:41:11 2001
+++ macperl/t/harness Mon Jul 22 20:24:35 2002
@@ -38,7 +38,7 @@
}
@tests = @ARGV;
-@tests = <base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t pragma/*.t lib/*.t pod/*.t>
+@tests = <base/*.t comp/*.t cmd/*.t run/*.t io/*.t op/*.t pragma/*.t lib/*.t pod/*.t win32/*.t>
unless @tests;
Test::Harness::runtests @tests;
==== //depot/maint-5.6/macperl/t/op/magic.t#3 (xtext) ====
Index: macperl/t/op/magic.t
--- macperl/t/op/magic.t#2~11813~ Sat Sep 1 15:01:40 2001
+++ macperl/t/op/magic.t Mon Jul 22 20:24:35 2002
@@ -183,7 +183,18 @@
s/\.exe//i if $Is_Dos or $Is_os2;
s{\\}{/}g;
ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`";
- ok 25, unlink($script), $!;
+
+ local $ENV{PATH}= ".";
+ (my $script_name = $script) =~ s/.*(show-shebang)/$1/;
+ $s1 = "\$^X is $perl, \$0 is $script_name\n" if $Is_MSWin32;
+ $_ = `$script_name`;
+ s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2;
+ s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
+ s{is perl}{is $perl}; # for systems where $^X is only a basename
+ s{\\}{/}g;
+ ok 25, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:";
+
+ unlink($script) || die "unlink($script): $!";
}
# $], $^O, $^T
==== //depot/maint-5.6/macperl/t/win32/longpath.t#1 (xtext) ====
Index: macperl/t/win32/longpath.t
--- /dev/null Tue May 5 13:32:27 1998
+++ macperl/t/win32/longpath.t Mon Jul 22 20:24:35 2002
@@ -0,0 +1,52 @@
+#!perl -w
+
+# tests for Win32::GetLongPathName()
+
+$^O =~ /^MSWin/ or print("1..0 # not win32\n" ), exit;
+
+my @paths = qw(
+ /
+ //
+ .
+ ..
+ c:
+ c:/
+ c:./
+ c:/.
+ c:/..
+ c:./..
+ //./
+ //.
+ //..
+ //./..
+);
+push @paths, map { my $x = $_; $x =~ s,/,\\,g; $x } @paths;
+push @paths, qw(
+ ../\
+ c:.\\../\
+ c:/\..//
+ c://.\/./\
+ \\.\\../\
+ //\..//
+ //.\/./\
+);
+
+my $drive = $ENV{SystemDrive};
+if ($drive) {
+ for (@paths) {
+ s/^c:/$drive/;
+ }
+ push @paths, $ENV{SystemRoot} if $ENV{SystemRoot};
+}
+my %expect;
+@expect{@paths} = map { my $x = $_; $x =~ s,(.[/\\])[/\\]+,$1,g; $x } @paths;
+
+print "1.." . @paths . "\n";
+my $i = 1;
+for (@paths) {
+ my $got = Win32::GetLongPathName($_);
+ print "# '$_' => expect '$expect{$_}' => got '$got'\n";
+ print "not " unless $expect{$_} eq $got;
+ print "ok $i\n";
+ ++$i;
+}
==== //depot/maint-5.6/macperl/toke.c#7 (text) ====
Index: macperl/toke.c
--- macperl/toke.c#6~14607~ Fri Feb 8 11:21:04 2002
+++ macperl/toke.c Mon Jul 22 20:24:35 2002
@@ -2657,6 +2657,19 @@
sv_setpvn(x, ipath, ipathend - ipath);
SvSETMAGIC(x);
}
+ else {
+ STRLEN blen;
+ STRLEN llen;
+ char *bstart = SvPV(CopFILESV(PL_curcop),blen);
+ char *lstart = SvPV(x,llen);
+ if (llen < blen) {
+ bstart += blen - llen;
+ if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ }
+ }
TAINT_NOT; /* $^X is always tainted, but that's OK */
}
#endif /* ARG_ZERO_IS_SCRIPT */
==== //depot/maint-5.6/macperl/util.c#9 (text) ====
Index: macperl/util.c
--- macperl/util.c#8~14607~ Fri Feb 8 11:21:04 2002
+++ macperl/util.c Mon Jul 22 20:24:35 2002
@@ -1982,9 +1982,16 @@
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
+#ifdef USE_ITHREADS
+ /* only parent thread can modify process environment */
+ if (PL_curinterp == aTHX)
+#endif
+ {
#ifndef PERL_USE_SAFE_PUTENV
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i=setenv_getix(nam); /* where does it go? */
+ register I32 i;
+
+ i = setenv_getix(nam); /* where does it go? */
if (environ == PL_origenviron) { /* need we copy environment? */
I32 j;
@@ -2030,6 +2037,7 @@
(void)putenv(new_env);
# endif /* __CYGWIN__ */
#endif /* PERL_USE_SAFE_PUTENV */
+ }
}
#else /* WIN32 */
@@ -2339,6 +2347,7 @@
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
PerlLIO_close(p[This]);
+ PerlLIO_close(p[that]);
if (did_pipes) {
PerlLIO_close(pp[0]);
PerlLIO_close(pp[1]);
@@ -2356,7 +2365,6 @@
#undef THAT
#define THIS that
#define THAT This
- PerlLIO_close(p[THAT]);
if (did_pipes) {
PerlLIO_close(pp[0]);
#if defined(HAS_FCNTL) && defined(F_SETFD)
@@ -2366,7 +2374,11 @@
if (p[THIS] != (*mode == 'r')) {
PerlLIO_dup2(p[THIS], *mode == 'r');
PerlLIO_close(p[THIS]);
+ if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
+ PerlLIO_close(p[THAT]);
}
+ else
+ PerlLIO_close(p[THAT]);
#ifndef OS2
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
@@ -2393,7 +2405,6 @@
#undef THAT
}
do_execfree(); /* free any memory malloced by child on vfork */
- PerlLIO_close(p[that]);
if (did_pipes)
PerlLIO_close(pp[1]);
if (p[that] < p[This]) {
@@ -2401,6 +2412,9 @@
PerlLIO_close(p[This]);
p[This] = p[that];
}
+ else
+ PerlLIO_close(p[that]);
+
LOCK_FDPID_MUTEX;
sv = *av_fetch(PL_fdpid,p[This],TRUE);
UNLOCK_FDPID_MUTEX;
@@ -2510,6 +2524,12 @@
{
struct sigaction act, oact;
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return SIG_ERR;
+#endif
+
act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
@@ -2542,6 +2562,12 @@
{
struct sigaction act;
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return -1;
+#endif
+
act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
@@ -2558,6 +2584,12 @@
int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return -1;
+#endif
+
return sigaction(signo, save, (struct sigaction *)NULL);
}
@@ -2566,6 +2598,12 @@
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return SIG_ERR;
+#endif
+
return PerlProc_signal(signo, handler);
}
@@ -2584,6 +2622,12 @@
{
Sighandler_t oldsig;
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return SIG_ERR;
+#endif
+
sig_trapped = 0;
oldsig = PerlProc_signal(signo, sig_trap);
PerlProc_signal(signo, oldsig);
@@ -2595,6 +2639,11 @@
int
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return -1;
+#endif
*save = PerlProc_signal(signo, handler);
return (*save == SIG_ERR) ? -1 : 0;
}
@@ -2602,6 +2651,11 @@
int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
+#ifdef USE_ITHREADS
+ /* only "parent" interpreter can diddle signals */
+ if (PL_curinterp != aTHX)
+ return -1;
+#endif
return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
}
==== //depot/maint-5.6/macperl/utils/h2xs.PL#2 (xtext) ====
Index: macperl/utils/h2xs.PL
--- macperl/utils/h2xs.PL#1~11007~ Thu Jun 28 10:46:27 2001
+++ macperl/utils/h2xs.PL Mon Jul 22 20:24:35 2002
@@ -895,6 +895,7 @@
$tmp
(\$constname = \$AUTOLOAD) =~ s/.*:://;
croak "&$module::constant not defined" if \$constname eq 'constant';
+ local \$! = 0;
my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
if (\$! != 0) {
if (\$! =~ /Invalid/ || \$!{EINVAL}) {
==== //depot/maint-5.6/macperl/win32/perlhost.h#6 (text) ====
Index: macperl/win32/perlhost.h
--- macperl/win32/perlhost.h#5~13612~ Mon Dec 10 20:58:52 2001
+++ macperl/win32/perlhost.h Mon Jul 22 20:24:35 2002
@@ -22,16 +22,10 @@
extern char * g_win32_get_sitelib(const char *pl);
extern char * g_win32_get_vendorlib(const char *pl);
extern char * g_getlogin(void);
-extern int do_spawn2(char *cmd, int exectype);
#if !defined(PERL_OBJECT)
END_EXTERN_C
#endif
-#ifdef PERL_OBJECT
-extern int g_do_aspawn(void *vreally, void **vmark, void **vsp);
-#define do_aspawn g_do_aspawn
-#endif
-
class CPerlHost
{
public:
@@ -1821,30 +1815,34 @@
win32_str_os_error(sv, dwErr);
}
-BOOL
-PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
+int
+PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
{
- do_spawn2(cmd, EXECF_EXEC);
- return FALSE;
+ return win32_spawnvp(mode, cmdname, argv);
}
-int
-PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
+/* XXX these three are only here for binary compatibility */
+BOOL
+PerlProcDoCmd(struct IPerlProc* piPerl, char *cmd)
{
- return do_spawn2(cmds, EXECF_SPAWN);
+ dTHXo;
+ return do_exec(cmd);
}
int
-PerlProcSpawnvp(struct IPerlProc* piPerl, int mode, const char *cmdname, const char *const *argv)
+PerlProcSpawn(struct IPerlProc* piPerl, char* cmds)
{
- return win32_spawnvp(mode, cmdname, argv);
+ dTHXo;
+ return do_spawn(cmds);
}
int
-PerlProcASpawn(struct IPerlProc* piPerl, void *vreally, void **vmark, void **vsp)
+PerlProcASpawn(struct IPerlProc* piPerl, SV *really, SV **mark, SV **sp)
{
- return do_aspawn(vreally, vmark, vsp);
+ dTHXo;
+ return do_aspawn(really, mark, sp);
}
+/* XXX above three are only here for binary compatibility */
struct IPerlProc perlProc =
{
==== //depot/maint-5.6/macperl/win32/win32.c#9 (text) ====
Index: macperl/win32/win32.c
--- macperl/win32/win32.c#8~13612~ Mon Dec 10 20:58:52 2001
+++ macperl/win32/win32.c Mon Jul 22 20:24:35 2002
@@ -85,22 +85,22 @@
# define win32_get_sitelib g_win32_get_sitelib
# undef win32_get_vendorlib
# define win32_get_vendorlib g_win32_get_vendorlib
-# undef do_spawn
-# define do_spawn g_do_spawn
# undef getlogin
# define getlogin g_getlogin
#endif
-#if defined(PERL_OBJECT)
-# undef do_aspawn
-# define do_aspawn g_do_aspawn
-# undef Perl_do_exec
-# define Perl_do_exec g_do_exec
-#endif
+# ifdef PERL_OBJECT
+# undef Perl_do_aspawn
+# define Perl_do_aspawn CPerlObj::Perl_do_aspawn
+# undef Perl_do_spawn
+# define Perl_do_spawn CPerlObj::Perl_do_spawn
+# undef Perl_do_spawn_nowait
+# define Perl_do_spawn_nowait CPerlObj::Perl_do_spawn_nowait
+# endif
static void get_shell(void);
static long tokenize(const char *str, char **dest, char ***destv);
- int do_spawn2(char *cmd, int exectype);
+static int do_spawn2(pTHXo_ char *cmd, int exectype);
static BOOL has_shell_metachars(char *ptr);
static long filetime_to_clock(PFILETIME ft);
static BOOL filetime_from_time(PFILETIME ft, time_t t);
@@ -121,6 +121,18 @@
char w32_module_name[MAX_PATH+1];
END_EXTERN_C
+#define MY_CXT_KEY "CORE::Win32::_guts"
+
+typedef struct {
+ BOOL use_showwindow;
+ unsigned short showwindow;
+} my_cxt_t;
+
+#define w32_use_showwindow (MY_CXT.use_showwindow)
+#define w32_showwindow (MY_CXT.showwindow)
+
+START_MY_CXT
+
static DWORD w32_platform = (DWORD)-1;
#define ONE_K_BUFSIZE 1024
@@ -523,12 +535,8 @@
}
int
-do_aspawn(void *vreally, void **vmark, void **vsp)
+Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp)
{
- dTHXo;
- SV *really = (SV*)vreally;
- SV **mark = (SV**)vmark;
- SV **sp = (SV**)vsp;
char **argv;
char *str;
int status;
@@ -614,10 +622,9 @@
return (char*)s;
}
-int
-do_spawn2(char *cmd, int exectype)
+static int
+do_spawn2(pTHXo_ char *cmd, int exectype)
{
- dTHXo;
char **a;
char *s;
char **argv;
@@ -707,21 +714,21 @@
}
int
-do_spawn(char *cmd)
+Perl_do_spawn(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN);
+ return do_spawn2(aTHXo_ cmd, EXECF_SPAWN);
}
int
-do_spawn_nowait(char *cmd)
+Perl_do_spawn_nowait(pTHX_ char *cmd)
{
- return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+ return do_spawn2(aTHXo_ cmd, EXECF_SPAWN_NOWAIT);
}
bool
Perl_do_exec(pTHX_ char *cmd)
{
- do_spawn2(cmd, EXECF_EXEC);
+ do_spawn2(aTHXo_ cmd, EXECF_EXEC);
return FALSE;
}
@@ -1240,6 +1247,18 @@
return res;
}
+#define isSLASH(c) ((c) == '/' || (c) == '\\')
+#define SKIP_SLASHES(s) \
+ STMT_START { \
+ while (*(s) && isSLASH(*(s))) \
+ ++(s); \
+ } STMT_END
+#define COPY_NONSLASHES(d,s) \
+ STMT_START { \
+ while (*(s) && !isSLASH(*(s))) \
+ *(d)++ = *(s)++; \
+ } STMT_END
+
/* Find the longname of a given path. path is destructively modified.
* It should have space for at least MAX_PATH characters. */
DllExport char *
@@ -1255,61 +1274,74 @@
return Nullch;
/* drive prefix */
- if (isALPHA(path[0]) && path[1] == ':' &&
- (path[2] == '/' || path[2] == '\\'))
- {
+ if (isALPHA(path[0]) && path[1] == ':') {
start = path + 2;
*tmpstart++ = path[0];
*tmpstart++ = ':';
}
/* UNC prefix */
- else if ((path[0] == '/' || path[0] == '\\') &&
- (path[1] == '/' || path[1] == '\\'))
- {
+ else if (isSLASH(path[0]) && isSLASH(path[1])) {
start = path + 2;
*tmpstart++ = path[0];
*tmpstart++ = path[1];
- /* copy machine name */
- while (*start && *start != '/' && *start != '\\')
- *tmpstart++ = *start++;
+ SKIP_SLASHES(start);
+ COPY_NONSLASHES(tmpstart,start); /* copy machine name */
if (*start) {
- *tmpstart++ = *start;
- start++;
- /* copy share name */
- while (*start && *start != '/' && *start != '\\')
- *tmpstart++ = *start++;
+ *tmpstart++ = *start++;
+ SKIP_SLASHES(start);
+ COPY_NONSLASHES(tmpstart,start); /* copy share name */
}
}
- sep = *start++;
- if (sep == '/' || sep == '\\')
- *tmpstart++ = sep;
*tmpstart = '\0';
- while (sep) {
- /* walk up to slash */
- while (*start && *start != '/' && *start != '\\')
- ++start;
+ while (*start) {
+ /* copy initial slash, if any */
+ if (isSLASH(*start)) {
+ *tmpstart++ = *start++;
+ *tmpstart = '\0';
+ SKIP_SLASHES(start);
+ }
+
+ /* FindFirstFile() expands "." and "..", so we need to pass
+ * those through unmolested */
+ if (*start == '.'
+ && (!start[1] || isSLASH(start[1])
+ || (start[1] == '.' && (!start[2] || isSLASH(start[2])))))
+ {
+ COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */
+ *tmpstart = '\0';
+ continue;
+ }
- /* discard doubled slashes */
- while (*start && (start[1] == '/' || start[1] == '\\'))
+ /* if this is the end, bust outta here */
+ if (!*start)
+ break;
+
+ /* now we're at a non-slash; walk up to next slash */
+ while (*start && !isSLASH(*start))
++start;
- sep = *start;
/* stop and find full name of component */
+ sep = *start;
*start = '\0';
fhand = FindFirstFile(path,&fdata);
+ *start = sep;
if (fhand != INVALID_HANDLE_VALUE) {
- strcpy(tmpstart, fdata.cFileName);
- tmpstart += strlen(fdata.cFileName);
- if (sep)
- *tmpstart++ = sep;
- *tmpstart = '\0';
- *start++ = sep;
- FindClose(fhand);
+ STRLEN len = strlen(fdata.cFileName);
+ if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) {
+ strcpy(tmpstart, fdata.cFileName);
+ tmpstart += len;
+ FindClose(fhand);
+ }
+ else {
+ FindClose(fhand);
+ errno = ERANGE;
+ return Nullch;
+ }
}
else {
/* failed a step, just return without side effects */
/*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/
- *start = sep;
+ errno = EINVAL;
return Nullch;
}
}
@@ -2390,17 +2422,22 @@
int stdfd, oldfd;
int ourmode;
int childpid;
+ DWORD nhandle;
+ HANDLE old_h;
+ int lock_held = 0;
/* establish which ends read and write */
if (strchr(mode,'w')) {
stdfd = 0; /* stdin */
parent = 1;
child = 0;
+ nhandle = STD_INPUT_HANDLE;
}
else if (strchr(mode,'r')) {
stdfd = 1; /* stdout */
parent = 0;
child = 1;
+ nhandle = STD_OUTPUT_HANDLE;
}
else
return NULL;
@@ -2416,7 +2453,7 @@
/* the child doesn't inherit handles */
ourmode |= O_NOINHERIT;
- if (win32_pipe( p, 512, ourmode) == -1)
+ if (win32_pipe(p, 512, ourmode) == -1)
return NULL;
/* save current stdfd */
@@ -2431,12 +2468,25 @@
/* close the child end in parent */
win32_close(p[child]);
+ /* save the old std handle, and set the std handle */
+ OP_REFCNT_LOCK;
+ lock_held = 1;
+ old_h = GetStdHandle(nhandle);
+ SetStdHandle(nhandle, (HANDLE)_get_osfhandle(stdfd));
+
/* start the child */
{
dTHXo;
if ((childpid = do_spawn_nowait((char*)command)) == -1)
goto cleanup;
+ /* restore the old std handle */
+ if (lock_held) {
+ SetStdHandle(nhandle, old_h);
+ OP_REFCNT_UNLOCK;
+ lock_held = 0;
+ }
+
/* revert stdfd to whatever it was before */
if (win32_dup2(oldfd, stdfd) == -1)
goto cleanup;
@@ -2459,6 +2509,11 @@
/* we don't need to check for errors here */
win32_close(p[0]);
win32_close(p[1]);
+ if (lock_held) {
+ SetStdHandle(nhandle, old_h);
+ OP_REFCNT_UNLOCK;
+ lock_held = 0;
+ }
if (oldfd != -1) {
win32_dup2(oldfd, stdfd);
win32_close(oldfd);
@@ -3382,6 +3437,7 @@
return spawnvp(mode, cmdname, (char * const *)argv);
#else
dTHXo;
+ dMY_CXT;
int ret;
void* env;
char* dir;
@@ -3448,14 +3504,18 @@
StartupInfo.hStdInput = tbl.childStdIn;
StartupInfo.hStdOutput = tbl.childStdOut;
StartupInfo.hStdError = tbl.childStdErr;
- if (StartupInfo.hStdInput != INVALID_HANDLE_VALUE &&
- StartupInfo.hStdOutput != INVALID_HANDLE_VALUE &&
- StartupInfo.hStdError != INVALID_HANDLE_VALUE)
+ if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE &&
+ StartupInfo.hStdOutput == INVALID_HANDLE_VALUE &&
+ StartupInfo.hStdError == INVALID_HANDLE_VALUE)
{
- StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
+ create |= CREATE_NEW_CONSOLE;
}
else {
- create |= CREATE_NEW_CONSOLE;
+ StartupInfo.dwFlags |= STARTF_USESTDHANDLES;
+ }
+ if (w32_use_showwindow) {
+ StartupInfo.dwFlags |= STARTF_USESHOWWINDOW;
+ StartupInfo.wShowWindow = w32_showwindow;
}
DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
@@ -3806,6 +3866,32 @@
XSRETURN_UNDEF;
}
+ static
+XS(w32_SetChildShowWindow)
+{
+ dXSARGS;
+ dMY_CXT;
+ BOOL use_showwindow = w32_use_showwindow;
+ unsigned short showwindow = w32_showwindow;
+
+ if (items > 1)
+ Perl_croak(aTHX_ "usage: Win32::SetChildShowWindow($showwindow)");
+
+ if (items == 0 || !SvOK(ST(0)))
+ w32_use_showwindow = FALSE;
+ else {
+ w32_use_showwindow = TRUE;
+ w32_showwindow = (unsigned short)SvIV(ST(0));
+ }
+
+ EXTEND(SP, 1);
+ if (use_showwindow)
+ ST(0) = sv_2mortal(newSViv(showwindow));
+ else
+ ST(0) = &PL_sv_undef;
+ XSRETURN(1);
+}
+
static
XS(w32_SetCwd)
{
@@ -4235,6 +4321,8 @@
dTHXo;
char *file = __FILE__;
dXSUB_SYS;
+ /* dXSUB_SYS may be empty, or contain statements */
+ {MY_CXT_INIT;}
/* these names are Activeware compatible */
newXS("Win32::GetCwd", w32_GetCwd, file);
@@ -4257,6 +4345,7 @@
newXS("Win32::GetLongPathName", w32_GetLongPathName, file);
newXS("Win32::CopyFile", w32_CopyFile, file);
newXS("Win32::Sleep", w32_Sleep, file);
+ newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
/* XXX Bloat Alert! The following Activeware preloads really
* ought to be part of Win32::Sys::*, so they're not included
==== //depot/maint-5.6/macperl/win32/win32.h#3 (text) ====
Index: macperl/win32/win32.h
--- macperl/win32/win32.h#2~12173~ Mon Sep 24 05:56:13 2001
+++ macperl/win32/win32.h Mon Jul 22 20:24:35 2002
@@ -341,9 +341,6 @@
#endif
extern int my_fclose(FILE *);
extern int my_fstat(int fd, struct stat *sbufptr);
-extern int do_aspawn(void *really, void **mark, void **sp);
-extern int do_spawn(char *cmd);
-extern int do_spawn_nowait(char *cmd);
extern char * win32_get_privlib(const char *pl);
extern char * win32_get_sitelib(const char *pl);
extern char * win32_get_vendorlib(const char *pl);
@@ -422,7 +419,7 @@
long perlshell_items;
struct av * fdpid;
child_tab * children;
-#ifdef USE_ITHREADS
+#if defined(USE_ITHREADS) || defined(PERL_OBJECT)
DWORD pseudo_id;
child_tab * pseudo_children;
#endif
End of Patch.