1package Log::Dispatch::File;
2{
3  $Log::Dispatch::File::VERSION = '2.34';
4}
5
6use strict;
7use warnings;
8
9use Log::Dispatch::Output;
10
11use base qw( Log::Dispatch::Output );
12
13use Params::Validate qw(validate SCALAR BOOLEAN);
14Params::Validate::validation_options( allow_extra => 1 );
15
16use Scalar::Util qw( openhandle );
17
18# Prevents death later on if IO::File can't export this constant.
19*O_APPEND = \&APPEND unless defined &O_APPEND;
20
21sub APPEND { 0 }
22
23sub new {
24    my $proto = shift;
25    my $class = ref $proto || $proto;
26
27    my %p = @_;
28
29    my $self = bless {}, $class;
30
31    $self->_basic_init(%p);
32    $self->_make_handle(%p);
33
34    return $self;
35}
36
37sub _make_handle {
38    my $self = shift;
39
40    my %p = validate(
41        @_,
42        {
43            filename => { type => SCALAR },
44            mode     => {
45                type    => SCALAR,
46                default => '>'
47            },
48            binmode => {
49                type    => SCALAR,
50                default => undef
51            },
52            autoflush => {
53                type    => BOOLEAN,
54                default => 1
55            },
56            close_after_write => {
57                type    => BOOLEAN,
58                default => 0
59            },
60            permissions => {
61                type     => SCALAR,
62                optional => 1
63            },
64        }
65    );
66
67    $self->{filename}    = $p{filename};
68    $self->{close}       = $p{close_after_write};
69    $self->{permissions} = $p{permissions};
70    $self->{binmode}     = $p{binmode};
71    $self->{syswrite}    = $p{syswrite};
72
73    if ( $self->{close} ) {
74        $self->{mode} = '>>';
75    }
76    elsif (
77           exists $p{mode}
78        && defined $p{mode}
79        && (
80            $p{mode} =~ /^(?:>>|append)$/
81            || (   $p{mode} =~ /^\d+$/
82                && $p{mode} == O_APPEND() )
83        )
84        ) {
85        $self->{mode} = '>>';
86    }
87    else {
88        $self->{mode} = '>';
89    }
90
91    $self->{autoflush} = $p{autoflush};
92
93    $self->_open_file() unless $p{close_after_write};
94
95}
96
97sub _open_file {
98    my $self = shift;
99
100    open my $fh, $self->{mode}, $self->{filename}
101        or die "Cannot write to '$self->{filename}': $!";
102
103    if ( $self->{autoflush} ) {
104        my $oldfh = select $fh;
105        $| = 1;
106        select $oldfh;
107    }
108
109    if ( $self->{permissions}
110        && !$self->{chmodded} ) {
111        my $current_mode = ( stat $self->{filename} )[2] & 07777;
112        if ( $current_mode ne $self->{permissions} ) {
113            chmod $self->{permissions}, $self->{filename}
114                or die
115                "Cannot chmod $self->{filename} to $self->{permissions}: $!";
116        }
117
118        $self->{chmodded} = 1;
119    }
120
121    if ( $self->{binmode} ) {
122        binmode $fh, $self->{binmode};
123    }
124
125    $self->{fh} = $fh;
126}
127
128sub log_message {
129    my $self = shift;
130    my %p    = @_;
131
132    if ( $self->{close} ) {
133        $self->_open_file;
134    }
135
136    my $fh = $self->{fh};
137
138    if ( $self->{syswrite} ) {
139        defined syswrite( $fh, $p{message} )
140            or die "Cannot write to '$self->{filename}': $!";
141    }
142    else {
143        print $fh $p{message}
144            or die "Cannot write to '$self->{filename}': $!";
145    }
146
147    if ( $self->{close} ) {
148        close $fh
149            or die "Cannot close '$self->{filename}': $!";
150    }
151}
152
153sub DESTROY {
154    my $self = shift;
155
156    if ( $self->{fh} ) {
157        my $fh = $self->{fh};
158        close $fh if openhandle($fh);
159    }
160}
161
1621;
163
164# ABSTRACT: Object for logging to files
165
166__END__
167
168=pod
169
170=head1 NAME
171
172Log::Dispatch::File - Object for logging to files
173
174=head1 VERSION
175
176version 2.34
177
178=head1 SYNOPSIS
179
180  use Log::Dispatch;
181
182  my $log = Log::Dispatch->new(
183      outputs => [
184          [
185              'File',
186              min_level => 'info',
187              filename  => 'Somefile.log',
188              mode      => '>>',
189              newline   => 1
190          ]
191      ],
192  );
193
194  $log->emerg("I've fallen and I can't get up");
195
196=head1 DESCRIPTION
197
198This module provides a simple object for logging to files under the
199Log::Dispatch::* system.
200
201Note that a newline will I<not> be added automatically at the end of a message
202by default.  To do that, pass C<< newline => 1 >>.
203
204=head1 CONSTRUCTOR
205
206The constructor takes the following parameters in addition to the standard
207parameters documented in L<Log::Dispatch::Output>:
208
209=over 4
210
211=item * filename ($)
212
213The filename to be opened for writing.
214
215=item * mode ($)
216
217The mode the file should be opened with.  Valid options are 'write',
218'>', 'append', '>>', or the relevant constants from Fcntl.  The
219default is 'write'.
220
221=item * binmode ($)
222
223A layer name to be passed to binmode, like ":encoding(UTF-8)" or ":raw".
224
225=item * close_after_write ($)
226
227Whether or not the file should be closed after each write.  This
228defaults to false.
229
230If this is true, then the mode will always be append, so that the file is not
231re-written for each new message.
232
233=item * autoflush ($)
234
235Whether or not the file should be autoflushed.  This defaults to true.
236
237=item * syswrite ($)
238
239Whether or not to perform the write using L<perlfunc/syswrite>(),
240as opposed to L<perlfunc/print>().  This defaults to false.
241The usual caveats and warnings as documented in L<perlfunc/syswrite> apply.
242
243=item * permissions ($)
244
245If the file does not already exist, the permissions that it should
246be created with.  Optional.  The argument passed must be a valid
247octal value, such as 0600 or the constants available from Fcntl, like
248S_IRUSR|S_IWUSR.
249
250See L<perlfunc/chmod> for more on potential traps when passing octal
251values around.  Most importantly, remember that if you pass a string
252that looks like an octal value, like this:
253
254 my $mode = '0644';
255
256Then the resulting file will end up with permissions like this:
257
258 --w----r-T
259
260which is probably not what you want.
261
262=back
263
264=head1 AUTHOR
265
266Dave Rolsky <autarch@urth.org>
267
268=head1 COPYRIGHT AND LICENSE
269
270This software is Copyright (c) 2011 by Dave Rolsky.
271
272This is free software, licensed under:
273
274  The Artistic License 2.0 (GPL Compatible)
275
276=cut
277