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

# ***********************************************************************
# Report                                                                *
#                                                                       *
# Discussion:                                                           *
#                                                                       *
# Input:                                                                *
# Output:                                                               *
# Manager: D. Huggins (email removed)                                   *
# Company: Full-Duplex Communications Corporation                       *
#          http://www.full-duplex.com                                   *
#          http://www.in-brandon.com                                    *
# Start:   Wednesday, 17 January, 2007                                  *
# Version: 1.004                                                        *
# Release: 07.07.09.09:06                                               *
# Status:  PRODUCTION                                                   *
# ***********************************************************************

# All rights reserved by Full-Duplex Communications Corporation
#                  Copyright 2003 - 2007
package Text::Report;

$Text::Report::VERSION = '1.004';
@Text::Report::ISA = qw(Text);


BEGIN
{
   eval "use Storable qw(store retrieve dclone)";
   $Text::Report::stor_loaded = $@ ? 0 : 1;
};

use strict;
# use warnings;

use vars qw/ $VERSION @ISA/;

# use Data::Dumper;
use Carp;


our $AUTOLOAD;


my %debug_lev =
   (
      'off'       => 0,
      'notice'    => 1,
      'warning'   => 2,
      'error'     => 3,
      'critical'  => 4,
   );

1;


# autoindex => 1/0, # Report.pm sets print order of blocks based upon
#                     creation (defblock()) order; DEFAULT=1 (strongly recommended)
# logfh => *FH
# debug => ['off' | 'notice' | ...] str # Sets debug level; Default is 'critical'
# debugv => 1/0 # carp longmess | shortmess
# autoindex => 1/0 # If set (DEFAULT), Report.pm will index block print
#                    order in the same order as the block was defblock'd
sub new
{
   my $class = shift;
   my %this = @_;

   my $self = {};

   $self->{_page}{_index} = 0;

   $self->{_page}{_line} =
      {
         'dotted_line' => '.',
         'dbl_line'    => '=',
         'single_line' => '-',
         'under_line'  => '_',
         'blank_line'  => ' ',
      };

   bless $self, $class;

   # --- Build the default _report --- #
   $self->_default_report('report');

   # --- Changed 'Log' to 'logfh' in v1.003 --- #
   if($this{Log}){$this{logfh} = $this{Log};}

   # ---------------------------------------- #
   # --- Either we get a FH or use STDOUT --- #
   # ---------------------------------------- #
   $self->{_log}{_file} = ref $this{logfh} ? $this{logfh} : \*STDOUT;
   $self->{_debug}{_lev} = $this{debug} ? $debug_lev{$this{debug}} : 1;
   $self->{_debug}{_verbose} = $this{debugv} ? 1 : 0;

   # ------------------------------------------------ #
   # --- $this{autoindex} can only be set on init --- #
   # ------------------------------------------------ #
   $self->{_page}{_profile}{report}{autoindex} = $this{autoindex} ? $this{autoindex} : 1;

   delete $this{logfh}; delete $this{debug}; delete $this{debugv};

   # --- Build the default _block --- #
   $self->_default_block('_block');

   # ---------------------------------------------------- #
   # --- Build the report page layout w/modifications --- #
   # --- to the default block, if any                 --- #
   # ---------------------------------------------------- #
   $self->configure(%this);

   return $self;
}

# --- Define Report Properties --- #
# width => int, # Report width DEFAULT=80
# asis => 1/0, # Report.pm sets all block titles to caps & adds underline; DEFAULT=0
# debug => [off|notice|error|warning|critical] # Level of debug; DEFAULT='warning'
# debugv => 1/0 # Verbose mode using carp(longmess|shortmess)
# blockPad => {top => int, bottom => int} # Set global block padding
# column => int => {width => int, align => 'left', head => 'str'}
# useColHeaders => 1/0 # Off (DEFAULT) means that no col headers will be printed or auto generated
# sortby => int # Col number to sort 2-dimensional array; Zero for no sort oder
sub configure
{
   my $self = shift;

   my %this = @_ ? @_ : return(undef);

   my @idx = keys %{$self->{_page}{_profile}{report}};

   for(@idx)
   {
      next if /^autoindex$/;
      if(defined $this{$_}){$self->{_page}{_profile}{report}{$_} = $this{$_}}
   }

   $self->{_debug}{_lev} = $debug_lev{ $this{debug} } if defined $this{debug} &&
      $this{debug} =~ /^(off|notice|error|warning|critical)$/i;
   $self->{_debug}{_verbose} = $this{debugv} if defined $this{debugv};


   # --- To use or not to use Headers --- #
   $self->{_block}{_profile}{'_block'}{useColHeaders} = $this{useColHeaders}
      if defined $this{useColHeaders};

   # --- Set column to sort by (zero/undef = no sort) --- #
   $self->{_block}{_profile}{'_block'}{sortby} = $this{sortby}
      if defined $this{sortby} && $this{sortby} =~ /^\d+$/;

   if(defined $this{width})
   {
      # --- Set default page width --- #
      $self->{_page}{_profile}{report}{width} = $this{width};
      # --- Set default block col width --- #
      $self->{_block}{_profile}{'_block'}{column}{1}{width} = $this{width};
   }

   # -------------------------------------------------- #
   # --- Overwrite any existing (eg default _block) --- #
   # --- col def's                                  --- #
   # -------------------------------------------------- #
   if($this{column})
   {
      return undef unless $this{column} =~ /HASH/;
      # --- Test keys - Expect int --- #
      my @int = keys %{$this{column}} || return undef;
      for(@int){return undef unless /^\d+$/;}
      delete $self->{_block}{_profile}{'_block'}{column}; # reset

      foreach my $col(keys %{$this{column}})
      {
         $self->setcol('_block', $col, %{$this{column}{$col}});
      }
   }

   if(defined $this{blockPad})
   {
      eval{
      for(keys %{$self->{_block}{_profile}{'_block'}{pad}})
      {
         $self->{_block}{_profile}{'_block'}{pad}{$_} = $this{blockPad}{$_}
            if defined $this{blockPad}{$_};
      }};

      if($@)
      {
         $self->_debug(4, "configure(pad => {top => int, bottom => int}) syntax - $@");
         return undef;
      }
   }

   $self;
}

