File Coverage

blib/lib/CTK/Log.pm
Criterion Covered Total %
statement 112 155 72.2
branch 35 62 56.4
condition 26 70 37.1
subroutine 22 44 50.0
pod 20 20 100.0
total 215 351 61.2


line stmt bran cond sub pod time code
1             package CTK::Log;
2 3     3   55954 use strict;
  3         11  
  3         74  
3 3     3   13 use utf8;
  3         5  
  3         10  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::Log - CTK Logging
10              
11             =head1 VERSION
12              
13             Version 2.64
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Log;
18             use CTK::Log qw/:constants/;
19              
20             my $logger = CTK::Logger->new (
21             file => "logs/foo.log",
22             level => CTK::Log::LOG_INFO,
23             ident => "ident string",
24             );
25              
26             $logger->log( CTK::Log::LOG_INFO, " ... Blah-Blah-Blah ... " );
27              
28             $logger->log_except( "..." ); # 9 exception, aborts program!
29             $logger->log_fatal( "..." ); # 8 system unusable, aborts program!
30             $logger->log_emerg( "..." ); # 7 system is unusable
31             $logger->log_alert( "..." ); # 6 failure in primary system
32             $logger->log_crit( "..." ); # 5 failure in backup system
33             $logger->log_error( "..." ); # 4 non-urgent program errors, a bug
34             $logger->log_warning( "..." ); # 3 possible problem, not necessarily error
35             $logger->log_notice( "..." ); # 2 unusual conditions
36             $logger->log_info( "..." ); # 1 normal messages, no action required
37             $logger->log_debug( "..." ); # 0 debugging messages (default)
38              
39             =head1 DESCRIPTION
40              
41             Logger class
42              
43             Log level overview:
44              
45             LVL SLL NAME ALIAS NOTE
46             0 7 debug debugging messages, copious tracing output
47             1 6 info normal messages, no action required
48             2 5 notice note unusual conditions
49             3 4 warning warn possible problem, not necessarily error
50             4 3 error err non-urgent program errors, a bug
51             5 2 critical crit failure in backup system
52             6 1 alert failure in primary system
53             7 0 emergency emerg system unusable
54             8 0 fatal system unusable, aborts program!
55             9 0 exception except exception, aborts program!
56              
57             * SLL -- SysLog Level
58              
59             =head1 METHODS
60              
61             =head2 new
62              
63             my $logger = CTK::Log->new(
64             file => "logs/foo.log",
65             level => "info", # or CTK::Log::LOG_INFO
66             ident => "ident string",
67             );
68              
69             Returns logger object for logging to file
70              
71             my $logger = CTK::Log->new(
72             level => "info", # or CTK::Log::LOG_INFO
73             ident => "ident string",
74             );
75              
76             Returns logger object for logging to syslog
77              
78             =over 8
79              
80             =item B
81              
82             The part of the system to report about, for example C. See L
83              
84             Default: C
85              
86             =item B
87              
88             Specifies log file. If not specify, then will be used syslog
89              
90             Default: undef
91              
92             =item B
93              
94             Specifies ident string for each log-record
95              
96             ident = "test"
97              
98             [Mon Apr 29 20:02:04 2019] [info] [7936] [test] Blah Blah Blah
99              
100             ident = undef
101              
102             [Mon Apr 29 20:02:04 2019] [info] [7936] Blah Blah Blah
103              
104             Default: undef
105              
106             =item B
107              
108             This directive specifies the minimum possible priority level. You can use:
109              
110             constants:
111              
112             LOG_DEBUG
113             LOG_INFO
114             LOG_NOTICE or LOG_NOTE
115             LOG_WARNING or LOG_WARN
116             LOG_ERR or LOG_ERROR
117             LOG_CRIT
118             LOG_ALERT
119             LOG_EMERG or LOG_EMERGENCY
120             LOG_FATAL
121             LOG_EXCEPT or LOG_EXCEPTION
122              
123             ...or strings:
124              
125             'debug'
126             'info'
127             'notice' or 'note'
128             'warning' or 'warn'
129             'error' or 'err'
130             'crit'
131             'alert'
132             'emerg' or 'emergency'
133             'fatal'
134             'except' or 'exception'
135              
136             Default: C
137              
138             =item B
139              
140             Specifies flag for suppressing prefixes log-data
141              
142             ident = "test"
143             pure = 0
144              
145             [Mon Apr 29 19:12:55 2019] [crit] [7480] [test] Blah-Blah-Blah
146              
147             ident = "test"
148             pure = 1
149              
150             [test] Blah-Blah-Blah
151              
152             ident = undef
153             pure = 1
154              
155             Blah-Blah-Blah
156              
157             Default: 0
158              
159             =item B
160              
161             Separator of log-record elements
162              
163             separator = " "
164              
165             [Mon Apr 29 20:02:04 2019] [info] [7936] [test] Blah Blah Blah
166              
167             separator = ","
168              
169             [Mon Apr 29 20:02:04 2019],[info],[7936],[test],Blah Blah Blah
170              
171             Default: C<" ">
172              
173             =item B
174              
175             Socket optrions for L
176              
177             Allowed formats, examples:
178              
179             socketopts => "unix"
180             socketopts => ["unix"]
181             socketopts => { type => "tcp", port => 2486 }
182              
183             Default: C
184              
185             =item B
186              
187             Options of L
188              
189             Default: C
190              
191             =item B
192              
193             Sets to 1 for send data to syslog forced
194              
195             Default: 0
196              
197             =item B
198              
199             Sets flag utf8 for logging data. The flag is enabled by default
200              
201             Default: 1
202              
203             =back
204              
205             =head2 error
206              
207             my $error = $logger->error;
208              
209             Returns error string if occurred any errors while creating the object
210              
211             =head2 status
212              
213             print $logger->error unless $logger->status;
214              
215             Returns boolean status of object creating
216              
217             =head1 LOG METHODS
218              
219             =head2 log
220              
221             $logger->log( , , , ... );
222             $logger->log( LOG_INFO, "Message: Blah-Blah-Blah" );
223             $logger->log( LOG_INFO, "Message: %s", "Blah-Blah-Blah" );
224             $logger->log( "info", "Message: Blah-Blah-Blah" );
225              
226             Logging with info level (1). Same as log_info( "Message: %s", "Blah-Blah-Blah" )
227              
228             =head2 log_debug
229              
230             $logger->log_debug( , , ... );
231             $logger->log_debug( "the function returned 3" );
232             $logger->log_debug( "going to call function abc" );
233              
234             Level 0: debug-level messages (default)
235              
236             =head2 log_info
237              
238             $logger->log_info( , , ... );
239             $logger->log_info( "File soandso successfully deleted." );
240              
241             Level 1: informational
242              
243             =head2 log_notice, log_note
244              
245             $logger->log_notice( , , ... );
246             $logger->log_notice( "Attempted to create config, but config already exists." );
247              
248             Level 2: normal but significant condition
249              
250             =head2 log_warning, log_warn
251              
252             $logger->log_warning( , , ... );
253             $logger->log_warning( "Couldn't delete the file." );
254              
255             Level 3: warning conditions
256              
257             =head2 log_error, log_err
258              
259             $logger->log_error( , , ... );
260             $logger->log_error( "Division by zero attempted." );
261              
262             Level 4: error conditions
263              
264             =head2 log_crit, log_critical
265              
266             $logger->log_crit( , , ... );
267             $logger->log_crit( "The battery is too hot!" );
268              
269             Level 5: critical conditions
270              
271             =head2 log_alert
272              
273             $logger->log_alert( , , ... );
274             $logger->log_alert( "The battery died!" );
275              
276             Level 6: action must be taken immediately
277              
278             =head2 log_emerg, log_emergency
279              
280             $logger->log_emerg( , , ... );
281             $logger->log_emerg( "No config found, cannot continue!" );
282              
283             Level 7: system is unusable
284              
285             =head2 log_fatal
286              
287             $logger->log_fatal( , , ... );
288             $logger->log_fatal( "No free memory" );
289              
290             Level 8: fatal
291              
292             =head2 log_except, log_exception
293              
294             $logger->log_except( , , ... );
295             $logger->log_except( "Segmentation violation" );
296              
297             Level 9: exception
298              
299             =head1 HISTORY
300              
301             See C file
302              
303             =head1 DEPENDENCIES
304              
305             L, L
306              
307             =head1 TO DO
308              
309             See C file
310              
311             =head1 BUGS
312              
313             * none noted
314              
315             =head1 SEE ALSO
316              
317             L, L
318              
319             =head1 AUTHOR
320              
321             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
322              
323             =head1 COPYRIGHT
324              
325             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
326              
327             =head1 LICENSE
328              
329             This program is free software; you can redistribute it and/or
330             modify it under the same terms as Perl itself.
331              
332             See C file and L
333              
334             =cut
335              
336              
337 3     3   181 use vars qw/$VERSION %EXPORT_TAGS @EXPORT_OK/;
  3         6  
  3         186  
