File Coverage

File:	blib/lib/Log/Simple.pm
Coverage:	94.9%

line	stmt	bran	cond	sub	pod	time	code
1							package Log::Simple;
2	12 12			12		416790 56	use 5.007;
3	12 12 12			12		76 19 456	use strict;
4	12 12 12			12		76 36 608	use warnings;
5
6	12 12 12			12		74 15 1350	use Carp qw(croak);
7	12 12 12			12		6054 120858 116	use POSIX qw(strftime);
8	12 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			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			12		57	my $sub_names = _sub_names();
29
30							{
31	12 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			166		8171	my ($self, $msg) = @_;
38
39	166	100				924	$self->level($ENV{LS_LEVEL}) if defined $ENV{LS_LEVEL};
40
41	166	100				669	if ($sub =~ /^_(\d)$/){
42	52	100				158	return if $1 > $self->level;
43							}
44	163	100				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			56	0	1721584	my ($class, %args) = @_;
61
62	56					220	my $self = bless {}, $class;
63
64	56	100				270	if (defined $args{level}) {
65	18					66	$self->level($args{level});
66							}
67							else {
68	38	100				188	my $lvl = defined $ENV{LS_LEVEL} ? $ENV{LS_LEVEL} : 4;
69	38					160	$self->level($lvl);
70							}
71
72	56	100				205	if ($args{file}){
73	5					31	$self->file($args{file}, $args{write_mode});
74							}
75
76	56	100				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	100				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			475	1	1120	my ($self, $level) = @_;
97
98	475					1061	my %levels = $self->levels;
99	475					3068	my %rev = reverse %levels;
100
101	475	100				1895	$self->{level} = $ENV{LS_LEVEL} if defined $ENV{LS_LEVEL};
102	475					515	my $lvl;
103
104	475	100				1036	if (defined $level) {
105	238	100 100	67 67			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			27	1	5667	my ($self, $file, $mode) = @_;
120
121	27	100				100	if (! defined $file){
122	1					5	return $self->{file};
123							}
124	26	100				132	if ($file =~ /^0$/){
125	7	50				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	100	25			184	if (defined $file && $self->{file} && $file ne $self->{file}){
133	8					668	close $self->{fh};
134							}
135	19	100				78	$mode = 'w' if ! defined $mode;
136	19	100				107	my $op = $mode =~ /^a/ ? '>>' : '>';
137
138	19	50				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			345	0	582	my ($self, $name) = @_;
145	345	100				767	$self->{name} = $name if defined $name;
146	345					1314	return $self->{name};
147							}
148							sub timestamp {
149	79			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			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	100	67			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			900	0	5477	my $self = shift;
180	900					882	my ($tag, %tags);
181
182	900	100				1785	if (@_ == 1){
183	832					1067	$tag = shift;
184							}
185							else {
186	68					312	%tags = @_;
187							}
188
189	900	100				1994	if (defined $tag){
190	832	100				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	100				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	100				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	100		225	0	1502	$_[0]->{print} = $_[1] if defined $_[1];
227	225					1421	return $_[0]->{print};
228							}
229							sub child {
230	24			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			283		64283	my ($self, $level) = @_;
237
238	283	100				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			252		3758	my ($self, $label) = @_;
247
248	252					589	my %levels = $self->levels;
249
250	252	100				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			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	100				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	100				609	if ($label =~ /^_(\d)$/){
273	49					158	$label = $self->_translate($1);
274							}
275
276	163	100				522	$msg = $msg ? "$msg\n" : "\n";
277
278	163					168	my $log_entry;
279	163	100				411	$log_entry .= "[".$self->timestamp()."]" if $self->display('time');
280	163	100				439	$log_entry .= "[$label]" if $self->display('label');
281	163	100	100			397	$log_entry .= "[".$self->name."]" if $self->display('name') && $self->name;
282	163	100				341	$log_entry .= "[$$]" if $self->display('pid');
283	163	100				360	$log_entry .= "[$proc]" if $self->display('proc');
284	163	100				462	$log_entry .= " " if $log_entry;
285	163					237	$log_entry .= $msg;
286
287	163	100				423	return $log_entry if ! $self->print;
288
289	46	100				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;