File Coverage

blib/lib/Text/Report.pm
Criterion Covered Total %
statement 334 497 67.2
branch 133 228 58.3
condition 42 82 51.2
subroutine 23 28 82.1
pod 15 15 100.0
total 547 850 64.3


line stmt bran cond sub pod time code
1             # ***********************************************************************
2             # Report *
3             # *
4             # Discussion: *
5             # *
6             # Input: *
7             # Output: *
8             # Manager: D. Huggins (email removed) *
9             # Company: Full-Duplex Communications Corporation *
10             # http://www.full-duplex.com *
11             # http://www.in-brandon.com *
12             # Start: Wednesday, 17 January, 2007 *
13             # Version: 1.004 *
14             # Release: 07.07.09.09:06 *
15             # Status: PRODUCTION *
16             # ***********************************************************************
17              
18             # All rights reserved by Full-Duplex Communications Corporation
19             # Copyright 2003 - 2007
20             package Text::Report;
21              
22             $Text::Report::VERSION = '1.004';
23             @Text::Report::ISA = qw(Text);
24              
25              
26             BEGIN
27             {
28 5     5   187135 eval "use Storable qw(store retrieve dclone)";
  5     5   8504  
  5         36991  
  5         356  
29 5 50       137 $Text::Report::stor_loaded = $@ ? 0 : 1;
30             };
31              
32 5     5   41 use strict;
  5         10  
  5         234  
33             # use warnings;
34              
35 5     5   28 use vars qw/ $VERSION @ISA/;
  5         10  
  5         290  
36              
37             # use Data::Dumper;
38 5     5   25 use Carp;
  5         10  
  5         51507  
39              
40              
41             our $AUTOLOAD;
42              
43              
44             my %debug_lev =
45             (
46             'off' => 0,
47             'notice' => 1,
48             'warning' => 2,
49             'error' => 3,
50             'critical' => 4,
51             );
52              
53             1;
54              
55              
56             # autoindex => 1/0, # Report.pm sets print order of blocks based upon
57             # creation (defblock()) order; DEFAULT=1 (strongly recommended)
58             # logfh => *FH
59             # debug => ['off' | 'notice' | ...] str # Sets debug level; Default is 'critical'
60             # debugv => 1/0 # carp longmess | shortmess
61             # autoindex => 1/0 # If set (DEFAULT), Report.pm will index block print
62             # order in the same order as the block was defblock'd
63             sub new
64             {
65 4     4 1 4224 my $class = shift;
66 4         20 my %this = @_;
67            
68 4         11 my $self = {};
69            
70 4         17 $self->{_page}{_index} = 0;
71            
72 4         33 $self->{_page}{_line} =
73             {
74             'dotted_line' => '.',
75             'dbl_line' => '=',
76             'single_line' => '-',
77             'under_line' => '_',
78             'blank_line' => ' ',
79             };
80            
81 4         12 bless $self, $class;
82            
83             # --- Build the default _report --- #
84 4         18 $self->_default_report('report');
85            
86             # --- Changed 'Log' to 'logfh' in v1.003 --- #
87 4 50       20 if($this{Log}){$this{logfh} = $this{Log};}
  0         0  
88            
89             # ---------------------------------------- #
90             # --- Either we get a FH or use STDOUT --- #
91             # ---------------------------------------- #
92 4 50       30 $self->{_log}{_file} = ref $this{logfh} ? $this{logfh} : \*STDOUT;
93 4 50       28 $self->{_debug}{_lev} = $this{debug} ? $debug_lev{$this{debug}} : 1;
94 4 100       33 $self->{_debug}{_verbose} = $this{debugv} ? 1 : 0;
95            
96             # ------------------------------------------------ #
97             # --- $this{autoindex} can only be set on init --- #
98             # ------------------------------------------------ #
99 4 50       19 $self->{_page}{_profile}{report}{autoindex} = $this{autoindex} ? $this{autoindex} : 1;
100            
101 4         9 delete $this{logfh}; delete $this{debug}; delete $this{debugv};
  4         10  
  4         8  
102            
103             # --- Build the default _block --- #
104 4         19 $self->_default_block('_block');
105            
106             # ---------------------------------------------------- #
107             # --- Build the report page layout w/modifications --- #
108             # --- to the default block, if any --- #
109             # ---------------------------------------------------- #
110 4         32 $self->configure(%this);
111              
112 4         33 return $self;
113             }
114              
115             # --- Define Report Properties --- #
116             # width => int, # Report width DEFAULT=80
117             # asis => 1/0, # Report.pm sets all block titles to caps & adds underline; DEFAULT=0
118             # debug => [off|notice|error|warning|critical] # Level of debug; DEFAULT='warning'
119             # debugv => 1/0 # Verbose mode using carp(longmess|shortmess)
120             # blockPad => {top => int, bottom => int} # Set global block padding
121             # column => int => {width => int, align => 'left', head => 'str'}
122             # useColHeaders => 1/0 # Off (DEFAULT) means that no col headers will be printed or auto generated
123             # sortby => int # Col number to sort 2-dimensional array; Zero for no sort oder
124             sub configure
125             {
126 14     14 1 3938 my $self = shift;
127            
128 14 100       60 my %this = @_ ? @_ : return(undef);
129            
130 9         12 my @idx = keys %{$self->{_page}{_profile}{report}};
  9         38  
131            
132 9         22 for(@idx)
133             {
134 27 100       109 next if /^autoindex$/;
135 18 100       45 if(defined $this{$_}){$self->{_page}{_profile}{report}{$_} = $this{$_}}
  1         4  
136             }
137            
138 9 100 66     61 $self->{_debug}{_lev} = $debug_lev{ $this{debug} } if defined $this{debug} &&
139             $this{debug} =~ /^(off|notice|error|warning|critical)$/i;
140 9 100       24 $self->{_debug}{_verbose} = $this{debugv} if defined $this{debugv};
141            
142            
143             # --- To use or not to use Headers --- #
144 9 100       22 $self->{_block}{_profile}{'_block'}{useColHeaders} = $this{useColHeaders}
145             if defined $this{useColHeaders};
146            
147             # --- Set column to sort by (zero/undef = no sort) --- #
148 9 100 66     32 $self->{_block}{_profile}{'_block'}{sortby} = $this{sortby}
149             if defined $this{sortby} && $this{sortby} =~ /^\d+$/;
150            
151 9 100       29 if(defined $this{width})
152             {
153             # --- Set default page width --- #
154 1         3 $self->{_page}{_profile}{report}{width} = $this{width};
155             # --- Set default block col width --- #
156 1         4 $self->{_block}{_profile}{'_block'}{column}{1}{width} = $this{width};
157             }
158            
159             # -------------------------------------------------- #
160             # --- Overwrite any existing (eg default _block) --- #
161             # --- col def's --- #
162             # -------------------------------------------------- #
163 9 100       22 if($this{column})
164             {
165 2 100       18 return undef unless $this{column} =~ /HASH/;
166             # --- Test keys - Expect int --- #
167 1   50     2 my @int = keys %{$this{column}} || return undef;
168 1 50       3 for(@int){return undef unless /^\d+$/;}
  1         7  
169 1         4 delete $self->{_block}{_profile}{'_block'}{column}; # reset
170            
171 1         3 foreach my $col(keys %{$this{column}})
  1         3  
172             {
173 1         2 $self->setcol('_block', $col, %{$this{column}{$col}});
  1         7  
174             }
175             }
176            
177 8 100       19 if(defined $this{blockPad})
178             {
179 2         3 eval{
180 2         4 for(keys %{$self->{_block}{_profile}{'_block'}{pad}})
  2         7  
181             {
182 3 50       21 $self->{_block}{_profile}{'_block'}{pad}{$_} = $this{blockPad}{$_}
183             if defined $this{blockPad}{$_};
184             }};
185            
186 2 100       7 if($@)
187             {
188 1         6 $self->_debug(4, "configure(pad => {top => int, bottom => int}) syntax - $@");
189 1         5 return undef;
190             }
191             }
192            
193 7         34 $self;
194             }
195              
196             # --- Define Block Properties --- #
197             # name => 'sd1', # No name, no define
198             # title => 'Sample Data One', # DEFAULT - undef
199             # order => $order_idx++, # Block print order, only used if new(autoindex => 0)
200             # sortby => 1, # Column to sort. DEFAULT=0 (no sorting)
201             # sorttype => 'alpha', # DEFAULT: 'alpha' | 'numeric'
202             # orderby => 'ascending', # DEFAULT: 'ascending' | 'descending'
203             # useColHeaders => 0, # Set to 1 to display headers & header underlines at col head
204             # column => {1 => {width => 10, align => 'left', head => 'ColOne',},}, # head is opt
205             # cols => int GT zero # Tell Report.pm to autocreate x number of cols; Used INSTEAD of columns{}
206             # pad => {top => int, bottom => int} # Number of blank lines to pad beginning & end of block
207             # columnWidth => int GT zero # Set block default widths
208             # columnAlign => [left|right|center] # Set block default alignments
209             sub defblock # Define Block - New blocks only
210             {
211 5     5 1 4455 my $self = shift;
212 5         26 my %this = @_;
213            
214             # -------------------------- #
215             # --- Need a block name --- #
216             # -------------------------- #
217 5 50       21 unless(defined $this{name})
218             {
219 0         0 $self->_debug(3,
220             "defblock() Attempt to create a block with no \'name\'. ".
221             "Modify the default block using setblock() or call defblock() ".
222             "using defblock( name => \'block_name\')");
223            
224 0         0 return(undef);
225             }
226            
227             # ------------------------------------------- #
228             # --- Use configure() to alter the global --- #
229             # --- properties of the default '_block' --- #
230             # ------------------------------------------- #
231 5 50       30 if($this{name} =~ /^\_block/)
232             {
233 0         0 $self->_debug(3,
234             "defblock(name => \'_block\') Attempt to create a block with default block name. ".
235             "Modify the default block using configure() or call defblock() ".
236             "using defblock( name => \'block_name\')");
237            
238 0         0 return(undef);
239             }
240            
241 5         10 my $blockname = $this{name};
242            
243 5         7 my $cols;
244            
245             # ------------------------------------------------ #
246             # --- Do not allow the caller to use defblock --- #
247             # --- if it has already been def'd. Send the --- #
248             # --- caller to delblock() --- #
249             # ------------------------------------------------ #
250 5 50       16 if(defined $self->{_block}{_profile}{$blockname})
251             {
252 0         0 $self->_debug(2,
253             "defblock() Attempt to create an already defined block. ".
254             "Modify block using setblock() or delete block first using ".
255             "delblock(\'block_name\')");
256            
257 0         0 return(undef);
258             }
259            
260             # --------------------------- #
261             # --- Assign the defaults --- #
262             # --------------------------- #
263 5 50       15 unless(defined $self->{_block}{_profile}{$blockname})
264             {
265 5         18 $self->_assign_def_block($blockname);
266             }
267            
268             # ------------------------- #
269             # --- Block-end padding --- #
270             # ------------------------- #
271 5         7 eval{
272 5 100 66     39 if(defined $this{pad}{top} && $this{pad}{top} =~ /^\d+$/)
273             {
274 1         3 $self->{_block}{_profile}{$blockname}{pad}{top} = $this{pad}{top};
275             }
276             else
277             {
278 4         16 $self->{_block}{_profile}{$blockname}{pad}{top} = $self->{_block}{_profile}{'_block'}{pad}{top};
279             }
280 5 100 66     24 if(defined $this{pad}{bottom} && $this{pad}{bottom} =~ /^\d+$/)
281             {
282 1         3 $self->{_block}{_profile}{$blockname}{pad}{bottom} = $this{pad}{bottom};
283             }
284             else
285             {
286 4         27 $self->{_block}{_profile}{$blockname}{pad}{bottom} = $self->{_block}{_profile}{'_block'}{pad}{bottom};
287             }};
288              
289             # --- Trap incomplete hash --- #
290 5 50       15 if($@){$self->_debug(4, "defblock(pad => {top => int, bottom => int}) syntax - $@"); return undef}
  0         0  
  0         0  
291            
292             # ------------------- #
293             # --- Block Title --- #
294             # ------------------- #
295 5   100     28 $self->{_block}{_profile}{$blockname}{title} = $this{title} || undef;
296            
297             # -------------------------------------------------- #
298             # --- Does caller want us to automatically build --- #
299             # --- headers for this block? setcol() handles --- #
300             # --- the rest --- #
301             # -------------------------------------------------- #
302 5 100       13 if(defined $this{useColHeaders})
303             {
304 3         7 $self->{_block}{_profile}{$blockname}{useColHeaders} = $this{useColHeaders};
305             }
306             else
307             {
308 2         9 $self->{_block}{_profile}{$blockname}{useColHeaders} = $self->{_block}{_profile}{'_block'}{useColHeaders}
309             }
310            
311             # --------------------------------------------- #
312             # --- Did the caller pass default alignment --- #
313             # --- &/or col width? If so, get these set --- #
314             # --- before cols are built --- #
315             # --------------------------------------------- #
316 5 100 66     29 if(defined $this{columnWidth} && $this{columnWidth} =~ /^\d+$/ && $this{columnWidth} > 0)
      66        
317             {
318 1         3 $self->{_block}{_profile}{$blockname}{width} = $this{columnWidth};
319            
320             # ------------------------------------------- #
321             # --- Col 1 is pre-defined at 'center'/80 --- #
322             # --- Adjust here --- #
323             # ------------------------------------------- #
324 1         2 $self->{_block}{_profile}{$blockname}{'column'}{1}{'width'} = $this{columnWidth};
325            
326             }
327             else
328             {
329 4         15 $self->{_block}{_profile}{$blockname}{width} = $self->{_page}{_profile}{report}{width};
330             }
331            
332 5 100 66     31 if(defined $this{columnAlign} && $this{columnAlign} =~ /^(left|right|center)$/i)
333             {
334 1         4 $self->{_block}{_profile}{$blockname}{align} = lc($this{columnAlign});
335            
336             # ------------------------------------------- #
337             # --- Col 1 is pre-defined at 'center'/80 --- #
338             # --- Adjust here --- #
339             # ------------------------------------------- #
340 1         3 $self->{_block}{_profile}{$blockname}{'column'}{1}{'align'} = lc($this{columnAlign});
341             }
342            
343             # -------------------------------------------------- #
344             # --- Overwrite any existing (eg default _block) --- #
345             # --- col def's --- #
346             # -------------------------------------------------- #
347 5 100 33     27 if($this{column})
    50 33        
348             {
349 1         6 delete $self->{_block}{_profile}{$blockname}{column}; # reset
350            
351 1         2 foreach my $col(keys %{$this{column}})
  1         5  
352             {
353 8         9 $self->setcol($blockname, $col, %{$this{column}{$col}});
  8         30  
354             }
355             }
356             # ----------------------------------------------------------------------- #
357             # --- Allow caller to generate cols using preset default width, align --- #
358             # --- Column widths are calc'd by dividing the current page width by --- #
359             # --- number of columns unless we are passed a columnWidth. An --- #
360             # --- attempt is made to use it. If the total width is GT the page --- #
361             # --- width, then we revert to calc'ing using prev formula --- #
362             # ----------------------------------------------------------------------- #
363             elsif(defined $this{cols} && $this{cols} =~ /^\d+$/ && $this{cols} > 0)
364             {
365             # --- Clear existing columns --- #
366 0         0 delete $self->{_block}{_profile}{$blockname}{column}; # reset
367            
368             # ----------------------------------------------- #
369             # --- Next, make sure all of this is going to --- #
370             # --- fit on the report page --- #
371             # ----------------------------------------------- #
372 0         0 my $pg_width = $self->{_page}{_profile}{report}{width};
373 0         0 my $tl_block_width = $this{cols} * ($self->{_block}{_profile}{$blockname}{width});
374            
375             # ------------------------------- #
376             # --- If it doesn't, force it --- #
377             # ------------------------------- #
378 0 0       0 if($tl_block_width > $pg_width)
379             {
380             # -------------------------------------------------- #
381             # --- Recalc col width based upon the page width --- #
382             # --- divided by number of cols requested --- #
383             # -------------------------------------------------- #
384 0         0 eval{$self->{_block}{_profile}{$blockname}{width} =
  0         0  
385             ($self->{_page}{_profile}{report}{width} / $this{cols});};
386            
387             # --- $this{cols} is > zero, so shouldn't be a prob --- #
388 0 0       0 if($@){$self->_debug(2, "Col width 102 calc err for block ($blockname) - $@");}
  0         0  
389            
390             # --- Clean up --- #
391 0         0 $self->{_block}{_profile}{$blockname}{width} =
392             sprintf("%0.0f\n", $self->{_block}{_profile}{$blockname}{width});
393            
394             # --- Adjust --- #
395 0         0 $self->{_block}{_profile}{$blockname}{width} -= 2;
396            
397 0         0 $self->_debug(1, "Calculated col width = ".
398             "$self->{_block}{_profile}{$blockname}{width} for block ($blockname)");
399             }
400            
401 0         0 for(my $i = 1; $i <= $this{cols}; $i++)
402             {
403 0         0 $self->setcol($blockname, $i,
404             width => $self->{_block}{_profile}{$blockname}{width},
405             align => $self->{_block}{_profile}{$blockname}{align},
406             head => $this{head}->[$i-1],
407             );
408             }
409             }
410             # --- Otherwise use the default: 1 col, center, 80 chars wide --- #
411            
412            
413             # ----------------------------------- #
414             # --- Determine block print order --- #
415             # ----------------------------------- #
416 5 50       17 if($self->{_page}{_profile}{report}{autoindex})
417             {
418             # --- Add auto print sequence to _order --- #
419 5         35 $self->{_order}{_block}{$self->{_page}{_index}++} = $blockname;
420             }
421             else
422             {
423 0 0       0 unless($this{order} =~ /^\d+$/)
424             {
425 0         0 $self->_debug(3,
426             "defblock(order) Need print order sequence number to process block ".
427             "$blockname. Call defblock() using defblock(order => int)");
428            
429 0         0 return(undef);
430             }
431            
432 0         0 $self->{_order}{_block}{$this{order}} = $blockname;
433             }
434            
435             # --------------------------------- #
436             # --- Define column to sort on --- #
437             # --- The DEFAULT is no sorting --- #
438             # --------------------------------- #
439 5 100 66     27 if(defined $this{sortby} && $this{sortby} =~ /^\d+$/)
440             {
441 2         7 $self->{_block}{_profile}{$blockname}{sortby} = $this{sortby};
442             }
443            
444             # --------------------------------- #
445             # --- Define sort type --- #
446             # --------------------------------- #
447 5 100 66     49 if(defined $this{sorttype} && $this{sorttype} =~ /^(alpha|numeric)$/i)
448             {
449 2         7 $self->{_block}{_profile}{$blockname}{sorttype} = lc($this{sorttype});
450             }
451            
452             # -------------------------------- #
453             # --- Define sort direction --- #
454             # -------------------------------- #
455 5 100 66     37 if(defined $this{orderby} && $this{orderby} =~ /^(ascending|descending)$/i)
456             {
457 2         14 $self->{_block}{_profile}{$blockname}{orderby} = lc($this{orderby});
458             }
459            
460 5         26 $self;
461             }
462             # --- Alter An Existing Block's Properties --- #
463             # title => 'Sample Data One', # DEFAULT - undef
464             # order => $order_idx++, # Block print order, only used if new(autoindex => 0)
465             # sortby => 1, # Column to sort. DEFAULT=0
466             # sorttype => 'alpha', # DEFAULT: 'alpha' | 'numeric'
467             # orderby => 'ascending', # DEFAULT: 'ascending' | 'descending'
468             # pad => {top => int, bottom => int} # Number of blank lines to pad beginning & end of block
469             # useColHeaders => 1/0 # Turn on/off column headers & their assoc underlines
470             sub setblock
471             {
472 4     4 1 5807 my $self = shift;
473            
474 4 100       25 my %this = @_ ? @_ : return(undef);
475            
476 3         3 my $blockname;
477            
478 3 50       11 return undef unless $blockname = $this{name};
479            
480             # ----------------------------------------- #
481             # --- Do not modify the default '_block --- #
482             # --- here - Use configure() --- #
483             # ----------------------------------------- #
484 3 50       9 return undef if $blockname =~ /^\_block$/;
485            
486             # --------------------------------------------------------- #
487             # --- This method is only for modifying existing blocks --- #
488             # --------------------------------------------------------- #
489 3 100       14 unless(defined $self->{_block}{_profile}{$blockname})
490             {
491 1         6 $self->_debug(3, "setblock() Attempt to modify a non-defined block. ".
492             "Create block using defblock()");
493 1         6 return undef;
494             }
495            
496             # ------------------------- #
497             # --- Block-end padding --- #
498             # ------------------------- #
499 2         4 eval{
500 2 50 33     11 if(defined $this{pad}{top} && $this{pad}{top} =~ /^\d+$/)
501             {
502 0         0 $self->{_block}{_profile}{$blockname}{pad}{top} = $this{pad}{top};
503             }
504             else
505             {
506 2         10 $self->{_block}{_profile}{$blockname}{pad}{top} = $self->{_block}{_profile}{_block}{pad}{top};
507             }
508 2 50 33     10 if(defined $this{pad}{bottom} && $this{pad}{bottom} =~ /^\d+$/)
509             {
510 0         0 $self->{_block}{_profile}{$blockname}{pad}{bottom} = $this{pad}{bottom};
511             }
512             else
513             {
514 2         9 $self->{_block}{_profile}{$blockname}{pad}{bottom} = $self->{_block}{_profile}{_block}{pad}{bottom};
515             }};
516            
517             # --- Trap incomplete hash --- #
518 2 50       6 if($@){$self->_debug(4, "setblock(pad => {top => int, bottom => int}) syntax - $@"); return undef}
  0         0  
  0         0  
519            
520             # ------------------- #
521             # --- Block Title --- #
522             # ------------------- #
523 2 50       6 $self->{_block}{_profile}{$blockname}{title} = $this{title} if defined $this{title};
524            
525             # ---------------------- #
526             # --- Column Headers --- #
527             # ---------------------- #
528 2 100       9 $self->{_block}{_profile}{$blockname}{useColHeaders} = $this{useColHeaders} if defined $this{useColHeaders};
529            
530             # ----------------------------------- #
531             # --- Determine block print order --- #
532             # ----------------------------------- #
533 2 50 33     8 if(defined $this{order} && $this{order} =~ /^\d+$/)
534             {
535 0 0       0 if($self->{_page}{_profile}{report}{autoindex})
536 0         0 {
537 0         0 $self->_debug(2, 'setblock() Cannot set order if Report object init\'d with autoindex. '.
538             'Create Text::Report->new(autoindex => 0) the default is on');
539             }
540             else{$self->{_order}{_block}{$this{order}} = $blockname;}
541             }
542            
543             # --------------------------------- #
544             # --- Define column to sort on --- #
545             # --- The DEFAULT is no sorting --- #
546             # --------------------------------- #
547 2 50 33     8 if(defined $this{sortby} && $this{sortby} =~ /^\d+$/)
548             {
549 0         0 $self->{_block}{_profile}{$blockname}{sortby} = $this{sortby};
550             }
551            
552             # -------------------------------- #
553             # --- Define sort type --- #
554             # -------------------------------- #
555 2 50 33     9 if(defined $this{sorttype} && $this{sorttype} =~ /^(alpha|numeric)$/i)
556             {
557 0         0 $self->{_block}{_profile}{$blockname}{sorttype} = lc($this{sorttype});
558             }
559            
560             # -------------------------------- #
561             # --- Define sort direction --- #
562             # -------------------------------- #
563 2 50 33     6 if(defined $this{orderby} && $this{orderby} =~ /^(ascending|descending)$/i)
564             {
565 0         0 $self->{_block}{_profile}{$blockname}{orderby} = lc($this{orderby});
566             }
567            
568 2         10 $self;
569             }
570             # Set/change Column Properties
571             # $obj->setcol($blockname, $colnumber, align => [left|right|center], width => int, head => 'str')
572             # align => [left|right|center] #
573             # width => int GT zero #
574             # head => 'str' # Column header
575             sub setcol
576             {
577 18     18 1 34 my $self = shift;
578 18         22 my $blockname = shift;
579 18         20 my $number = shift;
580            
581 18 50       59 my %this = @_ ? @_ : return(undef);
582            
583 18 50       65 return undef unless $number =~ /^\d+$/;
584            
585 18 50       43 unless(defined $blockname){$blockname = '_block';}
  0         0  
586            
587            
588             # ---------------------------------------- #
589             # --- If the caller has not def'd this --- #
590             # --- $blockname, right back at 'em --- #
591             # ---------------------------------------- #
592 18 50       48 unless(defined $self->{_block}{_profile}{$blockname})
593             {
594 0         0 $self->_debug(3, "setcol() Attempt to modify a non-defined block. ".
595             "Create block first using defblock()");
596 0         0 return undef;
597             }
598            
599 18 100 66     93 if(defined $this{align} && $this{align} =~ /^(left|right|center)$/i)
600             {
601 10         47 $self->{_block}{_profile}{$blockname}{column}{$number}{align} = lc($this{align});
602             }
603             else # use our built-in default
604             {
605 8 100       30 unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{align})
606             {
607 4         13 $self->{_block}{_profile}{$blockname}{column}{$number}{align} = $self->{_block}{_profile}{$blockname}{align};
608 4         16 $self->_debug(1, "setcol(align) param not set for col number \"$number\". ".
609             "Defining col align as \"$self->{_block}{_profile}{$blockname}{align}\"");
610             }
611             }
612            
613 18 100 66     142 if(defined $this{width} && $this{width} =~ /^\d+$/ && $this{width} > 0)
      66        
614             {
615 13         41 $self->{_block}{_profile}{$blockname}{column}{$number}{width} = $this{width};
616             }
617             else
618             {
619 5 100       17 unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{width})
620             {
621 4         10 $self->{_block}{_profile}{$blockname}{column}{$number}{width} = $self->{_block}{_profile}{$blockname}{width};
622 4         14 $self->_debug(1, "setcol(width) param not set for col number \"$number\". ".
623             "Defining col width as \"$self->{_block}{_profile}{$blockname}{width}\"");
624             }
625             }
626            
627 18 100       31 if(defined $this{head})
628             {
629 13         69 $self->{_block}{_profile}{$blockname}{column}{$number}{head} = $this{head};
630             }
631             else
632             {
633 5 100       21 if($self->{_block}{_profile}{$blockname}{useColHeaders})
634             {
635 1 50       6 unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{head})
636             {
637 0         0 $self->{_block}{_profile}{$blockname}{column}{$number}{head} = $number;
638 0         0 $self->_debug(1, "setcol(\'block_name\', col_num, head => ".
639             "\"Header Title\") param not set \& \'useColHeaders\' flag ".
640             "is set. Defining col header as \"$number\"");
641             }
642             }
643             }
644            
645 18         44 $self;
646             }
647              
648             # Insert a page separation line
649             # order => int # unless autoindex is set
650             # pad => {top => int, bottom => int}
651             # width => int # override the default width (page width)
652             sub insert
653             {
654 3     3 1 10 my $self = shift;
655 3         5 my $line_type = shift;
656 3         6 my %this = @_;
657            
658 3         4 my $blockname;
659            
660             # ----------------------------------- #
661             # --- Determine block print order --- #
662             # ----------------------------------- #
663 3 50       12 if($self->{_page}{_profile}{report}{autoindex})
664             {
665 3         9 $blockname = "__separator_$self->{_page}{_index}";
666            
667             # ----------------------------------------- #
668             # --- Add auto print sequence to _order --- #
669             # ----------------------------------------- #
670 3         11 $self->{_order}{_block}{$self->{_page}{_index}++} = $blockname;
671             }
672             else
673             {
674 0 0       0 unless($this{order} =~ /^\d+$/)
675             {
676 0         0 $self->_debug(3,
677             "insert(order) Need print order sequence number to process ".
678             "separator. Call insert() using insert(\'line_type\', order => int)");
679            
680 0         0 return(undef);
681             }
682            
683 0         0 $blockname = "__separator_$this{order}";
684            
685 0         0 $self->{_order}{_block}{$this{order}} = $blockname;
686             }
687            
688             # --- Create a new block --- #
689 3         10 $self->_default_block($blockname);
690            
691             # --- No headers will be used --- #
692 3         16 $self->{_block}{_profile}{$blockname}{useColHeaders} = 0;
693            
694             # --- Set width - either by callers specs or use page def --- #
695 3   33     25 $self->{_block}{_profile}{$blockname}{width} = $this{width} || $self->{_page}{_profile}{report}{width};
696            
697             # --- Reset, if necessary, the col width --- #
698 3         14 $self->setcol($blockname, 1, width => $self->{_block}{_profile}{$blockname}{width});
699            
700             # ------------------------------------ #
701             # --- Set padding if any requested --- #
702             # --- --- #
703             # --- We don't use the default pad --- #
704             # --- here. The caller must --- #
705             # --- specifically request padding --- #
706             # ------------------------------------ #
707 3         4 my @insert;
708            
709 3 50       8 if(defined $this{pad})
710             {
711 0         0 eval{
712 0         0 for(1 .. $this{pad}{top})
  0         0  
713             {push(@insert, [$self->_draw_line('blank_line', $self->{_page}{_profile}{report}{width})]);}
714            
715 0         0 push(@insert, [$self->_draw_line($line_type, $self->{_page}{_profile}{report}{width})]);
716            
717 0         0 for(1 .. $this{pad}{bottom})
  0         0  
718             {push(@insert, [$self->_draw_line('blank_line', $self->{_page}{_profile}{report}{width})]);}};
719             }
720             else
721             {
722 3         15 push(@insert, [$self->_draw_line($line_type, $self->{_page}{_profile}{report}{width})]);
723             }
724            
725 3         11 $self->fill_block($blockname, @insert);
726 3         12 $self;
727             }
728             ###########################
729             # $obj->fill_block('named_block', @AoA)
730             #
731             # Fill formatted, named block w/data
732             # passed to us in table form where
733             # @_ = [array1],[array2],[array3]...
734             sub fill_block
735             {
736 125     125 1 2561 my $self = shift;
737 125         174 my $blockname = shift;
738 125         192 my @table = @_; # AoA
739            
740 125 100       339 unless(defined $self->{_block}{_profile}{$blockname})
741             {
742 88         258 $self->_debug(3, "fill_block() Attempt to fill a non-defined block. ".
743             "Create block first using defblock()");
744 88         375 return undef;
745             }
746            
747 37         37 my @fCol; my @csv;
748            
749 37         121 my %align = (left => '<', center => '|', right => '>', );
750            
751 37         37 my @col_head;
752            
753 37         102 foreach my $col(sort _numeric(keys %{$self->{_block}{_profile}{$blockname}{column}}))
  37         223  
754             {
755             # ---------------------- #
756             # --- Column attribs --- #
757             # ---------------------- #
758 251         638 my $align = $align{ $self->{_block}{_profile}{$blockname}{column}{$col}{align} };
759 251         470 my $width = $self->{_block}{_profile}{$blockname}{column}{$col}{width};
760            
761             # ---------------------- #
762             # --- Column header --- #
763             # ---------------------- #
764 251 100       644 if(defined $self->{_block}{_profile}{$blockname}{column}{$col}{head})
765             {
766 245         563 push(@col_head, $self->{_block}{_profile}{$blockname}{column}{$col}{head});
767             }
768            
769 251         618 push(@fCol, '@'.$align x $width);
770             }
771            
772 37         123 my $columns = join(" ", @fCol);
773            
774            
775 37         54 my $format = 'formline <<"END", @data;'."\n".'$columns'."\n"."END";
776            
777             # ------------------------------------------------------------ #
778             # --- Build title & column headers first time through only --- #
779             # ------------------------------------------------------------ #
780 37 100       100 unless($self->{_block}{_profile}{$blockname}{_append})
781             {
782 9         19 $self->{_block}{_profile}{$blockname}{_append} = 1;
783             # ------------------- #
784             # --- Place Title --- #
785             # ------------------- #
786 9 100       36 if($self->{_block}{_profile}{$blockname}{title})
787             {
788 3 50       15 unless($self->{_page}{_profile}{report}{asis})
789             {
790             # --- Store title & header data in {hdata} --- #
791             # --- to retain for template building --- #
792 3         5 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, uc($self->{_block}{_profile}{$blockname}{title}));
  3         16  
793            
794             # --- Title Underline --- #
795 3         33 my @chars = split('', $self->{_block}{_profile}{$blockname}{title}); # Get char count
796 3         8 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, ($self->_draw_line('single_line', scalar(@chars))));
  3         22  
797            
798 3         16 push(@csv, uc($self->{_block}{_profile}{$blockname}{title}));
799             }
800             else
801             {
802 0         0 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $self->{_block}{_profile}{$blockname}{title});
  0         0  
803 0         0 push(@csv, $self->{_block}{_profile}{$blockname}{title});
804             }
805            
806             # --------------------------- #
807             # --- Pad the block title --- #
808             # --- CONSTANT --- #
809             # --------------------------- #
810 3 50       13 unless($self->{_page}{_profile}{report}{asis})
811             {
812 3         5 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, ($self->_draw_line('blank_line', 1)));
  3         37  