338             $VERSION = '2.64';
339              
340 3     3   15 use base qw/Exporter/;
  3         5  
  3         307  
341              
342 3     3   18 use Carp;
  3         4  
  3         195  
343 3     3   385 use IO::File;
  3         7017  
  3         388  
344 3     3   2174 use Sys::Syslog ();
  3         33185  
  3         95  
345 3     3   975 use Try::Tiny;
  3         3699  
  3         178  
346 3     3   20 use Cwd qw/getcwd/;
  3         7  
  3         107  
347 3     3   16 use File::Spec ();
  3         7  
  3         499  
348              
349             @EXPORT_OK = qw(
350             LOG_DEBUG LOG_INFO LOG_NOTICE LOG_NOTE LOG_WARNING LOG_WARN LOG_ERR
351             LOG_ERROR LOG_CRIT LOG_ALERT LOG_EMERG LOG_EMERGENCY LOG_FATAL
352             LOG_EXCEPT LOG_EXCEPTION
353             );
354              
355             %EXPORT_TAGS = (
356             constants => [@EXPORT_OK],
357             );
358              
359             use constant {
360 3 50       5530 LOGOPT => 'ndelay,pid', # For Sys::Syslog
361             MSWIN => $^O =~ /mswin/i ? 1 : 0,
362             SEPARATOR => ' ',
363             LOGLEVELSA => [qw/debug info notice warning error crit alert emerg fatal except/],
364             LOGLEVELS => {
365             'debug' => 0,
366             'info' => 1,
367             'notice' => 2, 'note' => -2,
368             'warning' => 3, 'warn' => -3,
369             'error' => 4, 'err' => -4,
370             'crit' => 5, 'critical' => -5,
371             'alert' => 6,
372             'emerg' => 7, 'emergency' => -7,
373             'fatal' => 8,
374             'except' => 9, 'exception' => -9,
375             },
376             LOG_DEBUG => 0,
377             LOG_INFO => 1,
378             LOG_NOTICE => 2, LOG_NOTE => 2,
379             LOG_WARNING => 3, LOG_WARN => 3,
380             LOG_ERR => 4, LOG_ERROR => 4,
381             LOG_CRIT => 5,
382             LOG_ALERT => 6,
383             LOG_EMERG => 7, LOG_EMERGENCY => 7,
384             LOG_FATAL => 8,
385             LOG_EXCEPT => 9, LOG_EXCEPTION => 9,
386 3     3   19 };
  3         13  
