File Coverage

blib/lib/Tie/Handle/Filter.pm
Criterion Covered Total %
statement 47 48 97.9
branch 11 18 61.1
condition 4 9 44.4
subroutine 19 19 100.0
pod n/a
total 81 94 86.1


line stmt bran cond sub pod time code
1             package Tie::Handle::Filter;
2              
3             # ABSTRACT: filters the output to a filehandle through a coderef
4              
5             #pod =head1 SYNOPSIS
6             #pod
7             #pod use Tie::Handle::Filter;
8             #pod
9             #pod # prefix output to STDERR with standard Greenwich time
10             #pod BEGIN {
11             #pod tie *STDERR, 'Tie::Handle::Filter', *STDERR,
12             #pod sub { scalar(gmtime) . ': ', @_ };
13             #pod }
14             #pod
15             #pod =head1 DESCRIPTION
16             #pod
17             #pod This is a small module for changing output when it is sent to a given
18             #pod file handle. By default it passes everything unchanged, but when
19             #pod provided a code reference, that reference is passed the string being
20             #pod sent to the tied file handle and may return a transformed result.
21             #pod
22             #pod =head1 OTHER INCLUDED MODULES
23             #pod
24             #pod =over
25             #pod
26             #pod =item L
27             #pod
28             #pod Prepends filehandle output with a timestamp, optionally formatted via
29             #pod L|POSIX/strftime>.
30             #pod
31             #pod =item L
32             #pod
33             #pod Prepends every line of filehandle output with a timestamp, optionally
34             #pod formatted via L|POSIX/strftime>.
35             #pod
36             #pod =back
37             #pod
38             #pod =cut
39              
40 5     5   40506 use 5.008;
  5         12  
41 5     5   15 use strict;
  5         6  
  5         70  
42 5     5   14 use warnings;
  5         4  
  5         119  
43 5     5   14 use base 'Tie::Handle';
  5         5  
  5         2031  
44 5     5   7029 use Carp;
  5         8  
  5         204  
45 5     5   2108 use English '-no_match_vars';
  5         12860  
  5         24  
46 5     5   3448 use FileHandle::Fmode ':all';
  5         5832  
  5         3150  
