File Coverage

blib/lib/Log/Dispatch/File.pm
Criterion Covered Total %
statement 65 66 98.4
branch 30 38 78.9
condition 8 12 66.6
subroutine 12 13 92.3
pod 0 3 0.0
total 115 132 87.1


line stmt bran cond sub pod time code
1             package Log::Dispatch::File;
2              
3 27     27   6377 use strict;
  27         55  
  27         630  
4 27     27   136 use warnings;
  27         68  
  27         903  
5              
6             our $VERSION = '2.69';
7              
8 27     27   581 use IO::Handle;
  27         5621  
  27         946  
9 27     27   135 use Log::Dispatch::Types;
  27         31  
  27         202  
10 27     27   628555 use Params::ValidationCompiler qw( validation_for );
  27         57  
  27         1448  
11 27     27   161 use Scalar::Util qw( openhandle );
  27         52  
  27         1062  
12              
13 27     27   137 use base qw( Log::Dispatch::Output );
  27         53  
  27         12927  
14              
15             # Prevents death later on if IO::File can't export this constant.
16             *O_APPEND = \&APPEND unless defined &O_APPEND;
17              
18 0     0 0 0 sub APPEND {0}
19              
20             {
21             my $validator = validation_for(
22             params => {
23             filename => { type => t('NonEmptyStr') },
24             mode => {
25             type => t('Value'),
26             default => '>',
27             },
28             binmode => {
29             type => t('Str'),
30             optional => 1,
31             },
32             autoflush => {
33             type => t('Bool'),
34             default => 1,
35             },
36             close_after_write => {
37             type => t('Bool'),
38             default => 0,
39             },
40             lazy_open => {
41             type => t('Bool'),
42             default => 0,
43             },
44             permissions => {
45             type => t('PositiveOrZeroInt'),
46             optional => 1,
47             },
48             syswrite => {
49             type => t('Bool'),
50             default => 0,
51             },
52             },
53             slurpy => 1,
54             );
55              
56             # We stick these in $self as-is without looking at them in new().
57             my @self_p = qw(
58             autoflush
59             binmode
60             close_after_write
61             filename
62             lazy_open
63             permissions
64             syswrite
65             );
66              
67             sub new {
68 68     68 0 13521 my $class = shift;
69 68         2530 my %p = $validator->(@_);
70              
71 68         7417 my $self = bless { map { $_ => delete $p{$_} } @self_p }, $class;
  476         2072  
72              
73 68 100 33     771 if ( $self->{close_after_write} ) {
    100 66        
74 23         148 $self->{mode} = '>>';
75             }
76             elsif (
77             $p{mode} =~ /^(?:>>|append)$/
78             || ( $p{mode} =~ /^\d+$/
79             && $p{mode} == O_APPEND() )
80             ) {
81 31         206 $self->{mode} = '>>';
82             }
83             else {
84 14         40 $self->{mode} = '>';
85             }
86 68         167 delete $p{mode};
87              
88 68         712 $self->_basic_init(%p);
89             $self->_open_file()
90 68 100 100     1653 unless $self->{close_after_write} || $self->{lazy_open};
91              
92 68         419 return $self;
93             }
94             }
95              
96             sub _open_file {
97 78     78   150 my $self = shift;
98              
99             ## no critic (InputOutput::RequireBriefOpen)
100             open my $fh, $self->{mode}, $self->{filename}
101 78 50       41628 or die "Cannot write to '$self->{filename}': $!";
102              
103 78 50       486 if ( $self->{autoflush} ) {
104 78         6112 $fh->autoflush(1);
105             }
106              
107 78 100 66     6298 if ( $self->{permissions}
108             && !$self->{chmodded} ) {
109             ## no critic (ValuesAndExpressions::ProhibitLeadingZeros)
110 2         25 my $current_mode = ( stat $self->{filename} )[2] & 07777;
111 2 100       11 if ( $current_mode ne $self->{permissions} ) {
112             chmod $self->{permissions}, $self->{filename}
113             or die sprintf(
114             'Cannot chmod %s to %04o: %s',
115 1 50       21 $self->{filename}, $self->{permissions} & 07777, $!
116             );
117             }
118              
119 2         5 $self->{chmodded} = 1;
120             }
121              
122 78 100       522 if ( $self->{binmode} ) {
123             binmode $fh, $self->{binmode}
124 2 50   1   50 or die "Cannot set binmode on filehandle: $!";
  1         10  
  1         2  
  1         7  
125             }
126              
127 78         2243 $self->{fh} = $fh;
128             }
129              
130             sub log_message {
131 28     28 0 36 my $self = shift;
132 28         59 my %p = @_;
133              
134 28 100       97 if ( $self->{close_after_write} ) {
    100          
135 3         6 $self->_open_file;
136             }
137             elsif ( $self->{lazy_open} ) {
138 1         3 $self->_open_file;
139 1         2 $self->{lazy_open} = 0;
140             }
141              
142 28         41 my $fh = $self->{fh};
143              
144 28 100       46 if ( $self->{syswrite} ) {
145             defined syswrite( $fh, $p{message} )
146 2 50       7 or die "Cannot write to '$self->{filename}': $!";
147             }
148             else {
149             print $fh $p{message}
150 26 50       836 or die "Cannot write to '$self->{filename}': $!";
151             }
152              
153 28 100       264 if ( $self->{close_after_write} ) {
154 3 50       29 close $fh
155             or die "Cannot close '$self->{filename}': $!";
156 3         31 delete $self->{fh};
157             }
158             }
159              
160             sub DESTROY {
161 68     68   23889721 my $self = shift;
162              
163 68 100       3337 if ( $self->{fh} ) {
164 45         91 my $fh = $self->{fh};
165             ## no critic (InputOutput::RequireCheckedSyscalls)
166 45 50       5643 close $fh if openhandle($fh);
167             }
168             }
169              
170             1;
171              
172             # ABSTRACT: Object for logging to files
173              
174             __END__
175              
176             =pod
177              
178             =encoding UTF-8
179              
180             =head1 NAME
181              
182             Log::Dispatch::File - Object for logging to files
183              
184             =head1 VERSION
185              
186             version 2.69
187              
188             =head1 SYNOPSIS
189              
190             use Log::Dispatch;
191              
192             my $log = Log::Dispatch->new(
193             outputs => [
194             [
195             'File',
196             min_level => 'info',
197             filename => 'Somefile.log',
198             mode => '>>',
199             newline => 1
200             ]
201             ],
202             );
203              
204             $log->emerg("I've fallen and I can't get up");
205              
206             =head1 DESCRIPTION
207              
208             This module provides a simple object for logging to files under the
209             Log::Dispatch::* system.
210              
211             Note that a newline will I<not> be added automatically at the end of a message
212             by default. To do that, pass C<< newline => 1 >>.
213              
214             B<NOTE:> If you are writing to a single log file from multiple processes, the
215             log output may become interleaved and garbled. Use the
216             L<Log::Dispatch::File::Locked> output instead, which allows multiple processes
217             to safely share a single file.
218              
219             =for Pod::Coverage new log_message
220              
221             =head1 CONSTRUCTOR
222              
223             The constructor takes the following parameters in addition to the standard
224             parameters documented in L<Log::Dispatch::Output>:
225              
226             =over 4
227              
228             =item * filename ($)
229              
230             The filename to be opened for writing.
231              
232             =item * mode ($)
233              
234             The mode the file should be opened with. Valid options are 'write',
235             '>', 'append', '>>', or the relevant constants from Fcntl. The
236             default is 'write'.
237              
238             =item * binmode ($)
239              
240             A layer name to be passed to binmode, like ":encoding(UTF-8)" or ":raw".
241              
242             =item * close_after_write ($)
243              
244             Whether or not the file should be closed after each write. This
245             defaults to false.
246              
247             If this is true, then the mode will always be append, so that the file is not
248             re-written for each new message.
249              
250             =item * lazy_open ($)
251              
252             Whether or not the file should be opened only on first write. This defaults to
253             false.
254              
255             =item * autoflush ($)
256              
257             Whether or not the file should be autoflushed. This defaults to true.
258              
259             =item * syswrite ($)
260              
261             Whether or not to perform the write using L<perlfunc/syswrite>(),
262             as opposed to L<perlfunc/print>(). This defaults to false.
263             The usual caveats and warnings as documented in L<perlfunc/syswrite> apply.
264              
265             =item * permissions ($)
266              
267             If the file does not already exist, the permissions that it should
268             be created with. Optional. The argument passed must be a valid
269             octal value, such as 0600 or the constants available from Fcntl, like
270             S_IRUSR|S_IWUSR.
271              
272             See L<perlfunc/chmod> for more on potential traps when passing octal
273             values around. Most importantly, remember that if you pass a string
274             that looks like an octal value, like this:
275              
276             my $mode = '0644';
277              
278             Then the resulting file will end up with permissions like this:
279              
280             --w----r-T
281              
282             which is probably not what you want.
283              
284             =back
285              
286             =head1 SUPPORT
287              
288             Bugs may be submitted at L<https://github.com/houseabsolute/Log-Dispatch/issues>.
289              
290             I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
291              
292             =head1 SOURCE
293              
294             The source code repository for Log-Dispatch can be found at L<https://github.com/houseabsolute/Log-Dispatch>.
295              
296             =head1 AUTHOR
297              
298             Dave Rolsky <autarch@urth.org>
299              
300             =head1 COPYRIGHT AND LICENSE
301              
302             This software is Copyright (c) 2019 by Dave Rolsky.
303              
304             This is free software, licensed under:
305              
306             The Artistic License 2.0 (GPL Compatible)
307              
308             The full text of the license can be found in the
309             F<LICENSE> file included with this distribution.
310              
311             =cut