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


line stmt bran cond sub pod time code
1             package Test::Trap::Builder::SystemSafe;
2              
3 27     27   503443 use version; $VERSION = qv('0.3.5');
  27         11119  
  27         127  
4              
5 27     27   1888 use strict;
  27         108  
  27         443  
6 27     27   119 use warnings;
  27         68  
  27         654  
7 27     27   3141 use Test::Trap::Builder;
  27         54  
  27         1298  
8 27     27   1337 use File::Temp qw( tempfile );
  27         31409  
  27         1140  
9 27     27   157 use IO::Handle;
  27         43  
  27         1069  
10              
11             ########
12             #
13             # I can no longer (easily?) install Devel::Cover on 5.6.2, so silence the coverage report:
14             #
15             # uncoverable condition right
16             # uncoverable condition false
17 27   50 27   167 use constant GOTPERLIO => (eval "use PerlIO (); 1" || 0);
  27     27   56  
  27         1538  
  27         145  
  27         50  
  27         197  
18              
19             sub import {
20 64     64   484 shift; # package name
21 64 100       198 my $strategy_name = @_ ? shift : 'systemsafe';
22 64 100       145 my $strategy_option = @_ ? shift : {};
23 64         479 Test::Trap::Builder->capture_strategy( $strategy_name => $_ ) for sub {
24 159     159   233 my $self = shift;
25 159         349 my ($name, $fileno, $globref) = @_;
26 159         367 my $pid = $$;
27 159 100 66     685 if (tied *$globref or $fileno < 0) {
28 1         3 $self->Exception("SystemSafe only works with real file descriptors; aborting");
29             }
30 158         226 my ($fh, $file) = do {
31 158         728 local ($!, $^E);
32 158         628 tempfile( UNLINK => 1 ); # XXX: Test?
33             };
34 158         57932 my ($fh_keeper, $autoflush_keeper, @io_layers, @restore_io_layers);
35 158         546 my $Die = $self->ExceptionFunction;
36 158         386 for my $buffer ($self->{$name}) {
37 158         998 $self->Teardown($_) for sub {
38 154         1073 local ($!, $^E);
39 154 100       524 if ($pid == $$) {
40             # this process opened it, so it gets to collect the contents:
41 152         502 local $/;
42 152         4909 $buffer .= $fh->getline;
43 152         9668 close $fh; # don't leak this one either!
44 152         4605 unlink $file;
45             }
46 154         3686 close *$globref;
47 154 100       504 return unless $fh_keeper;
48             # close and reopen the file to the keeper!
49 152         347 my $fno = fileno $fh_keeper;
50             _close_reopen( $Die, $globref, $fileno, ">&$fno",
51             sub {
52 2         50 close $fh_keeper;
53 2         22 sprintf "Cannot dup '%s' for %s: '%s'",
54             $fno, $name, $!;
55             },
56 152         1775 );
57 147         1046 close $fh_keeper; # another potential leak, I suppose.
58 147         761 $globref->autoflush($autoflush_keeper);
59             IO_LAYERS: {
60 147         5576 GOTPERLIO or last IO_LAYERS;
  147         212  
61 147         454 local($!, $^E);
62 147         354 binmode *$globref;
63 147         373 my @tmp = @restore_io_layers;
64 147 50       1054 $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*$globref);
65 147         738 binmode *$globref, $_ for @tmp;
66             }
67             };
68             }
69 158         438 binmode $fh; # superfluous?
70             {
71 158         199 local ($!, $^E);
  158         641  
72 158 100       3504 open $fh_keeper, ">&$fileno"
73             or $self->Exception("Cannot dup '$fileno' for $name: '$!'");
74             }
75             IO_LAYERS: {
76 156         696 GOTPERLIO or last IO_LAYERS;
  156         198  
77 156         440 local($!, $^E);
78 156         950 @restore_io_layers = PerlIO::get_layers(*$globref, output => 1);
79 156 100       430 if ($strategy_option->{preserve_io_layers}) {
80 50         105 @io_layers = @restore_io_layers;
81             }
82 156 100       476 if ($strategy_option->{io_layers}) {
83 18         51 push @io_layers, $strategy_option->{io_layers};
84             }
85             }
86 156         635 $autoflush_keeper = $globref->autoflush;
87             _close_reopen( $self->ExceptionFunction, $globref, $fileno, ">>$file",
88             sub {
89 2         50 sprintf "Cannot open %s for %s: '%s'",
90             $file, $name, $!;
91             },
92 156         5824 );
93             IO_LAYERS: {
94 149         570 GOTPERLIO or last IO_LAYERS;
  149         207  
95 149         544 local($!, $^E);
96 149         322 for my $h (*$globref, $fh) {
97 298         1422 binmode $h;
98 298 100       810 my @tmp = @io_layers or next;
99 124 100       666 $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers($h);
100 124     1   629 binmode $h, $_ for @tmp;
  1         6  
  1         2  
  1         5  
101             }
102             }
103 149         732 $globref->autoflush(1);
104 149         4521 $self->Next;
105             };
106             }
107              
108             sub _close_reopen {
109 308     308   827 my ($Die, $glob, $fno_want, $what, $err) = @_;
110 308         1129 local ($!, $^E);
111 308         1312 close *$glob;
112 308         546 my @fh;
113 308         405 while (1) {
114 27     27   200 no warnings 'io';
  27         52  
  27         4928  
115 326 100       6312 open *$glob, $what or $Die->($err->());
116 323         1625 my $fileno = fileno *$glob;
117 323 100       877 last if $fileno == $fno_want;
118 27         136 close *$glob;
119 27 100       83 if ($fileno > $fno_want) {
120 6         36 $Die->("Cannot get the desired descriptor, '$fno_want' (could it be that it is fdopened and so still open?)");
121             }
122 21 100       100 if (grep{$fileno == fileno($_)}@fh) {
  3         26  
123 1         5 $Die->("Getting several files opened on fileno $fileno");
124             }
125 20 100       385 open my $fh, $what or $Die->($err->());
126 19 100       225 if (fileno($fh) != $fileno) {
127 1         7 $Die->("Getting fileno " . fileno($fh) . "; expecting $fileno");
128             }
129 18         61 push @fh, $fh;
130             }
131 296         1410 close $_ for @fh;
132             }
133              
134             1; # End of Test::Trap::Builder::SystemSafe
135              
136             __END__