813             }
814             }
815            
816 9 100       28 if($self->{_block}{_profile}{$blockname}{useColHeaders})
817             {
818             # ---------------------------- #
819             # --- Build Column Headers --- #
820             # ---------------------------- #
821 2         6 my @data = @col_head;
822            
823 2         118 eval $format;
824            
825 2 50       11 if($@){$self->_debug(3, "Internal/system Error - $@");} # Who the hell knows?
  0         0  
826            
827 2         6 chomp($^A);
828 2         2 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $^A);
  2         8  
829 2         4 $^A = '';
830            
831             # -------------------------------- #
832             # --- Column Header Underlines --- #
833             # -------------------------------- #
834 2         4 my @col_underline;
835            
836 2         3 my $i = 0;
837 2         5 for(@col_head)
838             {
839 13         32 my $chars = $self->{_block}{_profile}{$blockname}{column}{++$i}{width}; # Width of col
840 13         24 push(@col_underline, ($self->_draw_line('under_line', $chars)));
841             }
842            
843 2         7 @data = (); # reset data
844            
845 2         6 @data = @col_underline;
846            
847 2         110 eval $format;
848            
849 2 50       11 if($@){$self->_debug(3, "Internal/system Error - $@");}
  0         0  
850            
851 2         7 chomp($^A);
852 2         3 push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $^A);
  2         9  
