Codebase list libcapture-tiny-perl / 7da4795
Improve accurancy of relayering David Golden 8 years ago
3 changed file(s) with 103 addition(s) and 4 deletion(s). Raw diff Collapse all Expand all
+8
-0
Changes less more
00 Revision history for Capture-Tiny
11
22 {{$NEXT}}
3
4 Fixed:
5
6 - Application of layers to handles during and after capture now attempts
7 to more accurately duplicate the original layers, including potential
8 duplicate layers. Because of the unusual ways that layers are ordered
9 and applied, exact duplication is not guaranteeed, but this should be
10 better that what Capture::Tiny did before.
311
412 0.30 2015-05-15 20:43:54-04:00 America/New_York
513
+12
-4
lib/Capture/Tiny.pm less more
8282 sub _relayer {
8383 my ($fh, $layers) = @_;
8484 # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
85 my %seen = ( unix => 1, perlio => 1 ); # filter these out
86 my @unique = grep { !$seen{$_}++ } @$layers;
87 # _debug("# applying unique layers (@unique) to @{[fileno $fh]}\n");
88 binmode($fh, join(":", ":raw", @unique));
85
86 # eliminate pseudo-layers
87 binmode( $fh, ":raw" );
88 # strip off real layers until only :unix is left
89 while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
90 binmode( $fh, ":pop" );
91 }
92 # apply other layers
93 my @to_apply = @$layers;
94 shift @to_apply; # eliminate initial :unix
95 # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n");
96 binmode($fh, ":" . join(":",@to_apply));
8997 }
9098
9199 sub _name {
+83
-0
t/19-relayering.t less more
0 # Copyright (c) 2009 by David Golden. All rights reserved.
1 # Licensed under Apache License, Version 2.0 (the "License").
2 # You may not use this file except in compliance with the License.
3 # A copy of the License was distributed with this file or you may obtain a
4 # copy of the License from http://www.apache.org/licenses/LICENSE-2.0
5
6 use strict;
7 use warnings;
8 use Test::More;
9 use lib 't/lib';
10 use Utils qw/next_fd sig_num/;
11 use Capture::Tiny ':all';
12
13 unless ( PerlIO->can('get_layers') ) {
14 plan skip_all => "Requires PerlIO::getlayers";
15 }
16
17 plan 'no_plan';
18
19 local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts
20
21 my $builder = Test::More->builder;
22 binmode( $builder->failure_output, ':utf8' ) if $] >= 5.008;
23
24 my $fd = next_fd;
25 my ( $out, $err, $res, @res, %before, %inner, %outer );
26
27 sub _set_layers {
28 my ($fh, $new_layers) = @_;
29 # eliminate pseudo-layers
30 binmode( $fh, ":raw" ) or die "can't binmode $fh";
31 # strip off real layers until only :unix is left
32 while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
33 binmode( $fh, ":pop" ) or die "can't binmode $fh";
34 }
35 binmode($fh, $new_layers);
36 }
37
38 sub _get_layers {
39 return (
40 stdout => [ PerlIO::get_layers( *STDOUT, output => 1 ) ],
41 stderr => [ PerlIO::get_layers( *STDERR, output => 1 ) ],
42 );
43 }
44
45 sub _cmp_layers {
46 local $Test::Builder::Level = $Test::Builder::Level + 1;
47 my ($got, $exp, $label) = @_;
48
49 ($got, $exp) = map { ":" . join(":", @$_) } $got, $exp;
50 is( $got, $exp, $label );
51 }
52
53 #--------------------------------------------------------------------------#
54 # relayer should duplicate layers
55 #--------------------------------------------------------------------------#
56
57 _set_layers( \*STDOUT, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" );
58 _set_layers( \*STDERR, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" );
59
60 %before = _get_layers();
61
62 ( $out, $err, @res ) = capture {
63 %inner = _get_layers();
64 print STDOUT "foo\n";
65 print STDERR "bar\n";
66 };
67
68 %outer = _get_layers();
69
70 _cmp_layers( $inner{$_}, $before{$_}, "$_: layers inside capture match previous" )
71 for qw/stdout stderr/;
72 _cmp_layers( $outer{$_}, $before{$_}, "$_: layers after capture match previous" )
73 for qw/stdout stderr/;
74
75 #--------------------------------------------------------------------------#
76 # finish
77 #--------------------------------------------------------------------------#
78
79 is( next_fd, $fd, "no file descriptors leaked" );
80
81 exit 0;
82 # vim: set ts=4 sts=4 sw=4 et tw=75: