PFLANZE / FunctionalPerl-0.72.63-TRIAL / lib / Chj / xIO.pm 

            

              
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

              
#
# Copyright (c) 2013-2020 Christian Jaeger, copying@christianjaeger.ch
#
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file COPYING.md that came
# bundled with this file.
#
=head1 NAME
Chj::xIO - some IO utilities
=head1 SYNOPSIS
    use Chj::xIO qw(
       capture_stdout capture_stdout_
       capture_stderr capture_stderr_
       );
    is capture_stdout { print "Hi!" }, "Hi!";
    is substr(capture_stderr { warn "nah" }, 0,3), "nah";
    # if you want to avoid the '&' prototype:
    is capture_stdout_(sub { print "Hi!" }), "Hi!";
    use Chj::xIO qw(with_output_to_file);
    my $res = with_output_to_file(".xIO-test-out", sub { print "Hi"; 123 });
    is $res, 123;
    is do { open my $in, "<", ".xIO-test-out"; local $/; <$in> }, "Hi";
=head1 DESCRIPTION
Oh, there's Capture::Tiny ! Even uses the same names. TODO: move to
that. Although, Capture::Tiny might be using 'dup', which would not be
thread safe.
=head1 NOTE
This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.
=cut
package Chj::xIO;
use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use Exporter "import";
our @EXPORT    = qw();
our @EXPORT_OK = qw(
    capture_stdout capture_stdout_
    capture_stderr capture_stderr_
    with_output_to_file
);
our %EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
use FP::Carp;
sub capture_stdout_ {
    my ($thunk) = @_;
    my $buf = "";
    open my $out, ">", \$buf or die $!;
    {
        # XX threadsafe or not?
        local *STDOUT = $out;
        &$thunk();    # dropping results
    }
    close $out or die $!;
    $buf
}
sub capture_stdout (&) {
    capture_stdout_(@_)
}
# stupid COPY-PASTE
sub capture_stderr_ {
    my ($thunk) = @_;
    my $buf = "";
    open my $out, ">", \$buf or die $!;
    {
        # XX threadsafe or not?
        local *STDERR = $out;
        &$thunk();    # dropping results
    }
    close $out or die $!;
    $buf
}
sub capture_stderr (&) {
    capture_stderr_(@_)
}
sub with_output_to_file {
    @_ == 2 or fp_croak_arity 2;
    my ($file, $thunk) = @_;
    my $wantarray = wantarray;
    my @res;
    open my $out, ">", $file
        or fp_croak "with_output_to_file: open '$file': $!";
    binmode $out, ":encoding(UTF-8)"
        or fp_croak "with_output_to_file: binmode '$file': $!";
    {
        local *STDOUT = $out;
        if (defined $wantarray) {
            if ($wantarray) {
                @res = &$thunk();
            } else {
                @res = scalar &$thunk();
            }
        } else {
            &$thunk();
        }
    }
    close $out or fp_croak "with_output_to_file: close '$file': $!";
    $wantarray ? @res : $res[0]
}
1