File Coverage

blib/lib/Text/OutputFilter.pm
Criterion Covered Total %
statement 85 87 97.7
branch 41 44 93.1
condition 10 12 83.3
subroutine 20 20 100.0
pod n/a
total 156 163 95.7


line stmt bran cond sub pod time code
1             package Text::OutputFilter;
2              
3 6     6   4567 use strict;
  6         13  
  6         171  
4 6     6   31 use warnings;
  6         13  
  6         289  
5              
6             our $VERSION = "0.25";
7              
8             =head1 NAME
9              
10             OutputFilter - Enable post processing of output without fork
11              
12             =head1 SYNOPSIS
13              
14             use Text::OutputFilter;
15              
16             my $bucket = "";
17             tie *STDOUT, "Text::OutputFilter";
18             tie *HANDLE, "Text::OutputFilter", 4;
19             tie *HANDLE, "Text::OutputFilter", 4, *STDOUT;
20             tie *STDOUT, "Text::OutputFilter", 4, \$bucket;
21             tie *OUTPUT, "Text::OutputFilter", 4, *STDOUT, sub { "$_[0]" };
22              
23             =head1 DESCRIPTION
24              
25             This interface enables some post-processing on output streams,
26             like adding a left margin.
27              
28             The tied filehandle is opened unbuffered, but the output is line
29             buffered. The C takes three optional arguments:
30              
31             =over 4
32              
33             =item Left Margin
34              
35             The left margin must be a positive integer and defaults to C<4> spaces.
36              
37             =item Output Stream
38              
39             The output stream must be an already open stream, with writing
40             enabled. The default is C<*STDOUT>. All input methods on the new
41             stream are disabled. If a reference to a scalar is passed, it will
42             be opened as PerlIO::scalar - in-memory IO, scalar IO. No checks
43             performed to see if your perl supports it. If you want it, and your
44             perl does not, upgrade.
45              
46             Using C on the new stream is allowed and supported.
47              
48             OPEN, SEEK, and WRITE are not (yet) implemented.
49              
50             =item Line Modifying Function
51              
52             The output is line buffered, to enable line-modifier functions.
53             The line (without newline) is passed as the only argument to the
54             sub-ref, whose output is printed after the prefix from the first
55             argument. A newline is printed after the sub-ref's output.
56              
57             To B a line, as in I it from the stream, make the
58             sub return I.
59              
60             =back
61              
62             =head1 TODO
63              
64             Tests, tests, tests.
65             Tests with older perls
66              
67             =head1 AUTHOR
68              
69             H.Merijn Brand
70              
71             =head1 COPYRIGHT AND LICENSE
72              
73             Copyright (C) 2006-2023 H.Merijn Brand for PROCURA B.V.
74              
75             This library is free software; you can redistribute it and/or modify
76             it under the same terms as Perl itself.
77              
78             =head1 SEE ALSO
79              
80             perl(1), perlopen(1), 'open STDOUT, "|-"', Text::Filter
81              
82             =cut
83              
84 6     6   33 use Carp;
  6         12  
  6         7795  
