Commit ac30123c16d5a6e48238d74897e1b7a2b955d434 - libcapture-tiny-perl

[svn-upgrade] Integrating new upstream version, libcapture-tiny-perl (0.07) Jonathan Yu 14 years ago

10 changed file(s) with 133 addition(s) and 113 deletion(s). Raw diff Collapse all Expand all

+12

-3

Changes less more

1	1	# Copyright (c) 2009 by David Golden. All rights reserved.
2	2	# Licensed under Apache License, Version 2.0 (the "License").
3	3	# You may not use this file except in compliance with the License.
4		# A copy of the License was distributed with this file or you may obtain a
	4	# A copy of the License was distributed with this file or you may obtain a
5	5	# copy of the License from http://www.apache.org/licenses/LICENSE-2.0
6	6
7	7	Revision history for Capture-Tiny
	8
	9	0.07 Sun Jan 24 00:18:45 EST 2010
	10
	11	Fixed:
	12
	13	- Changed test for $? preservation to be more portable
	14
	15	- Dropped support for Perl 5.8.0 specifically due to excessive bugs.
	16	Tests will bail out. (5.6.X is still supported)
8	17
9	18	0.06 Thu May 7 06:54:53 EDT 2009
10	19

55	64	Fixed:
56	65
57	66	- Tests skip if not Win32 and no fork() (rather than Build.PL and
58		Makefile.PL failing); this allows capture() on odd platforms, even if
	67	Makefile.PL failing); this allows capture() on odd platforms, even if
59	68	fork doesn't work
60	69
61	70	0.02 Tue Feb 17 17:24:35 EST 2009
62	71
63		Fixed:
	72	Fixed:
64	73
65	74	- Bug recovering output when STDOUT is empty (reported by Vincent Pit)
66	75

-0

MANIFEST.SKIP less more

21	21	^_build
22	22	^cover_db
23	23	^.*\.bat$
	24	^MYMETA\.
24	25
25	26	# Temp, old, vi and emacs files.
26	27	~$

+23

-21

META.yml less more

0	0	---
1		name: Capture-Tiny
2		version: 0.06
	1	abstract: 'Capture STDOUT and STDERR from Perl, XS or external programs'
3	2	author:
4	3	- 'David Golden <dagolden@cpan.org>'
5		abstract: 'Capture STDOUT and STDERR from Perl, XS or external programs'
	4	build_requires:
	5	Test::More: 0.62
	6	configure_requires:
	7	Module::Build: 0.36
	8	generated_by: 'Module::Build version 0.3603'
6	9	license: apache
7		resources:
8		bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Capture-Tiny
9		repository: http://github.com/dagolden/capture-tiny/
	10	meta-spec:
	11	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	12	version: 1.4
	13	name: Capture-Tiny
	14	no_index:
	15	directory:
	16	- examples
	17	- inc
	18	- t
	19	provides:
	20	Capture::Tiny:
	21	file: lib/Capture/Tiny.pm
	22	version: 0.07
10	23	requires:
11	24	Exporter: 0
12	25	File::Spec: 0
13	26	File::Temp: 0.14
14	27	IO::Handle: 0
15	28	perl: 5.006
16		build_requires:
17		Test::More: 0.62
18		provides:
19		Capture::Tiny:
20		file: lib/Capture/Tiny.pm
21		version: 0.06
22		generated_by: Module::Build version 0.3201
23		meta-spec:
24		url: http://module-build.sourceforge.net/META-spec-v1.4.html
25		version: 1.4
26		no_index:
27		directory:
28		- examples
29		- inc
30		- t
	29	resources:
	30	bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Capture-Tiny
	31	repository: http://github.com/dagolden/capture-tiny/
	32	version: 0.07

-9

Makefile.PL less more

0		# Note: this file was auto-generated by Module::Build::Compat version 0.32_01
	0	# Note: this file was auto-generated by Module::Build::Compat version 0.3603
