X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=lib%2FPublicInbox%2FTestCommon.pm;h=386610ff5cbf6551eb5eda949ee3d8d1536f1776;hb=95bdac7f09c69036efed537a4d03d5bdd2ae4eb6;hp=45306a5a7f56722891fea6be5e91fec82b8a902c;hpb=3c313f9034aac96182e2efdc2f92c40803626f32;p=public-inbox.git

diff --git a/lib/PublicInbox/TestCommon.pm b/lib/PublicInbox/TestCommon.pm
index 45306a5a..386610ff 100644
--- a/lib/PublicInbox/TestCommon.pm
+++ b/lib/PublicInbox/TestCommon.pm
@@ -1,4 +1,4 @@
-# Copyright (C) 2015-2019 all contributors <meta@public-inbox.org>
+# Copyright (C) 2015-2020 all contributors <meta@public-inbox.org>
 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
 
 # internal APIs used only for tests
@@ -8,7 +8,7 @@ use parent qw(Exporter);
 use Fcntl qw(FD_CLOEXEC F_SETFD F_GETFD :seek);
 use POSIX qw(dup2);
 use IO::Socket::INET;
-our @EXPORT = qw(tmpdir tcp_server tcp_connect require_git
+our @EXPORT = qw(tmpdir tcp_server tcp_connect require_git require_mods
 	run_script start_script key2sub);
 
 sub tmpdir (;$) {
@@ -53,26 +53,68 @@ sub require_git ($;$) {
 	my $cur_int = ($cur_maj << 24) | ($cur_min << 16);
 	if ($cur_int < $req_int) {
 		return 0 if $maybe;
-		plan(skip_all => "git $req+ required, have $cur_maj.$cur_min");
+		Test::More::plan(skip_all =>
+				"git $req+ required, have $cur_maj.$cur_min");
 	}
 	1;
 }
 
+sub require_mods {
+	my @mods = @_;
+	my $maybe = pop @mods if $mods[-1] =~ /\A[0-9]+\z/;
+	my @need;
+	for my $mod (@mods) {
+		if ($mod eq 'Search::Xapian') {
+			if (eval { require PublicInbox::Search } &&
+				PublicInbox::Search::load_xapian()) {
+				next;
+			}
+		} elsif ($mod eq 'Search::Xapian::WritableDatabase') {
+			if (eval { require PublicInbox::SearchIdx } &&
+				PublicInbox::SearchIdx::load_xapian_writable()){
+					next;
+			}
+		} else {
+			eval "require $mod";
+		}
+		push @need, $mod if $@;
+	}
+	return unless @need;
+	my $m = join(', ', @need)." missing for $0";
+	Test::More::skip($m, $maybe) if $maybe;
+	Test::More::plan(skip_all => $m)
+}
+
 sub key2script ($) {
 	my ($key) = @_;
-	return $key if $key =~ m!\A/!;
+	return $key if (index($key, '/') >= 0);
 	# n.b. we may have scripts which don't start with "public-inbox" in
 	# the future:
 	$key =~ s/\A([-\.])/public-inbox$1/;
 	'blib/script/'.$key;
 }
 
+my @io_mode = ([ *STDIN{IO}, '<&' ], [ *STDOUT{IO}, '>&' ],
+		[ *STDERR{IO}, '>&' ]);
+
 sub _prepare_redirects ($) {
 	my ($fhref) = @_;
-	my @x = ([ \*STDIN, '<&' ], [ \*STDOUT, '>&' ], [ \*STDERR, '>&' ]);
-	for (my $fd = 0; $fd <= $#x; $fd++) {
+	my $orig_io = [];
+	for (my $fd = 0; $fd <= $#io_mode; $fd++) {
 		my $fh = $fhref->[$fd] or next;
-		my ($oldfh, $mode) = @{$x[$fd]};
+		my ($oldfh, $mode) = @{$io_mode[$fd]};
+		open my $orig, $mode, $oldfh or die "$$oldfh $mode stash: $!";
+		$orig_io->[$fd] = $orig;
+		open $oldfh, $mode, $fh or die "$$oldfh $mode redirect: $!";
+	}
+	$orig_io;
+}
+
+sub _undo_redirects ($) {
+	my ($orig_io) = @_;
+	for (my $fd = 0; $fd <= $#io_mode; $fd++) {
+		my $fh = $orig_io->[$fd] or next;
+		my ($oldfh, $mode) = @{$io_mode[$fd]};
 		open $oldfh, $mode, $fh or die "$$oldfh $mode redirect: $!";
 	}
 }
@@ -101,9 +143,11 @@ sub key2sub ($) {
 		my $f = key2script($key);
 		open my $fh, '<', $f or die "open $f: $!";
 		my $str = do { local $/; <$fh> };
-		my ($fc, $rest) = ($key =~ m/([a-z])([a-z0-9]+)\z/);
-		$fc = uc($fc);
-		my $pkg = "PublicInbox::TestScript::$fc$rest";
+		my $pkg = (split(m!/!, $f))[-1];
+		$pkg =~ s/([a-z])([a-z0-9]+)(\.t)?\z/\U$1\E$2/;
+		$pkg .= "_T" if $3;
+		$pkg =~ tr/-.//d;
+		$pkg = "PublicInbox::TestScript::$pkg";
 		eval <<EOF;
 package $pkg;
 use strict;
@@ -111,6 +155,8 @@ use subs qw(exit);
 
 *exit = *PublicInbox::TestCommon::run_script_exit;
 sub main {
+# the below "line" directive is a magic comment, see perlsyn(1) manpage
+# line 1 "$f"
 $str
 	0;
 }
@@ -149,35 +195,40 @@ sub run_script ($;$$) {
 	my $spawn_opt = {};
 	for my $fd (0..2) {
 		my $redir = $opt->{$fd};
-		next unless ref($redir);
-		open my $fh, '+>', undef or die "open: $!";
-		$fhref->[$fd] = $fh;
-		$spawn_opt->{$fd} = fileno($fh);
-		next if $fd > 0;
-		$fh->autoflush(1);
-		print $fh $$redir or die "print: $!";
-		seek($fh, 0, SEEK_SET) or die "seek: $!";
+		my $ref = ref($redir);
+		if ($ref eq 'SCALAR') {
+			open my $fh, '+>', undef or die "open: $!";
+			$fhref->[$fd] = $fh;
+			$spawn_opt->{$fd} = $fh;
+			next if $fd > 0;
+			$fh->autoflush(1);
+			print $fh $$redir or die "print: $!";
+			seek($fh, 0, SEEK_SET) or die "seek: $!";
+		} elsif ($ref eq 'GLOB') {
+			$spawn_opt->{$fd} = $fhref->[$fd] = $redir;
+		} elsif ($ref) {
+			die "unable to deal with $ref $redir";
+		}
 	}
 	if ($run_mode == 0) {
 		# spawn an independent new process, like real-world use cases:
 		require PublicInbox::Spawn;
 		my $cmd = [ key2script($key), @argv ];
 		my $pid = PublicInbox::Spawn::spawn($cmd, $env, $spawn_opt);
-		defined($pid) or die "spawn: $!";
 		if (defined $pid) {
 			my $r = waitpid($pid, 0);
 			defined($r) or die "waitpid: $!";
 			$r == $pid or die "waitpid: expected $pid, got $r";
 		}
 	} else { # localize and run everything in the same process:
-		local *STDIN = *STDIN;
-		local *STDOUT = *STDOUT;
-		local *STDERR = *STDERR;
+		# note: "local *STDIN = *STDIN;" and so forth did not work in
+		# old versions of perl
 		local %ENV = $env ? (%ENV, %$env) : %ENV;
 		local %SIG = %SIG;
 		local $0 = join(' ', @$cmd);
-		_prepare_redirects($fhref);
+		my $orig_io = _prepare_redirects($fhref);
 		_run_sub($sub, $key, \@argv);
+		_undo_redirects($orig_io);
 	}
 
 	# slurp the redirects back into user-supplied strings