1# -*-perl-*- hey - emacs - this is a perl file
2
3# src/tools/msvc/vcregress.pl
4
5use strict;
6
7our $config;
8
9use Cwd;
10use File::Basename;
11use File::Copy;
12use File::Find ();
13use File::Path qw(rmtree);
14use File::Spec;
15BEGIN  { use lib File::Spec->rel2abs(dirname(__FILE__)); }
16
17use Install qw(Install);
18
19my $startdir = getcwd();
20
21chdir "../../.." if (-d "../../../src/tools/msvc");
22
23my $topdir         = getcwd();
24my $tmp_installdir = "$topdir/tmp_install";
25
26do './src/tools/msvc/config_default.pl';
27do './src/tools/msvc/config.pl' if (-f 'src/tools/msvc/config.pl');
28
29# buildenv.pl is for specifying the build environment settings
30# it should contain lines like:
31# $ENV{PATH} = "c:/path/to/bison/bin;$ENV{PATH}";
32
33if (-e "src/tools/msvc/buildenv.pl")
34{
35	do "./src/tools/msvc/buildenv.pl";
36}
37
38my $what = shift || "";
39if ($what =~
40	/^(check|installcheck|plcheck|contribcheck|modulescheck|ecpgcheck|isolationcheck|upgradecheck|bincheck|recoverycheck|taptest)$/i
41  )
42{
43	$what = uc $what;
44}
45else
46{
47	usage();
48}
49
50# use a capital C here because config.pl has $config
51my $Config = -e "release/postgres/postgres.exe" ? "Release" : "Debug";
52
53copy("$Config/refint/refint.dll",                 "src/test/regress");
54copy("$Config/autoinc/autoinc.dll",               "src/test/regress");
55copy("$Config/regress/regress.dll",               "src/test/regress");
56copy("$Config/dummy_seclabel/dummy_seclabel.dll", "src/test/regress");
57
58$ENV{PATH} = "$topdir/$Config/libpq;$ENV{PATH}";
59
60if ($ENV{PERL5LIB})
61{
62	$ENV{PERL5LIB} = "$topdir/src/tools/msvc;$ENV{PERL5LIB}";
63}
64else
65{
66	$ENV{PERL5LIB} = "$topdir/src/tools/msvc";
67}
68
69my $maxconn = "";
70$maxconn = "--max_connections=$ENV{MAX_CONNECTIONS}"
71  if $ENV{MAX_CONNECTIONS};
72
73my $temp_config = "";
74$temp_config = "--temp-config=\"$ENV{TEMP_CONFIG}\""
75  if $ENV{TEMP_CONFIG};
76
77chdir "src/test/regress";
78
79my %command = (
80	CHECK          => \&check,
81	PLCHECK        => \&plcheck,
82	INSTALLCHECK   => \&installcheck,
83	ECPGCHECK      => \&ecpgcheck,
84	CONTRIBCHECK   => \&contribcheck,
85	MODULESCHECK   => \&modulescheck,
86	ISOLATIONCHECK => \&isolationcheck,
87	BINCHECK       => \&bincheck,
88	RECOVERYCHECK  => \&recoverycheck,
89	UPGRADECHECK   => \&upgradecheck,
90	TAPTEST        => \&taptest,);
91
92my $proc = $command{$what};
93
94exit 3 unless $proc;
95
96&$proc(@ARGV);
97
98exit 0;
99
100########################################################################
101
102sub installcheck_internal
103{
104	my ($schedule, @EXTRA_REGRESS_OPTS) = @_;
105	my @args = (
106		"../../../$Config/pg_regress/pg_regress",
107		"--dlpath=.",
108		"--bindir=../../../$Config/psql",
109		"--schedule=${schedule}_schedule",
110		"--max-concurrent-tests=20",
111		"--encoding=SQL_ASCII",
112		"--no-locale");
113	push(@args, $maxconn) if $maxconn;
114	push(@args, @EXTRA_REGRESS_OPTS);
115	system(@args);
116	my $status = $? >> 8;
117	exit $status if $status;
118	return;
119}
120
121sub installcheck
122{
123	my $schedule = shift || 'serial';
124	installcheck_internal($schedule);
125	return;
126}
127
128sub check
129{
130	my $schedule = shift || 'parallel';
131	InstallTemp();
132	chdir "${topdir}/src/test/regress";
133	my @args = (
134		"../../../$Config/pg_regress/pg_regress",
135		"--dlpath=.",
136		"--bindir=",
137		"--schedule=${schedule}_schedule",
138		"--max-concurrent-tests=20",
139		"--encoding=SQL_ASCII",
140		"--no-locale",
141		"--temp-instance=./tmp_check");
142	push(@args, $maxconn)     if $maxconn;
143	push(@args, $temp_config) if $temp_config;
144	system(@args);
145	my $status = $? >> 8;
146	exit $status if $status;
147	return;
148}
149
150sub ecpgcheck
151{
152	my $msbflags = $ENV{MSBFLAGS} || "";
153	chdir $startdir;
154	system("msbuild ecpg_regression.proj $msbflags /p:config=$Config");
155	my $status = $? >> 8;
156	exit $status if $status;
157	InstallTemp();
158	chdir "$topdir/src/interfaces/ecpg/test";
159	my $schedule = "ecpg";
160	my @args     = (
161		"../../../../$Config/pg_regress_ecpg/pg_regress_ecpg",
162		"--bindir=",
163		"--dbname=ecpg1_regression,ecpg2_regression",
164		"--create-role=regress_ecpg_user1,regress_ecpg_user2",
165		"--schedule=${schedule}_schedule",
166		"--encoding=SQL_ASCII",
167		"--no-locale",
168		"--temp-instance=./tmp_chk");
169	push(@args, $maxconn) if $maxconn;
170	system(@args);
171	$status = $? >> 8;
172	exit $status if $status;
173	return;
174}
175
176sub isolationcheck
177{
178	chdir "../isolation";
179	copy("../../../$Config/isolationtester/isolationtester.exe",
180		"../../../$Config/pg_isolation_regress");
181	my @args = (
182		"../../../$Config/pg_isolation_regress/pg_isolation_regress",
183		"--bindir=../../../$Config/psql",
184		"--inputdir=.",
185		"--schedule=./isolation_schedule");
186	push(@args, $maxconn) if $maxconn;
187	system(@args);
188	my $status = $? >> 8;
189	exit $status if $status;
190	return;
191}
192
193sub tap_check
194{
195	die "Tap tests not enabled in configuration"
196	  unless $config->{tap_tests};
197
198	my @flags;
199	foreach my $arg (0 .. scalar(@_) - 1)
200	{
201		next unless $_[$arg] =~ /^PROVE_FLAGS=(.*)/;
202		@flags = split(/\s+/, $1);
203		splice(@_, $arg, 1);
204		last;
205	}
206
207	my $dir = shift;
208	chdir $dir;
209
210	my @args = ("prove", @flags, glob("t/*.pl"));
211
212	# adjust the environment for just this test
213	local %ENV = %ENV;
214	$ENV{PERL5LIB}   = "$topdir/src/test/perl;$ENV{PERL5LIB}";
215	$ENV{PG_REGRESS} = "$topdir/$Config/pg_regress/pg_regress";
216	$ENV{REGRESS_SHLIB} = "$topdir/src/test/regress/regress.dll";
217
218	$ENV{TESTDIR} = "$dir";
219
220	rmtree('tmp_check');
221	system(@args);
222	my $status = $? >> 8;
223	return $status;
224}
225
226sub bincheck
227{
228	InstallTemp();
229
230	my $mstat = 0;
231
232	# Find out all the existing TAP tests by looking for t/ directories
233	# in the tree.
234	my @bin_dirs = glob("$topdir/src/bin/*");
235
236	# Process each test
237	foreach my $dir (@bin_dirs)
238	{
239		next unless -d "$dir/t";
240		my $status = tap_check($dir);
241		$mstat ||= $status;
242	}
243	exit $mstat if $mstat;
244	return;
245}
246
247sub taptest
248{
249	my $dir = shift;
250	my @args;
251
252	if ($dir =~ /^PROVE_FLAGS=/)
253	{
254		push(@args, $dir);
255		$dir = shift;
256	}
257
258	die "no tests found!" unless -d "$topdir/$dir/t";
259
260	push(@args, "$topdir/$dir");
261
262	InstallTemp();
263	my $status = tap_check(@args);
264	exit $status if $status;
265	return;
266}
267
268sub mangle_plpython3
269{
270	my $tests = shift;
271	mkdir "results" unless -d "results";
272	mkdir "sql/python3";
273	mkdir "results/python3";
274	mkdir "expected/python3";
275
276	foreach my $test (@$tests)
277	{
278		local $/ = undef;
279		foreach my $dir ('sql', 'expected')
280		{
281			my $extension = ($dir eq 'sql' ? 'sql' : 'out');
282
283			my @files =
284			  glob("$dir/$test.$extension $dir/${test}_[0-9].$extension");
285			foreach my $file (@files)
286			{
287				open(my $handle, '<', $file)
288				  || die "test file $file not found";
289				my $contents = <$handle>;
290				close($handle);
291				do
292				{
293					s/except ([[:alpha:]][[:alpha:].]*), *([[:alpha:]][[:alpha:]]*):/except $1 as $2:/g;
294					s/<type 'exceptions\.([[:alpha:]]*)'>/<class '$1'>/g;
295					s/<type 'long'>/<class 'int'>/g;
296					s/([0-9][0-9]*)L/$1/g;
297					s/([ [{])u"/$1"/g;
298					s/([ [{])u'/$1'/g;
299					s/def next/def __next__/g;
300					s/LANGUAGE plpython2?u/LANGUAGE plpython3u/g;
301					s/EXTENSION ([^ ]*_)*plpython2?u/EXTENSION $1plpython3u/g;
302					s/installing required extension "plpython2u"/installing required extension "plpython3u"/g;
303				  }
304				  for ($contents);
305				my $base = basename $file;
306				open($handle, '>', "$dir/python3/$base")
307				  || die "opening python 3 file for $file";
308				print $handle $contents;
309				close($handle);
310			}
311		}
312	}
313	do { s!^!python3/!; }
314	  foreach (@$tests);
315	return @$tests;
316}
317
318sub plcheck
319{
320	chdir "$topdir/src/pl";
321
322	foreach my $dir (glob("*/src *"))
323	{
324		next unless -d "$dir/sql" && -d "$dir/expected";
325		my $lang;
326		if ($dir eq 'plpgsql/src')
327		{
328			$lang = 'plpgsql';
329		}
330		elsif ($dir eq 'tcl')
331		{
332			$lang = 'pltcl';
333		}
334		else
335		{
336			$lang = $dir;
337		}
338		if ($lang eq 'plpython')
339		{
340			next
341			  unless -d "$topdir/$Config/plpython2"
342			  || -d "$topdir/$Config/plpython3";
343			$lang = 'plpythonu';
344		}
345		else
346		{
347			next unless -d "$topdir/$Config/$lang";
348		}
349		my @lang_args = ("--load-extension=$lang");
350		chdir $dir;
351		my @tests = fetchTests();
352		@tests = mangle_plpython3(\@tests)
353		  if $lang eq 'plpythonu' && -d "$topdir/$Config/plpython3";
354		if ($lang eq 'plperl')
355		{
356
357			# run both trusted and untrusted perl tests
358			push(@lang_args, "--load-extension=plperlu");
359
360			# assume we're using this perl to built postgres
361			# test if we can run two interpreters in one backend, and if so
362			# run the trusted/untrusted interaction tests
363			use Config;
364			if ($Config{usemultiplicity} eq 'define')
365			{
366				push(@tests, 'plperl_plperlu');
367			}
368		}
369		elsif ($lang eq 'plpythonu' && -d "$topdir/$Config/plpython3")
370		{
371			@lang_args = ();
372		}
373		print
374		  "============================================================\n";
375		print "Checking $lang\n";
376		my @args = (
377			"$topdir/$Config/pg_regress/pg_regress",
378			"--bindir=$topdir/$Config/psql",
379			"--dbname=pl_regression", @lang_args, @tests);
380		system(@args);
381		my $status = $? >> 8;
382		exit $status if $status;
383		chdir "$topdir/src/pl";
384	}
385
386	chdir "$topdir";
387	return;
388}
389
390sub subdircheck
391{
392	my $module = shift;
393
394	if (   !-d "$module/sql"
395		|| !-d "$module/expected"
396		|| (!-f "$module/GNUmakefile" && !-f "$module/Makefile"))
397	{
398		return;
399	}
400
401	chdir $module;
402	my @tests = fetchTests();
403	my @opts  = fetchRegressOpts();
404
405	# Special processing for python transform modules, see their respective
406	# Makefiles for more details regarding Python-version specific
407	# dependencies.
408	if ($module =~ /_plpython$/)
409	{
410		die "Python not enabled in configuration"
411		  if !defined($config->{python});
412
413		@opts = grep { $_ !~ /plpythonu/ } @opts;
414
415		if (-d "$topdir/$Config/plpython2")
416		{
417			push @opts, "--load-extension=plpythonu";
418			push @opts, '--load-extension=' . $module . 'u';
419		}
420		else
421		{
422			# must be python 3
423			@tests = mangle_plpython3(\@tests);
424		}
425	}
426
427	print "============================================================\n";
428	print "Checking $module\n";
429	my @args = (
430		"$topdir/$Config/pg_regress/pg_regress",
431		"--bindir=${topdir}/${Config}/psql",
432		"--dbname=contrib_regression", @opts, @tests);
433	print join(' ', @args), "\n";
434	system(@args);
435	chdir "..";
436	return;
437}
438
439sub contribcheck
440{
441	chdir "../../../contrib";
442	my $mstat = 0;
443	foreach my $module (glob("*"))
444	{
445		# these configuration-based exclusions must match Install.pm
446		next if ($module eq "uuid-ossp"  && !defined($config->{uuid}));
447		next if ($module eq "sslinfo"    && !defined($config->{openssl}));
448		next if ($module eq "xml2"       && !defined($config->{xml}));
449		next if ($module =~ /_plperl$/   && !defined($config->{perl}));
450		next if ($module =~ /_plpython$/ && !defined($config->{python}));
451		next if ($module eq "sepgsql");
452
453		subdircheck($module);
454		my $status = $? >> 8;
455		$mstat ||= $status;
456	}
457	exit $mstat if $mstat;
458	return;
459}
460
461sub modulescheck
462{
463	chdir "../../../src/test/modules";
464	my $mstat = 0;
465	foreach my $module (glob("*"))
466	{
467		subdircheck($module);
468		my $status = $? >> 8;
469		$mstat ||= $status;
470	}
471	exit $mstat if $mstat;
472	return;
473}
474
475sub recoverycheck
476{
477	InstallTemp();
478
479	my $mstat  = 0;
480	my $dir    = "$topdir/src/test/recovery";
481	my $status = tap_check($dir);
482	exit $status if $status;
483	return;
484}
485
486# Run "initdb", then reconfigure authentication.
487sub standard_initdb
488{
489	return (
490		system('initdb', '-N') == 0 and system(
491			"$topdir/$Config/pg_regress/pg_regress", '--config-auth',
492			$ENV{PGDATA}) == 0);
493}
494
495# This is similar to appendShellString().  Perl system(@args) bypasses
496# cmd.exe, so omit the caret escape layer.
497sub quote_system_arg
498{
499	my $arg = shift;
500
501	# Change N >= 0 backslashes before a double quote to 2N+1 backslashes.
502	$arg =~ s/(\\*)"/${\($1 . $1)}\\"/gs;
503
504	# Change N >= 1 backslashes at end of argument to 2N backslashes.
505	$arg =~ s/(\\+)$/${\($1 . $1)}/gs;
506
507	# Wrap the whole thing in unescaped double quotes.
508	return "\"$arg\"";
509}
510
511# Generate a database with a name made of a range of ASCII characters, useful
512# for testing pg_upgrade.
513sub generate_db
514{
515	my ($prefix, $from_char, $to_char, $suffix) = @_;
516
517	my $dbname = $prefix;
518	for my $i ($from_char .. $to_char)
519	{
520		next if $i == 7 || $i == 10 || $i == 13;    # skip BEL, LF, and CR
521		$dbname = $dbname . sprintf('%c', $i);
522	}
523	$dbname .= $suffix;
524
525	system('createdb', quote_system_arg($dbname));
526	my $status = $? >> 8;
527	exit $status if $status;
528	return;
529}
530
531sub upgradecheck
532{
533	my $status;
534	my $cwd = getcwd();
535
536	# Much of this comes from the pg_upgrade test.sh script,
537	# but it only covers the --install case, and not the case
538	# where the old and new source or bin dirs are different.
539	# i.e. only this version to this version check. That's
540	# what pg_upgrade's "make check" does.
541
542	$ENV{PGHOST} = 'localhost';
543	$ENV{PGPORT} ||= 50432;
544	my $tmp_root = "$topdir/src/bin/pg_upgrade/tmp_check";
545	rmtree($tmp_root);
546	mkdir $tmp_root || die $!;
547	my $upg_tmp_install = "$tmp_root/install";    # unshared temp install
548	print "Setting up temp install\n\n";
549	Install($upg_tmp_install, "all", $config);
550
551	# Install does a chdir, so change back after that
552	chdir $cwd;
553	my ($bindir, $libdir, $oldsrc, $newsrc) =
554	  ("$upg_tmp_install/bin", "$upg_tmp_install/lib", $topdir, $topdir);
555	$ENV{PATH} = "$bindir;$ENV{PATH}";
556	my $data = "$tmp_root/data";
557	$ENV{PGDATA} = "$data.old";
558	my $outputdir          = "$tmp_root/regress";
559	my @EXTRA_REGRESS_OPTS = ("--outputdir=$outputdir");
560	mkdir "$outputdir"                || die $!;
561	mkdir "$outputdir/sql"            || die $!;
562	mkdir "$outputdir/expected"       || die $!;
563	mkdir "$outputdir/testtablespace" || die $!;
564
565	my $logdir = "$topdir/src/bin/pg_upgrade/log";
566	rmtree($logdir);
567	mkdir $logdir || die $!;
568	print "\nRunning initdb on old cluster\n\n";
569	standard_initdb() or exit 1;
570	print "\nStarting old cluster\n\n";
571	my @args = ('pg_ctl', 'start', '-l', "$logdir/postmaster1.log");
572	system(@args) == 0 or exit 1;
573
574	print "\nCreating databases with names covering most ASCII bytes\n\n";
575	generate_db("\\\"\\", 1,  45,  "\\\\\"\\\\\\");
576	generate_db('',       46, 90,  '');
577	generate_db('',       91, 127, '');
578
579	print "\nSetting up data for upgrading\n\n";
580	installcheck_internal('serial', @EXTRA_REGRESS_OPTS);
581
582	# now we can chdir into the source dir
583	chdir "$topdir/src/bin/pg_upgrade";
584	print "\nDumping old cluster\n\n";
585	@args = ('pg_dumpall', '-f', "$tmp_root/dump1.sql");
586	system(@args) == 0 or exit 1;
587	print "\nStopping old cluster\n\n";
588	system("pg_ctl stop") == 0 or exit 1;
589	$ENV{PGDATA} = "$data";
590	print "\nSetting up new cluster\n\n";
591	standard_initdb() or exit 1;
592	print "\nRunning pg_upgrade\n\n";
593	@args = (
594		'pg_upgrade', '-d', "$data.old", '-D', $data, '-b',
595		$bindir,      '-B', $bindir);
596	system(@args) == 0 or exit 1;
597	print "\nStarting new cluster\n\n";
598	@args = ('pg_ctl', '-l', "$logdir/postmaster2.log", 'start');
599	system(@args) == 0 or exit 1;
600	print "\nSetting up stats on new cluster\n\n";
601	system(".\\analyze_new_cluster.bat") == 0 or exit 1;
602	print "\nDumping new cluster\n\n";
603	@args = ('pg_dumpall', '-f', "$tmp_root/dump2.sql");
604	system(@args) == 0 or exit 1;
605	print "\nStopping new cluster\n\n";
606	system("pg_ctl stop") == 0 or exit 1;
607	print "\nDeleting old cluster\n\n";
608	system(".\\delete_old_cluster.bat") == 0 or exit 1;
609	print "\nComparing old and new cluster dumps\n\n";
610
611	@args = ('diff', '-q', "$tmp_root/dump1.sql", "$tmp_root/dump2.sql");
612	system(@args);
613	$status = $?;
614	if (!$status)
615	{
616		print "PASSED\n";
617	}
618	else
619	{
620		print "dumps not identical!\n";
621		exit(1);
622	}
623	return;
624}
625
626sub fetchRegressOpts
627{
628	my $handle;
629	open($handle, '<', "GNUmakefile")
630	  || open($handle, '<', "Makefile")
631	  || die "Could not open Makefile";
632	local ($/) = undef;
633	my $m = <$handle>;
634	close($handle);
635	my @opts;
636
637	$m =~ s{\\\r?\n}{}g;
638	if ($m =~ /^\s*REGRESS_OPTS\s*\+?=(.*)/m)
639	{
640
641		# Substitute known Makefile variables, then ignore options that retain
642		# an unhandled variable reference.  Ignore anything that isn't an
643		# option starting with "--".
644		@opts = grep { !/\$\(/ && /^--/ }
645		  map { (my $x = $_) =~ s/\Q$(top_builddir)\E/\"$topdir\"/; $x; }
646		  split(/\s+/, $1);
647	}
648	if ($m =~ /^\s*ENCODING\s*=\s*(\S+)/m)
649	{
650		push @opts, "--encoding=$1";
651	}
652	if ($m =~ /^\s*NO_LOCALE\s*=\s*\S+/m)
653	{
654		push @opts, "--no-locale";
655	}
656	return @opts;
657}
658
659sub fetchTests
660{
661
662	my $handle;
663	open($handle, '<', "GNUmakefile")
664	  || open($handle, '<', "Makefile")
665	  || die "Could not open Makefile";
666	local ($/) = undef;
667	my $m = <$handle>;
668	close($handle);
669	my $t = "";
670
671	$m =~ s{\\\r?\n}{}g;
672	if ($m =~ /^REGRESS\s*=\s*(.*)$/gm)
673	{
674		$t = $1;
675		$t =~ s/\s+/ /g;
676
677		if ($m =~ /contrib\/pgcrypto/)
678		{
679
680			# pgcrypto is special since the tests depend on the
681			# configuration of the build
682
683			my $cftests =
684			  $config->{openssl}
685			  ? GetTests("OSSL_TESTS", $m)
686			  : GetTests("INT_TESTS",  $m);
687			my $pgptests =
688			  $config->{zlib}
689			  ? GetTests("ZLIB_TST",     $m)
690			  : GetTests("ZLIB_OFF_TST", $m);
691			$t =~ s/\$\(CF_TESTS\)/$cftests/;
692			$t =~ s/\$\(CF_PGP_TESTS\)/$pgptests/;
693		}
694	}
695
696	return split(/\s+/, $t);
697}
698
699sub GetTests
700{
701	my $testname = shift;
702	my $m        = shift;
703	if ($m =~ /^$testname\s*=\s*(.*)$/gm)
704	{
705		return $1;
706	}
707	return "";
708}
709
710sub InstallTemp
711{
712	unless ($ENV{NO_TEMP_INSTALL})
713	{
714		print "Setting up temp install\n\n";
715		Install("$tmp_installdir", "all", $config);
716	}
717	$ENV{PATH} = "$tmp_installdir/bin;$ENV{PATH}";
718	return;
719}
720
721sub usage
722{
723	print STDERR
724	  "Usage: vcregress.pl <mode> [ <arg>]\n\n",
725	  "Options for <mode>:\n",
726	  "  bincheck       run tests of utilities in src/bin/\n",
727	  "  check          deploy instance and run regression tests on it\n",
728	  "  contribcheck   run tests of modules in contrib/\n",
729	  "  ecpgcheck      run regression tests of ECPG\n",
730	  "  installcheck   run regression tests on existing instance\n",
731	  "  isolationcheck run isolation tests\n",
732	  "  modulescheck   run tests of modules in src/test/modules/\n",
733	  "  plcheck        run tests of PL languages\n",
734	  "  recoverycheck  run recovery test suite\n",
735	  "  taptest        run an arbitrary TAP test set\n",
736	  "  upgradecheck   run tests of pg_upgrade\n",
737	  "\nOptions for <arg>: (used by check and installcheck)\n",
738	  "  serial         serial mode\n",
739	  "  parallel       parallel mode\n",
740	  "\nOption for <arg>: for taptest\n",
741	  "  TEST_DIR       (required) directory where tests reside\n";
742	exit(1);
743}
744