1	1	require 5.006;
2	2	use ExtUtils::MakeMaker;
3	3	WriteMakefile
4	4	(
5		'PL_FILES' => {},
6		'INSTALLDIRS' => 'site',
7	5	'NAME' => 'Capture::Tiny',
8		'EXE_FILES' => [],
9	6	'VERSION_FROM' => 'lib/Capture/Tiny.pm',
10	7	'PREREQ_PM' => {
11		'Test::More' => '0.62',
	8	'Exporter' => 0,
	9	'File::Spec' => 0,
	10	'File::Temp' => '0.14',
12	11	'IO::Handle' => 0,
13		'File::Temp' => '0.14',
14		'File::Spec' => 0,
15		'Exporter' => 0
16		}
	12	'Test::More' => '0.62'
	13	},
	14	'INSTALLDIRS' => 'site',
	15	'EXE_FILES' => [],
	16	'PL_FILES' => {}
17	17	)
18	18	;

+36

-32

README less more

2	2	programs
3	3
4	4	VERSION
5		This documentation describes version 0.06.
	5	This documentation describes version 0.07.
6	6
7	7	SYNOPSIS
8	8	use Capture::Tiny qw/capture tee capture_merged tee_merged/;
9
10		($stdout, $stderr) = capture {
11		# your code here
12		};
13
14		($stdout, $stderr) = tee {
15		# your code here
16		};
17
18		$merged = capture_merged {
19		# your code here
20		};
21
22		$merged = tee_merged {
	9
	10	($stdout, $stderr) = capture {
	11	# your code here
	12	};
	13
	14	($stdout, $stderr) = tee {
	15	# your code here
	16	};
	17
	18	$merged = capture_merged {
	19	# your code here
	20	};
	21
	22	$merged = tee_merged {
23	23	# your code here
24	24	};
25	25

42	42	($stdout, $stderr) = capture \&code;
43	43	$stdout = capture \&code;
44	44
45		The "capture" function takes a code reference and returns what is sent
	45	The `capture' function takes a code reference and returns what is sent
46	46	to STDOUT and STDERR. In scalar context, it returns only STDOUT. If no
47	47	output was received, returns an empty string. Regardless of context, all
48	48	output is captured -- nothing is passed to the existing handles.

57	57	capture_merged
58	58	$merged = capture_merged \&code;
59	59
60		The "capture_merged" function works just like "capture" except STDOUT
	60	The `capture_merged' function works just like `capture' except STDOUT
61	61	and STDERR are merged. (Technically, STDERR is redirected to STDOUT
62	62	before executing the function.) If no output was received, returns an
63		empty string. As with "capture" it may be called in block form.
	63	empty string. As with `capture' it may be called in block form.
64	64
65	65	Caution: STDOUT and STDERR output in the merged result are not
66	66	guaranteed to be properly ordered due to buffering.

69	69	($stdout, $stderr) = tee \&code;
70	70	$stdout = tee \&code;
71	71
72		The "tee" function works just like "capture", except that output is
	72	The `tee' function works just like `capture', except that output is
73	73	captured as well as passed on to the original STDOUT and STDERR. As with
74		"capture" it may be called in block form.
	74	`capture' it may be called in block form.
75	75
76	76	tee_merged
77	77	$merged = tee_merged \&code;
78	78
79		The "tee_merged" function works just like "capture_merged" except that
80		output is captured as well as passed on to STDOUT. As with "capture" it
	79	The `tee_merged' function works just like `capture_merged' except that
	80	output is captured as well as passed on to STDOUT. As with `capture' it
81	81	may be called in block form.
82	82
83	83	Caution: STDOUT and STDERR output in the merged result are not

85	85
86	86	LIMITATIONS
87	87	Portability
88		Portability is a goal, not a guarantee. "tee" requires fork, except on
89		Windows where "system(1, @cmd)" is used instead. Not tested on any
	88	Portability is a goal, not a guarantee. `tee' requires fork, except on
	89	Windows where `system(1, @cmd)' is used instead. Not tested on any
90	90	particularly esoteric platforms yet.
91	91
92	92	PerlIO layers
93	93	Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8'
94	94	or ':crlf' when capturing. Layers should be applied to STDOUT or STDERR
95		before the call to "capture" or "tee".
	95	before the call to `capture' or `tee'.
96	96
97	97	Closed STDIN, STDOUT or STDERR
98	98	Capture::Tiny will work even if STDIN, STDOUT or STDERR have been

104	104
105	105	Scalar filehandles and STDIN, STDOUT or STDERR
106	106	If STDOUT or STDERR are reopened to scalar filehandles prior to the call
107		to "capture" or "tee", then Capture::Tiny will override the output
108		handle for the duration of the "capture" or "tee" call and then send
	107	to `capture' or `tee', then Capture::Tiny will override the output
	108	handle for the duration of the `capture' or `tee' call and then send
109	109	captured output to the output handle after the capture is complete.
110	110	(Requires Perl 5.8)
111	111

113	113	scalar reference.
114	114
115	115	Tied STDIN, STDOUT or STDERR
116		If STDOUT or STDERR are tied prior to the call to "capture" or "tee",
	116	If STDOUT or STDERR are tied prior to the call to `capture' or `tee',
117	117	then Capture::Tiny will attempt to override the tie for the duration of
118		the "capture" or "tee" call and then send captured output to the tied
	118	the `capture' or `tee' call and then send captured output to the tied
119	119	handle after the capture is complete. (Requires Perl 5.8)
120	120
121	121	Capture::Tiny does not (yet) support resending utf8 encoded data to a

125	125	capturing or teeing when STDIN is tied is currently broken on Windows.
126	126
127	127	Modifiying STDIN, STDOUT or STDERR during a capture
128		Attempting to modify STDIN, STDOUT or STDERR during "capture" or "tee"
	128	Attempting to modify STDIN, STDOUT or STDERR during `capture' or `tee'
129	129	is almost certainly going to cause problems. Don't do that.
	130
	131	No support for Perl 5.8.0
	132	It's just too buggy when it comes to layers and UTF8.
130	133
131	134	BUGS
132	135	Please report any bugs or feature requests using the CPAN Request
133	136	Tracker. Bugs can be submitted through the web interface at
134		<http://rt.cpan.org/Dist/Display.html?Queue=Capture-Tiny>
	137	http://rt.cpan.org/Dist/Display.html?Queue=Capture-Tiny
135	138
136	139	When submitting a bug or request, please include a test-file or a patch
137	140	to an existing test-file that illustrates the bug or desired feature.

193	196	Licensed under Apache License, Version 2.0 (the "License"). You may not
194	197	use this file except in compliance with the License. A copy of the
195	198	License was distributed with this file or you may obtain a copy of the
196		License from http://www.apache.org/licenses/LICENSE-2.0
	199	License from
	200	http:E<sol>E<sol>www.apache.orgE<sol>licensesE<sol>LICENSE-2.0
197	201
198	202	Files produced as output though the use of this software, shall not be
199	203	considered Derivative Works, but shall be considered the original work

+39

-32

lib/Capture/Tiny.pm less more

0	0	# Copyright (c) 2009 by David Golden. All rights reserved.
1	1	# Licensed under Apache License, Version 2.0 (the "License").
2	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
	3	# A copy of the License was distributed with this file or you may obtain a
4	4	# copy of the License from http://www.apache.org/licenses/LICENSE-2.0
5	5
6	6	package Capture::Tiny;

13	13	use File::Spec ();
14	14	use File::Temp qw/tempfile tmpnam/;
15	15	# Get PerlIO or fake it
16		BEGIN { eval { require PerlIO; 1 } or *PerlIO::get_layers = sub { return () }; }
17
18		our $VERSION = '0.06';
	16	BEGIN {
	17	eval { require PerlIO; PerlIO->can('get_layers') }
	18	or *PerlIO::get_layers = sub { return () };
	19	}
	20
	21	our $VERSION = '0.07';
19	22	$VERSION = eval $VERSION; ## no critic
20	23	our @ISA = qw/Exporter/;
21	24	our @EXPORT_OK = qw/capture capture_merged tee tee_merged/;

35	38	# This is annoying, but seems to be the best that can be done
36	39	# as a simple, portable IPC technique
37	40	#--------------------------------------------------------------------------#
38		my @cmd = ($^X, '-e', '$SIG{HUP}=sub{exit}; '
	41	my @cmd = ($^X, '-e', '$SIG{HUP}=sub{exit}; '
39	42	. 'if( my $fn=shift ){ open my $fh, qq{>$fn}; print {$fh} $$; close $fh;} '
40	43	. 'my $buf; while (sysread(STDIN, $buf, 2048)) { '
41		. 'syswrite(STDOUT, $buf); syswrite(STDERR, $buf)}'
	44	. 'syswrite(STDOUT, $buf); syswrite(STDERR, $buf)}'
42	45	);
43	46
44	47	#--------------------------------------------------------------------------#

71	74	}
72	75
73	76	my %dup; # cache this so STDIN stays fd0
74		my %proxy_count;
	77	my %proxy_count;
75	78	sub _proxy_std {
76	79	my %proxies;
77	80	if ( ! defined fileno STDIN ) {

121	124
122	125	sub _unproxy {
123	126	my (%proxies) = @_;
124		_debug( "# unproxing " . join(" ", keys %proxies) . "\n" );
	127	_debug( "# unproxing " . join(" ", keys %proxies) . "\n" );
125	128	for my $p ( keys %proxies ) {
126	129	$proxy_count{$p}--;
127	130	_debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
128	131	if ( ! $proxy_count{$p} ) {
129	132	_close $proxies{$p};
130		_close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
	133	_close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
131	134	delete $dup{$p};
132	135	}
133	136	}

135	138
136	139	sub _copy_std {
137	140	my %handles = map { $_, IO::Handle->new } qw/stdin stdout stderr/;
138		_debug( "# copying std handles ...\n" );
139		_open $handles{stdin}, "<&STDIN";
	141	_debug( "# copying std handles ...\n" );
	142	_open $handles{stdin}, "<&STDIN";
140	143	_open $handles{stdout}, ">&STDOUT";
141	144	_open $handles{stderr}, ">&STDERR";
142	145	return \%handles;

158	161	# setup pipes
159	162	$stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
160	163	pipe $stash->{reader}{$which}, $stash->{tee}{$which};
161		_debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " "
162		. fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which})
	164	_debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " "
	165	. fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which})
163	166	. " " . fileno( $stash->{reader}{$which}) . "\n" );
164	167	select((select($stash->{tee}{$which}), $\|=1)[0]); # autoflush
165	168	# setup desired redirection for parent and child

