File Coverage

blib/lib/Test/Trap/Builder/SystemSafe.pm

Criterion	Covered	Total	%
statement	111	111	100.0
branch	33	34	97.0
condition	3	5	80.0
subroutine	13	13	100.0
pod			n/a
total	160	163	98.7

package Test::Trap::Builder::SystemSafe;

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__