File Coverage

blib/lib/Debuggit.pm
Criterion Covered Total %
statement 72 79 91.1
branch 32 34 94.1
condition 9 9 100.0
subroutine 18 21 85.7
pod 3 3 100.0
total 134 146 91.7


line stmt bran cond sub pod time code
1             package Debuggit;
2              
3 15     15   1140646 use strict;
  15         149  
  15         402  
4 15     15   71 use warnings;
  15         25  
  15         2296  
5              
6             our $VERSION = '2.07';
7              
8              
9             #################### main pod documentation begin ###################
10             ####
11             ###
12             ##
13             #
14              
15             =head1 NAME
16              
17             Debuggit - A fairly simplistic debug statement handler
18              
19             =head1 SYNOPSIS
20              
21             use Debuggit DEBUG => 1;
22              
23             # say you have a global hashref for your site configuration
24             # (not to imply that global vars are good)
25             our $Config = get_global_config();
26              
27             # now we can set some config things based on whether we're in debug mode or not
28             $Config->{'DB'} = DEBUG ? 'dev' : 'prod';
29              
30             # maybe we need to pull our local Perl modules from our VC working copy
31             push @INC, $Config->{'vcdir/lib'} if DEBUG;
32              
33             # basic debugging output
34             debuggit("only print this if debugging is on");
35             debuggit(3 => "only print this if debugging is level 3 or higher");
36              
37             # show off our formatting
38             my $var1 = 6;
39             my $var2;
40             my $var3 = " leading and trailing spaces ";
41             # assuming debugging is enabled ...
42             debuggit("var1 is", $var1); # var1 is 6
43             debuggit("var2 is", $var2); # var2 is <>
44             debuggit("var3 is", $var3); # var3 is << leading and trailing spaces >>
45             # note that spaces between args, as well as final newlines, are provided automatically
46              
47             # use "functions" in the debugging args list
48             my $var4 = { complex => 'hash', with => 'lots', of => 'stuff' };
49             # this will call Data::Dumper::Dumper() for you
50             # (even if you've never loaded Data::Dumper)
51             debuggit("var4 is", DUMP => $var4);
52              
53             # or maybe you prefer Data::Printer instead?
54             use Debuggit DEBUG => 1, DataPrinter => 1;
55             debuggit("var4 is", DUMP => $var4);
56              
57             # make your own function
58             Debuggit::add_func(CONFIG => 1,
59             sub { my ($self, $var) = $_; return (lc($self), 'var', $var, 'is', $Config->{$var}) });
60             # and use it like so
61             debuggit(CONFIG => 'DB'); # config var DB is dev
62              
63              
64             =head1 DESCRIPTION
65              
66             You want debugging? No, you want sophisticated, full-featured, on-demand debugging, and you don't
67             want to take it out when you release the code because you might need it again later, but you also
68             don't want it to take up any space or cause any slowdown of your production application. Sound
69             impossible? Nah. Just use Debuggit.
70              
71              
72             =head2 Quick Start
73              
74             To start:
75              
76             use strict;
77             use warnings;
78              
79             use Debuggit;
80              
81              
82             my $var = 6;
83             debuggit(2 => "var is", $var); # this does not print
84             debuggit(4 => "var is", $var); # neither does this
85              
86             Later ...
87              
88             use strict;
89             use warnings;
90              
91             use Debuggit DEBUG => 2;
92              
93              
94             my $var = 6;
95             debuggit(2 => "var is", $var); # now this prints
96             debuggit(4 => "var is", $var); # but this still doesn't
97              
98             That's it. Really. Everything else is just gravy.
99              
100              
101             =head2 Documentation
102              
103             This POD explains just the basics of using C. For full details, see L.
104              
105             =cut
106              
107             #
108             ##
109             ###
110             ####
111             #################### main pod documentation end ###################
112              
113             my ($debuggit, $add_func);
114              
115              
116             #####################################################################
117             ##
118             #
119              
120             =head1 EXPORTS
121              
122             =head2 DEBUG
123              
124             DEBUG is a constant integer set to whatever value you choose:
125              
126             use Debuggit DEBUG => 2;
127              
128             or to 0 if you don't choose:
129              
130             use Debuggit;
131              
132             Actually, failure to specify a value only defaults to 0 the first time in a program this is seen.
133             Subsequent times (e.g. in modules included by the main script), DEBUG will be set to the first value
134             passed in. In this way, you can set DEBUG in the main script and have it "fall through" to all
135             included modules. See L for full details.
136              
137             =head2 Functions exported
138              
139             Only L is exported.
140              
141             =cut
142              
143             #
144             ##
145             #####################################################################
146              
147              
148             sub import
149             {
150 20     20   1710 my ($pkg, %opts) = @_;
151 20 100       108 my $caller_package = $opts{PolicyModule} ? caller(1) : caller;
152              
153 20         1088 my $master_debug = eval "Debuggit::DEBUG()";
154 20 100       105 my $debug_value = defined $opts{DEBUG} ? $opts{DEBUG} : defined $master_debug ? $master_debug : 0;
    100          
155 20 100       62 unless (defined $master_debug)
156             {
157             # Perl does not know whether the string eval below will modify
158             # $debug_value, so it assumes the worst. So make the constant
159             # out of a new lexical scalar outside the eval's visible scope.
160             # This quiets a new warning in 5.20. Thanks ANDK!
161 15         27 my $inner_val = $debug_value;
162 15     0   102 *Debuggit::DEBUG = sub () { $inner_val };
  0         0  
163 15         33 $master_debug = $debug_value;
164             }
165              
166 15     15   103 no strict 'refs';
  15         27  
  15         548  
167 15     15   82 no warnings 'redefine';
  15         35  
  15         3400  
168              
169 20         819 my $caller_value = eval "${caller_package}::DEBUG()";
170 20 100       122 if (defined $caller_value)
171             {
172 2 100       18 warn("Cannot redefine DEBUG; original value of $caller_value is used") if $debug_value ne $caller_value;
173             }
174             else
175             {
176             # Thanx to tye from perlmonks for this line of code, which solves the Pod::Coverage issue
177             # (see t/pod_coverage.t). http://www.perlmonks.org/?node_id=951831
178 18         35 my $inner_val = $debug_value; # See comment above about $inner_val.
179 18     0   95 *{ join('::', $caller_package, 'DEBUG') } = sub () { $inner_val };
  18         100  
  0         0  
180             }
181              
182 20 100       107 if ($debug_value)
183             {
184 16         71 _setup_funcs($master_debug, $debug_value, $caller_package, $opts{DataPrinter});
185             }
186             else
187             {
188 4     2   10 *{ join('::', $caller_package, 'debuggit') } = sub {};
  4         12  
189 4 50   1   3187 *Debuggit::add_func = sub {} unless Debuggit->can('add_func');
190             }
191             }
192              
193              
194             sub _setup_funcs
195             {
196 16     16   55 my ($master_debug, $debug_value, $caller_package, $data_printer) = @_;
197              
198 15     15   109 no strict 'refs';
  15         28  
  15         460  
199 15     15   77 no warnings 'redefine';
  15         22  
  15         4275  
200              
201             # If our debug value is the same as the master debug value, we're just going to export our own
202             # debuggit() function out to the calling package. In this way, we avoid unnecessary code
203             # duplication by every package having its own copy of debuggit(). However, if the two values
204             # _don't_ match, it means that we're doing an override, and that in turns means that we _have_
205             # to give the calling package its own copy. This is because debuggit() is actually a closure,
206             # with the debug value stored in it. If we have two different debug values (one for the program
207             # as a whole, and a different one for this particular package), we have to have two different
208             # debuggit() calls as well.
209 16 100       48 if ($debug_value == $master_debug)
210             {
211 14 100 100 38   1393 *Debuggit::debuggit = eval $debuggit unless Debuggit->can('debuggit');
  38 100       111976  
  34 100       169  
212 14         37 *{ join('::', $caller_package, 'debuggit') } = \&debuggit;
  14         67  
213             }
214             else
215             {
216 2         232 *{ join('::', $caller_package, 'debuggit') } = eval $debuggit;
  2         10  
217             }
218              
219 16 100       4737 unless (Debuggit->can('add_func'))
220             {
221 11     15 1 704 eval $add_func;
  15         2563  
  15         62  
  15         12179  
222              
223             # create default function
224 11 50       54 if ($data_printer)
225             {
226             add_func(DUMP => 1, sub
227             {
228 0     0   0 require Data::Printer;
229 0         0 Data::Printer->VERSION("0.36");
230 0         0 shift;
231 0         0 return &Data::Printer::np(shift, colored => 1, hash_separator => ' => ', print_escapes => 1);
232 0         0 });
233             }
234             else
235             {
236             add_func(DUMP => 1, sub
237             {
238 2     2   878 require Data::Dumper;
239 2         7140 shift;
240 2         8 local $Data::Dumper::Sortkeys = 1;
241 2         12 return Data::Dumper::Dumper(shift);
242 11         259 });
243             }
244             }
245             }
246              
247              
248             #####################################################################
249             ##
250             #
251              
252             =head1 FUNCTIONS
253              
254             =cut
255              
256             #####################################################################
257             ##
258             #
259              
260             =head2 debuggit
261              
262             Use this function to conditionally print debugging output. If the first argument is a positive
263             integer, the output is printed only if DEBUG is set to that number or higher. If the first argument
264             is I a positive integer, the output is printed if DEBUG is non-zero (so omitting the debugging
265             leve is the same as setting it to 1). The remaining arguments are concatenated with spaces, a
266             newline is appended, and the results are printed to STDERR. Some minor formatting is done to help
267             distinguish C values and values with leading or trailing spaces. To get further details, or
268             to learn how to override any of those things, see L.
269              
270             =head2 default_formatter
271              
272             This is what C is set to initially. You can call it directly if you want to "wrap"
273             C. For examples of this, see L.
274              
275             =cut
276              
277             #
278             ##
279             #####################################################################
280              
281             BEGIN
282             {
283             # This is an anonymous closure. It has to be both of those things.
284             # * It has to be anonymous because it may be put into different packages depending on the
285             # circumstances. See the comments in _setup_funcs() for further details on that.
286             # * It has to be a closure because we want the debug value (against which we have to check
287             # the first arg, if it's a positive integer), to be stored with the sub. We in turn want
288             # this for several reasons:
289             # - We have to reference the DEBUG value in the calling package.
290             # - If we determine that via reference, that works for most cases. But in the case of
291             # Moose classes, most of which are autocleaned, the DEBUG constant, which is just a
292             # function, may well be gone by the time debuggit() runs. If we were calling it
293             # directly, autocleaning wouldn't keep that from working. But calling by reference is
294             # a whole different story.
295             # - So our best bet is to use a closure. The $debug_value referred to below must exist
296             # in the scope in which this is eval'ed. Then that value gets wrapped in the closure
297             # and it doesn't matter a whit if the function is autocleaned.
298 15     15   2544 $debuggit = q{
299             sub
300             {
301             return unless @_ > 0 && ($_[0] =~ /^\d+$/ ? shift : 1) <= $debug_value;
302             $Debuggit::output->($Debuggit::formatter->(Debuggit::_process_funcs(@_)));
303             }
304             };
305             }
306              
307              
308             sub default_formatter
309             {
310 33 100 100 33 1 100 return join(' ', map { !defined $_ ? '<>' : /^ +/ || / +$/ ? "<<$_>>" : $_ } @_) . "\n";
  44 100       485  
311             }
312              
313             our $formatter = \&default_formatter;
314              
315             our $output = sub { print STDERR @_ };
316              
317              
318             #####################################################################
319             ###
320             ##
321             #
322              
323             =head2 add_func
324              
325             =head2 remove_func
326              
327             Add or remove debugging functions. Please see L.
328              
329             =cut
330              
331             #
332             ##
333             ###
334             #####################################################################
335              
336              
337             my %PROCS;
338              
339             BEGIN
340             {
341 15     15   2833 $add_func = q{
342             sub Debuggit::add_func
343             {
344             my ($name, $argc, $code) = @_;
345              
346             $Debuggit::PROCS{$name} = { argc => $argc, code => $code };
347              
348             return 1;
349             }
350             };
351             }
352              
353              
354             sub remove_func
355             {
356 2     2 1 1358 delete $Debuggit::PROCS{shift()};
357 2         28 return 1;
358             }
359              
360              
361              
362             #####################################################################
363             # PRIVATE FUNCTIONS
364             #####################################################################
365              
366              
367             sub _process_funcs
368             {
369 34     34   68 my @parts;
370              
371 34         109 while (@_)
372             {
373 43         110 local $_ = shift;
374              
375 43 100 100     255 if ($_ and exists $Debuggit::PROCS{$_})
376             {
377 7         21 my @args = ($_);
378 7         37 push @args, shift foreach 1..$Debuggit::PROCS{$_}->{argc};
379 7         36 push @parts, $Debuggit::PROCS{$_}->{code}->(@args);
380             }
381             else
382             {
383 36         121 push @parts, $_;
384             }
385             }
386              
387 34         282 return @parts;
388             }
389              
390              
391             #################### remainder of pod begin ###################
392             ####
393             ###
394             ##
395             #
396              
397             =head1 DIAGNOSTICS
398              
399             =over 4
400              
401             =item * Cannot redefine DEBUG; original value of %s is used
402              
403             It means you did something like this:
404              
405             use Debuggit DEBUG => 2;
406             use Debuggit DEBUG => 3;
407              
408             only probably not nearly so obvious. Debuggit tries to be very tolerant of multiple imports into
409             the same package, but the C symbol is a constant function and can't be redefined without
410             engendering severe wonkiness, so Debuggit won't do it. As long as you pass the same value for
411             C, that's okay. But if the second (or more) value is different from the first, then you will
412             get the original value regardless. At least this way you'll be forewarned.
413              
414             =back
415              
416              
417              
418             =head1 PERFORMANCE
419              
420             Debuggit is designed to be left in your code, even when running in production environments.
421             Because of this, it needs to disappear entirely when debugging is turned off. It can achieve this
422             unlikely goal via the use of a compile-time constant. Please see
423             L for full details.
424              
425              
426              
427             =head1 BUGS and CAVEATS
428              
429             =over
430              
431             =item *
432              
433             Once you set C, you can't change it. Even if you try, you get the original value. See
434             L.
435              
436             =item *
437              
438             Doing:
439              
440             debuggit(0 => "in production mode");
441              
442             never prints anything, even when C is 0. That's because C is guaranteed to be an
443             empty function when debugging is turned off.
444              
445             =item *
446              
447             Doing:
448              
449             debuggit($var, "is the value");
450              
451             is inherently dangerous. If C<$var> is a positive integer, C would interpret it as a
452             debug level, and not print it. So, either do this:
453              
454             debuggit(1 => $var, "is the value");
455              
456             or this:
457              
458             debuggit("the value is", $var);
459              
460             Or, to look at it another way, you can pass a value as the first arg to print, or you can leave off
461             a debugging level altogether, but don't try to do both at once.
462              
463             =item *
464              
465             Doing:
466              
467             my $var1 = "DUMP";
468             my $var2 = "stuff";
469             debuggit(1 => "vars are", $var1, $var2);
470              
471             is equivalent to:
472              
473             debuggit(1 => "vars are", DUMP => $var2);
474              
475             which is probably not what you wanted, assuming the default functions are still in place. See
476             L for full details.
477              
478             =item *
479              
480             Doing:
481              
482             debuggit(2 => "first thousand elements:", @array[0..999]);
483              
484             is likely going to have a performance impact even when debugging is off. Instead, do:
485              
486             debuggit("first thousand elements:", @array[0..999]) if DEBUG >= 2;
487              
488             See L for another example and details on the problem.
489              
490             =back
491              
492             That's all I know of. However, lacking omniscience, I welcome bug reports.
493              
494              
495              
496             =head1 SUPPORT
497              
498             Debuggit is on GitHub at barefootcoder/debuggit. Feel free to fork and submit patches. Please note
499             that I develop via TDD (Test-Driven Development), so a patch that includes a failing test is much
500             more likely to get accepted (or at least likely to get accepted more quickly).
501              
502             If you just want to report a problem or request a feature, that's okay too. You can create an issue
503             on GitHub, or a bug in CPAN's RT (at http://rt.cpan.org). Or just send an email to
504             bug-Debuggit@rt.cpan.org.
505              
506              
507              
508             =head1 AUTHOR
509              
510             Buddy Burden
511             CPAN ID: BAREFOOT
512             Barefoot Software
513             barefootcoder@gmail.com
514              
515             =head1 COPYRIGHT
516              
517             This program is free software licensed under
518              
519             The Artistic License
520              
521             The full text of the license can be found in the LICENSE file included with this module.
522              
523              
524             This module is copyright (c) 2008-2015, Barefoot Software. It has many venerable ancestors (some
525             more direct than others), including but not limited to:
526              
527             =over
528              
529             =item *
530              
531             C, (c) 2000-2006 Barefoot Software, 2004-2006 ThinkGeek
532              
533             =item *
534              
535             C, (c) 2001-2006 Barefoot Software
536              
537             =item *
538              
539             C, (c) 2004 ThinkGeek
540              
541             =item *
542              
543             C, (c) 2004-2008 Barefoot Software, 2004 ThinkGeek
544              
545             =item *
546              
547             C, (c) 2006-2009 Barefoot Software
548              
549             =item *
550              
551             C, (c) 2008 Rent.com
552              
553             =back
554              
555              
556             =head1 SEE ALSO
557              
558             L, L, L, L, L.
559              
560             Comparison with most of these (and others) can be found in L.
561              
562             =cut
563              
564             #
565             ##
566             ###
567             ####
568             #################### remainder of pod end ###################
569              
570              
571             # Return a true value
572             1;