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