File Coverage

blib/lib/Debug/Easy.pm
Criterion Covered Total %
statement 171 202 84.6
branch 48 68 70.5
condition 10 18 55.5
subroutine 14 23 60.8
pod 12 12 100.0
total 255 323 78.9


line stmt bran cond sub pod time code
1             #############################################################################
2             ################# Easy Debugging Module ######################
3             ################# Copyright 2013 - 2021 Richard Kelsch ######################
4             ################# All Rights Reserved ######################
5             #############################################################################
6             ####### Licensing information available near the end of this file. ##########
7             #############################################################################
8              
9             package Debug::Easy;
10              
11 4     4   422269 use strict;
  4         39  
  4         165  
12             use constant {
13 4         339 TRUE => 1,
14             FALSE => 0
15 4     4   24 };
  4         8  
16              
17 4     4   3810 use DateTime;
  4         2076879  
  4         236  
18 4     4   3308 use Term::ANSIColor;
  4         42266  
  4         440  
19 4     4   2737 use Time::HiRes qw(time);
  4         6219  
  4         18  
20 4     4   805 use File::Basename;
  4         8  
  4         266  
21              
22 4     4   2843 use Data::Dumper; $Data::Dumper::Sortkeys = TRUE; $Data::Dumper::Purity = TRUE; $Data::Dumper::Deparse = TRUE;
  4         28728  
  4         377  
23              
24 4     4   35 use Config;
  4         14  
  4         373  