# --- Define Block Properties --- #
# name => 'sd1', # No name, no define
# title => 'Sample Data One', # DEFAULT - undef
# order => $order_idx++, # Block print order, only used if new(autoindex => 0)
# sortby => 1, # Column to sort. DEFAULT=0 (no sorting)
# sorttype => 'alpha', # DEFAULT: 'alpha' | 'numeric'
# orderby => 'ascending', # DEFAULT: 'ascending' | 'descending'
# useColHeaders => 0, # Set to 1 to display headers & header underlines at col head
# column => {1 => {width => 10, align => 'left',  head => 'ColOne',},}, # head is opt
# cols =>  int GT zero # Tell Report.pm to autocreate x number of cols; Used INSTEAD of columns{}
# pad => {top => int, bottom => int} # Number of blank lines to pad beginning & end of block
# columnWidth => int GT zero # Set block default widths
# columnAlign => [left|right|center] # Set block default alignments
sub defblock # Define Block - New blocks only
{
   my $self = shift;
   my %this = @_;

   # -------------------------- #
   # --- Need a block name  --- #
   # -------------------------- #
   unless(defined $this{name})
   {
      $self->_debug(3,
         "defblock() Attempt to create a block with no \'name\'. ".
         "Modify the default block using setblock() or call defblock() ".
         "using defblock( name => \'block_name\')");

      return(undef);
   }

   # ------------------------------------------- #
   # --- Use configure() to alter the global --- #
   # --- properties of the default '_block'  --- #
   # ------------------------------------------- #
   if($this{name} =~ /^\_block/)
   {
      $self->_debug(3,
         "defblock(name => \'_block\') Attempt to create a block with default block name. ".
         "Modify the default block using configure() or call defblock() ".
         "using defblock( name => \'block_name\')");

      return(undef);
   }

   my $blockname = $this{name};

   my $cols;

   # ------------------------------------------------ #
   # --- Do  not allow the caller to use defblock --- #
   # --- if it has already been def'd. Send the   --- #
   # --- caller to delblock()                     --- #
   # ------------------------------------------------ #
   if(defined $self->{_block}{_profile}{$blockname})
   {
      $self->_debug(2,
         "defblock() Attempt to create an already defined block. ".
         "Modify block using setblock() or delete block first using ".
         "delblock(\'block_name\')");

      return(undef);
   }

   # --------------------------- #
   # --- Assign the defaults --- #
   # --------------------------- #
   unless(defined $self->{_block}{_profile}{$blockname})
   {
      $self->_assign_def_block($blockname);
   }

   # ------------------------- #
   # --- Block-end padding --- #
   # ------------------------- #
   eval{
   if(defined $this{pad}{top} && $this{pad}{top} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{pad}{top} = $this{pad}{top};
   }
   else
   {
      $self->{_block}{_profile}{$blockname}{pad}{top} = $self->{_block}{_profile}{'_block'}{pad}{top};
   }
   if(defined $this{pad}{bottom} && $this{pad}{bottom} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{pad}{bottom} = $this{pad}{bottom};
   }
   else
   {
      $self->{_block}{_profile}{$blockname}{pad}{bottom} = $self->{_block}{_profile}{'_block'}{pad}{bottom};
   }};

   # --- Trap incomplete hash --- #
   if($@){$self->_debug(4, "defblock(pad => {top => int, bottom => int}) syntax - $@"); return undef}

   # ------------------- #
   # --- Block Title --- #
   # ------------------- #
   $self->{_block}{_profile}{$blockname}{title} = $this{title} || undef;

   # -------------------------------------------------- #
   # --- Does caller want us to automatically build --- #
   # --- headers for this block? setcol() handles   --- #
   # --- the rest                                   --- #
   # -------------------------------------------------- #
   if(defined $this{useColHeaders})
   {
      $self->{_block}{_profile}{$blockname}{useColHeaders} = $this{useColHeaders};
   }
   else
   {
       $self->{_block}{_profile}{$blockname}{useColHeaders} = $self->{_block}{_profile}{'_block'}{useColHeaders}
   }

   # --------------------------------------------- #
   # --- Did the caller pass default alignment --- #
   # --- &/or col width? If so, get these set  --- #
   # --- before cols are built                 --- #
   # --------------------------------------------- #
   if(defined $this{columnWidth} && $this{columnWidth} =~ /^\d+$/ && $this{columnWidth} > 0)
   {
      $self->{_block}{_profile}{$blockname}{width} = $this{columnWidth};

      # ------------------------------------------- #
      # --- Col 1 is pre-defined at 'center'/80 --- #
      # --- Adjust here                         --- #
      # ------------------------------------------- #
      $self->{_block}{_profile}{$blockname}{'column'}{1}{'width'} = $this{columnWidth};

   }
   else
   {
      $self->{_block}{_profile}{$blockname}{width} = $self->{_page}{_profile}{report}{width};
   }

   if(defined $this{columnAlign} && $this{columnAlign} =~ /^(left|right|center)$/i)
   {
      $self->{_block}{_profile}{$blockname}{align} = lc($this{columnAlign});

      # ------------------------------------------- #
      # --- Col 1 is pre-defined at 'center'/80 --- #
      # --- Adjust here                         --- #
      # ------------------------------------------- #
      $self->{_block}{_profile}{$blockname}{'column'}{1}{'align'} = lc($this{columnAlign});
   }

   # -------------------------------------------------- #
   # --- Overwrite any existing (eg default _block) --- #
   # --- col def's                                  --- #
   # -------------------------------------------------- #
   if($this{column})
   {
      delete $self->{_block}{_profile}{$blockname}{column}; # reset

      foreach my $col(keys %{$this{column}})
      {
         $self->setcol($blockname, $col, %{$this{column}{$col}});
      }
   }
   # ----------------------------------------------------------------------- #
   # --- Allow caller to generate cols using preset default width, align --- #
   # --- Column widths are calc'd by dividing the current page width by  --- #
   # --- number of columns unless we are passed a columnWidth. An       --- #
   # --- attempt is made to use it. If the total width is GT the page    --- #
   # --- width, then we revert to calc'ing using prev formula            --- #
   # ----------------------------------------------------------------------- #
   elsif(defined $this{cols} && $this{cols} =~ /^\d+$/ && $this{cols} > 0)
   {
      # --- Clear existing columns --- #
      delete $self->{_block}{_profile}{$blockname}{column}; # reset

      # ----------------------------------------------- #
      # --- Next, make sure all of this is going to --- #
      # --- fit on the report page                  --- #
      # ----------------------------------------------- #
      my $pg_width = $self->{_page}{_profile}{report}{width};
      my $tl_block_width = $this{cols} * ($self->{_block}{_profile}{$blockname}{width});

      # ------------------------------- #
      # --- If it doesn't, force it --- #
      # ------------------------------- #
      if($tl_block_width > $pg_width)
      {
         # -------------------------------------------------- #
         # --- Recalc col width based upon the page width --- #
         # --- divided by number of cols requested        --- #
         # -------------------------------------------------- #
         eval{$self->{_block}{_profile}{$blockname}{width} =
            ($self->{_page}{_profile}{report}{width} / $this{cols});};

         # --- $this{cols} is > zero, so shouldn't be a prob --- #
         if($@){$self->_debug(2, "Col width 102 calc err for block ($blockname) - $@");}

         # --- Clean up --- #
         $self->{_block}{_profile}{$blockname}{width} =
            sprintf("%0.0f\n", $self->{_block}{_profile}{$blockname}{width});

         # --- Adjust --- #
         $self->{_block}{_profile}{$blockname}{width} -= 2;

         $self->_debug(1, "Calculated col width = ".
            "$self->{_block}{_profile}{$blockname}{width} for block ($blockname)");
      }

      for(my $i = 1; $i <= $this{cols}; $i++)
      {
         $self->setcol($blockname, $i,
                        width => $self->{_block}{_profile}{$blockname}{width},
                        align => $self->{_block}{_profile}{$blockname}{align},
                        head => $this{head}->[$i-1],
                        );
      }
   }
   # --- Otherwise use the default:  1 col, center, 80 chars wide --- #


   # ----------------------------------- #
   # --- Determine block print order --- #
   # ----------------------------------- #
   if($self->{_page}{_profile}{report}{autoindex})
   {
      # --- Add auto print sequence to _order --- #
      $self->{_order}{_block}{$self->{_page}{_index}++} = $blockname;
   }
   else
   {
      unless($this{order} =~ /^\d+$/)
      {
         $self->_debug(3,
            "defblock(order) Need print order sequence number to process block ".
            "$blockname. Call defblock() using defblock(order => int)");

         return(undef);
      }

      $self->{_order}{_block}{$this{order}} = $blockname;
   }

   # --------------------------------- #
   # --- Define column to sort on  --- #
   # --- The DEFAULT is no sorting --- #
   # --------------------------------- #
   if(defined $this{sortby} && $this{sortby} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{sortby} = $this{sortby};
   }

   # --------------------------------- #
   # --- Define sort type          --- #
   # --------------------------------- #
   if(defined $this{sorttype} && $this{sorttype} =~ /^(alpha|numeric)$/i)
   {
      $self->{_block}{_profile}{$blockname}{sorttype} = lc($this{sorttype});
   }

   # -------------------------------- #
   # --- Define sort direction    --- #
   # -------------------------------- #
   if(defined $this{orderby} && $this{orderby} =~ /^(ascending|descending)$/i)
   {
      $self->{_block}{_profile}{$blockname}{orderby} = lc($this{orderby});
   }

   $self;
}
# --- Alter An Existing Block's Properties --- #
# title => 'Sample Data One', # DEFAULT - undef
# order => $order_idx++, # Block print order, only used if new(autoindex => 0)
# sortby => 1, # Column to sort. DEFAULT=0
# sorttype => 'alpha', # DEFAULT: 'alpha' | 'numeric'
# orderby => 'ascending', # DEFAULT: 'ascending' | 'descending'
# pad => {top => int, bottom => int} # Number of blank lines to pad beginning & end of block
# useColHeaders => 1/0 # Turn on/off column headers & their assoc underlines
sub setblock
{
   my $self = shift;

   my %this = @_ ? @_ : return(undef);

   my $blockname;

   return undef unless $blockname = $this{name};

   # ----------------------------------------- #
   # --- Do not modify the default '_block --- #
   # --- here - Use configure()            --- #
   # ----------------------------------------- #
   return undef if $blockname =~ /^\_block$/;

   # --------------------------------------------------------- #
   # --- This method is only for modifying existing blocks --- #
   # --------------------------------------------------------- #
   unless(defined $self->{_block}{_profile}{$blockname})
   {
      $self->_debug(3, "setblock() Attempt to modify a non-defined block. ".
         "Create block using defblock()");
      return undef;
   }

   # ------------------------- #
   # --- Block-end padding --- #
   # ------------------------- #
   eval{
   if(defined $this{pad}{top} && $this{pad}{top} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{pad}{top} = $this{pad}{top};
   }
   else
   {
      $self->{_block}{_profile}{$blockname}{pad}{top} = $self->{_block}{_profile}{_block}{pad}{top};
   }
   if(defined $this{pad}{bottom} && $this{pad}{bottom} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{pad}{bottom} = $this{pad}{bottom};
   }
   else
   {
      $self->{_block}{_profile}{$blockname}{pad}{bottom} = $self->{_block}{_profile}{_block}{pad}{bottom};
   }};

   # --- Trap incomplete hash --- #
   if($@){$self->_debug(4, "setblock(pad => {top => int, bottom => int}) syntax - $@"); return undef}

   # ------------------- #
   # --- Block Title --- #
   # ------------------- #
   $self->{_block}{_profile}{$blockname}{title} = $this{title} if defined $this{title};

   # ---------------------- #
   # --- Column Headers --- #
   # ---------------------- #
   $self->{_block}{_profile}{$blockname}{useColHeaders} = $this{useColHeaders} if defined $this{useColHeaders};

   # ----------------------------------- #
   # --- Determine block print order --- #
   # ----------------------------------- #
   if(defined $this{order} && $this{order} =~ /^\d+$/)
   {
      if($self->{_page}{_profile}{report}{autoindex})
      {
         $self->_debug(2, 'setblock() Cannot set order if Report object init\'d with autoindex. '.
            'Create Text::Report->new(autoindex => 0) the default is on');
      }
      else{$self->{_order}{_block}{$this{order}} = $blockname;}
   }

   # --------------------------------- #
   # --- Define column to sort on  --- #
   # --- The DEFAULT is no sorting --- #
   # --------------------------------- #
   if(defined $this{sortby} && $this{sortby} =~ /^\d+$/)
   {
      $self->{_block}{_profile}{$blockname}{sortby} = $this{sortby};
   }

   # -------------------------------- #
   # --- Define sort type         --- #
   # -------------------------------- #
   if(defined $this{sorttype} && $this{sorttype} =~ /^(alpha|numeric)$/i)
   {
      $self->{_block}{_profile}{$blockname}{sorttype} = lc($this{sorttype});
   }

   # -------------------------------- #
   # --- Define sort direction    --- #
   # -------------------------------- #
   if(defined $this{orderby} && $this{orderby} =~ /^(ascending|descending)$/i)
   {
      $self->{_block}{_profile}{$blockname}{orderby} = lc($this{orderby});
   }

   $self;
}
# Set/change Column Properties
# $obj->setcol($blockname, $colnumber, align => [left|right|center], width => int, head => 'str')
# align => [left|right|center] #
# width => int GT zero #
# head => 'str' # Column header
sub setcol
{
   my $self = shift;
   my $blockname = shift;
   my $number = shift;

   my %this = @_ ? @_ : return(undef);

   return undef unless $number =~ /^\d+$/;

   unless(defined $blockname){$blockname = '_block';}


   # ---------------------------------------- #
   # --- If the caller has not def'd this --- #
   # --- $blockname, right back at 'em    --- #
   # ---------------------------------------- #
   unless(defined $self->{_block}{_profile}{$blockname})
   {
      $self->_debug(3, "setcol() Attempt to modify a non-defined block. ".
                        "Create block first using defblock()");
      return undef;
   }

   if(defined $this{align} && $this{align} =~ /^(left|right|center)$/i)
   {
      $self->{_block}{_profile}{$blockname}{column}{$number}{align} = lc($this{align});
   }
   else # use our built-in default
   {
      unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{align})
      {
         $self->{_block}{_profile}{$blockname}{column}{$number}{align} = $self->{_block}{_profile}{$blockname}{align};
         $self->_debug(1, "setcol(align) param not set for col number \"$number\". ".
            "Defining col align as \"$self->{_block}{_profile}{$blockname}{align}\"");
      }
   }

   if(defined $this{width} && $this{width} =~ /^\d+$/ && $this{width} > 0)
   {
      $self->{_block}{_profile}{$blockname}{column}{$number}{width} = $this{width};
   }
   else
   {
      unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{width})
      {
         $self->{_block}{_profile}{$blockname}{column}{$number}{width} = $self->{_block}{_profile}{$blockname}{width};
         $self->_debug(1, "setcol(width) param not set for col number \"$number\". ".
            "Defining col width as \"$self->{_block}{_profile}{$blockname}{width}\"");
      }
   }

   if(defined $this{head})
   {
      $self->{_block}{_profile}{$blockname}{column}{$number}{head} = $this{head};
   }
   else
   {
      if($self->{_block}{_profile}{$blockname}{useColHeaders})
      {
         unless(exists $self->{_block}{_profile}{$blockname}{column}{$number}{head})
         {
            $self->{_block}{_profile}{$blockname}{column}{$number}{head} = $number;
            $self->_debug(1, "setcol(\'block_name\', col_num, head => ".
               "\"Header Title\") param not set \& \'useColHeaders\' flag ".
               "is set. Defining col header as \"$number\"");
         }
      }
   }

   $self;
}