194	197
195	198	sub _fork_exec {
196	199	my ($which, $stash) = @_;
197		my $pid = fork;
	200	my $pid = fork;
198	201	if ( not defined $pid ) {
199	202	Carp::confess "Couldn't fork(): $!";
200	203	}
201	204	elsif ($pid == 0) { # child
202		_debug( "# in child process ...\n" );
	205	_debug( "# in child process ...\n" );
203	206	untie STDIN; untie STDOUT; untie *STDERR;
204	207	_close $stash->{tee}{$which};
205		_debug( "# redirecting handles in child ...\n" );
	208	_debug( "# redirecting handles in child ...\n" );
206	209	_open_std( $stash->{child}{$which} );
207		_debug( "# calling exec on command ...\n" );
	210	_debug( "# calling exec on command ...\n" );
208	211	exec @cmd, $stash->{flag_files}{$which};
209	212	}
210	213	$stash->{pid}{$which} = $pid

212	215
213	216	sub _files_exist { -f $_ \|\| return 0 for @_; return 1 }
214	217
215		sub _wait_for_tees {
	218	sub _wait_for_tees {
216	219	my ($stash) = @_;
217	220	my $start = time;
218	221	my @files = values %{$stash->{flag_files}};
219	222	1 until _files_exist(@files) \|\| (time - $start > 30);
220	223	Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
221		unlink $_ for @files;
	224	unlink $_ for @files;
222	225	}
223	226
224	227	sub _kill_tees {

236	239	}
237	240	}
238	241
239		sub _slurp {
240		seek $_[0],0,0; local $/; return scalar readline $_[0];
	242	sub _slurp {
	243	seek $_[0],0,0; local $/; return scalar readline $_[0];
241	244	}
242	245
243	246	#--------------------------------------------------------------------------#

245	248	#--------------------------------------------------------------------------#
246	249
247	250	sub _capture_tee {
248		_debug( "# starting _capture_tee with (@_)...\n" );
	251	_debug( "# starting _capture_tee with (@_)...\n" );
249	252	my ($tee_stdout, $tee_stderr, $merge, $code) = @_;
250	253	# save existing filehandles and setup captures
251	254	local CT_ORIG_STDIN = STDIN ;

265	268	$localize{stderr}++, local(*STDERR) if grep { $_ eq 'scalar' } @{$layers{stderr}};
266	269	$localize{stdout}++, local(STDOUT), _open( \STDOUT, ">&=1") if tied *STDOUT && $] >= 5.008;
267	270	$localize{stderr}++, local(STDERR), _open( \STDERR, ">&=2") if tied *STDERR && $] >= 5.008;
268		_debug( "# localized $_\n" ) for keys %localize;
	271	_debug( "# localized $_\n" ) for keys %localize;
269	272	my %proxy_std = _proxy_std();
270	273	_debug( "# proxy std is @{ [%proxy_std] }\n" );
271	274	my $stash = { old => _copy_std() };

286	289	# finalize redirection
287	290	$stash->{new}{stderr} = $stash->{new}{stdout} if $merge;
288	291	$stash->{new}{stdin} = $stash->{old}{stdin};
289		_debug( "# redirecting in parent ...\n" );
	292	_debug( "# redirecting in parent ...\n" );
290	293	_open_std( $stash->{new} );
291	294	# execute user provided code
292	295	my $exit_code;
293	296	{
294	297	local STDIN = CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
295	298	local STDERR = STDOUT if $merge; # minimize buffer mixups during $code
296		_debug( "# finalizing layers ...\n" );
	299	_debug( "# finalizing layers ...\n" );
297	300	_relayer(\*STDOUT, $layers{stdout});
298	301	_relayer(\*STDERR, $layers{stderr}) unless $merge;
299		_debug( "# running code $code ...\n" );
	302	_debug( "# running code $code ...\n" );
300	303	$code->();
301	304	$exit_code = $?; # save this for later
302	305	}
303	306	# restore prior filehandles and shut down tees
304		_debug( "# restoring ...\n" );
	307	_debug( "# restoring ...\n" );
305	308	_open_std( $stash->{old} );
306	309	_close( $_ ) for values %{$stash->{old}}; # don't leak fds
307	310	_unproxy( %proxy_std );

312	315	_debug( "# slurping captured $_ with layers: @{[PerlIO::get_layers($stash->{capture}{$_})]}\n") for qw/stdout stderr/;
313	316	my $got_out = _slurp($stash->{capture}{stdout});
314	317	my $got_err = $merge ? q() : _slurp($stash->{capture}{stderr});
315		print CT_ORIG_STDOUT $got_out if $localize{stdout} && $tee_stdout;
316		print CT_ORIG_STDERR $got_err if !$merge && $localize{stderr} && $tee_stdout;
	318	print CT_ORIG_STDOUT $got_out if $localize{stdout} && $tee_stdout;
	319	print CT_ORIG_STDERR $got_err if !$merge && $localize{stderr} && $tee_stdout;
317	320	$? = $exit_code;
318		_debug( "# ending _capture_tee with (@_)...\n" );
	321	_debug( "# ending _capture_tee with (@_)...\n" );
319	322	return $got_out if $merge;
320	323	return wantarray ? ($got_out, $got_err) : $got_out;
321	324	}
322	325
323	326	#--------------------------------------------------------------------------#
324		# create API subroutines from [tee STDOUT flag, tee STDERR, merge flag]
	327	# create API subroutines from [tee STDOUT flag, tee STDERR, merge flag]