85              
86             sub TIEHANDLE {
87 25     25   19226 my ($class, $lm, $io, $ref, $fno) = @_;
88              
89 25 100       78 defined $lm or $lm = 4;
90 25 100       62 defined $io or $io = *STDOUT;
91 25 100   8   87 defined $ref or $ref = sub { shift };
  8         16  
92              
93 25 100 100     616 ref $lm || $lm !~ m/^\d+$/ and
94             croak "OutputFilter tie's 1st arg must be numeric";
95 22 100       542 ref $ref eq "CODE" or
96             croak "OutputFilter tie's 3rd arg must be CODE-ref";
97              
98 17         26 my $fh;
99 17 50 66     83 if (ref $io eq "GLOB" and ref *{$io}{IO} eq "IO::Handle") {
  1 100       5  
100 0         0 open $fh, ">&", *{$io}{IO};
  0         0  
101             }
102             elsif (ref $io eq "SCALAR") {
103 6     6   40 open $fh, ">", $io;
  6         130  
  6         51  
  11         274  
104             }
105             else {
106 6         10 eval { $fno = fileno $io };
  6         24  
107 6 100 100     464 defined $fno && $fno >= 0 or
108             croak "OutputFilter tie's 2nd arg must be the output handle\n";
109 1         25 open $fh, ">&", $fno;
110             }
111 12 50       4393 $fh or croak "OutputFilter cannot dup the output handle: $!";
112 12         66 select ((select ($fh), $| = 1)[0]);
113              
114 12         107 bless {
115             pfx => " " x $lm,
116             sb => $ref,
117             io => $fh,
118              
119             line => "",
120              
121             closed => 0,
122             }, $class;
123             } # TIEHANDLE
124              
125             sub BINMODE {
126 3     3   11 my $self = shift;
127 3 100       88 $self->{closed} and croak "Cannot set binmode on closed filehandle";
128 2 100       6 if (@_) {
129 1         2 my $mode = shift;
130 1         8 binmode $self->{io}, $mode;
131             }
132             else {
133 1         7 binmode $self->{io};
134             }
135             } # BINMODE
136              
137             sub FILENO {
138 1     1   3 my $self = shift;
139 1         6 fileno $self->{io};
140             } # FILENO
141              
142             sub _Filter_ {
143 18     18   41 my ($nl, $pfx, $sub, $line) = @_;
144 18         40 my $l = $sub->($line);
145 18 100       193 defined $l ? $pfx . $l . ($nl ? "\n" : "") : "";
    100          
146             } # _Filter_
147              
148             sub PRINT {
149 20     20   10026 my $self = shift;
150 20         40 my ($pfx, $io, $sub) = @{$self}{qw( pfx io sb )};
  20         70  
151              
152 20 100       130 $self->{closed} and croak "Cannot print to closed filehandle";
153              
154 19 100       47 my $fsep = defined $, ? $, : "";
155 19 100       47 my $rsep = defined $\ ? $\ : "";
156 19         60 my $line = $self->{line} . (join $fsep => @_) . $rsep;
157 19         60 my @line = split m/\n/, $line, -1;
158 19         41 $self->{line} = pop @line;
159 19         33 print { $io } map { _Filter_ (1, $pfx, $sub, $_) } @line;
  19         62  
  15         40  
160             } # PRINT
161              
162             sub PRINTF {
163 3     3   641 my $self = shift;
164 3         6 my ($pfx, $io, $sub) = @{$self}{qw( pfx io sb )};
  3         12  
165              
166             # Do not delegate this to PRINT, so we can prevent sprintf side effects
167 3 100       81 $self->{closed} and croak "Cannot print to closed filehandle";
168              
169 2         3 my $fmt = shift;
170 2         11 $self->PRINT (sprintf $fmt, @_);
171             } # PRINTF
172              
173             sub TELL {
174 2     2   637 my $self = shift;
175 2 100       77 $self->{closed} and croak "Cannot tell from a closed filehandle";
176 1         5 tell $self->{io};
177             } # TELL
178              
179             sub EOF {
180 2     2   6 my $self = shift;
181 2         10 $self->{closed};
182             } # EOF
183              
184             sub CLOSE {
185 12     12   1892 my $self = shift;
186 12         22 my ($pfx, $io, $sub, $line) = @{$self}{qw( pfx io sb line )};
  12         38  
187             defined $line && $line ne "" and
188 12 100 66     67 print { $io } _Filter_ (0, $pfx, $sub, $line);
  3         10  
189 12 100       53 $self->{closed} or close $io;
190 12         22 $self->{line} = "";
191 12         37 $self->{closed} = 1;
192             } # CLOSE
193              
194             sub UNTIE {
195 11     11   6027 my $self = shift;
196 11 100       43 $self->{closed} or $self->CLOSE;
197 11         29 $self;
198             } # UNTIE
199              
200             sub DESTROY {
201 11     11   19 my $self = shift;
202 11 50       28 $self->{closed} or $self->CLOSE;
203 11         66 %$self = ();
204 11         727 undef $self;
205             } # DESTROY
206              
207             ### ###########################################################################
208              
209             sub _outputOnly {
210 36     36   61 my $name = shift;
211 36     1   118 sub { croak "No support for $name method: File is output only" };
  1         170  
212             } # _outputOnly
213              
214             *read = _outputOnly ("read");
215             *READ = _outputOnly ("READ");
216             *readline = _outputOnly ("readline");
217             *READLINE = _outputOnly ("READLINE");
218             *getc = _outputOnly ("getc");
219             *GETC = _outputOnly ("GETC");
220              
221             sub _NYI {
222 36     36   56 my $name = shift;
223 36     1   97 sub { croak "Support for $name method NYI" };
  1         763  
224             } # _NYI
225              
226             *open = _NYI ("open");
227             *OPEN = _NYI ("OPEN");
228             *seek = _NYI ("seek");
229             *SEEK = _NYI ("SEEK");
230             *write = _NYI ("write");
231             *WRITE = _NYI ("WRITE");
232              
233             =begin comment
234              
235             We do not want to document these:
236              
237             =over 4
238              
239             =item getc
240              
241             =item open
242              
243             =item read
244              
245             =item readline
246              
247             =item seek
248              
249             =item write
250              
251             =back
252              
253             =end comment
254              
255             =cut
256              
257             1;