[RFC PATCH v7 6/9] gitweb/lib - Simple output capture by redirecting STDOUT to file

[Jakub Narebski <jnareb@gmail.com>]

Add GitwebCache::Capture::ToFile package, which captures output by
redirecting STDOUT to given file (specified by filename, or given opened
filehandle), earlier saving original STDOUT to restore it when finished
capturing.

GitwebCache::Capture::ToFile preserves PerlIO layers, both those set
before started capturing output, and those set during capture.

No care was taken to handle the following special cases (prior to
starting capture): closed STDOUT, STDOUT reopened to scalar reference,
tied STDOUT.  You shouldn't modify STDOUT during capture.

Includes separate tests for capturing output in
t9510/test_capture_interface.pl which is run as external test from
t9510-gitweb-capture-interface.sh.  It tests capturing of utf8 data
printed in :utf8 mode, and of binary data (containing invalid utf8) in
:raw mode.


This patch was based on "gitweb: add output buffering and associated
functions" patch by John 'Warthog9' Hawley (J.H.) in "Gitweb caching v7"
series, and on code of Capture::Tiny by David Golden (Apache License 2.0).

Based-on-work-by: John 'Warthog9' Hawley <warthog9@kernel.org>
Signed-off-by: Jakub Narebski <jnareb@gmail.com>
---

 gitweb/lib/GitwebCache/Capture/ToFile.pm |  109 +++++++++++++++++++++++++
 t/t9510-gitweb-capture-interface.sh      |   34 ++++++++
 t/t9510/test_capture_interface.pl        |  132 ++++++++++++++++++++++++++++++
 3 files changed, 275 insertions(+), 0 deletions(-)
 create mode 100644 gitweb/lib/GitwebCache/Capture/ToFile.pm
 create mode 100755 t/t9510-gitweb-capture-interface.sh
 create mode 100755 t/t9510/test_capture_interface.pl


