This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix another Win32 breakage caused by change 23554
[perl5.git] / t / win32 / system.t
CommitLineData
dd7038b3
JH
1#!perl
2
3BEGIN {
4 chdir 't' if -d 't';
f2e3b69f
SH
5 # We need '../../lib' as well as '../lib' because parts of Config are
6 # delay-loaded, after we've chdir()'ed into $testdir.
7 @INC = ('../lib', '../../lib');
dd7038b3
JH
8 # XXX this could be further munged to enable some parts on other
9 # platforms
10 unless ($^O =~ /^MSWin/) {
11 print "1..0 # skipped: windows specific test\n";
12 exit 0;
13 }
14}
15
16use File::Path;
17use File::Copy;
18use Config;
19use Cwd;
20use strict;
21
22$| = 1;
23
24my $cwd = cwd();
25
26my $testdir = "t e s t";
27my $exename = "showav";
28my $plxname = "showargv";
29rmtree($testdir);
30mkdir($testdir);
9e735501 31die "Could not create '$testdir':$!" unless -d $testdir;
dd7038b3
JH
32
33open(my $F, ">$testdir/$exename.c")
34 or die "Can't create $testdir/$exename.c: $!";
35print $F <<'EOT';
36#include <stdio.h>
d22c057c
VK
37#ifdef __BORLANDC__
38#include <windows.h>
39#endif
dd7038b3
JH
40int
41main(int ac, char **av)
42{
43 int i;
d22c057c 44#ifdef __BORLANDC__
42165d27 45 char *s = GetCommandLine();
d22c057c
VK
46 int j=0;
47 av[0] = s;
48 if (s[0]=='"') {
49 for(;s[++j]!='"';)
50 ;
51 av[0]++;
52 }
53 else {
54 for(;s[++j]!=' ';)
55 ;
56 }
57 s[j]=0;
58#endif
dd7038b3
JH
59 for (i = 0; i < ac; i++)
60 printf("[%s]", av[i]);
61 printf("\n");
62 return 0;
63}
64EOT
65
66open($F, ">$testdir/$plxname.bat")
67 or die "Can't create $testdir/$plxname.bat: $!";
68print $F <<'EOT';
69@rem = '--*-Perl-*--
70@echo off
71if "%OS%" == "Windows_NT" goto WinNT
72EOT
73
74print $F <<EOT;
75"$^X" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
76goto endofperl
77:WinNT
78"$^X" -x -S %0 %*
79EOT
80print $F <<'EOT';
81if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
82if %errorlevel% == 9009 echo You do not have Perl in your PATH.
83if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
84goto endofperl
85@rem ';
86#!perl
87#line 15
88print "[$_]" for ($0, @ARGV);
89print "\n";
90__END__
91:endofperl
92EOT
93
94close $F;
95
96# build the executable
97chdir($testdir);
98END {
0ec158f4 99 chdir($cwd) && rmtree("$cwd/$testdir") if -d "$cwd/$testdir";
dd7038b3 100}
946f19ad 101if (open(my $EIN, "$cwd/win32/${exename}_exe.uu")) {
dd7038b3
JH
102 print "# Unpacking $exename.exe\n";
103 my $e;
104 {
105 local $/;
106 $e = unpack "u", <$EIN>;
107 close $EIN;
108 }
109 open my $EOUT, ">$exename.exe" or die "Can't write $exename.exe: $!";
110 binmode $EOUT;
111 print $EOUT $e;
112 close $EOUT;
113}
114else {
9e735501
NIS
115 my $minus_o = '';
116 if ($Config{cc} eq 'gcc')
117 {
118 $minus_o = "-o $exename.exe";
119 }
120 print "# Compiling $exename.c\n# $Config{cc} $Config{ccflags} $exename.c\n";
121 if (system("$Config{cc} $Config{ccflags} $minus_o $exename.c >log 2>&1") != 0) {
dd7038b3
JH
122 print "# Could not compile $exename.c, status $?\n"
123 ."# Where is your C compiler?\n"
124 ."1..0 # skipped: can't build test executable\n";
9e735501
NIS
125 exit(0);
126 }
127 unless (-f "$exename.exe") {
128 if (open(LOG,'<log'))
129 {
130 while(<LOG>) {
131 print "# ",$_;
132 }
133 }
134 else {
135 warn "Cannot open log (in $testdir):$!";
136 }
dd7038b3
JH
137 }
138}
139copy("$plxname.bat","$plxname.cmd");
140chdir($cwd);
9e735501
NIS
141unless (-x "$testdir/$exename.exe") {
142 print "# Could not build $exename.exe\n"
143 ."1..0 # skipped: can't build test executable\n";
144 exit(0);
145}
dd7038b3 146
946f19ad
NK
147open my $T, "$^X -I../lib -w win32/system_tests |"
148 or die "Can't spawn win32/system_tests: $!";
dd7038b3
JH
149my $expect;
150my $comment = "";
151my $test = 0;
152while (<$T>) {
153 chomp;
154 if (/^1\.\./) {
155 print "$_\n";
156 }
157 elsif (/^#+\s(.*)$/) {
158 $comment = $1;
159 }
160 elsif (/^</) {
161 $expect = $_;
162 $expect =~ tr/<>/[]/;
163 $expect =~ s/\Q$plxname\E]/$plxname.bat]/;
164 }
165 else {
166 if ($expect ne $_) {
167 print "# $comment\n" if $comment;
168 print "# want: $expect\n";
169 print "# got : $_\n";
170 print "not ";
171 }
172 ++$test;
173 print "ok $test\n";
174 }
175}
176close $T;