25              
26              
27             BEGIN {
28 4     4   25 require Exporter;
29              
30             # set the version for version checking
31 4         10 our $VERSION = '2.05';
32              
33             # Inherit from Exporter to export functions and variables
34 4         80 our @ISA = qw(Exporter);
35              
36             # Functions and variables which are exported by default
37 4         21 our @EXPORT = qw();
38              
39             # Functions and variables which can be optionally exported
40 4         11312 our @EXPORT_OK = qw(@Levels);
41             } ## end BEGIN
42              
43             # This can be optionally exported for whatever
44             our @Levels = qw( ERR WARN NOTICE INFO VERBOSE DEBUG DEBUGMAX );
45              
46             # For quick level checks to speed up execution
47             our %LevelLogic;
48             for (my $count = 0 ; $count < scalar(@Levels) ; $count++) {
49             $LevelLogic{$Levels[$count]} = $count;
50             }
51              
52             our $PARENT = $$; # This needs to be defined at the very beginning before new
53             my ($SCRIPTNAME, $SCRIPTPATH, $suffix) = fileparse($0);
54              
55             =head1 NAME
56              
57             Debug::Easy - A Handy Debugging Module With Colorized Output and Formatting
58              
59             =head1 SYNOPSIS
60              
61             use Debug::Easy;
62              
63             my $debug = Debug::Easy->new( 'LogLevel' => 'DEBUG', 'Color' => 1 );
64              
65             'LogLevel' is the maximum level to report, and ignore the rest. The method names correspond to their loglevels, when outputting a specific message. This identifies to the module what type of message it is.
66              
67             The following is a list, in order of level, of the logging methods:
68              
69             ERR = Error
70             WARN = Warning
71             NOTICE = Notice
72             INFO = Information
73             VERBOSE = Special version of INFO that does not output any
74             Logging headings. Very useful for verbose modes in your
75             scripts.
76             DEBUG = Level 1 Debugging messages
77             DEBUGMAX = Level 2 Debugging messages (typically more terse)
78              
79             The parameter is either a string or a reference to an array of strings to output as multiple lines.
80              
81             Each string can contain newlines, which will also be split into a separate line and formatted accordingly.
82              
83             $debug->ERR( ['Error message']);
84             $debug->ERROR( ['Error message']);
85             $debug->WARN( ['Warning message']);
86             $debug->WARNING( ['Warning message']);
87             $debug->NOTICE( ['Notice message']);
88             $debug->INFO( ['Information and VERBOSE mode message']);
89             $debug->INFORMATION(['Information and VERBOSE mode message']);
90             $debug->DEBUG( ['Level 1 Debug message']);
91             $debug->DEBUGMAX( ['Level 2 (terse) Debug message']);
92              
93             my @messages = (
94             'First Message',
95             'Second Message',
96             "Third Message First Line\nThird Message Second Line",
97             \%hash_reference
98             );
99              
100             $debug->INFO(\@messages);
101              
102             =head1 DESCRIPTION
103              
104             This module makes it easy to add debugging features to your code, Without having to re-invent the wheel. It uses STDERR and ANSI color formatted text output, as well as indented and multiline text formatting, to make things easy to read. NOTE: It is generally defaulted to output in a format for viewing on wide terminals!
105              
106             Benchmarking is automatic, to make it easy to spot bottlenecks in code. It automatically stamps from where it was called, and makes debug coding so much easier, without having to include the location of the debugging location in your debug message. This is all taken care of for you.
107              
108             It also allows multiple output levels from errors only, to warnings, to notices, to verbose information, to full on debug output. All of this fully controllable by the coder.
109              
110             Generally all you need are the defaults and you are ready to go.
111              
112             =head1 B<EXPORTABLE VARIABLES>
113              
114             =head2 B<@Levels>
115              
116             A simple list of all the acceptable debug levels to pass as "LogLevel" in the {new} method. Not normally needed for coding, more for reference. Only exported if requested.
117              
118             =cut
119              
120             sub DESTROY { # We spit out one last message before we die, the total execute time.
121 13     13   8210 my $self = shift;
122 13         216 my $bench = colored(['bright_cyan'], sprintf('%06s', sprintf('%.02f', (time - $self->{'MASTERSTART'}))));
123 13         619 my $name = $SCRIPTNAME;
124 13 50       89 $name .= ' [child]' if ($PARENT ne $$);
125 13         113 $self->DEBUG([$bench . ' ' . colored(['black on_white'],"---- $name complete ----")]);
126             }
127              
128             =head1 B<METHODS>
129              
130             =head2 B<new>
131              
132             * The parameter names are case insensitive as of Version 0.04.
133              
134             =over 4
135              
136             =item B<LogLevel> [level]
137              
138             This adjusts the global log level of the Debug object. It requires a string.
139              
140             =back
141              
142             =over 8
143              
144             B<ERR> (default)
145              
146             This level shows only error messages and all other messages are not shown.
147              
148             B<WARN>
149              
150             This level shows error and warning messages. All other messages are not shown.
151              
152             B<NOTICE>
153              
154             This level shows error, warning, and notice messages. All other messages are not shown.
155              
156             B<INFO>
157              
158             This level shows error, warning, notice, and information messages. Only debug level messages are not shown.
159              
160             B<VERBOSE>
161              
162             This level can be used as a way to do "Verbose" output for your scripts. It ouputs INFO level messages without logging headers and on STDOUT instead of STDERR.
163              
164             B<DEBUG>
165              
166             This level shows error, warning, notice, information, and level 1 debugging messages. Level 2 Debug messages are not shown.
167              
168             B<DEBUGMAX>
169              
170             This level shows all messages up to level 2 debugging messages.
171              
172             NOTE: It has been asked "Why have two debugging levels?" Well, I have had many times where I would like to see what a script is doing without it showing what I consider garbage overhead it may generate. This is simply because the part of the code you are debugging you may not need such a high level of detail. I use 'DEBUGMAX' to show me absolutely everything. Such as Data::Dumper output. Besides, anyone asking that question obviously hasn't dealt with complex data conversion scripts.
173              
174             =back
175              
176             =over 4
177              
178             =item B<Color> [boolean] (Not case sensitive)
179              
180             B<0>, B<Off>, or B<False> (Off)
181              
182             This turns off colored output. Everything is plain text only.
183              
184             B<1>, B<On>, or B<True> (On - Default)
185              
186             This turns on colored output. This makes it easier to spot all of the different types of messages throughout a sea of debug output. You can read the output with Less, and see color, by using it's switch "-r".
187              
188             =back
189              
190             =over 4
191              
192             =item B<Prefix> [pattern]
193              
194             This is global
195              
196             A string that is parsed into the output prefix.
197              
198             DEFAULT: '%Date% %Time% %Benchmark% %Loglevel%[%Subroutine%][%Lastline%] '
199              
200             %Date% = Date (Uses format of "DateStamp" below)
201             %Time% = Time (Uses format of "TimeStamp" below)
202             %Epoch% = Epoch (Unix epoch)
203             %Benchmark% = Benchmark - The time it took between the last benchmark display
204             of this loglevel. If in an INFO level message, it benchmarks
205             the time until the next INFO level message. The same rule is
206             true for all loglevels.
207             %Loglevel% = Log Level
208             %Lines% = Line Numbers of all nested calls
209             %Module% = Module and subroutine of call (can be a lot of stuff!)
210             %Subroutine% = Just the last subroutine
211             %Lastline% = Just the last line number
212             %PID% = Process ID
213             %date% = Just Date (typically used internally only, use %Date%)
214             %time% = Just time (typically used internally only, use %Time%)
215             %epoch% = Unix epoch (typically used internally only, use %Epoch%)
216             %Filename% = Script Filename (parsed $0)
217             %Fork% = Running in parent or child?
218             P = Parent
219             C = Child
220             %Thread% = Running in Parent or Thread
221             P = Parent
222             T## = Thread # = Thread ID
223              
224             =item B<[loglevel]-Prefix> [pattern]
225              
226             You can define a prefix for a specific log level.
227              
228             ERR-Prefix
229             WARN-Prefix
230             NOTICE-Prefix
231             INFO-Prefix
232             DEBUG-Prefix
233             DEBUGMAX-Prefix
234              
235             If one of these are not defined, then the global value is used.
236              
237             =item B<TimeStamp> [pattern]
238              
239             (See Log::Fast for specifics on these)
240              
241             I suggest you just use Prefix above, but here it is anyway.
242              
243             Make this an empty string to turn it off, otherwise:
244              
245             =back
246              
247             =over 8
248              
249             B<%T>
250              
251             Formats the timestamp as HH:MM:SS. This is the default for the timestamp.
252              
253             B<%S>
254              
255             Formats the timestamp as seconds.milliseconds. Normally not needed, as the benchmark is more helpful.
256              
257             B<%T %S>
258              
259             Combines both of the above. Normally this is just too much, but here if you really want it.
260              
261             =back
262              
263             =over 4
264              
265             =item B<DateStamp> [pattern]
266              
267             I suggest you just use Prefix above, but here it is anyway.
268              
269             Make this an empty string to turn it off, otherwise:
270              
271             =back
272              
273             =over 8
274              
275             B<%D>
276              
277             Formats the datestamp as YYYY-MM-DD. It is the default, and the only option.
278              
279             =back
280              
281             =over 4
282              
283             =item B<FileHandle>
284              
285             File handle to write log messages.
286              
287             =item B<ANSILevel>
288              
289             Contains a hash reference describing the various colored debug level labels
290              
291             The default definition (using Term::ANSIColor) is as follows:
292              
293             =back
294              
295             =over 8
296              
297             'ANSILevel' => {
298             'ERR' => colored(['white on_red'], '[ ERROR ]'),
299             'WARN' => colored(['black on_yellow'], '[WARNING]'),
300             'NOTICE' => colored(['yellow'], '[NOTICE ]'),
301             'INFO' => colored(['black on_white'], '[ INFO ]'),
302             'DEBUG' => colored(['bold green'], '[ DEBUG ]'),
303             'DEBUGMAX' => colored(['bold black on_green'], '[DEBUGMX]'),
304             }
305              
306             =back
307              
308             =cut
309              
310             sub new {
311             # This module uses the Log::Fast library heavily. Many of the
312             # Log::Fast variables and features can work here. See the perldocs
313             # for Log::Fast for specifics.
314 13     13 1 3147 my $class = shift;
315 13         514 my ($filename, $dir, $suffix) = fileparse($0);
316 13         181 my $self = {
317             'LogLevel' => 'ERR', # Default is errors only
318             'Type' => 'fh', # Default is a filehandle
319             'Path' => '/var/log', # Default path should type be unix
320             'FileHandle' => \*STDERR, # Default filehandle is STDERR
321             'MasterStart' => time,
322             'ANY_LastStamp' => time, # Initialize main benchmark
323             'ERR_LastStamp' => time, # Initialize the ERR benchmark
324             'WARN_LastStamp' => time, # Initialize the WARN benchmark
325             'INFO_LastStamp' => time, # Initialize the INFO benchmark
326             'NOTICE_LastStamp' => time, # Initialize the NOTICE benchmark
327             'DEBUG_LastStamp' => time, # Initialize the DEBUG benchmark
328             'DEBUGMAX_LastStamp' => time, # Initialize the DEBUGMAX benchmark
329             'Color' => TRUE, # Default to colorized output
330             'DateStamp' => colored(['yellow'], '%date%'),
331             'TimeStamp' => colored(['yellow'], '%time%'),
332             'Epoch' => colored(['cyan'], '%epoch%'),
333             'Padding' => -20, # Default padding is 20 spaces
334             'Lines-Padding' => -2,
335             'Subroutine-Padding' => 0,
336             'Line-Padding' => 0,
337             'PARENT' => $$,
338             'Prefix' => '%Date% %Time% %Benchmark% %Loglevel%[%Subroutine%][%Lastline%] ',
339             'DEBUGMAX-Prefix' => '%Date% %Time% %Benchmark% %Loglevel%[%Module%][%Lines%] ',
340             'Filename' => '[' . colored(['magenta'], $filename) . ']',
341             'TIMEZONE' => DateTime::TimeZone->new(name => 'local'),
342             'ANSILevel' => {
343             'ERR' => colored(['white on_red'], '[ ERROR ]'),
344             'WARN' => colored(['black on_yellow'], '[WARNING ]'),
345             'NOTICE' => colored(['yellow'], '[ NOTICE ]'),
346             'INFO' => colored(['black on_white'], '[ INFO ]'),
347             'DEBUG' => colored(['bold green'], '[ DEBUG ]'),
348             'DEBUGMAX' => colored(['bold black on_green'], '[DEBUGMAX]'),
349             },
350             };
351              
352             # This pretty much makes all hash keys uppercase
353 13         28114 my @Keys = (keys %{$self}); # Hash is redefined on the fly, so get the list before
  13         88  
354 13         39 foreach my $Key (@Keys) {
355 338         482 my $upper = uc($Key);
356 338 100       622 if ($Key ne $upper) {
    50          
357 312         588 $self->{$upper} = $self->{$Key};
358              
359             # This fixes a documentation error for past versions
360 312 100       590 if ($upper eq 'LOGLEVEL') {
361 13 50       40 $self->{$upper} = 'ERR' if ($self->{$upper} =~ /^ERROR$/i);
362 13         35 $self->{$upper} = uc($self->{$upper}); # Make loglevels case insensitive
363             }
364 312         877 delete($self->{$Key});
365             } elsif ($Key eq 'LOGLEVEL') { # Make loglevels case insensitive
366 0         0 $self->{$upper} = uc($self->{$upper});
367             }
368             } ## end foreach my $Key (@Keys)
369             { # This makes sure the user overrides actually override
370 13         26 my %params = (@_);
  13         58  
371 13         45 foreach my $Key (keys %params) {
372 39         104 $self->{uc($Key)} = $params{$Key};
373             }
374             }
375              
376             # This instructs the ANSIColor library to turn off coloring,
377             # if the Color attribute is set to zero.
378 13 50       96 if ($self->{'COLOR'} =~ /0|FALSE|OFF|NO/i) {
379 0         0 $ENV{'ANSI_COLORS_DISABLED'} = TRUE;
380             # If COLOR is FALSE, then clear color data from ANSILEVEL, as these were
381             # defined before color was turned off.
382 0         0 $self->{'ANSILEVEL'} = {
383             'ERR' => '[ ERROR ]',
384             'WARN' => '[WARNING ]',
385             'NOTICE' => '[ NOTICE ]',
386             'INFO' => '[ INFO ]',
387             'DEBUG' => '[ DEBUG ]',
388             'DEBUGMAX' => '[DEBUGMAX]',
389             };
390 0         0 $self->{'DATESTAMP'} = '%date%';
391 0         0 $self->{'TIMESTAMP'} = '%time%';
392 0         0 $self->{'EPOCH'} = '%epoch%';
393             }
394              
395 13         41 foreach my $lvl (@Levels) {
396 91 100 66     455 $self->{"$lvl-PREFIX"} = $self->{'PREFIX'} unless (exists($self->{"$lvl-PREFIX"}) && defined($self->{"$lvl-PREFIX"}));
397             }
398              
399 13         31 my $fh = $self->{'FILEHANDLE'};
400             # Signal the script has started (and logger initialized)
401 13         38 my $name = $SCRIPTNAME;
402 13 50       54 $name .= ' [child]' if ($PARENT ne $$);
403 13         97 print $fh sprintf(' %.02f%s %s', 0, $self->{'ANSILEVEL'}->{'DEBUG'}, colored(['black on_white'], "----- $name begin -----") . " (To View in 'less', use it's '-r' switch)" ),"\n";
404              
405 13         777 bless($self, $class);
406 13         93 return ($self);
407             } ## end sub new
408              
409             =head2 debug
410              
411             NOTE: This is a legacy method for backwards compatibility. Please use the direct methods instead.
412              
413             The parameters must be passed in the order given
414              
415             =over 4
416              
417             =item B<LEVEL>
418              
419             The log level with which this message is to be triggered
420              
421             =item B<MESSAGE(S)>
422              
423             A string or a reference to a list of strings to output line by line.
424              
425             =back
426              
427             =cut
428              
429             sub debug {
430 247     247 1 154490 my $self = shift;
431 247         516 my $level = uc(shift);
432 247         350 my $msgs = shift;
433              
434 247 100       1379 if ($level !~ /ERR.*|WARN.*|NOTICE|INFO.*|DEBUG/i) { # Compatibility with older versions.
435 108         176 $level = uc($msgs); # It tosses the legacy __LINE__ argument
436 108         216 $msgs = shift;
437             }
438 247         1060 $level =~ s/(OR|ING|RMATION)$//; # Strip off the excess
439              
440             # A much quicker bypass when the log level is below what is needed
441 247 100       1316 return if ($LevelLogic{$self->{'LOGLEVEL'}} < $LevelLogic{$level});
442              
443 142         221 my @messages;
444 142 100 66     723 if (ref($msgs) eq 'SCALAR' || ref($msgs) eq '') {
    50          
445 92         207 push(@messages, $msgs);
446             } elsif (ref($msgs) eq 'ARRAY') {
447 50         74 @messages = @{$msgs};
  50         140  
448             } else {
449 0         0 push(@messages,Dumper($msgs));
450             } ## end else [ if (ref($msgs) eq 'SCALAR'...)]
451 142         409 my ($sname, $cline, $nested, $subroutine, $thisBench, $thisBench2, $sline, $short) = ('', '', '', '', '', '', '', '');
452              
453             # Figure out the proper caller tree and line number ladder
454             # But only if it's part of the prefix, else don't waste time.
455 142 50       899 if ($self->{'PREFIX'} =~ /\%(Subroutine|Module|Lines|Lastline)\%/) { # %P = Subroutine, %l = Line number(s)
456 142         251 my $package = '';
457 142         184 my $count = 1;
458 142         188 my $nest = 0;
459 142         475 while (my @array = caller($count)) {
460 12 100       63 if ($array[3] !~ /Debug::Easy/) {
461 4         32 $package = $array[0];
462 4         9 my $subroutine = $array[3];
463 4         45 $subroutine =~ s/^$package\:\://;
464 4         26 $sname =~ s/$subroutine//;
465 4 50       18 if ($sname eq '') {
466 4 50       14 $sname = ($subroutine ne '') ? $subroutine : $package;
467 4         10 $cline = $array[2];
468             } else {
469 0         0 $sname = $subroutine . '::' . $sname;
470 0         0 $cline = $array[2] . '/' . $cline;
471             }
472 4 50       16 if ($count == 2) {
473 0         0 $short = $array[3];
474 0         0 $sline = $array[2];
475             }
476 4         9 $nest++;
477             } ## end if ($array[3] !~ /Debug::Easy/)
478 12         59 $count++;
479             } ## end while (my @array = caller...)
480 142 100       324 if ($package ne '') {
481 4         12 $sname = $package . '::' . $sname;
482 4 50       15 $nested = ' ' x $nest if ($nest);
483             } else {
484 138         240 my @array = caller(1);
485 138         212 $cline = $array[2];
486 138 50 33     361 if (!defined($cline) || $cline eq '') {
487 138         724 @array = caller(0);
488 138         287 $cline = $array[2];
489             }
490 138         207 $sname = 'main';
491 138         199 $sline = $cline;
492 138         297 $short = $sname;
493             } ## end else [ if ($package ne '') ]
494 142 50       312 $subroutine = ($sname ne '') ? $sname : 'main';
495 142 50       383 $self->{'PADDING'} = 0 - length($subroutine) if (length($subroutine) > abs($self->{'PADDING'}));
496 142 50       331 $self->{'LINES-PADDING'} = 0 - length($cline) if (length($cline) > abs($self->{'LINES-PADDING'}));
497 142 100       301 $self->{'SUBROUTINE-PADDING'} = 0 - length($short) if (length($short) > abs($self->{'SUBROUTINE-PADDING'}));
498 142 100       313 $self->{'LINE-PADDING'} = 0 - length($sline) if (length($sline) > abs($self->{'LINE-PADDING'}));
499 142         549 $cline = sprintf('%' . $self->{'LINES-PADDING'} . 's', $cline);
500 142         748 $subroutine = colored(['bold cyan'], sprintf('%' . $self->{'PADDING'} . 's', $subroutine));
501 142         6484 $sline = sprintf('%' . $self->{'LINE-PADDING'} . 's', $sline);
502 142         525 $short = colored(['bold cyan'], sprintf('%' . $self->{'SUBROUTINE-PADDING'} . 's', $short));
503             } ## end if ($self->{'PREFIX'} ...)
504              
505             # Figure out the benchmarks, but only if it is in the prefix
506 142 50       5556 if ($self->{'PREFIX'} =~ /\%Benchmark\%/) {
507             # For multiline output, only output the bench data on the first line. Use padded spaces for the rest.
508             # $thisBench = sprintf('%7s', sprintf(' %.02f', time - $self->{$level . '_LASTSTAMP'}));
509 142         1185 $thisBench = sprintf('%7s', sprintf(' %.02f', time - $self->{'ANY_LASTSTAMP'}));
510 142         409 $thisBench2 = ' ' x length($thisBench);
511             } ## end if ($self->{'PREFIX'} ...)
512 142         217 my $first = TRUE; # Set the first line flag.
513 142         261 foreach my $msg (@messages) { # Loop through each line of output and format accordingly.
514 234 50       529 if (ref($msg) ne '') {
515 0         0 $msg = Dumper($msg);
516             } ## end if (ref($msg) ne '')
517 234 100       566 if ($msg =~ /\n/s) { # If the line contains newlines, then it too must be split into multiple lines.
518 46         159 my @message = split(/\n/, $msg);
519 46         86 foreach my $line (@message) { # Loop through the split lines and format accordingly.
520 92         269 $self->_send_to_logger($level, $nested, $line, $first, $thisBench, $thisBench2, $subroutine, $cline, $sline, $short);
521 92         250 $first = FALSE; # Clear the first line flag.
522             }
523             } else { # This line does not contain newlines. Treat it as a single line.
524 188         495 $self->_send_to_logger($level, $nested, $msg, $first, $thisBench, $thisBench2, $subroutine, $cline, $sline, $short);
525             }
526 234         569 $first = FALSE; # Clear the first line flag.
527             } ## end foreach my $msg (@messages)
528 142         323 $self->{'ANY_LASTSTAMP'} = time;
529 142         680 $self->{$level . '_LASTSTAMP'} = time;
530             } ## end sub debug
531              
532             sub _send_to_logger { # This actually simplifies the previous method ... seriously
533 280     280   415 my $self = shift;
534 280         413 my $level = shift;
535 280         393 my $padding = shift;
536 280         368 my $msg = shift;
537 280         421 my $first = shift;
538 280         362 my $thisBench = shift;
539 280         392 my $thisBench2 = shift;
540 280         375 my $subroutine = shift;
541 280         378 my $cline = shift;
542 280         374 my $sline = shift;
543 280         376 my $shortsub = shift;
544              
545 280   33     669 my $timezone = $self->{'TIMEZONE'} || DateTime::TimeZone->new(name => 'local');
546 280         970 my $dt = DateTime->now('time_zone' => $timezone);
547 280         93687 my $Date = $dt->ymd();
548 280         3933 my $Time = $dt->hms();
549 280         2583 my $prefix = $self->{$level . '-PREFIX'} . ''; # A copy not a pointer
550 280 50       953 my $forked = ($PARENT ne $$) ? 'C' : 'P';
551 280         419 my $threaded = 'PT-';
552 280         637 my $epoch = time;
553 280 50 33     3196 if (exists($Config{'useithreads'}) && $Config{'useithreads'}) { # Do eval so non-threaded perl's don't whine
554 0         0 eval(q(
555             my $tid = threads->tid();
556             $threaded = ($tid > 0) ? sprintf('T%02d',$tid) : 'PT-';
557             ));
558             }
559              
560 280         1055 $prefix =~ s/\%PID\%/$$/g;
561 280         1522 $prefix =~ s/\%Loglevel\%/$self->{'ANSILEVEL'}->{$level}/g;
562 280         701 $prefix =~ s/\%Lines\%/$cline/g;
563 280         811 $prefix =~ s/\%Lastline\%/$sline/g;
564 280         770 $prefix =~ s/\%Subroutine\%/$shortsub/g;
565 280         966 $prefix =~ s/\%Date\%/$self->{'DATESTAMP'}/g;
566 280         957 $prefix =~ s/\%Time\%/$self->{'TIMESTAMP'}/g;
567 280         533 $prefix =~ s/\%Epoch\%/$self->{'EPOCH'}/g;
568 280         735 $prefix =~ s/\%date\%/$Date/g;
569 280         760 $prefix =~ s/\%time\%/$Time/g;
570 280         490 $prefix =~ s/\%epoch\%/$epoch/g;
571 280         452 $prefix =~ s/\%Filename\%/$self->{'FILENAME'}/g;
572 280         485 $prefix =~ s/\%Fork\%/$forked/g;
573 280         439 $prefix =~ s/\%Thread\%/$threaded/g;
574 280         430 $prefix =~ s/\%Module\%/$subroutine/g;
575              
576 280 100       554 if ($first) {
577 142         407 $prefix =~ s/\%Benchmark\%/$thisBench/g;
578             } else {
579 138         391 $prefix =~ s/\%Benchmark\%/$thisBench2/g;
580             }
581 280         531 my $fh = $self->{'FILEHANDLE'};
582 280 100 100     939 if ($level eq 'INFO' && $self->{'LOGLEVEL'} eq 'VERBOSE') { # Trap verbose flag and temporarily drop the prefix.
    100          
583 6         48 print $fh "$msg\n";
584             # $self->{'LOG'}->INFO($msg);
585             } elsif ($level eq 'DEBUGMAX') { # Special version of DEBUG. Outputs as DEBUG in Log::Fast
586 12 50       31 if ($self->{'LOGLEVEL'} eq 'DEBUGMAX') {
587 12         109 print $fh "$prefix$padding$msg\n";
588             # $self->{'LOG'}->DEBUG($prefix . $padding . $msg);
589             }
590             } else {
591 262         2411 print $fh "$prefix$padding$msg\n";
592             # $self->{'LOG'}->$level($prefix . $padding . $msg);
593             }
594             } ## end sub _send_to_logger
595              
596             =head2 B<ERR> or B<ERROR>
597              
598             Sends ERROR level debugging output to the log. Errors are always shown.
599              
600             =over 4
601              
602             =item B<MESSAGE>
603              
604             Either a single string or a reference to a list of strings
605              
606             =back
607             =cut
608              
609             sub ERR {
610 0     0 1 0 my $self = shift;
611 0         0 $self->debug('ERR', @_);
612             }
613              
614             sub ERROR {
615 0     0 1 0 my $self = shift;
616 0         0 $self->debug('ERR', @_);
617             }
618              
619             =head2 B<WARN> or B<WARNING>
620              
621             If the log level is WARN or above, then these warnings are logged.
622              
623             =over 4
624              
625             =item B<MESSAGE>
626              
627             Either a single string or a reference to a list of strings
628              
629             =back
630             =cut
631              
632             sub WARN {
633 0     0 1 0 my $self = shift;
634 0         0 $self->debug('WARN', @_);
635             }
636              
637             sub WARNING {
638 0     0 1 0 my $self = shift;
639 0         0 $self->debug('WARN', @_);
640             }
641              
642             =head2 B<NOTICE> or B<ATTENTION>
643              
644             If the loglevel is NOTICE or above, then these notices are logged.
645              
646             =over 4
647              
648             =item B<MESSAGE>
649              
650             Either a single string or a reference to a list of strings
651              
652             =back
653             =cut
654              
655             sub NOTICE {
656 0     0 1 0 my $self = shift;
657 0         0 $self->debug('NOTICE', @_);
658             }
659              
660             sub ATTENTION {
661 0     0 1 0 my $self = shift;
662 0         0 $self->debug('NOTICE'. @_);
663             }
664              
665             =head2 B<INFO> or B<INFORMATION>
666              
667             If the loglevel is INFO (or VERBOSE) or above, then these information messages are displayed.
668              
669             =over 4
670              
671             =item B<MESSAGE>
672              
673             Either a single string or a reference to a list of strings
674              
675             =back
676             =cut
677              
678             sub INFO {
679 0     0 1 0 my $self = shift;
680 0         0 $self->debug('INFO', @_);
681             }
682              
683             sub INFORMATION {
684 0     0 1 0 my $self = shift;
685 0         0 $self->debug('INFO', @_);
686             }
687              
688             =head2 B<DEBUG>
689              
690             If the Loglevel is DEBUG or above, then basic debugging messages are logged. DEBUG is intended for basic program flow messages for easy tracing. Best not to place variable contents in these messages.
691              
692             =over 4
693              
694             =item B<MESSAGE>
695              
696             Either a single string or a reference to a list of strings
697              
698             =back
699             =cut
700              
701             sub DEBUG {
702 13     13 1 611 my $self = shift;
703 13         46 $self->debug('DEBUG', @_);
704             }
705              
706             =head2 B<DEBUGMAX>
707              
708             If the loglevel is DEBUGMAX, then all messages are shown, and terse debugging messages as well. Typically DEBUGMAX is used for variable dumps and detailed data output for heavy tracing. This is a very "noisy" log level.
709              
710             =over 4
711              
712             =item B<MESSAGE>
713              
714             Either a single string or a reference to a list of strings
715              
716             =back
717             =cut
718              
719             sub DEBUGMAX {
720 0     0 1   my $self = shift;
721 0           $self->debug('DEBUGMAX', @_);
722             }
723              
724             1;
725              
726             =head1 B<CAVEATS>
727              
728             Since it is possible to duplicate the object in a fork or thread, the output formatting may be mismatched between forks and threads due to the automatic padding adjustment of the subroutine name field.
729              
730             Ways around this are to separately create a Debug::Easy object in each fork or thread, and have them log to separate files.
731              
732             The "less" pager is the best for viewing log files generated by this module. It's switch "-r" allows you to see them in all their colorful glory.
733              
734             =head1 B<INSTALLATION>
735              
736             To install this module, run the following commands:
737              
738             perl Build.PL
739             ./Build
740             ./Build test
741             ./Build install
742              
743             OR you can use the old ExtUtils::MakeMaker method:
744              
745             perl Makefile.PL
746             make
747             make test
748             make install
749              
750             =head1 AUTHOR
751              
752             Richard Kelsch <rich@rk-internet.com>
753              
754             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
755              
756             =head1 B<VERSION>
757              
758             Version 2.05 (April 5, 2021)
759              
760             =head1 B<BUGS>
761              
762             Please report any bugs or feature requests to C<bug-easydebug at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=EasyDebug>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
763              
764             =head1 B<SUPPORT>
765              
766             You can find documentation for this module with the perldoc command.
767              
768             C<perldoc Debug::Easy>
769              
770             or if you have "man" installed, then
771              
772             C<man Debug::Easy>
773              
774             You can also look for information at:
775              
776             =over 4
777              
778             =item * RT: CPAN's request tracker (report bugs here)
779              
780             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Debug-Easy>
781              
782             =item * AnnoCPAN: Annotated CPAN documentation
783              
784             L<http://annocpan.org/dist/Debug-Easy>
785              
786             =item * CPAN Ratings
787              
788             L<http://cpanratings.perl.org/d/Debug-Easy>
789              
790             Not exactly a reliable and fair means of rating modules. Modules are updated and improved over time, and what may have been a poor or mediocre review at version 0,04, may not remotely apply to current or later versions. It applies ratings in an arbitrary manner with no ability for the author to add their own rebuttals or comments to the review, especially should the review be malicious or inapplicable.
791              
792             More importantly, issues brought up in a mediocre review may have been addressed and improved in later versions, or completely changed to allieviate that issue.
793              
794             So, check the reviews AND the version number when that review was written.
795              
796             =item * Search CPAN
797              
798             L<http://search.cpan.org/dist/Debug-Easy/>
799              
800             =back
801              
802             =head1 B<AUTHOR COMMENTS>
803              
804             I coded this module because it filled a gap when I was working for a major chip manufacturing company. It gave the necessary output the other coders asked for, and fulfilled a need. It has grown far beyond those days, and I use it every day in my coding work.
805              
806             If you have any features you wish added, or functionality improved or changed, then I welcome them, and will very likely incorporate them sooner than you think.
807              
808             =head1 B<LICENSE AND COPYRIGHT>
809              
810             Copyright 2013-2021 Richard Kelsch.
811              
812             This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at:
813              
814             L<http://www.perlfoundation.org/artistic_license_2_0>
815              
816             Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license.
817              
818             If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license.
819              
820             This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder.
821              
822             This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed.
823              
824             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
825              
826             =cut