diff --git a/gitweb/lib/GitwebCache/Capture/ToFile.pm b/gitweb/lib/GitwebCache/Capture/ToFile.pm
new file mode 100644
index 0000000..d2dbf0f
--- /dev/null
+++ b/gitweb/lib/GitwebCache/Capture/ToFile.pm
@@ -0,0 +1,109 @@
+# gitweb - simple web interface to track changes in git repositories
+#
+# (C) 2010, Jakub Narebski <jnareb@gmail.com>
+#
+# This program is licensed under the GPLv2
+
+#
+# Simple output capturing via redirecting STDOUT to given file.
+#
+
+# This is the same mechanism that Capture::Tiny uses, only simpler;
+# we don't capture STDERR at all, we don't tee, we capture to
+# explicitely provided file (or filehandle).
+
+package GitwebCache::Capture::ToFile;
+
+use strict;
+use warnings;
+
+use PerlIO;
+use Symbol qw(qualify_to_ref);
+
+# Constructor
+sub new {
+	my $class = shift;
+
+	my $self = {};
+	$self = bless($self, $class);
+
+	return $self;
+}
+
+sub capture {
+	my $self = shift;
+	my $code = shift;
+
+	$self->capture_start(@_); # pass rest of params
+	eval { $code->(); 1; };
+	my $exit_code = $?; # save this for later
+	my $error = $@;     # save this for later
+
+	my $got_out = $self->capture_stop();
+	$? = $exit_code;
+	die $error if $error;
+
+	return $got_out;
+}
+
+# ----------------------------------------------------------------------
+
+# Start capturing data (STDOUT)
+sub capture_start {
+	my $self = shift;
+	my $to   = shift;
+
+	# save copy of real STDOUT via duplicating it
+	my @layers = PerlIO::get_layers(\*STDOUT);
+	open $self->{'orig_stdout'}, ">&", \*STDOUT
+		or die "Couldn't dup STDOUT for capture: $!";
+
+	# close STDOUT, so that it isn't used anymode (to have it fd0)
+	close STDOUT;
+
+	$self->{'to'} = $to;
+	my $fileno = fileno(qualify_to_ref($to)); 
+	if (defined $fileno) {
+		# if $to is filehandle, redirect
+		open STDOUT, '>&', $fileno;
+	} elsif (! ref($to)) {
+		# if $to is name of file, open it
+		open STDOUT, '>',  $to;
+	}
+	_relayer(\*STDOUT, \@layers);
+
+	# started capturing
+	$self->{'capturing'} = 1;
+}
+
+# Stop capturing data (required for die_error)
+sub capture_stop {
+	my $self = shift;
+
+	# return if we didn't start capturing
+	return unless delete $self->{'capturing'};
+
+	# close capture file, and restore original STDOUT
+	my @layers = PerlIO::get_layers(\*STDOUT);
+	close STDOUT;
+	open STDOUT, '>&', fileno($self->{'orig_stdout'});
+	_relayer(\*STDOUT, \@layers);
+
+	return exists $self->{'to'} ? $self->{'to'} : $self->{'data'};
+}
+
+# taken from Capture::Tiny by David Golden, Apache License 2.0
+# with debugging stripped out
+sub _relayer {
+	my ($fh, $layers) = @_;
+
+	my %seen = ( unix => 1, perlio => 1); # filter these out
+	my @unique = grep { !$seen{$_}++ } @$layers;
+
+	binmode($fh, join(":", ":raw", @unique));
+}
+
+
+1;
+__END__
+# end of package GitwebCache::Capture::ToFile
diff --git a/t/t9510-gitweb-capture-interface.sh b/t/t9510-gitweb-capture-interface.sh
new file mode 100755
index 0000000..9151454
--- /dev/null
+++ b/t/t9510-gitweb-capture-interface.sh
@@ -0,0 +1,34 @@
+#!/bin/sh
+#
+# Copyright (c) 2010 Jakub Narebski
+#
+
+test_description='gitweb capturing interface
+
+This test checks capturing interface used for capturing gitweb output
+in gitweb caching (GitwebCache::Capture* modules).'
+
+# for now we are running only cache interface tests
+. ./test-lib.sh
+
+# this test is present in gitweb-lib.sh
+if ! test_have_prereq PERL; then
+	skip_all='perl not available, skipping test'
+	test_done
+fi
+
+"$PERL_PATH" -MTest::More -e 0 >/dev/null 2>&1 || {
+	skip_all='perl module Test::More unavailable, skipping test'
+	test_done
+}
+
+# ----------------------------------------------------------------------
+
+# The external test will outputs its own plan
+test_external_has_tap=1
+
+test_external \
+	'GitwebCache::Capture* Perl API (in gitweb/lib/)' \
+	"$PERL_PATH" "$TEST_DIRECTORY"/t9510/test_capture_interface.pl
+
+test_done
diff --git a/t/t9510/test_capture_interface.pl b/t/t9510/test_capture_interface.pl
new file mode 100755
index 0000000..6d90497
--- /dev/null
+++ b/t/t9510/test_capture_interface.pl
@@ -0,0 +1,132 @@
+#!/usr/bin/perl
+use lib (split(/:/, $ENV{GITPERLLIB}));
+
+use warnings;
+use strict;
+use utf8;
+
+use Test::More;
+
+# test source version
+use lib $ENV{GITWEBLIBDIR} || "$ENV{GIT_BUILD_DIR}/gitweb/lib";
+
+# ....................................................................
+
+use_ok('GitwebCache::Capture::ToFile');
+note("Using lib '$INC[0]'");
+note("Testing '$INC{'GitwebCache/Capture/ToFile.pm'}'");
+
+# Test setting up capture
+#
+my $capture = new_ok('GitwebCache::Capture::ToFile' => [], 'The $capture');
+
+
+# Test capturing to file (given by filename) and to filehandle
+#
+sub capture_block (&;$) {
+	$capture->capture(shift, shift || 'actual');
+
+	open my $fh, '<', 'actual' or return;
+	local $/ = undef;
+	my $result = <$fh>;
+	close $fh;
+	return $result;
+}
+
+diag('Should not print anything except test results and diagnostic');
+my $test_data = 'Capture this';
+my $captured = capture_block {
+	print $test_data;
+};
+is($captured, $test_data, 'capture simple data: filename');
+
+open my $fh, '>', 'actual';
+$captured = capture_block(sub {
+	print $test_data;
+}, $fh);
+close $fh;
+is($captured, $test_data, 'capture simple data: filehandle');
+
+
+# Test capturing :utf8 and :raw data
+#
+binmode STDOUT, ':utf8';
+$test_data = <<'EOF';
+Zażółć gęsią jaźń
+EOF
+utf8::decode($test_data);
+$captured = capture_block {
+	binmode STDOUT, ':utf8';
+
+	print $test_data;
+};
+utf8::decode($captured);
+is($captured, $test_data, 'capture utf8 data');
+
+$test_data = '|\x{fe}\x{ff}|\x{9F}|\000|'; # invalid utf-8
+$captured = capture_block {
+	binmode STDOUT, ':raw';
+
+	print $test_data;
+};
+is($captured, $test_data, 'capture raw data');
+
+
+# Test nested capturing, useful for future GitwebCache::CacheOutput tests
+#
+sub read_file {
+	my $filename = shift;
+
+	open my $fh, '<', $filename or return;
+	local $/ = undef;
+	my $result = <$fh>;
+	close $fh;
+
+	return $result;
+}
+
+my $outer_capture = GitwebCache::Capture::ToFile->new();
+$captured = $outer_capture->capture(sub {
+	print "pre|";
+	my $captured = $capture->capture(sub {
+		print "INNER";
+	}, 'inner_actual');
+	print "|post";
+}, 'outer_actual');
+
+my $inner = read_file('inner_actual');
+my $outer = read_file('outer_actual');
+
+is($inner, "INNER",     'nested capture: inner');
+is($outer, "pre||post", 'nested capture: outer');
+
+
+# Testing capture when code dies
+#
+$captured = $outer_capture->capture(sub {
+	print "pre|";
+	eval {
+		my $captured = $capture->capture(sub {
+			print "INNER:pre|";
+			die "die from inner\n";
+			print "INNER:post|"
+		}, 'inner_actual');
+	};
+	print "@=$@" if $@;
+	print "|post";
+}, 'outer_actual');
+
+my $inner = read_file('inner_actual');
+my $outer = read_file('outer_actual');
+
+is($inner, "INNER:pre|",
+   'nested capture with die: inner output captured up to die');
+is($outer, "pre|@=die from inner\n|post",
+   'nested capture with die: outer caught rethrown exception from inner');
+
+
+done_testing();
+
+# Local Variables:
+# coding: utf-8
+# End: