1package Test::Trap::Builder::SystemSafe;
2
3use version; $VERSION = qv('0.3.4');
4
5use strict;
6use warnings;
7use Test::Trap::Builder;
8use File::Temp qw( tempfile );
9use IO::Handle;
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
17use constant GOTPERLIO => (eval "use PerlIO (); 1" || 0);
18
19sub import {
20  shift; # package name
21  my $strategy_name = @_ ? shift : 'systemsafe';
22  my $strategy_option = @_ ? shift : {};
23  Test::Trap::Builder->capture_strategy( $strategy_name => $_ ) for sub {
24    my $self = shift;
25    my ($name, $fileno, $globref) = @_;
26    my $pid = $$;
27    if (tied *$globref or $fileno < 0) {
28      $self->Exception("SystemSafe only works with real file descriptors; aborting");
29    }
30    my ($fh, $file) = do {
31      local ($!, $^E);
32      tempfile( UNLINK => 1 ); # XXX: Test?
33    };
34    my ($fh_keeper, $autoflush_keeper, @io_layers, @restore_io_layers);
35    my $Die = $self->ExceptionFunction;
36    for my $buffer ($self->{$name}) {
37      $self->Teardown($_) for sub {
38        local ($!, $^E);
39        if ($pid == $$) {
40          # this process opened it, so it gets to collect the contents:
41          local $/;
42          $buffer .= $fh->getline;
43          close $fh; # don't leak this one either!
44          unlink $file;
45        }
46        close *$globref;
47        return unless $fh_keeper;
48        # close and reopen the file to the keeper!
49        my $fno = fileno $fh_keeper;
50        _close_reopen( $Die, $globref, $fileno, ">&$fno",
51                       sub {
52                         close $fh_keeper;
53                         sprintf "Cannot dup '%s' for %s: '%s'",
54                           $fno, $name, $!;
55                       },
56                     );
57        close $fh_keeper; # another potential leak, I suppose.
58        $globref->autoflush($autoflush_keeper);
59      IO_LAYERS: {
60          GOTPERLIO or last IO_LAYERS;
61          local($!, $^E);
62          binmode *$globref;
63          my @tmp = @restore_io_layers;
64          $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers(*$globref);
65          binmode *$globref, $_ for @tmp;
66        }
67      };
68    }
69    binmode $fh; # superfluous?
70    {
71      local ($!, $^E);
72      open $fh_keeper, ">&$fileno"
73        or $self->Exception("Cannot dup '$fileno' for $name: '$!'");
74    }
75  IO_LAYERS: {
76      GOTPERLIO or last IO_LAYERS;
77      local($!, $^E);
78      @restore_io_layers = PerlIO::get_layers(*$globref, output => 1);
79      if ($strategy_option->{preserve_io_layers}) {
80        @io_layers = @restore_io_layers;
81      }
82      if ($strategy_option->{io_layers}) {
83        push @io_layers, $strategy_option->{io_layers};
84      }
85    }
86    $autoflush_keeper = $globref->autoflush;
87    _close_reopen( $self->ExceptionFunction, $globref, $fileno, ">>$file",
88                   sub {
89                     sprintf "Cannot open %s for %s: '%s'",
90                       $file, $name, $!;
91                   },
92                 );
93  IO_LAYERS: {
94      GOTPERLIO or last IO_LAYERS;
95      local($!, $^E);
96      for my $h (*$globref, $fh) {
97        binmode $h;
98        my @tmp = @io_layers or next;
99        $_ eq $tmp[0] ? shift @tmp : last for PerlIO::get_layers($h);
100        binmode $h, $_ for @tmp;
101      }
102    }
103    $globref->autoflush(1);
104    $self->Next;
105  };
106}
107
108sub _close_reopen {
109  my ($Die, $glob, $fno_want, $what, $err) = @_;
110  local ($!, $^E);
111  close *$glob;
112  my @fh;
113  while (1) {
114    no warnings 'io';
115    open *$glob, $what or $Die->($err->());
116    my $fileno = fileno *$glob;
117    last if $fileno == $fno_want;
118    close *$glob;
119    if ($fileno > $fno_want) {
120      $Die->("Cannot get the desired descriptor, '$fno_want' (could it be that it is fdopened and so still open?)");
121    }
122    if (grep{$fileno == fileno($_)}@fh) {
123      $Die->("Getting several files opened on fileno $fileno");
124    }
125    open my $fh, $what or $Die->($err->());
126    if (fileno($fh) != $fileno) {
127      $Die->("Getting fileno " . fileno($fh) . "; expecting $fileno");
128    }
129    push @fh, $fh;
130  }
131  close $_ for @fh;
132}
133
1341; # End of Test::Trap::Builder::SystemSafe
135
136__END__
137
138=head1 NAME
139
140Test::Trap::Builder::SystemSafe - "Safe" capture strategies using File::Temp
141
142=head1 VERSION
143
144Version 0.3.4
145
146=head1 DESCRIPTION
147
148This module provides capture strategies I<systemsafe>, based on
149File::Temp, for the trap's output layers.  These strategies insists on
150reopening the output file handles with the same descriptors, and
151therefore, unlike L<Test::Trap::Builder::TempFile> and
152L<Test::Trap::Builder::PerlIO>, is able to trap output from forked-off
153processes, including system().
154
155The import accepts a name (as a string; default I<systemsafe>) and
156options (as a hashref; by default empty), and registers a capture
157strategy with that name and a variant implementation based on the
158options.
159
160Note that you may specify different strategies for each output layer
161on the trap.
162
163See also L<Test::Trap> (:stdout and :stderr) and
164L<Test::Trap::Builder> (output_layer).
165
166=head1 OPTIONS
167
168The following options are recognized:
169
170=head2 preserve_io_layers
171
172A boolean, indicating whether to apply to the handles writing to and
173reading from the tempfile, the same perlio layers as are found on the
174to-be-trapped output handle.
175
176=head2 io_layers
177
178A colon-separated string representing perlio layers to be applied to
179the handles writing to and reading from the tempfile.
180
181If the I<preserve_io_layers> option is set, these perlio layers will
182be applied on top of the original (preserved) perlio layers.
183
184=head1 CAVEATS
185
186Using File::Temp, we need privileges to create tempfiles.
187
188We need disk space for the output of every trap (it should clean up
189after the trap is sprung).
190
191Disk access may be slow -- certainly compared to the in-memory files
192of PerlIO.
193
194If the file handle we try to trap using this strategy is on an
195in-memory file, it would not be available to other processes in any
196case.  Rather than change the semantics of the trapped code or
197silently fail to trap output from forked-off processes, we just raise
198an exception in this case.
199
200If there is another file handle with the same descriptor (f ex after
201an C<< open OTHER, '>&=', THIS >>), we can't get that file descriptor.
202Rather than silently fail, we again raise an exception.
203
204If the options specify (explicitly or via preserve on handles with)
205perlio custom layers, they may (or may not) fail to apply to the
206tempfile read and write handles.
207
208Threads?  No idea.  It might even work correctly.
209
210=head1 BUGS
211
212Please report any bugs or feature requests directly to the author.
213
214=head1 AUTHOR
215
216Eirik Berg Hanssen, C<< <ebhanssen@cpan.org> >>
217
218=head1 COPYRIGHT & LICENSE
219
220Copyright 2006-2014 Eirik Berg Hanssen, All Rights Reserved.
221
222This program is free software; you can redistribute it and/or modify
223it under the same terms as Perl itself.
224
225=cut
226