# Insert a page separation line
# order => int # unless autoindex is set
# pad => {top => int, bottom => int}
# width => int # override the default width (page width)
sub insert
{
   my $self = shift;
   my $line_type = shift;
   my %this = @_;

   my $blockname;

   # ----------------------------------- #
   # --- Determine block print order --- #
   # ----------------------------------- #
   if($self->{_page}{_profile}{report}{autoindex})
   {
      $blockname = "__separator_$self->{_page}{_index}";

      # ----------------------------------------- #
      # --- Add auto print sequence to _order --- #
      # ----------------------------------------- #
      $self->{_order}{_block}{$self->{_page}{_index}++} = $blockname;
   }
   else
   {
      unless($this{order} =~ /^\d+$/)
      {
         $self->_debug(3,
            "insert(order) Need print order sequence number to process ".
            "separator. Call insert() using insert(\'line_type\', order => int)");

         return(undef);
      }

      $blockname = "__separator_$this{order}";

      $self->{_order}{_block}{$this{order}} = $blockname;
   }

   # --- Create a new block --- #
   $self->_default_block($blockname);

   # --- No headers will be used --- #
   $self->{_block}{_profile}{$blockname}{useColHeaders} = 0;

   # --- Set width - either by callers specs or use page def --- #
   $self->{_block}{_profile}{$blockname}{width} = $this{width} || $self->{_page}{_profile}{report}{width};

   # --- Reset, if necessary, the col width --- #
   $self->setcol($blockname, 1, width => $self->{_block}{_profile}{$blockname}{width});

   # ------------------------------------ #
   # --- Set padding if any requested --- #
   # ---                              --- #
   # --- We don't use the default pad --- #
   # --- here. The caller must        --- #
   # --- specifically request padding --- #
   # ------------------------------------ #
   my @insert;

   if(defined $this{pad})
   {
      eval{
      for(1 .. $this{pad}{top})
         {push(@insert, [$self->_draw_line('blank_line', $self->{_page}{_profile}{report}{width})]);}

      push(@insert, [$self->_draw_line($line_type, $self->{_page}{_profile}{report}{width})]);

      for(1 .. $this{pad}{bottom})
         {push(@insert, [$self->_draw_line('blank_line', $self->{_page}{_profile}{report}{width})]);}};
   }
   else
   {
      push(@insert, [$self->_draw_line($line_type, $self->{_page}{_profile}{report}{width})]);
   }

   $self->fill_block($blockname, @insert);
   $self;
}
###########################
# $obj->fill_block('named_block', @AoA)
#
# Fill formatted, named block w/data
# passed to us in table form where
# @_ = [array1],[array2],[array3]...
sub fill_block
{
   my $self = shift;
   my $blockname = shift;
   my @table = @_; # AoA

   unless(defined $self->{_block}{_profile}{$blockname})
   {
      $self->_debug(3, "fill_block() Attempt to fill a non-defined block. ".
                        "Create block first using defblock()");
      return undef;
   }

   my @fCol; my @csv;

   my %align = (left => '<', center => '|', right => '>', );

   my @col_head;

   foreach my $col(sort _numeric(keys %{$self->{_block}{_profile}{$blockname}{column}}))
   {
      # ---------------------- #
      # --- Column attribs --- #
      # ---------------------- #
      my $align = $align{ $self->{_block}{_profile}{$blockname}{column}{$col}{align} };
      my $width = $self->{_block}{_profile}{$blockname}{column}{$col}{width};

      # ---------------------- #
      # --- Column header  --- #
      # ---------------------- #
      if(defined $self->{_block}{_profile}{$blockname}{column}{$col}{head})
      {
         push(@col_head, $self->{_block}{_profile}{$blockname}{column}{$col}{head});
      }

      push(@fCol, '@'.$align x $width);
   }

   my $columns = join(" ", @fCol);


   my $format = 'formline <<"END", @data;'."\n".'$columns'."\n"."END";

   # ------------------------------------------------------------ #
   # --- Build title & column headers first time through only --- #
   # ------------------------------------------------------------ #
   unless($self->{_block}{_profile}{$blockname}{_append})
   {
      $self->{_block}{_profile}{$blockname}{_append} = 1;
      # ------------------- #
      # --- Place Title --- #
      # ------------------- #
      if($self->{_block}{_profile}{$blockname}{title})
      {
         unless($self->{_page}{_profile}{report}{asis})
         {
            # --- Store title & header data in {hdata} --- #
            # --- to retain for template building      --- #
            push(@{$self->{_block}{_profile}{$blockname}{hdata}}, uc($self->{_block}{_profile}{$blockname}{title}));

            # --- Title Underline --- #
            my @chars = split('', $self->{_block}{_profile}{$blockname}{title}); # Get char count
            push(@{$self->{_block}{_profile}{$blockname}{hdata}}, ($self->_draw_line('single_line', scalar(@chars))));

            push(@csv, uc($self->{_block}{_profile}{$blockname}{title}));
         }
         else
         {
            push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $self->{_block}{_profile}{$blockname}{title});
            push(@csv, $self->{_block}{_profile}{$blockname}{title});
         }

         # --------------------------- #
         # --- Pad the block title --- #
         # ---     CONSTANT        --- #
         # --------------------------- #
         unless($self->{_page}{_profile}{report}{asis})
         {
            push(@{$self->{_block}{_profile}{$blockname}{hdata}}, ($self->_draw_line('blank_line', 1)));
         }
      }

      if($self->{_block}{_profile}{$blockname}{useColHeaders})
      {
         # ---------------------------- #
         # --- Build Column Headers --- #
         # ---------------------------- #
         my @data = @col_head;

         eval $format;

         if($@){$self->_debug(3, "Internal/system Error - $@");} # Who the hell knows?

         chomp($^A);
         push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $^A);
         $^A = '';

         # -------------------------------- #
         # --- Column Header Underlines --- #
         # -------------------------------- #
         my @col_underline;

         my $i = 0;
         for(@col_head)
         {
            my $chars = $self->{_block}{_profile}{$blockname}{column}{++$i}{width}; # Width of col
            push(@col_underline, ($self->_draw_line('under_line', $chars)));
         }

         @data = (); # reset data

         @data = @col_underline;

         eval $format;

         if($@){$self->_debug(3, "Internal/system Error - $@");}

         chomp($^A);
         push(@{$self->{_block}{_profile}{$blockname}{hdata}}, $^A);
         $^A = '';
      }

      if(@col_head > 1){push(@csv, join(',', @col_head));}
      if(@col_head == 1){push(@csv, $col_head[0]);}
   }

   my @sorted = $self->_sort($blockname, @table);

   # ---------------------------- #
   # --- Add the data portion --- #
   # ---------------------------- #
   my $debug = 0;

   foreach my $block(@sorted)
   {
      my @data = @{$block};

      push(@csv, join(',', @{$block}));

      eval $format;

      # ------------------------------------------ #
      # --- This should never happen, but then --- #
      # --- what do i know                     --- #
      # ------------------------------------------ #
      if($@)
      {
         $self->_debug(4, 'Internal/system Error - Data format failure. Please '.
            'contact your system administrator. I\'m sure he\'ll know what to do.'.
            "ABEND - $@");

         die $@;
      }

      chomp($^A); push(@{$self->{_block}{_profile}{$blockname}{data}}, $^A);
      $^A = '';
   }
   # ---------------------- #
   # --- Store csv data --- #
   # ---------------------- #
   for(@csv){push(@{$self->{_block}{_profile}{$blockname}{_csv}}, $_);}

   $self;
}