47             our $VERSION = '0.009'; # TRIAL
48              
49             #pod =head1 DIAGNOSTICS
50             #pod
51             #pod Wherever possible this module attempts to emulate the built-in functions
52             #pod it ties, so it will return values as expected from whatever function is
53             #pod called. Certain operations may also L|Carp> (throw a fatal
54             #pod exception) if they fail, such as aliasing the file handle during a
55             #pod L|perlfunc/tie> or attempting to perform an
56             #pod L on a tied file handle.
57             #pod
58             #pod =cut
59              
60             sub TIEHANDLE {
61 22     22   14316 my ( $class, $handle_glob, $writer_ref ) = @_;
62              
63             ## no critic (InputOutput::RequireBriefOpen)
64 22 50       78 open my $fh, _get_filehandle_open_mode($handle_glob) . q(&=), $handle_glob
65             or croak $OS_ERROR;
66              
67             return bless {
68             filehandle => $fh,
69             writer => (
70             ( defined $writer_ref and 'CODE' eq ref $writer_ref )
71             ? $writer_ref
72 2     2   16 : sub { return @_ }
73 22 100 66     616 ),
74             }, $class;
75             }
76              
77             sub _get_filehandle_open_mode {
78 22     22   30 my $fh = shift;
79 22         40 for ($fh) {
80 22 50 33     57 return '>>' if is_WO($_) and is_A($_);
81 22 50       260 return '>' if is_WO($_);
82 22 50       180 return '<' if is_RO($_);
83 22 50 33     198 return '+>>' if is_RW($_) and is_A($_);
84 22 50       418 return '+<' if is_RW($_);
85             }
86 0         0 return '+>';
87             }
88              
89             ## no critic (Subroutines::RequireArgUnpacking)
90             ## no critic (Subroutines::RequireFinalReturn)
91              
92             #pod =method PRINT
93             #pod
94             #pod All arguments to L|perlfunc/print> and L|perlfunc/say>
95             #pod directed at the tied file handle are passed to the user-defined
96             #pod function, and the result is then passed to L|perlfunc/print>.
97             #pod
98             #pod =cut
99              
100             sub PRINT {
101 9     9   1013 my $self = shift;
102             ## no critic (InputOutput::RequireCheckedSyscalls)
103 9         9 print { $self->{filehandle} } $self->{writer}->(@_);
  9         63  
104             }
105              
106             #pod =method PRINTF
107             #pod
108             #pod The second and subsequent arguments to L|perlfunc/printf>
109             #pod (i.e., everything but the format string) directed at the tied file
110             #pod handle are passed to the user-defined function, and the result is then
111             #pod passed preceded by the format string to L|perlfunc/printf>.
112             #pod
113             #pod Please note that this does not include calls to
114             #pod L|perlfunc/sprintf>.
115             #pod
116             #pod =cut
117              
118             sub PRINTF {
119 2     2   374 my ( $self, $format ) = splice @_, 0, 2;
120 2         3 printf { $self->{filehandle} } $format, $self->{writer}->(@_);
  2         6  
121             }
122              
123             #pod =method WRITE
124             #pod
125             #pod The first argument to L|perlfunc/syswrite> (i.e., the buffer
126             #pod scalar variable) directed at the tied file handle is passed to the
127             #pod user-defined function, and the result is then passed along with the
128             #pod optional second and third arguments (i.e., length of data in bytes and
129             #pod offset within the string) to L|perlfunc/syswrite>.
130             #pod
131             #pod Note that if you do not provide a length argument to
132             #pod L|perlfunc/syswrite>, it will be computed from the result of
133             #pod the user-defined function. However, if you do provide a length (and
134             #pod possibly offset), they will be relative to the results of the
135             #pod user-defined function, not the input.
136             #pod
137             #pod =cut
138              
139             sub WRITE {
140 3     3   408 my ( $self, $original ) = splice @_, 0, 2;
141 3         8 my $buffer = ( $self->{writer}->($original) )[0];
142 3 50       80 syswrite $self->{filehandle}, $buffer,
    100          
143             ( defined $_[0] ? $_[0] : length $buffer ),
144             ( defined $_[1] ? $_[1] : 0 );
145             }
146              
147             sub CLOSE {
148 10     10   3525 my $self = shift;
149             ## no critic (InputOutput::RequireCheckedSyscalls)
150             ## no critic (InputOutput::RequireCheckedClose)
151 10         217 close $self->{filehandle};
152             }
153              
154             #pod =head1 BUGS AND LIMITATIONS
155             #pod
156             #pod If your function needs to know what operation was used to call it,
157             #pod consider using C<(caller 1)[3]> to determine the method used to call
158             #pod it, which will return C,
159             #pod C, or C per
160             #pod L.
161             #pod
162             #pod Currently this module is biased towards write-only file handles, such as
163             #pod C, C, or ones used for logging. It does not (yet) define
164             #pod the following methods and their associated functions, so don't do them
165             #pod with file handles tied to this class.
166             #pod
167             #pod =head2 READ
168             #pod
169             #pod =over
170             #pod
171             #pod =item L|perlfunc/read>
172             #pod
173             #pod =item L|perlfunc/sysread>
174             #pod
175             #pod =back
176             #pod
177             #pod =head2 READLINE
178             #pod
179             #pod =over
180             #pod
181             #pod =item LHANDLEE>|perlop/"I/O Operators">
182             #pod
183             #pod =item L|perlfunc/readline>
184             #pod
185             #pod =back
186             #pod
187             #pod =head2 GETC
188             #pod
189             #pod =over
190             #pod
191             #pod =item L|perlfunc/getc>
192             #pod
193             #pod =back
194             #pod
195             #pod =head2 OPEN
196             #pod
197             #pod =over
198             #pod
199             #pod =item L|perlfunc/open> (e.g., re-opening the file handle)
200             #pod
201             #pod =back
202             #pod
203             #pod =head2 BINMODE
204             #pod
205             #pod =over
206             #pod
207             #pod =item L|perlfunc/binmode>
208             #pod
209             #pod =back
210             #pod
211             #pod =head2 EOF
212             #pod
213             #pod =over
214             #pod
215             #pod =item L|perlfunc/eof>
216             #pod
217             #pod =back
218             #pod
219             #pod =head2 TELL
220             #pod
221             #pod =over
222             #pod
223             #pod =item L|perlfunc/tell>
224             #pod
225             #pod =back
226             #pod
227             #pod =head2 SEEK
228             #pod
229             #pod =over
230             #pod
231             #pod =item L|perlfunc/seek>
232             #pod
233             #pod =back
234             #pod
235             #pod =cut
236              
237             my $unimplemented_ref = sub {
238             ## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
239             my $package = ( caller 0 )[0];
240             my $method = ( caller 1 )[3];
241             $method =~ s/\A ${package} :: //xms;
242             croak "$package doesn't define a $method method";
243             };
244              
245 1     1   45 sub OPEN { $unimplemented_ref->() }
246 1     1   43 sub BINMODE { $unimplemented_ref->() }
247 1     1   43 sub EOF { $unimplemented_ref->() }
248 1     1   60 sub TELL { $unimplemented_ref->() }
249 1     1   68 sub SEEK { $unimplemented_ref->() }
250              
251             1;
252              
253             __END__