1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
package PrimitiveCapture;
use strict;
use warnings;
if ("$]" >= 5.008000) {
eval "#line @{[__LINE__+1]} ".q{"lib/PrimitiveCapture.pm"
sub capture_stdout {
my $sub = shift;
my $stdout;
open my $oldout, ">&STDOUT" or die "Can't dup STDOUT: $!";
close STDOUT;
open STDOUT, '>', \$stdout or die "Can't open STDOUT: $!";
$sub->();
close STDOUT;
open STDOUT, ">&", $oldout or die "Can't dup \$oldout: $!";
return $stdout;
}
sub capture_stderr {
my $sub = shift;
my $stderr;
open my $olderr, ">&STDERR" or die "Can't dup STDERR: $!";
close STDERR;
open STDERR, '>', \$stderr or die "Can't open STDERR: $!";
$sub->();
close STDERR;
open STDERR, ">&", $olderr or die "Can't dup \$olderr: $!";
return $stderr;
}
}; die $@ unless $@ eq "";
} else {
eval "#line @{[__LINE__+1]} ".q{"lib/PrimitiveCapture.pm"
use File::Spec;
use File::Temp;
my $tmpdir;
my $i = 0;
sub _tmpfile {
$tmpdir ||= File::Temp::tempdir(CLEANUP => 1, TMPDIR => 1);
return File::Spec->catfile($tmpdir, $i++);
}
sub _slurp {
my $filename = shift;
open my $fh, "<", $filename or die "Can't read $filename: $!";
local $/ = undef;
my $content = <$fh>;
defined $content or die "Can't read $filename: $!";
return $content;
}
sub capture_stdout {
my $sub = shift;
my $tmpfile = _tmpfile();
local *OLDSTDOUT;
open OLDSTDOUT, ">&STDOUT" or die "Can't dup STDOUT: $!";
close STDOUT;
open STDOUT, '>', $tmpfile or die "Can't open STDOUT: $!";
$sub->();
close STDOUT;
open STDOUT, ">&OLDSTDOUT" or die "Can't dup OLDSTDOUT: $!";
close OLDSTDOUT;
return _slurp($tmpfile);
}
sub capture_stderr {
my $sub = shift;
my $tmpfile = _tmpfile();
local *OLDSTDERR;
open OLDSTDERR, ">&STDERR" or die "Can't dup STDERR: $!";
close STDERR;
open STDERR, '>', $tmpfile or die "Can't open STDERR: $!";
$sub->();
close STDERR;
open STDERR, ">&OLDSTDERR" or die "Can't dup OLDSTDERR: $!";
close OLDSTDERR;
return _slurp($tmpfile);
}
}; die $@ unless $@ eq "";
}
1;
|
