File Coverage

blib/lib/App/Framework/Base/Object/DumpObj.pm
Criterion Covered Total %
statement 99 121 81.8
branch 39 52 75.0
condition n/a
subroutine 15 18 83.3
pod 8 8 100.0
total 161 199 80.9


line stmt bran cond sub pod time code
1             package App::Framework::Base::Object::DumpObj ;
2              
3             =head1 NAME
4              
5             App::Framework::Base::Object::DumpObj - Dump out an objects contents
6              
7             =head1 SYNOPSIS
8              
9             use App::Framework::Base::Object::DumpObj ;
10              
11              
12              
13             =head1 DESCRIPTION
14              
15             Given a data object (scalar, hash, array etc) prints out that objects contents
16              
17              
18             =head1 REQUIRES
19              
20              
21             =head1 DIAGNOSTICS
22              
23             Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.
24              
25             =head1 AUTHOR
26              
27             Steve Price C<< >>
28              
29             =head1 BUGS
30              
31             None that I know of!
32              
33             =head1 INTERFACE
34              
35             =over 4
36              
37             =cut
38              
39 30     30   153 use strict ;
  30         52  
  30         955  
40 30     30   146 use Carp ;
  30         52  
  30         1552  
41 30     30   146 use Cwd ;
  30         49  
  30         55803  