387              
388             my %SYSLOG_LEVEL_MAP = (
389             # My LEVEL , SysLog LEVEL
390             LOG_DEBUG , LOG_EMERG,
391             LOG_INFO , LOG_ALERT,
392             LOG_NOTICE , LOG_CRIT,
393             LOG_WARNING , LOG_ERR,
394             LOG_ERR , LOG_WARNING,
395             LOG_CRIT , LOG_NOTICE,
396             LOG_ALERT , LOG_INFO,
397             LOG_EMERG , LOG_DEBUG,
398             LOG_FATAL , LOG_DEBUG,
399             LOG_EXCEPT , LOG_DEBUG,
400             );
401              
402             sub new {
403 2     2 1 118 my $class = shift;
404 2         7 my %args = @_;
405 2   50     13 my $level = _getLevel($args{level} // LOG_DEBUG);
406 2 50       7 carp(sprintf("Incorrect level %s", $args{level})) unless defined $level;
407 2   50     11 my $usesyslog = $args{usesyslog} || 0;
408 2   50     10 my $syslogopts = $args{syslogopts} // LOGOPT;
409 2         3 my $socketopts = $args{socketopts};
410 2   50     8 my $facility = $args{facility} || Sys::Syslog::LOG_USER;
411 2         4 my $file = $args{file};
412 2 100 66     9 $usesyslog = 1 unless defined($file) && length($file);
413 2 100 66     35 $file = File::Spec->catfile(getcwd(), $file)
414             if $file && !File::Spec->file_name_is_absolute($file);
415              
416             # Create object
417             my $self = bless {
418             status => 0,
419             error => "",
420             usesyslog => $usesyslog,
421             file => $file,
422             level => $level || LOG_DEBUG,
423             ident => $args{ident},
424             syslogopts => $syslogopts,
425             socketopts => $socketopts,
426             facility => $facility,
427             separator => $args{separator} // SEPARATOR,
428             "utf8" => $args{"utf8"} // 1,
429 2   100     48 pure => $args{pure} // 0,
      50        
      50        
      50        
430             fh => undef,
431             }, $class;
432              
433 2 100       13 if ($usesyslog) {
434             # never log to console - thats too slow, and
435             # it corrupts the DBD database connection!
436 1 50 33     8 if ($socketopts && ref($socketopts) eq 'ARRAY') {
    50 0        
      33        
437 0         0 Sys::Syslog::setlogsock(@$socketopts);
438             } elsif ($socketopts && (!ref($socketopts) || ref($socketopts) eq 'HASH')) {
439 0         0 Sys::Syslog::setlogsock($socketopts);
440             }
441             #elsif (!MSWIN) {
442             # Sys::Syslog::setlogsock('unix');
443             #}
444 1   50     4 my $ident = $args{ident} || scalar(caller(0));
445             try { # ignore errors
446 1     1   67 Sys::Syslog::openlog($ident, $syslogopts, $facility);
447             } catch {
448 0   0 0   0 $self->{error} = $_ // '';
449 1         14 };
450 1 50       273 return $self if length($self->{error});
451 1         4 $self->{status} = 1;
452             } else {
453 1         1 my $fh;
454             try {
455 1     1   52 $fh = IO::File->new($file, "a");
456             } catch {
457 0     0   0 $self->{error} = sprintf("Can't open log file %s: %s", $file, $_);
458 1         6 };
459 1 50       194 return $self if length($self->{error});
460 1 50       3 unless (defined($fh)) {
461 0         0 $self->{error} = sprintf("Can't open log file %s", $file);
462 0         0 return $self;
463             }
464 1 50       5 $fh->binmode(":raw:utf8") if $self->{"utf8"};
465 1         17 $fh->autoflush(1);
466 1         42 $self->{fh} = $fh;
467 1         1 $self->{status} = 1;
468             }
469              
470 2         10 return $self;
471             }
472             sub error {
473 2     2 1 4 my $self = shift;
474 2   50     6 return $self->{error} // '';
475             }
476             sub status {
477 5     5 1 438 my $self = shift;
478 5 50       22 return $self->{status} ? 1 : 0;
479             }
480              
481             sub log {
482 2     2 1 3 my $self = shift;
483 2   50     5 my $ll = shift // LOG_DEBUG;
484 2         3 my @msg = @_;
485 2 50       4 return 0 unless $self->status;
486 2         3 my $ident = $self->{ident};
487 2         4 my $level = _getLevel($ll);
488 2 50       4 unless (defined($level)) {
489 0         0 unshift(@msg, $ll);
490 0         0 $level = LOG_DEBUG;
491             }
492 2 100       17 return 0 if $level < $self->{level};
493              
494             # Flush!
495 1 50       3 if ($self->{usesyslog}) {
496 0         0 return $self->_flush_to_syslog($level, @msg);
497             } else {
498 1         3 return $self->_flush_to_file($level, @msg);
499             }
500              
501 0         0 return 0;
502             }
503 0     0 1 0 sub log_debug { shift->log(LOG_DEBUG, @_) };
504 1     1 1 3 sub log_info { shift->log(LOG_INFO, @_) };
505 0     0 1 0 sub log_notice { shift->log(LOG_NOTICE, @_) };
506 0     0 1 0 sub log_note { goto &log_notice };
507 0     0 1 0 sub log_warning { shift->log(LOG_WARNING, @_) };
508 0     0 1 0 sub log_warn { goto &log_warning };
509 0     0 1 0 sub log_error { shift->log(LOG_ERROR, @_) };
510 0     0 1 0 sub log_err { goto &log_error };
511 0     0 1 0 sub log_critical { shift->log(LOG_CRIT, @_) };
512 0     0 1 0 sub log_crit { goto &log_critical };
513 0     0 1 0 sub log_alert { shift->log(LOG_ALERT, @_) };
514 0     0 1 0 sub log_emerg { shift->log(LOG_EMERG, @_) };
515 0     0 1 0 sub log_emergency { goto &log_emerg };
516 0     0 1 0 sub log_fatal { shift->log(LOG_FATAL, @_) };
517 0     0 1 0 sub log_except { shift->log(LOG_EXCEPT, @_) };
518 0     0 1 0 sub log_exception { goto &log_except };
519              
520             # Internal methods
521             sub _flush_to_file {
522 1     1   2 my $self = shift;
523 1         1 my $level = shift;
524 1   50     2 my $format = shift // "";
525 1         3 my @message = @_;
526 1 50       2 return unless defined $level;
527              
528             # Adding
529 1         2 my @buffer = ();
530 1 50       2 unless ($self->{pure}) {
531 1         49 push @buffer, sprintf("[%s]", scalar(localtime(time())));
532 1         5 push @buffer, sprintf("[%s]", LOGLEVELSA()->[$level]);
533 1         4 push @buffer, sprintf("[%s]", $$);
534             }
535              
536             # Ident?
537 1         9 my $ident = $self->{ident};
538 1 50 33     8 push @buffer, sprintf("[%s]", $ident) if defined($ident) && length($ident);
539              
540             # Print
541 1         2 my $fh = $self->{fh};
542 1 50       3 if (defined($fh)) {
543             try {
544 1 50   1   70 $fh->print(join($self->{separator}, @buffer, "")) if @buffer;
545 1         61 $fh->printf($format, @message);
546 1         22 $fh->print("\n");
547             } catch {
548 0   0 0   0 $self->{error} = $_ // '';
549 1         8 };
550 1 50       30 return 0 if length($self->{error});
551             } else {
552 0         0 $self->{status} = 0;
553 0         0 return 0;
554             }
555              
556 1         5 return 1;
557             }
558             sub _flush_to_syslog {
559 0     0   0 my $self = shift;
560 0         0 my $level = shift;
561 0   0     0 my $format = shift // "";
562 0         0 my @message = @_;
563 0 0       0 return unless defined $level;
564 0         0 my $sl = _to_syslog($level);
565             try { # ignore errors
566 0     0   0 Sys::Syslog::syslog($sl, $format, @message);
567             } catch {
568 0   0 0   0 $self->{error} = $_ // '';
569 0         0 };
570 0 0       0 return 0 if length($self->{error});
571 0         0 return 1;
572             }
573              
574             # Internal functions
575             sub _getLevel { # Returns integer val: 0-9 -- ok, undef - incorrect :(
576 4     4   7 my $ll = shift;
577 4 50       10 return LOG_DEBUG unless defined $ll;
578 4         5 my $loglevels = LOGLEVELS;
579 4         44 my %levels = %$loglevels; # name => val
580 4         37 my %rlevels = reverse %$loglevels; # val => name
581 4 100 66     43 if (($ll =~ /^[0-9]+$/) && exists($rlevels{$ll})) { # integer val
    50 33        
582 3 50 33     22 return $ll if $ll >= LOG_DEBUG and $ll <= LOG_EXCEPT;
583 0         0 return LOG_DEBUG;
584             } elsif (($ll =~ /^[a-z]+$/i) && exists($levels{lc($ll)})) { # string
585 1         7 return $levels{lc($ll)};
586             }
587 0         0 return undef;
588             }
589             sub _to_syslog { # for syslog
590 0   0 0   0 my $level = shift // LOG_DEBUG;
591 0   0     0 return $SYSLOG_LEVEL_MAP{$level} // $SYSLOG_LEVEL_MAP{(LOG_DEBUG)};
592             }
593              
594             sub DESTROY {
595 2     2   6 my $self = shift;
596 2 50 33     12 return 1 unless $self && $self->status;
597 2 100       12 if ($self->{usesyslog}) {
598 1         7 Sys::Syslog::closelog();
599             } else {
600 1 50 33     8 $self->{fh}->close if defined($self->{fh}) && ref($self->{fh});
601             }
602 2         52 undef($self);
603 2         129 return 1;
604             }
605              
606             1;
607              
608             __END__