1 |
3 |
ahitrov@rambler.ru |
package Contenido::Logger; |
2 |
|
|
use base 'Log::Dispatch'; |
3 |
|
|
use strict; |
4 |
|
|
use Log::Dispatch::Screen; |
5 |
|
|
use Carp; |
6 |
|
|
|
7 |
|
|
=head1 NAME |
8 |
|
|
|
9 |
|
|
Contenido::Logger - Log wrapper for conenido around Log::Dispatch. |
10 |
|
|
|
11 |
|
|
=head1 SYNOPSIS |
12 |
|
|
|
13 |
|
|
my $log = Contenido::Logger->new(); |
14 |
|
|
$log->debug('Hello world'); |
15 |
|
|
$log->error('SMX code is wrong'); |
16 |
|
|
$log->emergency('Fuck!'); |
17 |
|
|
|
18 |
|
|
=head1 DESCRIPTION |
19 |
|
|
|
20 |
|
|
Not yet |
21 |
|
|
|
22 |
|
|
=head1 METHODS |
23 |
|
|
|
24 |
|
|
=head2 new |
25 |
|
|
|
26 |
|
|
Contenido::Logger->new(%options); |
27 |
|
|
|
28 |
|
|
=head2 instance |
29 |
|
|
|
30 |
|
|
Contenido::Logger->instance(%options); |
31 |
|
|
|
32 |
|
|
|
33 |
|
|
=over |
34 |
|
|
|
35 |
|
|
Options: |
36 |
|
|
|
37 |
|
|
=item * |
38 |
|
|
|
39 |
|
|
min_level: minimum level of logging |
40 |
|
|
[debug info notice warning error critical alert emergency]. |
41 |
|
|
|
42 |
|
|
=item * |
43 |
|
|
|
44 |
|
|
max_level: maximum level of logging |
45 |
|
|
|
46 |
|
|
=item * |
47 |
|
|
|
48 |
|
|
callback: custom callback when logging (instead of default). |
49 |
|
|
CODE reference. See L<Log::Dispatch> for more info. |
50 |
|
|
|
51 |
|
|
=item * |
52 |
|
|
|
53 |
|
|
log_format: custom log format style. Default to '%d %C:%L(%P) [%l]: %m%n'. |
54 |
|
|
|
55 |
|
|
=over |
56 |
|
|
|
57 |
|
|
Where: |
58 |
|
|
|
59 |
|
|
=item * |
60 |
|
|
|
61 |
|
|
%d - date (format [mday/mon/year hour:min:sec]) |
62 |
|
|
|
63 |
|
|
=item * |
64 |
|
|
|
65 |
|
|
%P - current process ID |
66 |
|
|
|
67 |
|
|
=item * |
68 |
|
|
|
69 |
|
|
%C - name of package caused this log |
70 |
|
|
|
71 |
|
|
=item * |
72 |
|
|
|
73 |
|
|
%L - code line in %C |
74 |
|
|
|
75 |
|
|
=item * |
76 |
|
|
|
77 |
|
|
%l - log level |
78 |
|
|
|
79 |
|
|
=item * |
80 |
|
|
|
81 |
|
|
%m - log text |
82 |
|
|
|
83 |
|
|
=item * |
84 |
|
|
|
85 |
|
|
%n - "\n" |
86 |
|
|
|
87 |
|
|
=back |
88 |
|
|
|
89 |
|
|
=item * |
90 |
|
|
|
91 |
|
|
stack_trace: enable stack trace on log levels warning, ..., emergency. Boolean. |
92 |
|
|
|
93 |
|
|
=back |
94 |
|
|
|
95 |
|
|
=cut |
96 |
|
|
|
97 |
|
|
our @levels = qw/debug info notice warning error critical alert emergency/; |
98 |
|
|
my $i = 0; |
99 |
|
|
our %levels = map { $_ => $i++ } @levels; |
100 |
|
|
$levels{emerg} = $levels{emergency}; |
101 |
|
|
$levels{err} = $levels{error}; |
102 |
|
|
$levels{crit} = $levels{critical}; |
103 |
|
|
my $instance; |
104 |
|
|
|
105 |
|
|
sub new { |
106 |
|
|
my ($this, %opts) = @_; |
107 |
|
|
$this = ref $this if ref $this; |
108 |
|
|
|
109 |
|
|
my $log_format = $opts{log_format} || "%d %C:%L(%P) [%l]: %m%n"; |
110 |
|
|
my %subst_hash = ( |
111 |
|
|
P => $$, |
112 |
|
|
n => "\n", |
113 |
|
|
); |
114 |
|
|
$log_format =~ s#%(.)#exists $subst_hash{$1} ? $subst_hash{$1} : '%'.$1#ge; |
115 |
|
|
my $stack_trace = $opts{stack_trace}; |
116 |
|
|
my $custom_callback = $opts{callback}; |
117 |
|
|
|
118 |
|
|
my $callback = sub { |
119 |
|
|
my %p = @_; |
120 |
|
|
$p{message} .= |
121 |
|
|
"\n >>>>>>>>>> StackTrace\n". |
122 |
|
|
Carp::longmess('Begin StackTrace'). |
123 |
|
|
" <<<<<<<<<< /StackTrace" |
124 |
|
|
if $stack_trace and $levels{$p{level}} >= $levels{warning}; |
125 |
|
|
return $custom_callback->(%p) if $custom_callback; |
126 |
|
|
|
127 |
|
|
my ($sec, $min, $hour, $mday, $mon, $year) = localtime; |
128 |
|
|
$subst_hash{d} = sprintf( |
129 |
|
|
'[%02d/%02d/%02d %02d:%02d:%02d]', |
130 |
|
|
$mday, $mon+1, $year-100, $hour, $min, $sec, |
131 |
|
|
); |
132 |
|
|
|
133 |
|
|
$subst_hash{m} = $p{message}; |
134 |
|
|
$subst_hash{l} = $p{level}; |
135 |
|
|
|
136 |
|
|
#Who's calling? |
137 |
|
|
my @caller = caller(4 - ($p{_direct} || 0)); |
138 |
|
|
$subst_hash{C} = $caller[0]; |
139 |
|
|
$subst_hash{L} = $caller[2]; |
140 |
|
|
|
141 |
|
|
my $final_msg = $log_format; |
142 |
|
|
$final_msg =~ s#%(.)#exists $subst_hash{$1} ? $subst_hash{$1} : '%'.$1#ge; |
143 |
|
|
return $final_msg; |
144 |
|
|
}; |
145 |
|
|
|
146 |
|
|
my $self = $this->SUPER::new(callbacks => $callback); |
147 |
|
|
|
148 |
|
|
my $minlevel = $opts{min_level} || 'debug'; |
149 |
|
|
$self->add( |
150 |
|
|
Log::Dispatch::Screen->new( |
151 |
|
|
name => 'genlog', |
152 |
|
|
min_level => $minlevel, |
153 |
|
|
max_level => $opts{max_level} || 'emergency', |
154 |
|
|
stderr => 1, |
155 |
|
|
) |
156 |
|
|
); |
157 |
|
|
$self->cut_min_level($minlevel); |
158 |
|
|
$instance = $self; |
159 |
|
|
$self; |
160 |
|
|
} |
161 |
|
|
|
162 |
|
|
sub instance { $instance || shift->new( @_ ) } |
163 |
|
|
|
164 |
|
|
sub cut_min_level { |
165 |
|
|
my (undef, $minlevel) = @_; |
166 |
|
|
my $num = $levels{$minlevel} or return; |
167 |
|
|
my @to_cut = grep {$levels{$_} < $num} keys %levels; |
168 |
|
|
no strict 'refs'; |
169 |
|
|
no warnings; |
170 |
|
|
*$_ = sub {} for @to_cut; |
171 |
|
|
*log = sub { |
172 |
|
|
my $self = shift; |
173 |
|
|
my %p = @_; |
174 |
|
|
return if $levels{$p{level}} < $num; |
175 |
|
|
$self->SUPER::log(@_, caller !~ /^Log::Dispatch/ ? (_direct => 1) : ()); |
176 |
|
|
}; |
177 |
|
|
return; |
178 |
|
|
} |
179 |
|
|
|
180 |
|
|
sub log { shift->SUPER::log(@_, caller !~ /^Log::Dispatch/ ? (_direct => 1) : ()) } |
181 |
|
|
|
182 |
|
|
1; |