42              
43              
44             our $VERSION = "2.002" ;
45              
46             require Exporter ;
47             our @ISA = qw(Exporter);
48             our @EXPORT =qw(
49             );
50              
51             our @EXPORT_OK =qw(
52             prt_data
53             prtstr_data
54             exclude
55              
56             debug
57             verbose
58              
59             $DEBUG
60             $VERBOSE
61             $PRINT_OBJECTS
62             $PREFIX
63             );
64              
65              
66             #============================================================================================
67             # USES
68             #============================================================================================
69              
70              
71             #============================================================================================
72             # GLOBALS
73             #============================================================================================
74              
75             our $DEBUG = 0 ;
76             our $VERBOSE = 0 ;
77             our $PRINT_OBJECTS = 0 ;
78             our $QUOTE_VALS = 0 ;
79             our $PREFIX = 0 ;
80              
81             my $level ;
82             my %already_seen ;
83             my $prt_str ;
84             my %excludes ;
85              
86              
87             #============================================================================================
88             # EXPORTED
89             #============================================================================================
90              
91             #---------------------------------------------------------------------------------------------------
92              
93             =item B
94              
95             Set debug print options to B<$level>.
96              
97             0 = No debug
98             1 = standard debug information
99             2 = verbose debug information
100              
101             =cut
102              
103             sub debug
104             {
105 0     0 1 0 my ($flag) = @_ ;
106              
107 0         0 my $old = $DEBUG ;
108              
109 0 0       0 if (defined($flag))
110             {
111             # set this module debug flag & sub-modules
112 0         0 $DEBUG = $flag ;
113             }
114 0         0 return $old ;
115             }
116              
117             #---------------------------------------------------------------------------------------------------
118              
119             =item B
120              
121             Set vebose print options to B<$level>.
122              
123             0 = Non verbose
124             1 = verbose print
125              
126             =cut
127              
128             sub verbose
129             {
130 0     0 1 0 my ($flag) = @_ ;
131              
132 0         0 my $old = $VERBOSE ;
133              
134 0 0       0 if (defined($flag))
135             {
136             # set this module verbose flag & sub-modules
137 0         0 $VERBOSE = $flag ;
138             }
139 0         0 return $old ;
140             }
141              
142              
143             #---------------------------------------------------------------------------------------------------
144              
145             =item B
146              
147             Set option for printing out objects to B<$flag>.
148              
149             0 = Do not print contents of object [DEFAULT]
150             1 = print contents of object
151              
152             =cut
153              
154             sub print_objects_flag
155             {
156 1266     1266 1 1658 my ($flag) = @_ ;
157              
158 1266         1478 my $old = $PRINT_OBJECTS ;
159              
160 1266 50       2812 if (defined($flag))
161             {
162             # set this module debug flag & sub-modules
163 1266         1707 $PRINT_OBJECTS = $flag ;
164             }
165 1266         4881 return $old ;
166             }
167              
168              
169             #---------------------------------------------------------------------------------------------------
170              
171             =item B
172              
173             Set option quoting the values to B<$flag>.
174              
175             0 = Do not quote values [DEFAULT]
176             1 = Print values inside quotes
177            
178             This is useful for re-using the output directly to define an array/hash
179              
180             =cut
181              
182             sub quote_vals_flag
183             {
184 0     0 1 0 my ($flag) = @_ ;
185              
186 0         0 my $old = $QUOTE_VALS ;
187              
188 0 0       0 if (defined($flag))
189             {
190             # set this module debug flag & sub-modules
191 0         0 $QUOTE_VALS = $flag ;
192             }
193 0         0 return $old ;
194             }
195              
196             #---------------------------------------------------------------------------------------------------
197              
198             =item B
199              
200             Set the list of excluded HASH keys. Any keys in a HASH that match the name(s) in the list will not be
201             displayed.
202              
203             Specifying an empty list clears the excludes
204              
205             =cut
206              
207             sub exclude
208             {
209 26     26 1 88 my (@list) = @_ ;
210            
211 26         73 %excludes = () ;
212 26         73 %excludes = map {$_ => 1} @list ;
  26         169  
213              
214 26         90 return ;
215             }
216              
217             #---------------------------------------------------------------------------------------------------
218              
219             =item B
220              
221             Prefix all output lines with B<$prefix>
222              
223             Returns previous value
224              
225             =cut
226              
227             sub prefix
228             {
229 2340     2340 1 3539 my ($prefix) = @_ ;
230            
231 2340         3030 my $old = $PREFIX ;
232              
233 2340 50       9207 if (defined($prefix))
234             {
235             # set this module debug flag & sub-modules
236 2340         3188 $PREFIX = $prefix ;
237             }
238 2340         6276 return $old ;
239             }
240              
241              
242              
243             #---------------------------------------------------------------------
244              
245             =item B
246              
247             Create a multiline string of all items in the list. Handles scalars, hashes (as an array),
248             arrays, ref to scalar, ref to hash, ref to array, object.
249              
250             =cut
251              
252             sub prtstr_data
253             {
254 1267     1267 1 1889 my (@data_list) = @_ ;
255              
256 1267         1853 $level = -1 ;
257 1267         2305 %already_seen = () ;
258 1267         2408 $prt_str = '' ;
259              
260 1267         2146 foreach my $var (@_)
261             {
262 1449 100       5887 if (ref ($var))
263             {
264 151         311 _print_ref($var);
265             }
266             else
267             {
268 1298         2561 _print_scalar($var);
269             }
270             }
271              
272 1267         2776 return $prt_str ;
273             }
274              
275             #---------------------------------------------------------------------
276              
277             =item B
278              
279             Print out each item in the list. Handles scalars, hashes (as an array),
280             arrays, ref to scalar, ref to hash, ref to array, object.
281              
282             =cut
283              
284             sub prt_data
285             {
286 1266     1266 1 2507 my (@data_list) = @_ ;
287            
288 1266         2096 prtstr_data(@data_list) ;
289 1266         83594 print $prt_str ;
290            
291             }
292              
293              
294              
295             # ============================================================================================
296             # UNEXPORTED BY DEFAULT
297             # ============================================================================================
298              
299             #---------------------------------------------------------------------------------------------------
300             sub _print_scalar
301             {
302 3059     3059   3313 ++$level;
303 3059         8081 _print_indented ($_[0]);
304 3059         5421 --$level;
305             }
306              
307             #---------------------------------------------------------------------------------------------------
308             sub _print_ref
309             {
310 1053     1053   1435 my $r = $_[0];
311              
312 1053 50       4465 if (!defined($r))
    100          
313             {
314 0         0 _print_indented ("undef\n");
315 0         0 return;
316             }
317             elsif (exists ($already_seen{$r}))
318             {
319 97         294 _print_indented ("# $r (Seen earlier)\n");
320 97         241 return;
321             }
322             else
323             {
324 956         2753 $already_seen{$r}=1;
325             }
326              
327 956         1414 my $ref_type = ref($r);
328              
329 956 100       2589 if ($ref_type eq "ARRAY")
    100          
    100          
    50          
330             {
331 341         663 _print_array($r);
332             }
333             elsif ($ref_type eq "SCALAR")
334             {
335 344         608 _print_scalar($$r);
336 344         1444 _print_str(" # Ref -> $r\n");
337             }
338             elsif ($ref_type eq "HASH")
339             {
340 223         943 _print_hash($r);
341             }
342             elsif ($ref_type eq "REF")
343             {
344 0         0 ++$level;
345 0         0 _print_indented("# Ref -> ($r)\n");
346 0         0 _print_ref($$r);
347 0         0 --$level;
348             }
349             else
350             {
351 48         136 _print_indented ("# OBJECT $ref_type\n");
352              
353             # If required (and we can) print out the object
354 48 50       133 if ($PRINT_OBJECTS)
355             {
356 48         98 my $obj_ref_str = "$r" ;
357 48 50       260 if ($obj_ref_str =~ /ARRAY/)
    100          
358             {
359 0         0 _print_array($r);
360             }
361             elsif ($obj_ref_str =~ m/HASH/)
362             {
363 11         68 _print_hash($r);
364             }
365             }
366             }
367             }
368              
369             #---------------------------------------------------------------------------------------------------
370             sub _print_array
371             {
372 341     341   454 my ($r_array) = @_;
373              
374 341         394 ++$level;
375 341         1050 _print_indented ("[ # $r_array\n");
376 341         901 foreach my $var (@$r_array)
377             {
378 1881 100       3376 if (ref ($var))
379             {
380 464         842 _print_ref($var);
381             }
382             else
383             {
384 1417         9562 _print_scalar($var);
385 1417         2517 _print_str(",\n");
386             }
387             }
388 341         734 _print_indented ("],\n");
389 341         936 --$level;
390             }
391              
392             #---------------------------------------------------------------------------------------------------
393             sub _print_hash
394             {
395 234     234   328 my($r_hash) = @_;
396              
397 234         277 my($key, $val);
398 234         834 ++$level;
399              
400 234         823 _print_indented ("{ # $r_hash\n");
401              
402             # while (($key, $val) = each %$r_hash)
403 234         2296 foreach my $key (sort keys %$r_hash)
404             {
405             #print "<< key <$key> r_hash <$r_hash> >>\n" ;
406 1736         3751 my $val = $r_hash->{$key} ;
407 1736 100       3015 if (defined($val))
408             {
409 1512 100       2747 $val = ($val ? $val : '0');
410             }
411             else
412             {
413 224         298 $val = 'undef' ;
414             }
415              
416 1736         2868 ++$level;
417              
418 1736 100       2988 if (exists($excludes{$key}))
419             {
420 10         32 _print_indented ("$key => ...\n");
421             }
422             else
423             {
424 1726 100       3178 if (ref ($val))
425             {
426 438         1040 _print_indented ("$key => \n");
427 438         1031 _print_ref($val);
428             }
429             else
430             {
431 1288         3777 _print_indented ("$key => $val,\n");
432             }
433             }
434 1736         3162 --$level;
435             }
436 234         648 _print_indented ("},\n");
437 234         694 --$level;
438             }
439              
440             #---------------------------------------------------------------------------------------------------
441             sub _print_indented
442             {
443 6090     6090   9884 my $spaces = " " x $level;
444 6090 100       11118 if ($PREFIX)
445             {
446             # print prefix at start of a line
447 2427 100       35775 if (!$prt_str)
    100          
448             {
449 1170         2790 _print_str("$PREFIX") ;
450             }
451             elsif ($prt_str =~ m/(.*)\n$/)
452             {
453 1209         2747 _print_str("$PREFIX") ;
454             }
455             }
456 6090         13738 _print_str("${spaces}") ;
457 6090         14867 _print_val($_[0]) ;
458             # $prt_str .= "\n" ;
459             }
460              
461              
462             #---------------------------------------------------------------------------------------------------
463             sub _print_val
464             {
465 6090     6090   8515 my ($val) = @_ ;
466            
467 6090 100       10388 if (defined($val))
468             {
469 5868         17117 _print_str("$val") ;
470              
471             # Print positive numerical value in hex too
472 5868 100       85908 if ($val =~ m/(^|\s+)(\d+)$/)
473             {
474 3 50       42 _print_str(sprintf " # [0x%0x]", $2) if ($2 > 0) ;
475             }
476             }
477             else
478             {
479 222         585 _print_str("undef") ;
480             }
481              
482             }
483              
484             #---------------------------------------------------------------------------------------------------
485             sub _print_str
486             {
487 16323     16323   30618 my ($str) = @_ ;
488            
489 16323         36620 $prt_str .= $str ;
490             }
491              
492              
493              
494             # ============================================================================================
495             # END OF PACKAGE
496             1;
497              
498             __END__