t/op/subst_wamp.t See if substitution works with $& present
t/op/sub_lval.t See if lvalue subroutines work
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
overhead of an XSUB; the user should be able to create PP code. Simon
Cozens has some ideas on this.
-=head2 spawnvp() on Win32
-
-Win32 has problems spawning processes, particularly when the arguments
-to the child process contain spaces, quotes or tab characters.
-
=head2 DLL Versioning
Windows needs a way to know what version of a XS or C<libperl> DLL it's
--- /dev/null
+#!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;
--- /dev/null
+#!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;
+ }
+}
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)
{
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';
}
static char *
-create_command_line(const char *cmdname, const char * const *args)
+create_command_line(char *cname, STRLEN clen, const char * const *args)
{
dTHX;
int index, argc;
bool bat_file = FALSE;
bool cmd_shell = FALSE;
bool extra_quotes = FALSE;
- char *cname = (char*)cmdname;
+ bool quote_next = FALSE;
if (!cname)
cname = (char*)args[0];
* 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 (cname) {
- STRLEN clen = strlen(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 if (stricmp(cname, "cmd.exe") == 0
- || stricmp(cname, "cmd") == 0)
- {
- cmd_shell = 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;
+ }
}
}
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++ = '"';
if (!extra_quotes
&& cmd_shell
- && (stricmp(arg, "/x/c") == 0 || stricmp(arg, "/c") == 0)
- && (argc-1 > index+1)) /* two or more arguments to cmd.exe? */
+ && (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;
+ }
+ }
}
}
STARTUPINFO StartupInfo;
PROCESS_INFORMATION ProcessInformation;
DWORD create = 0;
-
- char *cmd = create_command_line(cmdname, argv);
+ 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';
+ }
+ }
+
+ cmd = create_command_line(cname, clen, argv);
env = PerlEnv_get_childenv();
dir = PerlEnv_get_childdir();
}
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 */
* 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;
}
}
PerlEnv_free_childenv(env);
PerlEnv_free_childdir(dir);
Safefree(cmd);
- Safefree(fullcmd);
+ if (cname != cmdname)
+ Safefree(cname);
return ret;
#endif
}
projects / p5sagit/p5-mst-13.2.git / commitdiff