325	328	#--------------------------------------------------------------------------#
326	329
327	330	my %api = (

332	335	);
333	336
334	337	for my $sub ( keys %api ) {
335		my $args = join q{, }, @{$api{$sub}};
	338	my $args = join q{, }, @{$api{$sub}};
336	339	eval "sub $sub(&) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
337	340	}
338	341

485	488
486	489	Attempting to modify STDIN, STDOUT or STDERR ~during~ {capture} or {tee} is
487	490	almost certainly going to cause problems. Don't do that.
	491
	492	== No support for Perl 5.8.0
	493
	494	It's just too buggy when it comes to layers and UTF8.
488	495
489	496	= BUGS
490	497

-1

lib/Capture/Tiny.pod less more

7	7
8	8	=head1 VERSION
9	9
10		This documentation describes version 0.06.
	10	This documentation describes version 0.07.
11	11
12	12	=head1 SYNOPSIS
13	13

145	145	Attempting to modify STDIN, STDOUT or STDERR I<during> C<<< capture >>> or C<<< tee >>> is
146	146	almost certainly going to cause problems. Don't do that.
147	147
	148	=head2 No support for Perl 5.8.0
	149
	150	It's just too buggy when it comes to layers and UTF8.
	151
148	152	=head1 BUGS
149	153
150	154	Please report any bugs or feature requests using the CPAN Request Tracker.

