File Coverage

blib/lib/Log/Report/Dispatcher/File.pm
Criterion Covered Total %
statement 60 86 69.7
branch 11 36 30.5
condition 4 14 28.5
subroutine 14 18 77.7
pod 6 7 85.7
total 95 161 59.0


line stmt bran cond sub pod time code
1             # Copyrights 2007-2017 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5 4     4   2200 use warnings;
  4         8  
  4         124  
6 4     4   20 use strict;
  4         8  
  4         103  
7              
8             package Log::Report::Dispatcher::File;
9 4     4   18 use vars '$VERSION';
  4         8  
  4         175  
10             $VERSION = '1.21';
11              
12 4     4   23 use base 'Log::Report::Dispatcher';
  4         9  
  4         255  
13              
14 4     4   21 use Log::Report 'log-report';
  4         9  
  4         31  
15 4     4   22 use IO::File ();
  4         10  
  4         87  
16 4     4   22 use POSIX qw/strftime/;
  4         8  
  4         31  
17              
18 4     4   244 use Encode qw/find_encoding/;
  4         9  
  4         177  
19 4     4   27 use Fcntl qw/:flock/;
  4         9  
  4         3342  
20              
21              
22             sub init($)
23 4     4 0 11 { my ($self, $args) = @_;
24              
25 4 50       14 if(!$args->{charset})
26 4   50     41 { my $lc = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG} || '';
27 4 50       11 my $cs = $lc =~ m/\.([\w-]+)/ ? $1 : '';
28 4   33     15 $args->{charset} = length $cs && find_encoding $cs ? $cs : undef;
29             }
30              
31 4         24 $self->SUPER::init($args);
32              
33 4         18 my $name = $self->name;
34             $self->{to} = $args->{to}
35 4 50       15 or error __x"dispatcher {name} needs parameter 'to'", name => $name;
36 4   50     27 $self->{replace} = $args->{replace} || 0;
37              
38 4   50 0   13 my $format = $args->{format} || sub { '['.localtime()."] $_[0]" };
  0         0  
39             $self->{LRDF_format}
40             = ref $format eq 'CODE' ? $format
41             : $format eq 'LONG'
42 0     0   0 ? sub { my $msg = shift;
43 0   0     0 my $domain = shift || '-';
44 0         0 my $stamp = strftime "%Y-%m-%dT%H:%M:%S", gmtime;
45 0         0 "[$stamp $$] $domain $msg"
46             }
47 4 0 0     14 : error __x"unknown format parameter `{what}'"
    50          
48             , what => ref $format || $format;
49              
50 4         13 $self;
51             }
52              
53              
54              
55             sub close()
56 4     4 1 7 { my $self = shift;
57 4 50       22 $self->SUPER::close
58             or return;
59              
60 4         9 my $to = $self->{to};
61             my @close
62 0         0 = ref $to eq 'CODE' ? values %{$self->{LRDF_out}}
63             : $self->{LRDF_filename} ? $self->{LRDF_output}
64 4 50       22 : ();
    50          
65              
66 4         10 $_->close for @close;
67 4         18 $self;
68             }
69              
70             #-----------
71              
72 0     0 1 0 sub filename() {shift->{LRDF_filename}}
73 9     9 1 30 sub format() {shift->{LRDF_format}}
74              
75              
76             sub output($)
77             { # fast simple case
78 9 100   9 1 31 return $_[0]->{LRDF_output} if $_[0]->{LRDF_output};
79              
80 4         13 my ($self, $msg) = @_;
81 4         15 my $name = $self->name;
82              
83 4         9 my $to = $self->{to};
84 4 50       13 if(!ref $to)
85             { # constant file name
86 0         0 $self->{LRDF_filename} = $to;
87 0 0       0 my $binmode = $self->{replace} ? '>' : '>>';
88              
89 0 0       0 my $f = $self->{LRDF_output} = IO::File->new($to, $binmode)
90             or fault __x"cannot write log into {file} with mode {binmode}"
91             , binmode => $binmode, file => $to;
92 0         0 $f->autoflush;
93 0         0 return $self->{LRDF_output} = $f;
94             }
95              
96 4 50       23 if(ref $to eq 'CODE')
97             { # variable filename
98 0         0 my $fn = $self->{LRDF_filename} = $to->($self, $msg);
99 0         0 return $self->{LRDF_output} = $self->{LRDF_out}{$fn};
100             }
101              
102             # probably file-handle
103 4         10 $self->{LRDF_output} = $to;
104             }
105              
106              
107             #-----------
108              
109             sub rotate($)
110 0     0 1 0 { my ($self, $old) = @_;
111              
112 0         0 my $to = $self->{to};
113             my $logs = ref $to eq 'CODE' ? $self->{LRDF_out}
114 0 0       0 : +{ $self->{to} => $self->{LRDF_output} };
115            
116 0         0 while(my ($log, $fh) = each %$logs)
117 0 0       0 { !ref $log
118             or error __x"cannot rotate log file which was opened as file-handle";
119              
120              
121 0 0       0 my $oldfn = ref $old eq 'CODE' ? $old->($log) : $old;
122 0         0 trace "rotating $log to $oldfn";
123              
124 0 0       0 rename $log, $oldfn
125             or fault __x"unable to rotate logfile {fn} to {oldfn}"
126             , fn => $log, oldfn => $oldfn;
127              
128 0         0 $fh->close; # close after move not possible on Windows?
129 0 0       0 my $f = $self->{LRDF_output} = $logs->{$log} = IO::File->new($log, '>>')
130             or fault __x"cannot write log into {file}", file => $log;
131 0         0 $f->autoflush;
132             }
133              
134 0         0 $self;
135             }
136              
137             #-----------
138              
139             sub log($$$$)
140 9     9 1 29 { my ($self, $opts, $reason, $msg, $domain) = @_;
141 9         37 my $trans = $self->translate($opts, $reason, $msg);
142 9         35 my $text = $self->format->($trans, $domain, $msg, %$opts);
143              
144 9         40 my $out = $self->output($msg);
145 9         29 flock $out, LOCK_EX;
146 9         49 $out->print($text);
147 9         87 flock $out, LOCK_UN;
148             }
149              
150             1;