853 2         8 $^A = '';
854             }
855            
856 9 100       20 if(@col_head > 1){push(@csv, join(',', @col_head));}
  3         11  
857 9 50       45 if(@col_head == 1){push(@csv, $col_head[0]);}
  0         0  
858             }
859            
860 37         89 my @sorted = $self->_sort($blockname, @table);
861            
862             # ---------------------------- #
863             # --- Add the data portion --- #
864             # ---------------------------- #
865 37         51 my $debug = 0;
866            
867 37         57 foreach my $block(@sorted)
868             {
869 47         52 my @data = @{$block};
  47         143  
870            
871 47         59 push(@csv, join(',', @{$block}));
  47         882  
872            
873 47         3139 eval $format;
874            
875             # ------------------------------------------ #
876             # --- This should never happen, but then --- #
877             # --- what do i know --- #
878             # ------------------------------------------ #
879 47 50       201 if($@)
880             {
881 0         0 $self->_debug(4, 'Internal/system Error - Data format failure. Please '.
882             'contact your system administrator. I\'m sure he\'ll know what to do.'.
883             "ABEND - $@");
884            
885 0         0 die $@;
886             }
887            
888 47         133 chomp($^A); push(@{$self->{_block}{_profile}{$blockname}{data}}, $^A);
  47         56  
  47         172  
889 47         165 $^A = '';
890             }
891             # ---------------------- #
892             # --- Store csv data --- #
893             # ---------------------- #
894 37         111 for(@csv){push(@{$self->{_block}{_profile}{$blockname}{_csv}}, $_);}
  53         48  
  53         180  