-0

t/01-Capture-Tiny.t less more

17	17
18	18	plan tests => 2 + 2 * @api;
19	19
	20	if ( $] eq '5.008' ) {
	21	BAIL_OUT("OS unsupported: Perl 5.8.0 is too buggy for Capture::Tiny");
	22	}
	23
20	24	require_ok( 'Capture::Tiny' );
21	25
22	26	can_ok('Capture::Tiny', $_) for @api;

-14

t/09-preserve-exit-code.t less more

10	10	use Capture::Tiny qw/capture/;
11	11	use Config;
12	12
13		plan tests => 4;
	13	plan tests => 2;
14	14
15	15	my $builder = Test::More->builder;
16	16	binmode($builder->failure_output, ':utf8') if $] >= 5.008;

18	18	my $fd = next_fd;
19	19
20	20	capture {
21		system($^X, '-e', 'exit 42');
	21	$? = 42;
22	22	};
23		is( $? >> 8, 42, "exit code was 42" );
24
25		SKIP: {
26		skip "alarm() not available", 1
27		unless $Config{d_alarm};
28
29		capture {
30		system($^X, '-e', 'alarm 1; $now = time; 1 while (time - $now < 5)');
31		};
32		ok( $?, '$? is non-zero' );
33		is( ($^O eq 'MSWin32' ? $? >> 8 : $? & 127), sig_num('ALRM'), "caught SIGALRM" );
34		}
	23	is( $?, 42, "\$\? preserved after capture ends" );
35	24
36	25	is( next_fd, $fd, "no file descriptors leaked" );
37	26

-1

t/lib/Cases.pm less more

48	48	my %texts = (
49	49	short => 'Hello World',
50	50	multiline => 'First line\nSecond line\n',
51		( $] < 5.008 ? () : ( unicode => 'Hi! \x{263a}\n') ),
	51	( $] lt "5.008" ? () : ( unicode => 'Hi! \x{263a}\n') ),
52	52	);
53	53
54	54	#--------------------------------------------------------------------------#