File: | blib/lib/Log/Simple.pm |
Coverage: | 94.9% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Log::Simple; | ||||||
2 | 12 12 | 416790 56 | use 5.007; | ||||
3 | 12 12 12 | 76 19 456 | use strict; | ||||
4 | 12 12 12 | 76 36 608 | use warnings; | ||||
5 | |||||||
6 | 12 12 12 | 74 15 1350 | use Carp qw(croak); | ||||
7 | 12 12 12 | 6054 120858 116 | use POSIX qw(strftime); | ||||
8 | 12 12 12 | 28829 22919 86 | use Time::HiRes qw(time); | ||||
9 | |||||||
10 | our $VERSION = '0.05'; | ||||||
11 | |||||||
12 | BEGIN { | ||||||
13 | |||||||
14 | sub _sub_names { | ||||||
15 | 183 | 831 | my @levels = qw( | ||||
16 | emergency alert critical | ||||||
17 | error warning notice info debug | ||||||
18 | ); | ||||||
19 | 183 | 404 | my @short = qw(emerg crit err warn); | ||||
20 | 183 | 613 | my @nums = qw(_0 _1 _2 _3 _4 _5 _6 _7); | ||||
21 | |||||||
22 | 183 | 186 | my @all; | ||||
23 | 183 | 1392 | push @all, @levels, @short, @nums; | ||||
24 | |||||||
25 | 183 | 723 | return \@all; | ||||
26 | } | ||||||
27 | |||||||
28 | 12 | 57 | my $sub_names = _sub_names(); | ||||
29 | |||||||
30 | { | ||||||
31 | 12 12 12 12 | 5690 23 3849 22 | no strict 'refs'; | ||||
32 | |||||||
33 | 12 | 38 | for (@$sub_names) { | ||||
34 | 240 | 340 | my $sub = $_; | ||||
35 | |||||||
36 | *$_ = sub { | ||||||
37 | 166 | 8171 | my ($self, $msg) = @_; | ||||
38 | |||||||
39 | 166 | 924 | $self->level($ENV{LS_LEVEL}) if defined $ENV{LS_LEVEL}; | ||||
40 | |||||||
41 | 166 | 669 | if ($sub =~ /^_(\d)$/){ | ||||
42 | 52 | 158 | return if $1 > $self->level; | ||||
43 | } | ||||||
44 | 163 | 440 | return if $self->_level_value($sub) > $self->level; | ||||
45 | |||||||
46 | 159 | 2040 | my $proc = join '|', (caller(0))[1..2]; | ||||
47 | |||||||
48 | 159 | 863 | my %log_entry = ( | ||||
49 | label => $sub, | ||||||
50 | proc => $proc, | ||||||
51 | msg => $msg, | ||||||
52 | ); | ||||||
53 | |||||||
54 | 159 | 642 | $self->_generate_entry(%log_entry); | ||||
55 | } | ||||||
56 | 240 | 31565 | } | ||||
57 | } | ||||||
58 | } | ||||||
59 | sub new { | ||||||
60 | 56 | 0 | 1721584 | my ($class, %args) = @_; | |||
61 | |||||||
62 | 56 | 220 | my $self = bless {}, $class; | ||||
63 | |||||||
64 | 56 | 270 | if (defined $args{level}) { | ||||
65 | 18 | 66 | $self->level($args{level}); | ||||
66 | } | ||||||
67 | else { | ||||||
68 | 38 | 188 | my $lvl = defined $ENV{LS_LEVEL} ? $ENV{LS_LEVEL} : 4; | ||||
69 | 38 | 160 | $self->level($lvl); | ||||
70 | } | ||||||
71 | |||||||
72 | 56 | 205 | if ($args{file}){ | ||||
73 | 5 | 31 | $self->file($args{file}, $args{write_mode}); | ||||
74 | } | ||||||
75 | |||||||
76 | 56 | 193 | my $print = defined $args{print} ? $args{print} : 1; | ||||
77 | 56 | 244 | $self->print($print); | ||||
78 | |||||||
79 | 56 | 206 | $self->display( | ||||
80 | time => 1, | ||||||
81 | label => 1, | ||||||
82 | name => 1, | ||||||
83 | pid => 0, | ||||||
84 | proc => 0, | ||||||
85 | ); | ||||||
86 | |||||||
87 | 56 | 180 | if (defined $args{display}){ | ||||
88 | 4 | 17 | $self->display($args{display}); | ||||
89 | } | ||||||
90 | |||||||
91 | 56 | 295 | $self->name($args{name}); | ||||
92 | |||||||
93 | 56 | 263 | return $self; | ||||
94 | } | ||||||
95 | sub level { | ||||||
96 | 475 | 1 | 1120 | my ($self, $level) = @_; | |||
97 | |||||||
98 | 475 | 1061 | my %levels = $self->levels; | ||||
99 | 475 | 3068 | my %rev = reverse %levels; | ||||
100 | |||||||
101 | 475 | 1895 | $self->{level} = $ENV{LS_LEVEL} if defined $ENV{LS_LEVEL}; | ||||
102 | 475 | 515 | my $lvl; | ||||
103 | |||||||
104 | 475 | 1036 | if (defined $level) { | ||||
105 | 238 | 2190 | if ($level =~ /^\d$/ && defined $levels{$level}){ | ||||
106 | 229 | 607 | $self->{level} = $level; | ||||
107 | } | ||||||
108 | elsif ($level =~ /^\w{3}/ && defined($lvl = $self->_translate($level))){ | ||||||
109 | 8 | 23 | $self->{level} = $lvl; | ||||
110 | } | ||||||
111 | else { | ||||||
112 | 1 | 21 | CORE::warn | ||||
113 | "invalid level $level specified, using default 'warning'/4\n"; | ||||||
114 | } | ||||||
115 | } | ||||||
116 | 475 | 2952 | return $self->{level}; | ||||
117 | } | ||||||
118 | sub file { | ||||||
119 | 27 | 1 | 5667 | my ($self, $file, $mode) = @_; | |||
120 | |||||||
121 | 27 | 100 | if (! defined $file){ | ||||
122 | 1 | 5 | return $self->{file}; | ||||
123 | } | ||||||
124 | 26 | 132 | if ($file =~ /^0$/){ | ||||
125 | 7 | 131 | if (tell($self->{fh}) != -1) { | ||||
126 | 7 | 380 | close $self->{fh}; | ||||
127 | } | ||||||
128 | 7 | 22 | delete $self->{file}; | ||||
129 | 7 | 38 | delete $self->{fh}; | ||||
130 | 7 | 23 | return; | ||||
131 | } | ||||||
132 | 19 | 184 | if (defined $file && $self->{file} && $file ne $self->{file}){ | ||||
133 | 8 | 668 | close $self->{fh}; | ||||
134 | } | ||||||
135 | 19 | 78 | $mode = 'w' if ! defined $mode; | ||||
136 | 19 | 107 | my $op = $mode =~ /^a/ ? '>>' : '>'; | ||||
137 | |||||||
138 | 19 | 2496 | open $self->{fh}, $op, $file or die "can't open log file for writing: $!"; | ||||
139 | 19 | 78 | $self->{file} = $file; | ||||
140 | |||||||
141 | 19 | 87 | return $self->{file}; | ||||
142 | } | ||||||
143 | sub name { | ||||||
144 | 345 | 0 | 582 | my ($self, $name) = @_; | |||
145 | 345 | 767 | $self->{name} = $name if defined $name; | ||||
146 | 345 | 1314 | return $self->{name}; | ||||
147 | } | ||||||
148 | sub timestamp { | ||||||
149 | 79 | 0 | 283 | my $t = time; | |||
150 | 79 | 3729 | my $date = strftime "%Y-%m-%d %H:%M:%S", localtime $t; | ||||
151 | 79 | 803 | $date .= sprintf ".%03d", ($t-int($t))*1000; # without rounding | ||||
152 | 79 | 329 | return $date; | ||||
153 | } | ||||||
154 | sub levels { | ||||||
155 | 731 | 0 | 6012 | my ($self, $want) = @_; | |||
156 | |||||||
157 | 731 | 4071 | my %levels = ( | ||||
158 | 0 => 'emergency', | ||||||
159 | 1 => 'alert', | ||||||
160 | 2 => 'critical', | ||||||
161 | 3 => 'error', | ||||||
162 | 4 => 'warning', | ||||||
163 | 5 => 'notice', | ||||||
164 | 6 => 'info', | ||||||
165 | 7 => 'debug', | ||||||
166 | ); | ||||||
167 | |||||||
168 | 731 | 2211 | if (defined $want && $want eq 'names'){ | ||||
169 | 1 | 3 | my @level_list; | ||||
170 | 1 | 4 | for (0..7){ | ||||
171 | 8 | 15 | push @level_list, $levels{$_}; | ||||
172 | } | ||||||
173 | 1 | 9 | return @level_list; | ||||
174 | } | ||||||
175 | |||||||
176 | 730 | 5805 | return %levels; | ||||
177 | } | ||||||
178 | sub display { | ||||||
179 | 900 | 0 | 5477 | my $self = shift; | |||
180 | 900 | 882 | my ($tag, %tags); | ||||
181 | |||||||
182 | 900 | 1785 | if (@_ == 1){ | ||||
183 | 832 | 1067 | $tag = shift; | ||||
184 | } | ||||||
185 | else { | ||||||
186 | 68 | 312 | %tags = @_; | ||||
187 | } | ||||||
188 | |||||||
189 | 900 | 1994 | if (defined $tag){ | ||||
190 | 832 | 1934 | if ($tag =~ /^0$/){ | ||||
191 | 5 5 | 9 31 | for (keys %{ $self->{display} }){ | ||||
192 | 25 | 41 | $self->{display}{$_} = 0; | ||||
193 | } | ||||||
194 | 5 | 62 | return 0; | ||||
195 | } | ||||||
196 | 827 | 1520 | if ($tag =~ /^1$/){ | ||||
197 | 4 4 | 8 25 | for (keys %{ $self->{display} }){ | ||||
198 | 20 | 32 | $self->{display}{$_} = 1; | ||||
199 | } | ||||||
200 | 4 | 20 | return 1; | ||||
201 | } | ||||||
202 | |||||||
203 | 823 | 4236 | return $self->{display}{$tag}; | ||||
204 | } | ||||||
205 | |||||||
206 | 68 | 395 | my %valid = ( | ||||
207 | name => 0, | ||||||
208 | time => 0, | ||||||
209 | label => 0, | ||||||
210 | pid => 0, | ||||||
211 | proc => 0, | ||||||
212 | ); | ||||||
213 | |||||||
214 | 68 | 293 | for (keys %tags) { | ||||
215 | 291 | 602 | if (! defined $valid{$_}){ | ||||
216 | 1 | 28 | CORE::warn "$_ is an invalid tag...skipping\n"; | ||||
217 | 1 | 9 | next; | ||||
218 | } | ||||||
219 | 290 | 616 | $self->{display}{$_} = $tags{$_}; | ||||
220 | } | ||||||
221 | |||||||
222 | |||||||
223 | 68 68 | 123 311 | return %{ $self->{display} }; | ||||
224 | } | ||||||
225 | sub print { | ||||||
226 | 225 | 0 | 1502 | $_[0]->{print} = $_[1] if defined $_[1]; | |||
227 | 225 | 1421 | return $_[0]->{print}; | ||||
228 | } | ||||||
229 | sub child { | ||||||
230 | 24 | 0 | 209 | my ($self, $name) = @_; | |||
231 | 24 | 240 | my $child = bless { %$self }, ref $self; | ||||
232 | 24 | 64 | $child->name($self->name .".$name"); | ||||
233 | 24 | 62 | return $child; | ||||
234 | } | ||||||
235 | sub _level_value { | ||||||
236 | 283 | 64283 | my ($self, $level) = @_; | ||||
237 | |||||||
238 | 283 | 1069 | if ($level =~ /^_(\d)$/){ | ||||
239 | 97 | 536 | return $1; | ||||
240 | } | ||||||
241 | else { | ||||||
242 | 186 | 472 | return $self->_translate($level); | ||||
243 | } | ||||||
244 | } | ||||||
245 | sub _translate { | ||||||
246 | 252 | 3758 | my ($self, $label) = @_; | ||||
247 | |||||||
248 | 252 | 589 | my %levels = $self->levels; | ||||
249 | |||||||
250 | 252 | 1321 | if ($label =~ /^_?(\d)$/){ | ||||
251 | 57 | 317 | return $levels{$1}; | ||||
252 | } | ||||||
253 | else { | ||||||
254 | 195 | 1304 | my %rev = reverse %levels; | ||||
255 | 195 | 5627 | my ($lvl) = grep /^$label/, keys %rev; | ||||
256 | 195 | 1546 | return $rev{$lvl}; | ||||
257 | } | ||||||
258 | } | ||||||
259 | sub _generate_entry { | ||||||
260 | 164 | 283 | my $self = shift; | ||||
261 | 164 | 430 | my %entry = @_; | ||||
262 | |||||||
263 | 164 | 340 | my $label = $entry{label}; | ||||
264 | 164 | 235 | my $proc = $entry{proc}; | ||||
265 | 164 | 296 | my $msg = $entry{msg}; | ||||
266 | |||||||
267 | 164 | 520 | my $subs = $self->_sub_names; | ||||
268 | 164 3280 | 342 4914 | if (! grep { $label eq $_ } @$subs){ | ||||
269 | 1 | 288 | croak "_generate_entry() requires a sub/label name as its first param\n"; | ||||
270 | } | ||||||
271 | |||||||
272 | 163 | 609 | if ($label =~ /^_(\d)$/){ | ||||
273 | 49 | 158 | $label = $self->_translate($1); | ||||
274 | } | ||||||
275 | |||||||
276 | 163 | 522 | $msg = $msg ? "$msg\n" : "\n"; | ||||
277 | |||||||
278 | 163 | 168 | my $log_entry; | ||||
279 | 163 | 411 | $log_entry .= "[".$self->timestamp()."]" if $self->display('time'); | ||||
280 | 163 | 439 | $log_entry .= "[$label]" if $self->display('label'); | ||||
281 | 163 | 397 | $log_entry .= "[".$self->name."]" if $self->display('name') && $self->name; | ||||
282 | 163 | 341 | $log_entry .= "[$$]" if $self->display('pid'); | ||||
283 | 163 | 360 | $log_entry .= "[$proc]" if $self->display('proc'); | ||||
284 | 163 | 462 | $log_entry .= " " if $log_entry; | ||||
285 | 163 | 237 | $log_entry .= $msg; | ||||
286 | |||||||
287 | 163 | 423 | return $log_entry if ! $self->print; | ||||
288 | |||||||
289 | 46 | 105 | if ($self->{fh}){ | ||||
290 | 45 45 | 46 515 | print { $self->{fh} } $log_entry; | ||||
291 | } | ||||||
292 | else { | ||||||
293 | 1 | 9 | print $log_entry; | ||||
294 | } | ||||||
295 | } | ||||||
296 | |||||||
297 | 1; |