895            
896 37         246 $self;
897             }
898              
899             # $obj->report('get'); # Return report lines w/in array
900             # $obj->report('print'); # STDOUT
901             # $obj->report('csv'); # Retrieve csv data
902             sub report
903             {
904 3     3 1 5061 my $self = shift;
905            
906 3         7 my %this; my @page = ();
  3         9  
907            
908 3         12 $this{lc(shift)} = 1;
909            
910            
911 3 50       17 if(defined $self->{_order}{_block})
912             {
913             # ---------------------------------------- #
914             # --- If a named block has no 'order', --- #
915             # --- it will be silently ignored --- #
916             # ---------------------------------------- #
917 3         6 BLOCK: foreach my $key(sort _numeric(keys %{$self->{_order}{_block}}))
  3         24  
918             {
919 13         29 my $blockname = $self->{_order}{_block}{$key};
920            
921 13 50       31 if($this{'csv'})
922             {
923 0         0 push(@page, $self->{_block}{_profile}{$blockname}{_csv});
924 0         0 next BLOCK;
925             }
926            
927             # ----------------------- #
928             # --- Top pad, if any --- #
929             # ----------------------- #
930 13 100 66     100 if(defined $self->{_block}{_profile}{$blockname}{pad}{top} && $self->{_block}{_profile}{$blockname}{pad}{top} > 0)
931             {
932 1 50       4 if($this{'print'}){print "\n" x $self->{_block}{_profile}{$blockname}{pad}{top};}
  0         0  
933             else
934             {
935 1         4 for(1 .. $self->{_block}{_profile}{$blockname}{pad}{top})
936             {
937 2         5 push(@page, " ");
938             }
939             }
940             }
941            
942             # --- Top-of-block data --- #
943 13 100       43 if(exists $self->{_block}{_profile}{$blockname}{hdata})
944             {
945 3         7 for(@{$self->{_block}{_profile}{$blockname}{hdata}})
  3         14  
946             {
947 13 50       23 if($this{'print'}){print "$_\n";}
  0         0  
  13         26  
948             else{push(@page, $_);}
949             }
950             }
951             # --- Collected data --- #
952 13         17 for(@{$self->{_block}{_profile}{$blockname}{data}})
  13         37  
953             {
954 53 50       83 if($this{'print'}){print "$_\n";}
  0         0  
  53         106  
955             else{push(@page, $_);}
956             }
957            
958             # -------------------------- #
959             # --- Bottom pad, if any --- #
960             # -------------------------- #
961 13 50 33     104 if(defined $self->{_block}{_profile}{$blockname}{pad}{bottom} && $self->{_block}{_profile}{$blockname}{pad}{bottom} > 0)
962             {
963 13 50       26 if($this{'print'}){print "\n" x $self->{_block}{_profile}{$blockname}{pad}{bottom};}
  0         0  
964             else
965             {
966 13         39 for(1 .. $self->{_block}{_profile}{$blockname}{pad}{bottom})
967             {
968 14         44 push(@page, " ");
969             }
970             }
971             }
972             }
973             }
974             # --- No order, no laundry --- #
975             else
976             {
977 0         0 $self->_debug(3, 'Block print order has not been set. Either create Report object using '.
978             'Text::Report->new(autoindex => 1) or use $obj->defblock(order => int).'.
979             "Cannot print report");
980 0         0 $self->{_err} = 1;
981 0         0 push(@{$self->{_errors}}, ["Block print order has not been set. Cannot print report"]);
  0         0  
982            
983 0         0 return undef;
984             }
985            
986 3 50       39 return @page ? @page : undef;
987             }
988             # Use this meth to retrieve csv data for block(s)
989             # use $obj->report('csv') to retrieve csv data
990             # for entire report
991             # $obj->get_csv(blockname1, blockname2, ...);
992             sub get_csv
993             {
994 1     1 1 2 my $self = shift;
995            
996 1         2 my @list;
997            
998 1 50       4 for(@_ ? @_ : return(undef))
999             {
1000 1         5 push(@list, $self->{_block}{_profile}{$_}{_csv});
1001             }
1002            
1003 1         5 return(@list);
1004             }
1005              
1006             # --------------------------------------------------- #
1007             # --- Reset Named Block to orig default settings. --- #
1008             # --- Overrides any changes made to '_block' --- #
1009             # --------------------------------------------------- #
1010              
1011             # $obj->rst_block($block_name)
1012             # Resets named block to defaults
1013             # If $block_name does not exist, creates new block $block_name and applies defaults.
1014             sub rst_block
1015             {
1016 0     0 1 0 my $self = shift;
1017            
1018 0         0 $self->_default_block((shift));
1019            
1020 0         0 $self;
1021             }
1022              
1023             # $obj->del_block($block_name)
1024             # Deletes Named Block
1025             sub del_block
1026             {
1027 0     0 1 0 my $self = shift;
1028 0         0 my $blockname = shift;
1029            
1030 0         0 delete $self->{_block}{_profile}{$blockname};
1031            
1032 0         0 $self;
1033             }
1034              
1035             # $obj->clr_block_data($block_name)
1036             # Clears data & csv data from Named Block
1037             sub clr_block_data
1038             {
1039 1     1 1 3 my $self = shift;
1040 1         2 my $blockname = shift;
1041            
1042 1         7 delete $self->{_block}{_profile}{$blockname}{data};
1043 1         8 delete $self->{_block}{_profile}{$blockname}{_csv};
1044             # delete $self->{_block}{_profile}{(shift)}{hdata};
1045            
1046 1         4 $self;
1047             }
1048              
1049             # $obj->clr_block_headers($block_name)
1050             # Clears hdata (header data) from Named Block
1051             sub clr_block_headers
1052             {
1053 1     1 1 2 my $self = shift;
1054 1         3 my $blockname = shift;
1055            
1056 1         5 delete $self->{_block}{_profile}{$blockname}{hdata};
1057            
1058             # --- Reset "header set" flag --- #
1059 1         4 $self->{_block}{_profile}{$blockname}{_append} = undef;
1060            
1061 1         3 $self;
1062             }
1063              
1064             # $obj->named_blocks
1065             # Returns an array of all named_block's defined
1066             sub named_blocks
1067             {
1068 0     0 1 0 return(keys %{shift->{_block}{_profile}});
  0         0  
1069             }
1070              
1071             # $obj->linetypes
1072             # Returns an array of avail line types
1073             sub linetypes
1074             {
1075 0     0 1 0 return keys %{shift->{_page}{_line}};
  0         0  
1076             }
1077              
1078             # Maybe someday:
1079             # sub order
1080             # {
1081             # my $self = shift;
1082             # my %order = @_;
1083             #
1084             # # --- Cannot change order if autoindex is set --- #
1085             # if($self->{_page}{_profile}{report}{autoindex})
1086             # {
1087             # # ERROR
1088             # return(undef);
1089             # }
1090             #
1091             # $self->{_order}{_block} = \%order;
1092             # }
1093              
1094             # ----------------------------------- #
1095             # --- Private methods & functions --- #
1096             # ----------------------------------- #
1097             sub _sort
1098             {
1099 37     37   46 my $self = shift;
1100 37         48 my $blockname = shift;
1101 37         62 my @table = @_;
1102            
1103 37 100       119 return @table unless $self->{_block}{_profile}{$blockname}{sortby}; # 0="Don't sort"
1104            
1105 31         35 my %idx; my $rec = 0;
  31         33  
1106            
1107             # ------------------------------------------ #
1108             # --- Caller refers to 1st col as col 1, --- #
1109             # --- we refer to it as element zero --- #
1110             # ------------------------------------------ #
1111 31         70 my $sort_col = ($self->{_block}{_profile}{$blockname}{sortby} - 1);
1112            
1113 31         48 for my $row(@table){$idx{$rec++} = $row->[$sort_col];}
  37         113  
1114            
1115 31         47 my @sorted;
1116            
1117             # ------------------------- #
1118             # --- Sort numerically --- #
1119             # ------------------------- #
1120 31 100       116 if($self->{_block}{_profile}{$blockname}{sorttype} =~ /numeric/)
1121             {
1122             # ------------------------------- #
1123             # --- Sort in decending order --- #
1124             # ------------------------------- #
1125 30 50       90 if($self->{_block}{_profile}{$blockname}{orderby} =~ /descending/)
1126             {
1127 30         73 foreach my $key(sort { $idx{$b} <=> $idx{$a} } keys %idx)
  0         0  
1128             {
1129 30         94 push(@sorted, $table[$key]);
1130             }
1131             }
1132             # ------------------------------- #
1133             # --- Sort in ascending order --- #
1134             # ------------------------------- #
1135             else
1136             {
1137 0         0 foreach my $key(sort { $idx{$a} <=> $idx{$b} } keys %idx)
  0         0  
1138             {
1139 0         0 push(@sorted, $table[$key]);
1140             }
1141             }
1142             }
1143             # ---------------------------- #
1144             # --- Sort alphabetically --- #
1145             # ---------------------------- #
1146             else
1147             {
1148             # ------------------------------- #
1149             # --- Sort in decending order --- #
1150             # ------------------------------- #
1151 1 50       4 if($self->{_block}{_profile}{$blockname}{orderby} =~ /descending/)
1152             {
1153 0         0 foreach my $key(sort { $idx{$b} cmp $idx{$a} } keys %idx)
  0         0  
1154             {
1155 0         0 push(@sorted, $table[$key]);
1156             }
1157             }
1158             # ------------------------------- #
1159             # --- Sort in ascending order --- #
1160             # ------------------------------- #
1161             else
1162             {
1163 1         4 foreach my $key(sort { $idx{$a} cmp $idx{$b} } keys %idx)
  12         12  
1164             {
1165 7         11 push(@sorted, $table[$key]);
1166             }
1167             }
1168             }
1169            
1170 31         116 return(@sorted);
1171             }
1172              
1173             sub _draw_line
1174             {
1175 22     22   28 my $self = shift;
1176 22         25 my $type = shift;
1177 22         24 my $length = shift;
1178            
1179 22 50 33     118 unless($length =~ /\d+/ && $length > 0)
1180             {
1181 0         0 $self->_debug(3, "Cannot _draw_line() $type - Line length = $length");
1182 0         0 return(undef);
1183             }
1184            
1185 22 50       86 unless($self->{_page}{_line}{$type})
1186             {
1187 0         0 $self->_debug(3, "Cannot _draw_line() $type - ".
1188             "Do not know how to make type ($type)\; For ".
1189             "a list of valid line types call linetypes()");
1190            
1191 0         0 return(undef);
1192             }
1193            
1194             else
1195             {
1196 22         93 return($self->{_page}{_line}{$type} x $length);
1197             }
1198             }
1199              
1200             sub _debug
1201             {
1202 98     98   118 my $self = shift;
1203 98         116 my ($level, $msg) = @_;
1204            
1205 98         303 my %err_lev =
1206             (4 => 'Critical:', 3 => 'Error:', 2 => 'Warn:', 1 => 'Notice:');
1207              
1208 98 50       452 return unless $self->{_debug}{_lev};
1209            
1210 0         0 my $fh = $self->{_log}{_file};
1211            
1212 0 0       0 if($level >= $self->{_debug}{_lev})
1213             {
1214 0 0       0 if($self->{_debug}{_verbose})
1215 0         0 {
1216 0         0 print($fh Carp::longmess("$err_lev{$level} $msg\n"), "\n");
1217             }
1218             else{print($fh Carp::shortmess("$err_lev{$level} $msg\n"), "\n");}
1219             }
1220             }
1221              
1222 443     443   546 sub _numeric{$a <=> $b;}
1223              
1224             sub _default_block
1225             {
1226 7     7   13 my $self = shift;
1227            
1228 7         134 $self->{_block}{_profile}{(shift)} =
1229             {
1230             column => {1 => {width => 80, align => 'center'},},
1231             sortby => 0, # No sort
1232             sorttype => 'alpha',
1233             orderby => 'ascending',
1234             title => undef,
1235             useColHeaders => 0,
1236             width => 12, # Global col width setting
1237             align => 'center', # Global alignment setting
1238             # Number of blank lines to add to start|end-of-block
1239             pad => {top => 0, bottom => 1},
1240             };
1241             }
1242             # ----------------------------------------- #
1243             # --- Assuming that the caller may not --- #
1244             # --- have access to 'Storable' declone --- #
1245             # ----------------------------------------- #
1246             sub _assign_def_block
1247             {
1248 5     5   8 my $self = shift;
1249 5         9 my $blockname = shift;
1250            
1251 5         21 $self->{_block}{_profile}{$blockname}{width} =
1252             $self->{_block}{_profile}{'_block'}{width};
1253 5         17 $self->{_block}{_profile}{$blockname}{align} =
1254             $self->{_block}{_profile}{'_block'}{align};
1255 5         15 $self->{_block}{_profile}{$blockname}{sortby} =
1256             $self->{_block}{_profile}{'_block'}{sortby};
1257 5         15 $self->{_block}{_profile}{$blockname}{sorttype} =
1258             $self->{_block}{_profile}{'_block'}{sorttype};
1259 5         65 $self->{_block}{_profile}{$blockname}{orderby} =
1260             $self->{_block}{_profile}{'_block'}{orderby};
1261 5         25 $self->{_block}{_profile}{$blockname}{useColHeaders} =
1262             $self->{_block}{_profile}{'_block'}{useColHeaders};
1263 5         15 $self->{_block}{_profile}{$blockname}{title} =
1264             $self->{_block}{_profile}{'_block'}{title};
1265            
1266 5         7 for(keys%{$self->{_block}{_profile}{'_block'}{pad}})
  5         20  
1267             {
1268 10         43 $self->{_block}{_profile}{$blockname}{pad}{$_} =
1269             $self->{_block}{_profile}{'_block'}{pad}{$_};
1270             }
1271              
1272 5         10 for my $col(keys%{$self->{_block}{_profile}{'_block'}{column}})
  5         17  
1273             {
1274 5         7 for my $t(keys%{$self->{_block}{_profile}{'_block'}{column}{$col}})
  5         16  
1275             {
1276 10         47 $self->{_block}{_profile}{$blockname}{column}{$col}{$t} =
1277             $self->{_block}{_profile}{'_block'}{column}{$col}{$t};
1278             }
1279             }
1280            
1281 5         12 $self;
1282             }
1283              
1284             sub _default_report
1285             {
1286 4     4   8 my $self = shift;
1287            
1288 4         48 $self->{_page}{_profile}{(shift)} =
1289             {
1290             width => 80, # Width of report in characters
1291             asis => 0, # Report.pm sets all block titles to caps & adds underline
1292             autoindex => 1, # Let us do the indexing for you
1293             };
1294             }
1295              
1296             sub AUTOLOAD
1297             {
1298 0     0     my $self = shift;
1299 0           my %profile;
1300            
1301 0           my $type = shift;
1302            
1303 0 0         if($type){$profile{$type} = 1;}
  0            
1304            
1305 0           my %this = @_;
1306            
1307 0 0         return if $AUTOLOAD =~ /::DESTROY$/;
1308            
1309 0           my $meth = $AUTOLOAD; $meth =~ s/.*://; # Just the method, not the pkg
  0            
1310            
1311 0 0         unless($meth =~ /^profile/){$self->_debug(3, "Bad method - $meth"); return(undef);}
  0            
  0            
1312            
1313 0 0         unless($Text::Report::stor_loaded)
1314             {
1315 0           $self->_debug(3, 'Cannot load module Storable; In order to use '.
1316             '"NamedPages", Storable.pm must be installed & in @INC');
1317 0           return(undef);
1318             }
1319            
1320 0 0         unless(defined $this{path}){$this{path} = '/tmp';}
  0            
1321            
1322             # --- Clean path --- #
1323 0           $this{path} =~ s|^(.*)/$|$1|;
1324            
1325            
1326             # --- Test path --- #
1327 0 0         unless(-e $this{path})
1328             {
1329 0           $self->_debug(3, "Cannot access profile storage area\; Path ".
1330             "($this{path}) does not exist");
1331 0           return(undef);
1332             }
1333            
1334             # my $sid = int(time);
1335            
1336 0           my $tmp = "$this{path}/stor.test.".int(time);
1337            
1338             # --- Test creat Rights --- #
1339 0 0         unless(open F, "+>$tmp")
1340             {
1341 0           $self->_debug(3, "Insufficient file creation rights in profile ".
1342             "storage area - Path ($this{path})");
1343 0           return(undef);
1344             }
1345            
1346 0           $self->_debug(1, "Created tmp file $tmp");
1347            
1348 0           close F;
1349            
1350             # --- Clean up --- #
1351 0           my @ret = grep{unlink} $tmp;
  0            
1352            
1353 0           $self->_debug(1, "Removed tmp file(s)".join(', ', @ret));
1354            
1355            
1356             # --- Test name --- #
1357 0 0         if($this{name})
1358             {
1359             # --- No spaces allowed --- #
1360 0           while($this{name} =~ s/\s+//g){};
1361            
1362             # --- No special chars --- #
1363 0 0 0       unless($this{name} =~ /^\w+$/ && $this{name} !~ /^$/)
1364             {
1365 0           $self->_debug(3, "No empty strings or special chars allowed in profile ".
1366             "name($this{name})\; Create a name that conforms to UNIX file ".
1367             "naming standards");
1368 0           return(undef);
1369             }
1370             }
1371             else
1372             {
1373 0           $self->_debug(2, "No profile name passed as \$obj->profile(\'load\', name => ".
1374             "\'myname\')\; Assigning default profile name \'default\'");
1375            
1376 0           $this{name} = 'default';
1377             }
1378            
1379             # $obj->profile('load', name => 'str');
1380             # $obj->profile('save', name => 'str');
1381 0 0         if($profile{load})
1382             {
1383 0           my $msg = "Cannot load stored profile ($this{name})";
1384            
1385             # --- Don't overwrite ourselves --- #
1386             # --- in case of failure --- #
1387 0           my $temp;
1388            
1389 0           eval{$temp->{_block} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_block");};
  0            
1390            
1391 0 0         $self->_debug(4, "$msg\; $@"), return undef if $@;
1392            
1393 0           eval{$temp->{_page} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_page");};
  0            
1394            
1395 0 0         $self->_debug(4, "$msg\; $@"), return undef if $@;
1396            
1397 0           eval{$temp->{_order} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_order");};
  0            
1398            
1399 0 0         $self->_debug(4, "$msg\; $@"), return undef if $@;
1400            
1401 0           $self->{_block} = $temp->{_block};
1402 0           $self->{_page} = $temp->{_page};
1403 0           $self->{_order} = $temp->{_order};
1404            
1405 0           return(1);
1406             }
1407 0 0         if($profile{save})
1408             {
1409             # stor.rpt.._block
1410 0           my $temp;
1411            
1412 0           $temp->{_block} = dclone($self->{_block});
1413            
1414             # --- Save just the skeleton --- #
1415 0           for(keys %{$temp->{_block}{_profile}})
  0            
1416             {
1417 0 0         delete $temp->{_block}{_profile}{$_}{data} unless /^\_/; # Save the separators
1418 0           delete $temp->{_block}{_profile}{$_}{_csv};
1419             }
1420            
1421 0           store($temp->{_block}, "$this{path}/stor.rpt\.$this{name}\.\_block");
1422 0           store($self->{_page}, "$this{path}/stor.rpt\.$this{name}\.\_page");
1423 0           store($self->{_order}, "$this{path}/stor.rpt\.$this{name}\.\_order");
1424            
1425 0           return(1);
1426             }
1427            
1428 0           return(undef);
1429             }
1430              
1431              
1432              
1433             __END__