# $obj->report('get'); # Return report lines w/in array
# $obj->report('print'); # STDOUT
# $obj->report('csv'); # Retrieve csv data
sub report
{
   my $self = shift;

   my %this; my @page = ();

   $this{lc(shift)} = 1;


   if(defined $self->{_order}{_block})
   {
      # ---------------------------------------- #
      # --- If a named block has no 'order', --- #
      # --- it will be silently ignored      --- #
      # ---------------------------------------- #
      BLOCK: foreach my $key(sort _numeric(keys %{$self->{_order}{_block}}))
      {
         my $blockname = $self->{_order}{_block}{$key};

         if($this{'csv'})
         {
            push(@page, $self->{_block}{_profile}{$blockname}{_csv});
            next BLOCK;
         }

         # ----------------------- #
         # --- Top pad, if any --- #
         # ----------------------- #
         if(defined $self->{_block}{_profile}{$blockname}{pad}{top} && $self->{_block}{_profile}{$blockname}{pad}{top} > 0)
         {
            if($this{'print'}){print "\n" x $self->{_block}{_profile}{$blockname}{pad}{top};}
            else
            {
               for(1 .. $self->{_block}{_profile}{$blockname}{pad}{top})
               {
                  push(@page, " ");
               }
            }
         }

         # --- Top-of-block data --- #
         if(exists $self->{_block}{_profile}{$blockname}{hdata})
         {
            for(@{$self->{_block}{_profile}{$blockname}{hdata}})
            {
               if($this{'print'}){print "$_\n";}
               else{push(@page, $_);}
            }
         }
         # --- Collected data --- #
         for(@{$self->{_block}{_profile}{$blockname}{data}})
         {
            if($this{'print'}){print "$_\n";}
            else{push(@page, $_);}
         }

         # -------------------------- #
         # --- Bottom pad, if any --- #
         # -------------------------- #
         if(defined $self->{_block}{_profile}{$blockname}{pad}{bottom} && $self->{_block}{_profile}{$blockname}{pad}{bottom} > 0)
         {
            if($this{'print'}){print "\n" x $self->{_block}{_profile}{$blockname}{pad}{bottom};}
            else
            {
               for(1 .. $self->{_block}{_profile}{$blockname}{pad}{bottom})
               {
                  push(@page, " ");
               }
            }
         }
      }
   }
   # --- No order, no laundry --- #
   else
   {
      $self->_debug(3, 'Block print order has not been set. Either create Report object using '.
         'Text::Report->new(autoindex => 1) or use $obj->defblock(order => int).'.
         "Cannot print report");
      $self->{_err} = 1;
      push(@{$self->{_errors}}, ["Block print order has not been set. Cannot print report"]);

      return undef;
   }

   return @page ? @page : undef;
}
# Use this meth to retrieve csv data for block(s)
#  use $obj->report('csv') to retrieve csv data
#  for entire report
# $obj->get_csv(blockname1, blockname2, ...);
sub get_csv
{
   my $self = shift;

   my @list;

   for(@_ ? @_ : return(undef))
   {
      push(@list, $self->{_block}{_profile}{$_}{_csv});
   }

   return(@list);
}

