view release on metacpan or  search on metacpan

local/lib/perl5/Test/Trap/Builder/SystemSafe.pm  view on Meta::CPAN

use version; $VERSION = qv('0.3.5');

use strict;
use warnings;
use Test::Trap::Builder;
use File::Temp qw( tempfile );
use IO::Handle;

########
#
# I can no longer (easily?) install Devel::Cover on 5.6.2, so silence the coverage report:
#
# uncoverable condition right
# uncoverable condition false
use constant GOTPERLIO => (eval "use PerlIO (); 1" || 0);

sub import {
  shift; # package name
  my $strategy_name = @_ ? shift : 'systemsafe';
  my $strategy_option = @_ ? shift : {};
  Test::Trap::Builder->capture_strategy( $strategy_name => $_ ) for sub {
    my $self = shift;
    my ($name, $fileno, $globref) = @_;
    my $pid = $$;
    if (tied *$globref or $fileno < 0) {
      $self->Exception("SystemSafe only works with real file descriptors; aborting");
    }
    my ($fh, $file) = do {
      local ($!, $^E);
      tempfile( UNLINK => 1 ); # XXX: Test?
    };
    my ($fh_keeper, $autoflush_keeper, @io_layers, @restore_io_layers);
    my $Die = $self->ExceptionFunction;
    for my $buffer ($self->{$name}) {
      $self->Teardown($_) for sub {
        local ($!, $^E);
        if ($pid == $$) {
          # this process opened it, so it gets to collect the contents:
          local $/;
          $buffer .= $fh->getline;
          close $fh; # don't leak this one either!
          unlink $file;
        }
        close *$globref;
        return unless $fh_keeper;
        # close and reopen the file to the keeper!
        my $fno = fileno $fh_keeper;
        _close_reopen( $Die, $globref, $fileno, ">&$fno",
                       sub {
                         close $fh_keeper;
                         sprintf "Cannot dup '%s' for %s: '%s'",
                           $fno, $name, $!;
                       },
                     );
        close $fh_keeper; # another potential leak, I suppose.
        $globref->autoflush($autoflush_keeper);
      IO_LAYERS: {
          GOTPERLIO or last IO_LAYERS;
          local($!, $^E);
          binmode *$globref;
          my @tmp = @restore_io_layers;
          $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*$globref);
          binmode *$globref, $_ for @tmp;
        }
      };
    }
    binmode $fh; # superfluous?
    {
      local ($!, $^E);
      open $fh_keeper, ">&$fileno"
        or $self->Exception("Cannot dup '$fileno' for $name: '$!'");
    }
  IO_LAYERS: {
      GOTPERLIO or last IO_LAYERS;
      local($!, $^E);
      @restore_io_layers = PerlIO::get_layers(*$globref, output => 1);
      if ($strategy_option->{preserve_io_layers}) {
        @io_layers = @restore_io_layers;
      }
      if ($strategy_option->{io_layers}) {
        push @io_layers, $strategy_option->{io_layers};
      }
    }
    $autoflush_keeper = $globref->autoflush;
    _close_reopen( $self->ExceptionFunction, $globref, $fileno, ">>$file",
                   sub {
                     sprintf "Cannot open %s for %s: '%s'",
                       $file, $name, $!;
                   },
                 );
  IO_LAYERS: {
      GOTPERLIO or last IO_LAYERS;
      local($!, $^E);
      for my $h (*$globref, $fh) {
        binmode $h;
        my @tmp = @io_layers or next;
        $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers($h);
        binmode $h, $_ for @tmp;
      }
    }
    $globref->autoflush(1);
    $self->Next;
  };
}

sub _close_reopen {
  my ($Die, $glob, $fno_want, $what, $err) = @_;
  local ($!, $^E);
  close *$glob;
  my @fh;
  while (1) {
    no warnings 'io';
    open *$glob, $what or $Die->($err->());
    my $fileno = fileno *$glob;
    last if $fileno == $fno_want;
    close *$glob;
    if ($fileno > $fno_want) {
      $Die->("Cannot get the desired descriptor, '$fno_want' (could it be that it is fdopened and so still open?)");
    }
    if (grep{$fileno == fileno($_)}@fh) {
      $Die->("Getting several files opened on fileno $fileno");
    }
    open my $fh, $what or $Die->($err->());
    if (fileno($fh) != $fileno) {
      $Die->("Getting fileno " . fileno($fh) . "; expecting $fileno");
    }
    push @fh, $fh;
  }
  close $_ for @fh;
}

1; # End of Test::Trap::Builder::SystemSafe

__END__

=head1 NAME

Test::Trap::Builder::SystemSafe - "Safe" capture strategies using File::Temp

=head1 VERSION

Version 0.3.5

=head1 DESCRIPTION

This module provides capture strategies I<systemsafe>, based on
File::Temp, for the trap's output layers.  These strategies insists on
reopening the output file handles with the same descriptors, and
therefore, unlike L<Test::Trap::Builder::TempFile> and
L<Test::Trap::Builder::PerlIO>, is able to trap output from forked-off
processes, including system().

The import accepts a name (as a string; default I<systemsafe>) and
options (as a hashref; by default empty), and registers a capture
strategy with that name and a variant implementation based on the
options.

Note that you may specify different strategies for each output layer