File Coverage

blib/lib/Test/MockFile/FileHandle.pm
Criterion Covered Total %
statement 92 111 82.8
branch 32 40 80.0
condition 7 8 87.5
subroutine 17 22 77.2
pod n/a
total 148 181 81.7


line stmt bran cond sub pod time code
1             # Copyright (c) 2018, cPanel, LLC.
2             # All rights reserved.
3             # http://cpanel.net
4             #
5             # This is free software; you can redistribute it and/or modify it under the
6             # same terms as Perl itself. See L.
7              
8             package Test::MockFile::FileHandle;
9              
10 34     34   213 use strict;
  34         58  
  34         923  
11 34     34   178 use warnings;
  34         66  
  34         985  
12 34     34   7624 use Errno qw/EBADF/;
  34         23211  
  34         2746  
13 34     34   227 use Scalar::Util ();
  34         63  
  34         1268  
14              
15             our $VERSION = '0.034';
16              
17             my $files_being_mocked;
18             {
19 34     34   227 no warnings 'once';
  34         113  
  34         41115  
20             $files_being_mocked = \%Test::MockFile::files_being_mocked;
21             }
22              
23             =head1 NAME
24              
25             Test::MockFile::FileHandle - Provides a class for L to
26             tie to on B or B.
27              
28             =head1 VERSION
29              
30             Version 0.034
31              
32             =cut
33              
34             =head1 SYNOPSIS
35              
36             This is a helper class for L. It leverages data in the
37             Test::MockFile namespace but lives in its own package since it is the
38             class that file handles are tied to when created in L
39              
40             use Test::MockFile::FileHandle;
41             tie *{ $_[0] }, 'Test::MockFile::FileHandle', $abs_path, $rw;
42              
43              
44             =head1 EXPORT
45              
46             No exports are provided by this module.
47              
48             =head1 SUBROUTINES/METHODS
49              
50             =head2 TIEHANDLE
51              
52             Args: ($class, $file, $mode)
53              
54             Returns a blessed object for L to tie against. There
55             are no error conditions handled here.
56              
57             One of the object variables tracked here is a pointer to the file
58             contents in C<%Test::MockFile::files_being_mocked>. In order to allow
59             MockFiles to be DESTROYED when they go out of scope, we have to weaken
60             this pointer.
61              
62             See L for more info.
63              
64             =cut
65              
66             sub TIEHANDLE {
67 28     28   81 my ( $class, $file, $mode ) = @_;
68              
69 28 50       80 length $file or die("No file name passed!");
70              
71             my $self = bless {
72             'file' => $file,
73 28 100       381 'data' => $files_being_mocked->{$file},
    100          
74             'tell' => 0,
75             'read' => $mode =~ m/r/ ? 1 : 0,
76             'write' => $mode =~ m/w/ ? 1 : 0,
77             }, $class;
78              
79             # This ref count can't hold the object from getting released.
80 28         150 Scalar::Util::weaken( $self->{'data'} );
81              
82 28         91 return $self;
83             }
84              
85             =head2 PRINT
86              
87             This method will be triggered every time the tied handle is printed to
88             with the print() or say() functions. Beyond its self reference it also
89             expects the list that was passed to the print function.
90              
91             We append to
92             C<$Test::MockFile::files_being_mocked{$file}->{'contents'}> with what
93             was sent. If the file handle wasn't opened in a read mode, then this
94             call with throw EBADF via $!
95              
96             =cut
97              
98             sub PRINT {
99 11     11   48 my ( $self, @list ) = @_;
100              
101 11 100       35 if ( !$self->{'write'} ) {
102              
103             # Filehandle $fh opened only for input at t/readline.t line 27, <$fh> line 2.
104             # https://github.com/CpanelInc/Test-MockFile/issues/1
105 1         10 CORE::warn("Filehandle ???? opened only for input at ???? line ???, line ???.");
106 1         7 $! = EBADF;
107 1         4 return;
108             }
109              
110 10         24 my $starting_bytes = length $self->{'data'}->{'contents'};
111 10         33 foreach my $line (@list) {
112 10 100       24 next if !defined $line;
113 9         25 $self->{'data'}->{'contents'} .= $line;
114             }
115              
116 10         43 return length( $self->{'data'}->{'contents'} ) - $starting_bytes;
117             }
118              
119             =head2 PRINTF
120              
121             This method will be triggered every time the tied handle is printed to
122             with the printf() function. Beyond its self reference it also expects
123             the format and list that was passed to the printf function.
124              
125             We use sprintf to format the output and then it is sent to L
126              
127             =cut
128              
129             sub PRINTF {
130 1     1   4 my $self = shift;
131 1         2 my $format = shift;
132              
133 1         8 return $self->PRINT( sprintf( $format, @_ ) );
134             }
135              
136             =head2 WRITE
137              
138             This method will be called when the handle is written to via the
139             syswrite function.
140              
141             Arguments passed are:C<( $self, $buf, $len, $offset )>
142              
143             This is one of the more complicated functions to mimic properly because
144             $len and $offset have to be taken into account. Reviewing how syswrite
145             works reveals there are all sorts of weird corner cases.
146              
147             =cut
148              
149             sub WRITE {
150 3     3   8 my ( $self, $buf, $len, $offset ) = @_;
151              
152 3 50       19 unless ( $len =~ m/^-?[0-9.]+$/ ) {
153 0         0 $! = qq{Argument "$len" isn't numeric in syswrite at ??};
154 0         0 return 0;
155             }
156              
157 3         6 $len = int($len); # Perl seems to do this to floats.
158              
159 3 50       7 if ( $len < 0 ) {
160 0         0 $! = qq{Negative length at ???};
161 0         0 return 0;
162             }
163              
164 3         8 my $strlen = length($buf);
165 3   100     10 $offset //= 0;
166              
167 3 50       7 if ( $strlen - $offset < abs($len) ) {
168 0         0 $! = q{Offset outside string at ???.};
169 0         0 return 0;
170             }
171              
172 3   50     6 $offset //= 0;
173 3 50       7 if ( $offset < 0 ) {
174 0         0 $offset = $strlen + $offset;
175             }
176              
177 3         10 return $self->PRINT( substr( $buf, $offset, $len ) );
178             }
179              
180             =head2 READLINE
181              
182             This method is called when the handle is read via or readline
183             HANDLE.
184              
185             Based on the numeric location we are in the file (tell), we read until
186             the EOF separator (C<$/>) is seen. tell is updated after the line is
187             read. undef is returned if tell is already at EOF.
188              
189             =cut
190              
191             sub _READLINE_ONE_LINE {
192 19     19   27 my ($self) = @_;
193              
194 19         28 my $tell = $self->{'tell'};
195 19   100     44 my $rs = $/ // '';
196 19         45 my $new_tell = index( $self->{'data'}->{'contents'}, $rs, $tell ) + length($rs);
197              
198 19 100       57 if ( $new_tell == 0 ) {
199 4         5 $new_tell = length( $self->{'data'}->{'contents'} );
200             }
201 19 100       33 return undef if ( $new_tell == $tell ); # EOF
202              
203 18         41 my $str = substr( $self->{'data'}->{'contents'}, $tell, $new_tell - $tell );
204 18         25 $self->{'tell'} = $new_tell;
205              
206 18         66 return $str;
207             }
208              
209             sub READLINE {
210 24     24   739 my ($self) = @_;
211              
212 24 100       44 return if $self->EOF;
213              
214 15 100       32 if (wantarray) {
215 1         2 my @all;
216 1         2 my $line = _READLINE_ONE_LINE($self);
217 1         4 while ( defined $line ) {
218 4         6 push @all, $line;
219 4         6 $line = _READLINE_ONE_LINE($self);
220             }
221 1         5 return @all;
222             }
223              
224 14         28 return _READLINE_ONE_LINE($self);
225             }
226              
227             =head2 GETC
228              
229             B: Open a ticket in
230             L if you need
231             this feature.
232              
233             This method will be called when the getc function is called. It reads 1
234             character out of contents and adds 1 to tell. The character is
235             returned.
236              
237             =cut
238              
239             sub GETC {
240 0     0   0 my ($self) = @_;
241              
242 0         0 die('Unimplemented');
243             }
244              
245             =head2 READ
246              
247             Arguments passed are:C<( $self, $file_handle, $len, $offset )>
248              
249             This method will be called when the handle is read from via the read or
250             sysread functions. Based on C<$offset> and C<$len>, it's possible to
251             end up with some really weird strings with null bytes in them.
252              
253             =cut
254              
255             sub READ {
256 7     7   20 my ( $self, undef, $len, $offset ) = @_;
257              
258             # If the caller's buffer is undef, we need to make it a string of 0 length to start out with.
259 7 100       20 $_[1] = '' if !defined $_[1]; # TODO: test me
260              
261 7         19 my $contents_len = length $self->{'data'}->{'contents'};
262 7         9 my $buf_len = length $_[1];
263              
264 7   100     22 $offset //= 0;
265 7 100       15 if ( $offset > $buf_len ) {
266 1         5 $_[1] .= "\0" x ( $offset - $buf_len );
267             }
268 7         14 my $tell = $self->{'tell'};
269              
270 7 100       49 my $read_len = ( $contents_len - $tell < $len ) ? $contents_len - $tell : $len;
271              
272 7         21 substr( $_[1], $offset ) = substr( $self->{'data'}->{'contents'}, $tell, $read_len );
273              
274 7         13 $self->{'tell'} += $read_len;
275              
276 7         29 return $read_len;
277             }
278              
279             =head2 CLOSE
280              
281             This method will be called when the handle is closed via the close
282             function. The object is untied and the file contents (weak reference)
283             is removed. Further calls to this object should fail.
284              
285             =cut
286              
287             sub CLOSE {
288 48     48   1809 my ($self) = @_;
289              
290 48         99 delete $self->{'data'}->{'fh'};
291 48         81 untie $self;
292              
293 48         573 return 1;
294             }
295              
296             =head2 UNTIE
297              
298             As with the other types of ties, this method will be called when untie
299             happens. It may be appropriate to "auto CLOSE" when this occurs. See
300             The untie Gotcha below.
301              
302             What's strange about the development of this class is that we were
303             unable to determine how to trigger this call. At the moment, the call
304             is just redirected to CLOSE.
305              
306             =cut
307              
308             sub UNTIE {
309 0     0   0 my $self = shift;
310              
311             #print STDERR "# UNTIE!\n";
312 0         0 return $self->CLOSE;
313             }
314              
315             =head2 DESTROY
316              
317             As with the other types of ties, this method will be called when the
318             tied handle is about to be destroyed. This is useful for debugging and
319             possibly cleaning up.
320              
321             At the moment, the call is just redirected to CLOSE.
322              
323             =cut
324              
325             sub DESTROY {
326 28     28   10002 my ($self) = @_;
327              
328 28         106 return $self->CLOSE;
329             }
330              
331             =head2 EOF
332              
333             This method will be called when the eof function is called. Based on
334             C<$self-E{'tell'}>, we determine if we're at EOF.
335              
336             =cut
337              
338             sub EOF {
339 24     24   33 my ($self) = @_;
340              
341 24 50       53 if ( !$self->{'read'} ) {
342 0         0 CORE::warn(q{Filehandle STDOUT opened only for output});
343             }
344 24         85 return $self->{'tell'} == length $self->{'data'}->{'contents'};
345             }
346              
347             =head2 BINMODE
348              
349             Binmode does nothing as whatever format you put the data into the file as
350             is how it will come out. Possibly we could decode the SV if this was done
351             but then we'd have to do it every time contents are altered. Please open
352             a ticket if you want this to do something.
353              
354             No L
355             documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles>
356             exists on this method.
357              
358             =cut
359              
360             sub BINMODE {
361 0     0   0 my ($self) = @_;
362 0         0 return;
363             }
364              
365             =head2 OPEN
366              
367             B: Open a ticket in
368             L if you need
369             this feature.
370              
371             No L
372             documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles>
373             exists on this method.
374              
375             =cut
376              
377             sub OPEN {
378 0     0   0 my ($self) = @_;
379 0         0 die('Unimplemented');
380             }
381              
382             =head2 FILENO
383              
384             B: Open a ticket in
385             L if you need
386             this feature.
387              
388             No L
389             documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles>
390             exists on this method.
391              
392             =cut
393              
394             sub FILENO {
395 1     1   6372 my ($self) = @_;
396 1         15 die 'fileno is purposefully unsupported';
397             }
398              
399             =head2 SEEK
400              
401             Arguments passed are:C<( $self, $pos, $whence )>
402              
403             Moves the location of our current tell location.
404              
405             B<$whence is UNIMPLEMENTED>: Open a ticket in
406             L if you need
407             this feature.
408              
409             No L
410             documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles>
411             exists on this method.
412              
413             =cut
414              
415             sub SEEK {
416 6     6   16 my ( $self, $pos, $whence ) = @_;
417              
418 6 50       19 if ($whence) {
419 0         0 die('Unimplemented');
420             }
421 6         15 my $file_size = length $self->{'data'}->{'contents'};
422 6 50       26 return if $file_size < $pos;
423              
424 6         12 $self->{'tell'} = $pos;
425              
426 6 100       39 return $pos == 0 ? '0 but true' : $pos;
427             }
428              
429             =head2 TELL
430              
431             Returns the numeric location we are in the file. The C tells us
432             where we are in the file contents.
433              
434             No L
435             documentation|http://perldoc.perl.org/perltie.html#Tying-FileHandles>
436             exists on this method.
437              
438             =cut
439              
440             sub TELL {
441 0     0     my ($self) = @_;
442 0           return $self->{'tell'};
443             }
444              
445             1;