# --------------------------------------------------- #
# --- Reset Named Block to orig default settings. --- #
# --- Overrides any changes made to '_block'      --- #
# --------------------------------------------------- #

# $obj->rst_block($block_name)
# Resets named block to defaults
# If $block_name does not exist, creates new block $block_name and applies defaults.
sub rst_block
{
   my $self = shift;

   $self->_default_block((shift));

   $self;
}

# $obj->del_block($block_name)
# Deletes Named Block
sub del_block
{
   my $self = shift;
   my $blockname = shift;

   delete $self->{_block}{_profile}{$blockname};

   $self;
}

# $obj->clr_block_data($block_name)
# Clears data & csv data from Named Block
sub clr_block_data
{
   my $self = shift;
   my $blockname = shift;

   delete $self->{_block}{_profile}{$blockname}{data};
   delete $self->{_block}{_profile}{$blockname}{_csv};
   # delete $self->{_block}{_profile}{(shift)}{hdata};

   $self;
}

# $obj->clr_block_headers($block_name)
# Clears hdata (header data) from Named Block
sub clr_block_headers
{
   my $self = shift;
   my $blockname = shift;

   delete $self->{_block}{_profile}{$blockname}{hdata};

   # --- Reset "header set" flag --- #
   $self->{_block}{_profile}{$blockname}{_append} = undef;

   $self;
}

