git.maemo.org Git - dh-make-perl/blob - dev/arm/libtest-harness-perl/libtest-harness-perl-3.12/t/lib/IO/c55Capture.pm

   1 package IO::c55Capture;
   2
   3 use IO::Handle;
   4
   5 =head1 Name
   6
   7 t/lib/IO::c55Capture - a wafer-thin test support package
   8
   9 =head1 Why!?
  10
  11 Compatibility with 5.5.3 and no external dependencies.
  12
  13 =head1 Usage
  14
  15 Works with a global filehandle:
  16
  17     # set a spool to write to
  18     tie local *STDOUT, 'IO::c55Capture';
  19     ...
  20     # clear and retrieve buffer list
  21     my @spooled = tied(*STDOUT)->dump();
  22
  23 Or, a lexical (and autocreated) filehandle:
  24
  25     my $capture = IO::c55Capture->new_handle;
  26     ...
  27     my @output = tied($$capture)->dump;
  28
  29 Note the '$$' dereference.
  30
  31 =cut
  32
  33 # XXX actually returns an IO::Handle :-/
  34 sub new_handle {
  35     my $class  = shift;
  36     my $handle = IO::Handle->new;
  37     tie $$handle, $class;
  38     return ($handle);
  39 }
  40
  41 sub TIEHANDLE {
  42     return bless [], __PACKAGE__;
  43 }
  44
  45 sub PRINT {
  46     my $self = shift;
  47
  48     push @$self, @_;
  49 }
  50
  51 sub PRINTF {
  52     my $self = shift;
  53     push @$self, sprintf(@_);
  54 }
  55
  56 sub dump {
  57     my $self = shift;
  58     my @got  = @$self;
  59     @$self = ();
  60     return @got;
  61 }
  62
  63 package util;
  64
  65 use IO::File;
  66
  67 # mostly stolen from Module::Build MBTest.pm
  68
  69 {    # backwards compatible temp filename recipe adapted from perlfaq
  70     my $tmp_count = 0;
  71     my $tmp_base_name = sprintf( "%d-%d", $$, time() );
  72
  73     sub temp_file_name {
  74         sprintf( "%s-%04d", $tmp_base_name, ++$tmp_count );
  75     }
  76 }
  77 ########################################################################
  78
  79 sub save_handle {
  80     my ( $handle, $subr ) = @_;
  81     my $outfile = temp_file_name();
  82
  83     local *SAVEOUT;
  84     open SAVEOUT, ">&" . fileno($handle)
  85       or die "Can't save output handle: $!";
  86     open $handle, "> $outfile" or die "Can't create $outfile: $!";
  87
  88     eval { $subr->() };
  89     my $err = $@;
  90     open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
  91
  92     my $ret = slurp($outfile);
  93     1 while unlink $outfile;
  94     $err and die $err;
  95     return $ret;
  96 }
  97
  98 sub stdout_of { save_handle( \*STDOUT, @_ ) }
  99 sub stderr_of { save_handle( \*STDERR, @_ ) }
 100
 101 sub stdout_stderr_of {
 102     my $subr = shift;
 103     my ( $stdout, $stderr );
 104     $stdout = stdout_of(
 105         sub {
 106             $stderr = stderr_of($subr);
 107         }
 108     );
 109     return ( $stdout, $stderr );
 110 }
 111
 112 sub slurp {
 113     my $fh = IO::File->new( $_[0] ) or die "Can't open $_[0]: $!";
 114     local $/;
 115     return scalar <$fh>;
 116 }
 117
 118 1;
 119
 120 # vim:ts=4:sw=4:et:sta