Besides GitwebCache::Capture::SelectFH, which uses select(FH) to
redirect 'print LIST' and 'printf FORMAT, LIST' to in-memory file to
capture output, add GitwebCache::Capture::TiedCapture which uses
tie-ing filehandle to capture output, and GitwebCache::Capture::PerlIO
which uses push_layer method from non-core PerlIO::Util module to
capture output.
Add test (which can be run standalone) for all those implementations,
checking ':utf8' and ':raw' output, and benchmark comparing them
(includes example benchmark tests). Please note that the test for
alternate implementations is not run from t9504 test.
Signed-off-by: Jakub Narebski <jnareb@xxxxxxxxx>
---
Formerly as patch 08/17 in previous version of series, now marked PoC
("proof of concept"), and moved to the end of series.
Differences from v4:
* GitwebCache::Capture::TiedCapture has now two (sub)versions: one
appending data from tied operations to a string (after conversion)
via TiedCapture::String (default), other redirecting tied operations
to save to in-memory file via TiedCapture::PerlIO (new).
Add tests for new TiedCapture::PerlIO.
* Tie::Restore (non-core module from CPAN) is now in separate file;
should be probably in 'inc/' and not in 'lib/'.
* Change name of field in TiedCapture::* from 'mode' to 'binmode'.
* New example results of benchmark.
* Add test checking that all those implementations work correctly for
capturing both ':utf8' and ':raw' printed data.
gitweb/lib/GitwebCache/Capture/PerlIO.pm | 79 +++++++++
gitweb/lib/GitwebCache/Capture/TiedCapture.pm | 76 +++++++++
gitweb/lib/Tie/Restore.pm | 24 +++
gitweb/lib/TiedCapture/PerlIO.pm | 56 ++++++
gitweb/lib/TiedCapture/String.pm | 53 ++++++
t/t9504/benchmark_capture_implementations.pl | 226 +++++++++++++++++++++++++
t/t9504/test_capture_implementations.pl | 85 +++++++++
7 files changed, 599 insertions(+), 0 deletions(-)
create mode 100644 gitweb/lib/GitwebCache/Capture/PerlIO.pm
create mode 100644 gitweb/lib/GitwebCache/Capture/TiedCapture.pm
create mode 100644 gitweb/lib/Tie/Restore.pm
create mode 100644 gitweb/lib/TiedCapture/PerlIO.pm
create mode 100644 gitweb/lib/TiedCapture/String.pm
create mode 100755 t/t9504/benchmark_capture_implementations.pl
create mode 100755 t/t9504/test_capture_implementations.pl
diff --git a/gitweb/lib/GitwebCache/Capture/PerlIO.pm b/gitweb/lib/GitwebCache/Capture/PerlIO.pm
new file mode 100644
index 0000000..199aeed
--- /dev/null
+++ b/gitweb/lib/GitwebCache/Capture/PerlIO.pm
@@ -0,0 +1,79 @@
+# gitweb - simple web interface to track changes in git repositories
+#
+# (C) 2010, Jakub Narebski <jnareb@xxxxxxxxx>
+#
+# This program is licensed under the GPLv2
+
+#
+# Output capturing using PerlIO layers
+#
+
+# This module requires PaerlIO::Util installed.
+
+package GitwebCache::Capture::PerlIO;
+
+use PerlIO::Util;
+
+use strict;
+use warnings;
+
+use base qw(GitwebCache::Capture);
+use GitwebCache::Capture qw(:all);
+
+use Exporter qw(import);
+our @EXPORT = @GitwebCache::Capture::EXPORT;
+our @EXPORT_OK = @GitwebCache::Capture::EXPORT_OK;
+our %EXPORT_TAGS = %GitwebCache::Capture::EXPORT_TAGS;
+
+# Constructor
+sub new {
+ my $proto = shift;
+
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self = bless($self, $class);
+
+ $self->{'data'} = '';
+
+ return $self;
+}
+
+# Start capturing data (STDOUT)
+# (printed using 'print <sth>' or 'printf <sth>')
+sub start {
+ my $self = shift;
+
+ $self->{'data'} = '';
+ *STDOUT->push_layer('scalar' => \$self->{'data'});
+
+ # push ':utf8' on top, if it was on top
+ *STDOUT->push_layer(':utf8')
+ if ((*STDOUT->get_layers())[-2] eq 'utf8');
+}
+
+# Stop capturing data (required for die_error)
+sub stop {
+ my $self = shift;
+
+ # return if we didn't start capturing
+ my @layers = *STDOUT->get_layers();
+ return unless grep { $_ eq 'scalar' } @layers;
+
+ my $was_utf8 = $layers[-1] eq 'utf8';
+ # stop saving to scalar, i.e. remove topmost 'scalar' layer,
+ # but remember that 'utf8' layer might be on top of it
+ while ((my $layer = *STDOUT->pop_layer())) {
+ pop @layers;
+ last if $layer eq 'scalar';
+ }
+ # restore ':utf8' mode, if needed
+ if ($was_utf8 && $layers[-1] ne 'utf8') {
+ *STDOUT->push_layer('utf8');
+ }
+
+ return $self->{'data'};
+}
+
+1;
+__END__
+# end of package GitwebCache::Capture::PerlIO;
diff --git a/gitweb/lib/GitwebCache/Capture/TiedCapture.pm b/gitweb/lib/GitwebCache/Capture/TiedCapture.pm
new file mode 100644
index 0000000..6bed0f8
--- /dev/null
+++ b/gitweb/lib/GitwebCache/Capture/TiedCapture.pm
@@ -0,0 +1,76 @@
+# gitweb - simple web interface to track changes in git repositories
+#
+# (C) 2010, Jakub Narebski <jnareb@xxxxxxxxx>
+#
+# This program is licensed under the GPLv2
+
+#
+# Simple output capturing by tie-ing filehandle
+#
+
+package GitwebCache::Capture::TiedCapture;
+
+use PerlIO;
+
+use strict;
+use warnings;
+
+use base qw(GitwebCache::Capture);
+use GitwebCache::Capture qw(:all);
+
+use Exporter qw(import);
+our @EXPORT = @GitwebCache::Capture::EXPORT;
+our @EXPORT_OK = @GitwebCache::Capture::EXPORT_OK;
+our %EXPORT_TAGS = %GitwebCache::Capture::EXPORT_TAGS;
+
+# Constructor
+sub new {
+ my $proto = shift;
+
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self = bless($self, $class);
+
+ $self->{'data'} = '';
+ $self->{'tied'} = undef;
+ $self->{'tie_class'} = shift || 'TiedCapture::String';
+ eval "require $self->{'tie_class'}";
+
+ return $self;
+}
+
+# Start capturing data (STDOUT)
+# (printed using 'print <sth>' or 'printf <sth>')
+sub start {
+ my $self = shift;
+
+ # savie tie
+ $self->{'tied'} = tied *STDOUT;
+
+ $self->{'data'} = '';
+ tie *STDOUT, $self->{'tie_class'}, \$self->{'data'};
+
+ # re-binmode, so that tied class would pick it up
+ binmode STDOUT,
+ (PerlIO::get_layers(*STDOUT))[-1] eq 'utf8' ? ':utf8' : ':raw';
+}
+
+# Stop capturing data (required for die_error)
+sub stop {
+ my $self = shift;
+
+ # return if we didn't start capturing
+ return unless tied(*STDOUT)->isa($self->{'tie_class'});
+
+ # restore ties, if there were any
+ untie *STDOUT;
+ if ($self->{'tied'}) {
+ tie *STDOUT, 'Tie::Restore', $self->{'tied'};
+ }
+
+ return $self->{'data'};
+}
+
+1;
+__END__
+# end of package GitwebCache::Capture::TiedCapture;
diff --git a/gitweb/lib/Tie/Restore.pm b/gitweb/lib/Tie/Restore.pm
new file mode 100644
index 0000000..687434e
--- /dev/null
+++ b/gitweb/lib/Tie/Restore.pm
@@ -0,0 +1,24 @@
+########################################################################
+# This package should probably be put in `gitweb/inc/' instead
+#
+# taken from http://search.cpan.org/~robwalker/Tie-Restore-0.11/Restore.pm
+# with POD documentation stripped out
+
+package Tie::Restore;
+# Written by Robby Walker ( webmaster@xxxxxxxxxxxxxxx )
+# for Point Writer ( http://www.pointwriter.com/ ).
+
+our $VERSION = '0.11';
+$VERSION = eval $VERSION;
+
+# $object = tied %hash; # save
+# tie %hash, 'Tie::Restore', $object; # restore
+
+sub TIESCALAR { $_[1] }
+sub TIEARRAY { $_[1] }
+sub TIEHASH { $_[1] }
+sub TIEHANDLE { $_[1] }
+
+1;
+__END__
+# end of package Tie::Restore
diff --git a/gitweb/lib/TiedCapture/PerlIO.pm b/gitweb/lib/TiedCapture/PerlIO.pm
new file mode 100644
index 0000000..4bbd724
--- /dev/null
+++ b/gitweb/lib/TiedCapture/PerlIO.pm
@@ -0,0 +1,56 @@
+########################################################################
+
+package TiedCapture::PerlIO;
+
+our $VERSION = '0.001';
+$VERSION = eval $VERSION;
+
+use strict;
+use warnings;
+
+use PerlIO;
+
+sub TIEHANDLE {
+ my ($proto, $dataref) = @_;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self = bless($self, $class);
+ $self->{'scalar'} = $dataref;
+ $self->{'binmode'} = ':utf8';
+
+ $self->{'scalar_fh'} = undef;
+ open $self->{'scalar_fh'}, '>', $self->{'scalar'}
+ or die "Couldn't open in-memory file for capture: $!";
+
+ return $self;
+}
+
+sub WRITE {
+ my $self = shift;
+ syswrite $self->{'scalar_fh'}, @_;
+}
+
+sub PRINT {
+ my $self = shift;
+ print { $self->{'scalar_fh'} } @_;
+}
+
+sub PRINTF {
+ my $self = shift;
+ printf { $self->{'scalar_fh'} } @_;
+}
+
+sub BINMODE {
+ my $self = shift;
+ $self->{'binmode'} = shift || ':raw';
+ binmode $self->{'scalar_fh'}, $self->{'binmode'};
+}
+
+#sub UNTIE {
+# close $self->{'scalar_fh'};
+# $self->{'scalar_fh'} = undef;
+#}
+
+1;
+__END__
+# end of package TiedCapture::PerlIO
diff --git a/gitweb/lib/TiedCapture/String.pm b/gitweb/lib/TiedCapture/String.pm
new file mode 100644
index 0000000..72b15a7
--- /dev/null
+++ b/gitweb/lib/TiedCapture/String.pm
@@ -0,0 +1,53 @@
+########################################################################
+
+package TiedCapture::String;
+
+our $VERSION = '0.001';
+$VERSION = eval $VERSION;
+
+use strict;
+use warnings;
+
+sub TIEHANDLE {
+ my ($proto, $dataref) = @_;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self = bless($self, $class);
+ $self->{'scalar'} = $dataref;
+ $self->{'binmode'} = ':utf8';
+ return $self;
+}
+
+sub append_str {
+ my ($self, $str) = @_;
+ utf8::encode($str) if ($self->{'binmode'} eq ':utf8');
+ ${$self->{'scalar'}} .= $str;
+}
+
+sub WRITE {
+ my ($self, $buffer, $length, $offset) = @_;
+ $self->append_str(substr($buffer, $offset, $length));
+}
+
+sub PRINT {
+ my $self = shift;
+ $self->append_str(join('',@_));
+}
+
+sub PRINTF {
+ my $self = shift;
+ $self->append_str(sprintf(@_));
+}
+
+sub BINMODE {
+ my $self = shift;
+ $self->{'binmode'} = shift || ':raw';
+}
+
+#sub UNTIE {
+# local $^W = 0;
+#}
+
+1;
+__END__
+# end of package TiedCapture::String
diff --git a/t/t9504/benchmark_capture_implementations.pl b/t/t9504/benchmark_capture_implementations.pl
new file mode 100755
index 0000000..588c1dc
--- /dev/null
+++ b/t/t9504/benchmark_capture_implementations.pl
@@ -0,0 +1,226 @@
+#!/usr/bin/perl
+use lib (split(/:/, $ENV{GITPERLLIB}));
+
+use warnings;
+use strict;
+
+use File::Spec;
+use File::Path;
+use Benchmark qw(:all);
+
+use PerlIO;
+
+# benchmark source version
+sub __DIR__ () {
+ File::Spec->rel2abs(join '', (File::Spec->splitpath(__FILE__))[0, 1]);
+}
+use lib __DIR__."/../../gitweb/lib";
+
+# ....................................................................
+
+# Load modules (without importing)
+#
+my @modules =
+ map { "GitwebCache::Capture::$_" }
+ qw(SelectFH TiedCapture);
+foreach my $mod (@modules) {
+ eval "require $mod";
+}
+if (eval { require PerlIO::Util; 1 }) {
+ require GitwebCache::Capture::PerlIO;
+ push @modules, 'GitwebCache::Capture::PerlIO';
+}
+
+# Set up capturing, for each module
+#
+my @captures = map { $_->new() } @modules;
+push @captures, GitwebCache::Capture::TiedCapture->new('TiedCapture::PerlIO');
+
+
+my $test_data = <<'EOF';
+Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do
+eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad
+minim veniam, quis nostrud exercitation ullamco laboris nisi ut
+aliquip ex ea commodo consequat. Duis aute irure dolor in
+reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla
+pariatur. Excepteur sint occaecat cupidatat non proident, sunt in
+culpa qui officia deserunt mollit anim id est laborum.
+
+Sed ut perspiciatis unde omnis iste natus error sit voluptatem
+accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae
+ab illo inventore veritatis et quasi architecto beatae vitae dicta
+sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit
+aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos
+qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui
+dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed
+quia non numquam eius modi tempora incidunt ut labore et dolore magnam
+aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum
+exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex
+ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in
+ea voluptate velit esse quam nihil molestiae consequatur, vel illum
+qui dolorem eum fugiat quo voluptas nulla pariatur?
+EOF
+
+my @captured_output;
+my $repeat = 100;
+sub capture_output {
+ my ($class, $mode) = @_;
+
+ $class->start();
+ binmode select(), $mode if defined($mode);
+ print $test_data for (1..$repeat);
+
+ return $class->stop();
+}
+
+my %codehash;
+for (my $i = 0; $i < @captures; $i++) {
+ my $capture = $captures[$i];
+ my $name = ref($capture);
+ $name =~ s/^.*:://;
+ $name .= " ($captures[$i]->{'tie_class'})"
+ if $captures[$i]->{'tie_class'};
+ $name =~ s/TiedCapture:://;
+
+ $codehash{$name} = sub { $captured_output[$i] = capture_output($capture) };
+}
+
+# ....................................................................
+
+my $test_other_modules = 0;
+
+if ($test_other_modules) {
+
+ if (eval { require Capture::Tiny; 1; }) {
+ $codehash{'Capture::Tiny'} = sub {
+ my ($stdout, $stderr) = Capture::Tiny::capture(sub {
+ print $test_data for (1..$repeat);
+ });
+ print STDERR $stderr if defined($stderr);
+ };
+ }
+
+ if (eval { require IO::CaptureOutput; 1; }) {
+ $codehash{'IO::CaptureOutput'} = sub {
+ my ($stdout, $stderr);
+ IO::CaptureOutput::capture(sub {
+ print $test_data for (1..$repeat);
+ }, \$stdout, \$stderr);
+ print STDERR $stderr if defined($stderr);
+ };
+ # somehow it interferes with capturing in GitwebCache::Capture::PerlIO
+ delete $codehash{'PerlIO'};
+ }
+
+ if (eval { require IO::Capture::Stdout; 1; }) {
+ $codehash{'IO::Capture'} = sub {
+ my $capture = IO::Capture::Stdout->new();
+
+ $capture->start();
+ print $test_data for (1..$repeat);
+ $capture->stop();
+
+ my $captured_output = join('', $capture->read());
+ };
+ }
+} # end if ($test_other_modules)
+
+# ....................................................................
+
+print "Capturing $repeat x ".length($test_data).
+ " = ".($repeat * length($test_data))." characters\n";
+my $count = -10; # CPU seconds
+my $result = timethese($count, \%codehash);
+cmpthese($result);
+
+#if (exists $codehash{PerlIO}) {
+# cmpthese(-10, {
+# 'PerlIO::get_layers' => sub { PerlIO::get_layers(*STDOUT); },
+# 'PerlIO::Util method' => sub { *STDOUT->get_layers(); },
+# });
+#}
+
+1;
+__END__
+## EXAMPLE OUTPUT ##
+#
+## 1 x $test_data, PerlIO using *STDOUT->get_layers();
+# Benchmark: running PerlIO, SelectFH, TiedCapture for at least 10 CPU seconds...
+# PerlIO: 9 wallclock secs (10.38 usr + 0.13 sys = 10.51 CPU) @ 9676.31/s (n=101698)
+# SelectFH: 12 wallclock secs (10.51 usr + 0.02 sys = 10.53 CPU) @ 12294.21/s (n=129458)
+# TiedCapture: 10 wallclock secs (10.24 usr + 0.06 sys = 10.30 CPU) @ 9489.22/s (n=97739)
+# Rate TiedCapture PerlIO SelectFH
+# TiedCapture 9489/s -- -2% -23%
+# PerlIO 9676/s 2% -- -21%
+# SelectFH 12294/s 30% 27% --
+#
+## 10 x $test_data, PerlIO using *STDOUT->get_layers();
+# Benchmark: running PerlIO, SelectFH, TiedCapture for at least 10 CPU seconds...
+# PerlIO: 9 wallclock secs (10.47 usr + 0.07 sys = 10.54 CPU) @ 7558.35/s (n=79665)
+# SelectFH: 11 wallclock secs (10.36 usr + 0.04 sys = 10.40 CPU) @ 8970.87/s (n=93297)
+# TiedCapture: 11 wallclock secs (10.45 usr + 0.02 sys = 10.47 CPU) @ 2602.77/s (n=27251)
+# Rate TiedCapture PerlIO SelectFH
+# TiedCapture 2603/s -- -66% -71%
+# PerlIO 7558/s 190% -- -16%
+# SelectFH 8971/s 245% 19% --
+#
+## 100 x $test_data, PerlIO using *STDOUT->get_layers();
+# Benchmark: running PerlIO, SelectFH, TiedCapture for at least 50 CPU seconds...
+# PerlIO: 67 wallclock secs (35.28 usr + 17.82 sys = 53.10 CPU) @ 832.41/s (n=44201)
+# SelectFH: 73 wallclock secs (33.83 usr + 18.63 sys = 52.46 CPU) @ 830.06/s (n=43545)
+# TiedCapture: 71 wallclock secs (50.93 usr + 0.41 sys = 51.34 CPU) @ 95.31/s (n=4893)
+# Rate TiedCapture SelectFH PerlIO
+# TiedCapture 95.3/s -- -89% -89%
+# SelectFH 830/s 771% -- -0%
+# PerlIO 832/s 773% 0% --
+#
+## 100 x $test_data, PerlIO using mix of *STDOUT->get_layers() and PerlIO::get_layers(*STDOUT);
+# Capturing 100 x 1314 = 131400 characters
+# Benchmark: timing 25000 iterations of PerlIO, SelectFH, TiedCapture...
+# PerlIO: 30 wallclock secs (19.05 usr + 10.29 sys = 29.34 CPU) @ 852.08/s (n=25000)
+# SelectFH: 30 wallclock secs (18.95 usr + 10.26 sys = 29.21 CPU) @ 855.87/s (n=25000)
+# TiedCapture: 307 wallclock secs (267.37 usr + 2.95 sys = 270.32 CPU) @ 92.48/s (n=25000)
+# Rate TiedCapture PerlIO SelectFH
+# TiedCapture 92.5/s -- -89% -89%
+# PerlIO 852/s 821% -- -0%
+# SelectFH 856/s 825% 0% --
+#
+## 100 x $test_data (IO::CaptureOutput interferes with GitwebCache::Capture::PerlIO)
+# Capturing 100 x 1314 = 131400 characters
+# Benchmark: running IO::CaptureOutput, SelectFH, TiedCapture for at least 10 CPU seconds...
+# IO::CaptureOutput: 12 wallclock secs ( 5.12 usr + 5.63 sys = 10.75 CPU) @ 126.60/s (n=1361)
+# SelectFH: 12 wallclock secs ( 6.93 usr + 3.45 sys = 10.38 CPU) @ 808.29/s (n=8390)
+# TiedCapture: 11 wallclock secs (10.11 usr + 0.01 sys = 10.12 CPU) @ 103.26/s (n=1045)
+# Rate TiedCapture IO::CaptureOutput SelectFH
+# TiedCapture 103/s -- -18% -87%
+# IO::CaptureOutput 127/s 23% -- -84%
+# SelectFH 808/s 683% 538% --
+#
+## PerlIO::get_layers == PerlIO::get_layers(*STDOUT)
+## PerlIU::Util method == *STDOUT->get_layers()
+# Rate PerlIO::Util method PerlIO::get_layers
+# PerlIO::Util method 54405/s -- -38%
+# PerlIO::get_layers 87672/s 61% --
+
+##
+# Capturing 100 x 1314 = 131400 characters
+# Benchmark: running PerlIO, SelectFH, TiedCapture (PerlIO), TiedCapture (String)
+# for at least 10 CPU seconds...
+# Rate TiedCapture (String) TiedCapture (PerlIO) SelectFH PerlIO
+# TiedCapture (String) 96.5/s -- -76% -88% -88%
+# TiedCapture (PerlIO) 407/s 322% -- -48% -48%
+# SelectFH 787/s 715% 93% -- -0%
+# PerlIO 789/s 717% 94% 0% --
+#
+# comment: you can see effects of perltie overhead and repeated string concatenation here.
+
+##
+#
+# Capturing 100 x 1314 = 131400 characters
+# Benchmark: running IO::CaptureOutput, SelectFH, TiedCapture (PerlIO), TiedCapture (String)
+# for at least 10 CPU seconds...
+# Rate TiedCapture (String) IO::CaptureOutput TiedCapture (PerlIO) SelectFH
+# TiedCapture (String) 109/s -- -4% -72% -84%
+# IO::CaptureOutput 114/s 4% -- -70% -84%
+# TiedCapture (PerlIO) 384/s 253% 237% -- -45%
+# SelectFH 693/s 536% 509% 80% --
diff --git a/t/t9504/test_capture_implementations.pl b/t/t9504/test_capture_implementations.pl
new file mode 100755
index 0000000..86796ac
--- /dev/null
+++ b/t/t9504/test_capture_implementations.pl
@@ -0,0 +1,85 @@
+#!/usr/bin/perl
+use lib (split(/:/, $ENV{GITPERLLIB}));
+
+use warnings;
+use strict;
+
+use File::Spec;
+
+use Test::More;
+
+# test source version
+#use if defined($ENV{TEST_DIRECTORY}),
+# lib => "$ENV{TEST_DIRECTORY}/../gitweb/lib";
+sub __DIR__ () {
+ File::Spec->rel2abs(join '', (File::Spec->splitpath(__FILE__))[0, 1]);
+}
+use lib __DIR__."/../../gitweb/lib";
+
+# ....................................................................
+
+# Load modules
+my @modules =
+ map { "GitwebCache::Capture::$_" }
+ qw(SelectFH TiedCapture);
+require_ok($_) foreach @modules;
+if (eval { require PerlIO::Util; 1 }) {
+ require_ok('GitwebCache::Capture::PerlIO');
+ unshift @modules, 'GitwebCache::Capture::PerlIO';
+}
+
+# Test setting up capture
+#
+my @captures = map { new_ok($_ => []) } @modules;
+push @captures, new_ok('GitwebCache::Capture::TiedCapture' => ['TiedCapture::PerlIO']);
+isa_ok($_, 'GitwebCache::Capture', ref($_)) foreach @captures;
+
+# Test capturing
+#
+diag('Should not print anything except test results and diagnostic');
+
+my $test_data;
+my @captured_output;
+sub capture {
+ my ($class, $mode) = @_;
+
+ $class->start();
+ binmode select(), $mode if defined($mode);
+ print $test_data;
+ return $class->stop();
+}
+sub test_captures {
+ my $mode = shift;
+
+ @captured_output = map { capture($_, $mode); } @captures;
+ if ($mode eq ':utf8') {
+ utf8::decode($_) foreach @captured_output;
+ }
+ for (my $i = 0; $i < @captures; $i++) {
+ my $name = ref($captures[$i]);
+ $name .= " ($captures[$i]->{'tie_class'})"
+ if $captures[$i]->{'tie_class'};
+ my $output = $captured_output[$i];
+ is($output, $test_data, "$name captures $mode data");
+ }
+}
+
+
+binmode STDOUT, ':utf8';
+$test_data = 'ZaÅÃÅÄ gÄsiÄ jaÅÅ';
+utf8::decode($test_data);
+#diag("\$test_data = $test_data (decoded)\n");
+ok(utf8::is_utf8($test_data), '$test_data is utf8 (utf8::is_utf8)');
+ok(utf8::valid($test_data), '$test_data is valid (utf8::valid)');
+test_captures(':utf8');
+
+$test_data = '|\x{fe}\x{ff}|\x{9F}|\000|'; # invalid utf-8
+ok(!utf8::is_utf8($test_data), '$test_data is not utf8 (utf8::is_utf8)');
+ok(utf8::valid($test_data), '$test_data is valid (utf8::valid)');
+test_captures(':raw');
+
+done_testing();
+
+# Local Variables:
+# encoding: utf-8
+# End:
--
1.7.3
--
To unsubscribe from this list: send the line "unsubscribe git" in
the body of a message to majordomo@xxxxxxxxxxxxxxx
More majordomo info at http://vger.kernel.org/majordomo-info.html