# $obj->named_blocks
# Returns an array of all named_block's defined
sub named_blocks
{
   return(keys %{shift->{_block}{_profile}});
}

# $obj->linetypes
# Returns an array of avail line types
sub linetypes
{
   return keys %{shift->{_page}{_line}};
}

# Maybe someday:
# sub order
# {
#    my $self = shift;
#    my %order = @_;
#
#    # --- Cannot change order if autoindex is set --- #
#    if($self->{_page}{_profile}{report}{autoindex})
#    {
#       # ERROR
#       return(undef);
#    }
#
#    $self->{_order}{_block} = \%order;
# }

# ----------------------------------- #
# --- Private methods & functions --- #
# ----------------------------------- #
sub _sort
{
   my $self = shift;
   my $blockname   = shift;
   my @table = @_;

   return @table unless $self->{_block}{_profile}{$blockname}{sortby}; # 0="Don't sort"

   my %idx; my $rec = 0;

   # ------------------------------------------ #
   # --- Caller refers to 1st col as col 1, --- #
   # --- we refer to it as element zero     --- #
   # ------------------------------------------ #
   my $sort_col = ($self->{_block}{_profile}{$blockname}{sortby} - 1);

   for my $row(@table){$idx{$rec++} = $row->[$sort_col];}

   my @sorted;

   # ------------------------- #
   # --- Sort numerically  --- #
   # ------------------------- #
   if($self->{_block}{_profile}{$blockname}{sorttype} =~ /numeric/)
   {
      # ------------------------------- #
      # --- Sort in decending order --- #
      # ------------------------------- #
      if($self->{_block}{_profile}{$blockname}{orderby} =~ /descending/)
      {
         foreach my $key(sort { $idx{$b} <=> $idx{$a} } keys %idx)
         {
            push(@sorted, $table[$key]);
         }
      }
      # ------------------------------- #
      # --- Sort in ascending order --- #
      # ------------------------------- #
      else
      {
         foreach my $key(sort { $idx{$a} <=> $idx{$b} } keys %idx)
         {
            push(@sorted, $table[$key]);
         }
      }
   }
   # ---------------------------- #
   # --- Sort alphabetically  --- #
   # ---------------------------- #
   else
   {
      # ------------------------------- #
      # --- Sort in decending order --- #
      # ------------------------------- #
      if($self->{_block}{_profile}{$blockname}{orderby} =~ /descending/)
      {
         foreach my $key(sort { $idx{$b} cmp $idx{$a} } keys %idx)
         {
            push(@sorted, $table[$key]);
         }
      }
      # ------------------------------- #
      # --- Sort in ascending order --- #
      # ------------------------------- #
      else
      {
         foreach my $key(sort { $idx{$a} cmp $idx{$b} } keys %idx)
         {
            push(@sorted, $table[$key]);
         }
      }
   }

   return(@sorted);
}

