PERFORCE change 12819 for review
[email protected] (Chris Nandor) Fri, 2 Nov 2001 17:59:36 -0500
| Newsgroups | perl.perl5.changes.mac |
|---|---|
| Message-ID | <p05100307b808d48e296f@[10.0.1.177]> |
Change 12819 by pudge@pudge-mobile on 2001/11/02 21:21:56
Integrate with maintperl.
Affected files ...
.... //depot/maint-5.6/macperl/MANIFEST#3 integrate
.... //depot/maint-5.6/macperl/Todo-5.6#2 integrate
.... //depot/maint-5.6/macperl/ext/ODBM_File/ODBM_File.xs#3 integrate
.... //depot/maint-5.6/macperl/perl.h#6 integrate
.... //depot/maint-5.6/macperl/pod/perltodo.pod#2 integrate
.... //depot/maint-5.6/macperl/t/op/system.t#1 branch
.... //depot/maint-5.6/macperl/t/op/system_tests#1 branch
.... //depot/maint-5.6/macperl/util.c#5 integrate
.... //depot/maint-5.6/macperl/win32/win32.c#6 integrate
Differences ...
==== //depot/maint-5.6/macperl/MANIFEST#3 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Fri Nov 2 14:30:06 2001
+++ perl/MANIFEST Fri Nov 2 14:30:06 2001
@@ -1502,6 +1502,8 @@
t/op/subst_wamp.t See if substitution works with $& present
t/op/substr.t See if substr works
t/op/sysio.t See if sysread and syswrite work
+t/op/system.t See if system works
+t/op/system_tests Test runner for system.t
t/op/taint.t See if tainting works
t/op/tie.t See if tie/untie functions work
t/op/tiearray.t See if tie for arrays works
==== //depot/maint-5.6/macperl/Todo-5.6#2 (text) ====
Index: perl/Todo-5.6
--- perl/Todo-5.6.~1~ Fri Nov 2 14:30:06 2001
+++ perl/Todo-5.6 Fri Nov 2 14:30:06 2001
@@ -139,7 +139,6 @@
make Thread::Signal work under useithreads
Win32 stuff
- sort out the spawnvp() mess for system('a','b','c') compatibility
work out DLL versioning
Miscellaneous
==== //depot/maint-5.6/macperl/ext/ODBM_File/ODBM_File.xs#3 (text) ====
Index: perl/ext/ODBM_File/ODBM_File.xs
--- perl/ext/ODBM_File/ODBM_File.xs.~1~ Fri Nov 2 14:30:06 2001
+++ perl/ext/ODBM_File/ODBM_File.xs Fri Nov 2 14:30:06 2001
@@ -130,8 +130,9 @@
void
DESTROY(db)
ODBM_File db
+ PREINIT:
+ dMY_CXT;
CODE:
- dMY_CXT;
dbmrefcnt--;
dbmclose();
safefree(db);
==== //depot/maint-5.6/macperl/perl.h#6 (text) ====
Index: perl/perl.h
--- perl/perl.h.~1~ Fri Nov 2 14:30:06 2001
+++ perl/perl.h Fri Nov 2 14:30:06 2001
@@ -3414,7 +3414,7 @@
* interpreter-local data. */
#define dMY_CXT \
dMY_CXT_SV; \
- my_cxt_t *my_cxtp = (my_cxt_t*)SvUV(my_cxt_sv)
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
/* Creates and zeroes the per-interpreter data.
* (We allocate my_cxtp in a Perl SV so that it will be released when
@@ -3424,7 +3424,7 @@
/* newSV() allocates one more than needed */ \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Zero(my_cxtp, 1, my_cxt_t); \
- sv_setuv(my_cxt_sv, (UV)my_cxtp)
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
==== //depot/maint-5.6/macperl/pod/perltodo.pod#2 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod.~1~ Fri Nov 2 14:30:06 2001
+++ perl/pod/perltodo.pod Fri Nov 2 14:30:06 2001
@@ -575,8 +575,6 @@
=head2 Rename new headers to be consistent with the rest
-=head2 Sort out the spawnvp() mess
-
=head2 Work out DLL versioning
=head2 Style-check
==== //depot/maint-5.6/macperl/util.c#5 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Fri Nov 2 14:30:06 2001
+++ perl/util.c Fri Nov 2 14:30:06 2001
@@ -1707,6 +1707,9 @@
PL_restartop = die_where(message, msglen);
JMPENV_JUMP(3);
}
+ else if (!message)
+ message = SvPVx(ERRSV, msglen);
+
{
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
==== //depot/maint-5.6/macperl/win32/win32.c#6 (text) ====
Index: perl/win32/win32.c
--- perl/win32/win32.c.~1~ Fri Nov 2 14:30:06 2001
+++ perl/win32/win32.c Fri Nov 2 14:30:06 2001
@@ -590,6 +590,30 @@
return (status);
}
+/* returns pointer to the next unquoted space or the end of the string */
+static char*
+find_next_space(const char *s)
+{
+ bool in_quotes = FALSE;
+ while (*s) {
+ /* ignore doubled backslashes, or backslash+quote */
+ if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
+ s += 2;
+ }
+ /* keep track of when we're within quotes */
+ else if (*s == '"') {
+ s++;
+ in_quotes = !in_quotes;
+ }
+ /* break it up only at spaces that aren't in quotes */
+ else if (!in_quotes && isSPACE(*s))
+ return (char*)s;
+ else
+ s++;
+ }
+ return (char*)s;
+}
+
int
do_spawn2(char *cmd, int exectype)
{
@@ -609,27 +633,11 @@
strcpy(cmd2, cmd);
a = argv;
for (s = cmd2; *s;) {
- bool in_quotes = FALSE;
while (*s && isSPACE(*s))
s++;
if (*s)
*(a++) = s;
- while (*s) {
- /* ignore doubled backslashes, or backslash+quote */
- if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) {
- s += 2;
- }
- /* keep track of when we're within quotes */
- else if (*s == '"') {
- s++;
- in_quotes = !in_quotes;
- }
- /* break it up only at spaces that aren't in quotes */
- else if (!in_quotes && isSPACE(*s))
- break;
- else
- s++;
- }
+ s = find_next_space(s);
if (*s)
*s++ = '\0';
}
@@ -3051,16 +3059,21 @@
static char *
-create_command_line(const char * const *args)
+create_command_line(char *cname, STRLEN clen, const char * const *args)
{
dTHXo;
int index, argc;
char *cmd, *ptr;
const char *arg;
STRLEN len = 0;
+ bool bat_file = FALSE;
bool cmd_shell = FALSE;
bool extra_quotes = FALSE;
+ bool quote_next = FALSE;
+ if (!cname)
+ cname = (char*)args[0];
+
/* The NT cmd.exe shell has the following peculiarity that needs to be
* worked around. It strips a leading and trailing dquote when any
* of the following is true:
@@ -3073,13 +3086,34 @@
* to the string, if the first argument is either "cmd.exe" or "cmd",
* and there were at least two or more arguments passed to cmd.exe
* (not including switches).
+ * XXX the above rules (from "cmd /?") don't seem to be applied
+ * always, making for the convolutions below :-(
*/
- if (args[0]
- && (stricmp(args[0], "cmd.exe") == 0
- || stricmp(args[0], "cmd") == 0))
- {
- cmd_shell = TRUE;
- len += 3;
+ if (cname) {
+ if (!clen)
+ clen = strlen(cname);
+
+ if (clen > 4
+ && (stricmp(&cname[clen-4], ".bat") == 0
+ || (IsWinNT() && stricmp(&cname[clen-4], ".cmd") == 0)))
+ {
+ bat_file = TRUE;
+ len += 3;
+ }
+ else {
+ char *exe = strrchr(cname, '/');
+ char *exe2 = strrchr(cname, '\\');
+ if (exe2 > exe)
+ exe = exe2;
+ if (exe)
+ ++exe;
+ else
+ exe = cname;
+ if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) {
+ cmd_shell = TRUE;
+ len += 3;
+ }
+ }
}
DEBUG_p(PerlIO_printf(Perl_debug_log, "Args "));
@@ -3096,13 +3130,21 @@
New(1310, cmd, len, char);
ptr = cmd;
+ if (bat_file) {
+ *ptr++ = '"';
+ extra_quotes = TRUE;
+ }
+
for (index = 0; (arg = (char*)args[index]) != NULL; ++index) {
bool do_quote = 0;
STRLEN curlen = strlen(arg);
- /* we want to protect arguments with spaces with dquotes,
- * but only if they aren't already there */
- if (!(arg[0] == '"' && arg[curlen-1] == '"')) {
+ /* we want to protect empty arguments and ones with spaces with
+ * dquotes, but only if they aren't already there */
+ if (!curlen) {
+ do_quote = 1;
+ }
+ else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
STRLEN i = 0;
while (i < curlen) {
if (isSPACE(arg[i])) {
@@ -3112,6 +3154,13 @@
i++;
}
}
+ else if (quote_next) {
+ /* ok, we know the argument already has quotes; see if it
+ * really is multiple arguments pretending to be one and
+ * force a set of quotes around it */
+ if (*find_next_space(arg))
+ do_quote = 1;
+ }
if (do_quote)
*ptr++ = '"';
@@ -3125,12 +3174,22 @@
if (args[index+1])
*ptr++ = ' ';
- if (cmd_shell && !extra_quotes
- && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0)
- && (argc-1 > index+1)) /* two or more arguments to cmd.exe? */
+ if (!extra_quotes
+ && cmd_shell
+ && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0))
{
- *ptr++ = '"';
- extra_quotes = TRUE;
+ /* is there a next argument? */
+ if (args[index+1]) {
+ /* are there two or more next arguments? */
+ if (args[index+2]) {
+ *ptr++ = '"';
+ extra_quotes = TRUE;
+ }
+ else {
+ /* single argument, force quoting if unquoted */
+ quote_next = TRUE;
+ }
+ }
}
}
@@ -3320,9 +3379,30 @@
STARTUPINFO StartupInfo;
PROCESS_INFORMATION ProcessInformation;
DWORD create = 0;
+ char *cmd;
+ char *fullcmd = Nullch;
+ char *cname = (char *)cmdname;
+ STRLEN clen = 0;
+
+ if (cname) {
+ clen = strlen(cname);
+ /* if command name contains dquotes, must remove them */
+ if (strchr(cname, '"')) {
+ cmd = cname;
+ New(0,cname,clen+1,char);
+ clen = 0;
+ while (*cmd) {
+ if (*cmd != '"') {
+ cname[clen] = *cmd;
+ ++clen;
+ }
+ ++cmd;
+ }
+ cname[clen] = '\0';
+ }
+ }
- char *cmd = create_command_line(argv);
- char *fullcmd = Nullch;
+ cmd = create_command_line(cname, clen, argv);
env = PerlEnv_get_childenv();
dir = PerlEnv_get_childdir();
@@ -3369,9 +3449,9 @@
}
DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n",
- cmdname,cmd));
+ cname,cmd));
RETRY:
- if (!CreateProcess(cmdname, /* search PATH to find executable */
+ if (!CreateProcess(cname, /* search PATH to find executable */
cmd, /* executable, and its arguments */
NULL, /* process attributes */
NULL, /* thread attributes */
@@ -3389,12 +3469,14 @@
* jump through our own hoops by picking out the path
* we really want it to use. */
if (!fullcmd) {
- fullcmd = qualified_path(cmdname);
+ fullcmd = qualified_path(cname);
if (fullcmd) {
- cmdname = fullcmd;
+ if (cname != cmdname)
+ Safefree(cname);
+ cname = fullcmd;
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Retrying [%s] with same args\n",
- cmdname));
+ cname));
goto RETRY;
}
}
@@ -3427,7 +3509,8 @@
PerlEnv_free_childenv(env);
PerlEnv_free_childdir(dir);
Safefree(cmd);
- Safefree(fullcmd);
+ if (cname != cmdname)
+ Safefree(cname);
return ret;
#endif
}
==== //depot/maint-5.6/macperl/t/op/system.t#1 (text) ====
Index: perl/t/op/system.t
--- perl/t/op/system.t.~1~ Fri Nov 2 14:30:06 2001
+++ perl/t/op/system.t Fri Nov 2 14:30:06 2001
@@ -0,0 +1,134 @@
+#!perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ # XXX this could be further munged to enable some parts on other
+ # platforms
+ unless ($^O =~ /^MSWin/) {
+ print "1..0 # skipped: windows specific test\n";
+ exit 0;
+ }
+}
+
+use File::Path;
+use File::Copy;
+use Config;
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwd = cwd();
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+rmtree($testdir);
+mkdir($testdir);
+
+open(my $F, ">$testdir/$exename.c")
+ or die "Can't create $testdir/$exename.c: $!";
+print $F <<'EOT';
+#include <stdio.h>
+int
+main(int ac, char **av)
+{
+ int i;
+ for (i = 0; i < ac; i++)
+ printf("[%s]", av[i]);
+ printf("\n");
+ return 0;
+}
+EOT
+
+open($F, ">$testdir/$plxname.bat")
+ or die "Can't create $testdir/$plxname.bat: $!";
+print $F <<'EOT';
+@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+EOT
+
+print $F <<EOT;
+"$^X" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+"$^X" -x -S %0 %*
+EOT
+print $F <<'EOT';
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+print "[$_]" for ($0, @ARGV);
+print "\n";
+__END__
+:endofperl
+EOT
+
+close $F;
+
+# build the executable
+chdir($testdir);
+END {
+ chdir($cwd);
+ rmtree($testdir);
+}
+if (open(my $EIN, "$cwd/op/${exename}_exe.uu")) {
+ print "# Unpacking $exename.exe\n";
+ my $e;
+ {
+ local $/;
+ $e = unpack "u", <$EIN>;
+ close $EIN;
+ }
+ open my $EOUT, ">$exename.exe" or die "Can't write $exename.exe: $!";
+ binmode $EOUT;
+ print $EOUT $e;
+ close $EOUT;
+}
+else {
+ print "# Compiling $exename.c\n";
+ if (system("$Config{cc} $Config{ccflags} $exename.c 2>&1 >nul") != 0) {
+ print "# Could not compile $exename.c, status $?\n"
+ ."# Where is your C compiler?\n"
+ ."1..0 # skipped: can't build test executable\n";
+ }
+}
+copy("$plxname.bat","$plxname.cmd");
+chdir($cwd);
+
+open my $T, "$^X -I../lib -w op/system_tests |"
+ or die "Can't spawn op/system_tests: $!";
+my $expect;
+my $comment = "";
+my $test = 0;
+while (<$T>) {
+ chomp;
+ if (/^1\.\./) {
+ print "$_\n";
+ }
+ elsif (/^#+\s(.*)$/) {
+ $comment = $1;
+ }
+ elsif (/^</) {
+ $expect = $_;
+ $expect =~ tr/<>/[]/;
+ $expect =~ s/\Q$plxname\E]/$plxname.bat]/;
+ }
+ else {
+ if ($expect ne $_) {
+ print "# $comment\n" if $comment;
+ print "# want: $expect\n";
+ print "# got : $_\n";
+ print "not ";
+ }
+ ++$test;
+ print "ok $test\n";
+ }
+}
+close $T;
==== //depot/maint-5.6/macperl/t/op/system_tests#1 (text) ====
Index: perl/t/op/system_tests
--- perl/t/op/system_tests.~1~ Fri Nov 2 14:30:06 2001
+++ perl/t/op/system_tests Fri Nov 2 14:30:06 2001
@@ -0,0 +1,110 @@
+#!perl
+
+use Cwd;
+use strict;
+
+$| = 1;
+
+my $cwdb = my $cwd = cwd();
+$cwd =~ s,\\,/,g;
+$cwdb =~ s,/,\\,g;
+
+my $testdir = "t e s t";
+my $exename = "showav";
+my $plxname = "showargv";
+
+my $exe = "$testdir/$exename";
+my $exex = $exe . ".exe";
+(my $exeb = $exe) =~ s,/,\\,g;
+my $exebx = $exeb . ".exe";
+
+my $bat = "$testdir/$plxname";
+my $batx = $bat . ".bat";
+(my $batb = $bat) =~ s,/,\\,g;
+my $batbx = $batb . ".bat";
+
+my $cmdx = $bat . ".cmd";
+my $cmdb = $batb;
+my $cmdbx = $cmdb . ".cmd";
+
+my @commands = (
+ $exe,
+ $exex,
+ $exeb,
+ $exebx,
+ "./$exe",
+ "./$exex",
+ ".\\$exeb",
+ ".\\$exebx",
+ "$cwd/$exe",
+ "$cwd/$exex",
+ "$cwdb\\$exeb",
+ "$cwdb\\$exebx",
+ $bat,
+ $batx,
+ $batb,
+ $batbx,
+ "./$bat",
+ "./$batx",
+ ".\\$batb",
+ ".\\$batbx",
+ "$cwd/$bat",
+ "$cwd/$batx",
+ "$cwdb\\$batb",
+ "$cwdb\\$batbx",
+ $cmdx,
+ $cmdbx,
+ "./$cmdx",
+ ".\\$cmdbx",
+ "$cwd/$cmdx",
+ "$cwdb\\$cmdbx",
+ [$^X, $batx],
+ [$^X, $batbx],
+ [$^X, "./$batx"],
+ [$^X, ".\\$batbx"],
+ [$^X, "$cwd/$batx"],
+ [$^X, "$cwdb\\$batbx"],
+);
+
+my @av = (
+ undef,
+ "",
+ " ",
+ "abc",
+ "a b\tc",
+ "\tabc",
+ "abc\t",
+ " abc\t",
+ "\ta b c ",
+ ["\ta b c ", ""],
+ ["\ta b c ", " "],
+ ["", "\ta b c ", "abc"],
+ [" ", "\ta b c ", "abc"],
+);
+
+print "1.." . (@commands * @av * 2) . "\n";
+for my $cmds (@commands) {
+ for my $args (@av) {
+ my @all_args;
+ my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : ();
+ my @args = defined($args) ? (ref($args) ? @$args : $args) : ();
+ print "######## [@cmds]\n";
+ print "<", join('><', $cmds[$#cmds], @args), ">\n";
+ if (system(@cmds,@args) != 0) {
+ print "Failed, status($?)\n";
+# print "Running again in debug mode\n";
+# $^D = 1; # -Dp
+# system(@cmds,@args);
+ }
+ $^D = 0;
+ my $cmdstr = join " ", map { /\s|^$/ ? qq["$_"] : $_ } @cmds, @args;
+ print "######## '$cmdstr'\n";
+ if (system($cmdstr) != 0) {
+ print "Failed, status($?)\n";
+# print "Running again in debug mode\n";
+# $^D = 1; # -Dp
+# system($cmdstr);
+ }
+ $^D = 0;
+ }
+}
End of Patch.