sub _draw_line
{
   my $self = shift;
   my $type = shift;
   my $length = shift;

   unless($length =~ /\d+/ && $length > 0)
   {
      $self->_debug(3, "Cannot _draw_line() $type - Line length = $length");
      return(undef);
   }

   unless($self->{_page}{_line}{$type})
   {
      $self->_debug(3, "Cannot _draw_line() $type - ".
            "Do not know how to make type ($type)\; For ".
            "a list of valid line types call linetypes()");

      return(undef);
   }

   else
   {
      return($self->{_page}{_line}{$type} x $length);
   }
}

sub _debug
{
   my $self = shift;
   my ($level, $msg) = @_;

   my %err_lev =
      (4 => 'Critical:', 3 => 'Error:', 2 => 'Warn:', 1 => 'Notice:');

   return unless $self->{_debug}{_lev};

   my $fh = $self->{_log}{_file};

   if($level >= $self->{_debug}{_lev})
   {
      if($self->{_debug}{_verbose})
      {
         print($fh Carp::longmess("$err_lev{$level} $msg\n"), "\n");
      }
      else{print($fh Carp::shortmess("$err_lev{$level} $msg\n"), "\n");}
   }
}

sub _numeric{$a <=> $b;}

sub _default_block
{
   my $self = shift;

   $self->{_block}{_profile}{(shift)} =
      {
         column => {1 => {width => 80, align => 'center'},},
         sortby => 0, # No sort
         sorttype => 'alpha',
         orderby => 'ascending',
         title => undef,
         useColHeaders => 0,
         width => 12, # Global col width setting
         align => 'center', # Global alignment setting
         # Number of blank lines to add to start|end-of-block
         pad => {top => 0, bottom => 1},
      };
}
# ----------------------------------------- #
# --- Assuming that the caller may not  --- #
# --- have access to 'Storable' declone --- #
# ----------------------------------------- #
sub _assign_def_block
{
   my $self = shift;
   my $blockname = shift;

   $self->{_block}{_profile}{$blockname}{width} =
      $self->{_block}{_profile}{'_block'}{width};
   $self->{_block}{_profile}{$blockname}{align} =
      $self->{_block}{_profile}{'_block'}{align};
   $self->{_block}{_profile}{$blockname}{sortby} =
      $self->{_block}{_profile}{'_block'}{sortby};
   $self->{_block}{_profile}{$blockname}{sorttype} =
      $self->{_block}{_profile}{'_block'}{sorttype};
   $self->{_block}{_profile}{$blockname}{orderby} =
      $self->{_block}{_profile}{'_block'}{orderby};
   $self->{_block}{_profile}{$blockname}{useColHeaders} =
      $self->{_block}{_profile}{'_block'}{useColHeaders};
   $self->{_block}{_profile}{$blockname}{title} =
      $self->{_block}{_profile}{'_block'}{title};

   for(keys%{$self->{_block}{_profile}{'_block'}{pad}})
   {
      $self->{_block}{_profile}{$blockname}{pad}{$_} =
         $self->{_block}{_profile}{'_block'}{pad}{$_};
   }

   for my $col(keys%{$self->{_block}{_profile}{'_block'}{column}})
   {
      for my $t(keys%{$self->{_block}{_profile}{'_block'}{column}{$col}})
      {
         $self->{_block}{_profile}{$blockname}{column}{$col}{$t} =
            $self->{_block}{_profile}{'_block'}{column}{$col}{$t};
      }
   }

   $self;
}

sub _default_report
{
   my $self = shift;

   $self->{_page}{_profile}{(shift)} =
      {
         width     => 80, # Width of report in characters
         asis      => 0,  # Report.pm sets all block titles to caps & adds underline
         autoindex => 1,  # Let us do the indexing for you
      };
}

sub AUTOLOAD
{
   my $self = shift;
   my %profile;

   my $type = shift;

   if($type){$profile{$type} = 1;}

   my %this = @_;

   return if $AUTOLOAD =~ /::DESTROY$/;

   my $meth = $AUTOLOAD; $meth =~ s/.*://; # Just the method, not the pkg

   unless($meth =~ /^profile/){$self->_debug(3, "Bad method - $meth"); return(undef);}

   unless($Text::Report::stor_loaded)
   {
      $self->_debug(3, 'Cannot load module Storable; In order to use '.
            '"NamedPages", Storable.pm must be installed & in @INC');
      return(undef);
   }

   unless(defined $this{path}){$this{path} = '/tmp';}

   # --- Clean path --- #
   $this{path} =~ s|^(.*)/$|$1|;


   # --- Test path --- #
   unless(-e $this{path})
   {
      $self->_debug(3, "Cannot access profile storage area\; Path ".
            "($this{path}) does not exist");
      return(undef);
   }

   # my $sid = int(time);

   my $tmp = "$this{path}/stor.test.".int(time);

   # --- Test creat Rights --- #
   unless(open F, "+>$tmp")
   {
      $self->_debug(3, "Insufficient file creation rights in profile ".
            "storage area - Path ($this{path})");
      return(undef);
   }

   $self->_debug(1, "Created tmp file $tmp");

   close F;

   # --- Clean up --- #
   my @ret = grep{unlink} $tmp;

   $self->_debug(1, "Removed tmp file(s)".join(', ', @ret));


   # --- Test name --- #
   if($this{name})
   {
      # --- No spaces allowed --- #
      while($this{name} =~ s/\s+//g){};

      # --- No special chars --- #
      unless($this{name} =~ /^\w+$/ && $this{name} !~ /^$/)
      {
         $self->_debug(3, "No empty strings or special chars allowed in profile ".
               "name($this{name})\; Create a name that conforms to UNIX file ".
               "naming standards");
         return(undef);
      }
   }
   else
   {
      $self->_debug(2, "No profile name passed as \$obj->profile(\'load\', name => ".
            "\'myname\')\; Assigning default profile name \'default\'");

      $this{name} = 'default';
   }

   # $obj->profile('load', name => 'str');
   # $obj->profile('save', name => 'str');
   if($profile{load})
   {
      my $msg = "Cannot load stored profile ($this{name})";

      # --- Don't overwrite ourselves --- #
      # --- in case of failure        --- #
      my $temp;

      eval{$temp->{_block} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_block");};

      $self->_debug(4, "$msg\; $@"), return undef if $@;

      eval{$temp->{_page} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_page");};

      $self->_debug(4, "$msg\; $@"), return undef if $@;

      eval{$temp->{_order} = retrieve("$this{path}/stor.rpt\.$this{name}\.\_order");};

      $self->_debug(4, "$msg\; $@"), return undef if $@;

      $self->{_block} = $temp->{_block};
      $self->{_page} =  $temp->{_page};
      $self->{_order} =  $temp->{_order};

      return(1);
   }
   if($profile{save})
   {
      # stor.rpt.._block
      my $temp;

      $temp->{_block} = dclone($self->{_block});

      # --- Save just the skeleton --- #
      for(keys %{$temp->{_block}{_profile}})
      {
         delete $temp->{_block}{_profile}{$_}{data} unless /^\_/; # Save the separators
         delete $temp->{_block}{_profile}{$_}{_csv};
      }

      store($temp->{_block}, "$this{path}/stor.rpt\.$this{name}\.\_block");
      store($self->{_page}, "$this{path}/stor.rpt\.$this{name}\.\_page");
      store($self->{_order}, "$this{path}/stor.rpt\.$this{name}\.\_order");

      return(1);
   }

   return(undef);
}



__END__