# Table.pm: Class Used for Table Structures

package RDA::Object::Table;

# $Id: Table.pm,v 1.7 2014/04/16 20:16:46 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Object/Table.pm,v 1.7 2014/04/16 20:16:46 RDA Exp $
#
# Change History
# 20140416  MSC  Improve the documentation.

=head1 NAME

RDA::Object::Table - Class Used for Table Structures

=head1 SYNOPSIS

 require RDA::Object::Table;

=head1 DESCRIPTION

The objects of the C<RDA::Object::Table> class are used for storing table
structures. It is a subclass of L<RDA::Object|RDA::Object>.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
  use RDA::Object;
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA %SDCL);
$VERSION = sprintf('%d.%02d', q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(RDA::Object Exporter);
%SDCL    = (
  inc => [qw(RDA::Object)],
  met => {
    'add_column'  => {ret => 0},
    'add_row'     => {ret => 0},
    'add_uid'     => {ret => 0},
    'get_columns' => {ret => 1},
    'get_keys'    => {ret => 1},
    'get_offset'  => {ret => 0},
    'merge'       => {ret => 0},
    'set_type'    => {ret => 0},
    'write'       => {ret => 0},
    },
  new => 1,
  );

# Define the global private constants

# Define the global private variables
my @tb_mon = qw(??? Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
my %tb_dec = (
  NUM => \&decode_number,
  STR => \&decode_string,
  TSP => \&decode_timestamp,
  );
my %tb_enc = (
  FMT => \&encode_string,
  NUM => \&encode_number,
  STR => \&encode_string,
  TSP => \&encode_timestamp,
  );
my %tb_mon = (
  JAN => '01',
  FEB => '02',
  MAN => '03',
  APR => '04',
  MAY => '05',
  JUN => '06',
  JUL => '07',
  AUG => '08',
  SEP => '09',
  OCT => '10',
  NOV => '11',
  DEC => '12',
  );
my %tb_srt = (
  FMT => 'S',
  NUM => 'N',
  STR => 'S',
  TSP => 'S',
  );
my %tb_ttl = (
  FMT => \&title_string,
  NUM => \&title_number,
  STR => \&title_string,
  TSP => \&title_string,
  );

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<$h = RDA::Object::Table-E<gt>new($nam[,$def])>

The object constructor. You can provide the table name and the column
definition as arguments.

C<RDA::Object::Table> is represented by a blessed hash reference. The following
special keys are used:

=over 12

=item S<    B<'oid'>  > Table name

=item S<    B<'-dim'> > Number of columns

=item S<    B<'-dat'> > Data rows

=item S<    B<'-fmt'> > Column formats

=item S<    B<'-hdr'> > Column names

=item S<    B<'-idx'> > Unique identifier index

=item S<    B<'-typ'> > Column types

=item S<    B<'-uid'> > Unique identifier definition

=back

Internal keys are prefixed by a dash.

=cut

sub new
{ my ($cls, $nam, $def) = @_;
  my ($hdr, $slf);

  # Create the table object
  $slf = bless {
    oid  => $nam,
    -dim => 0,
    -dat => [],
    -fmt => [],
    -hdr => [],
    -typ => [],
    }, ref($cls) || $cls;

  # Initialize the table
  if (defined($def))
  { $def = [split(/,\s*|\s+/, $def)] unless ref($def) eq 'ARRAY';
    foreach my $itm (@{$def})
    { $hdr = _check_name($itm);
      push(@{$slf->{'-fmt'}}, undef);
      push(@{$slf->{'-hdr'}}, $hdr);
      push(@{$slf->{'-typ'}}, defined($hdr) ? 'STR' : 'NUL');
      ++$slf->{'-dim'};
    }
  }

  # Return the object reference
  return $slf;
}

sub _check_name
{ my ($nam) = @_;

  return (defined($nam) && !ref($nam) && length($nam)) ? $nam : undef;
}

=head2 S<$h-E<gt>add_column($name[,$pos[,$fmt[,off,...]]])>

This method adds a column in the table. You can indicate the position where it
must insert the column. It appends after the last column when the position is
an undefined value.

=cut

sub add_column
{ my ($slf, $nam, $pos, $fmt, @arg) = @_;
  my ($dim, $val, @fmt, @off, @tbl);

  # Validate the arguments
  $dim = $slf->{'-dim'};
  $fmt = q{} unless defined($fmt);
  $pos = defined($pos) ? _norm_offset($slf, $pos) : $dim;
  foreach my $off (@arg)
  { $off = _norm_offset($slf, $off);
    push(@off, $off);
    ++$off unless $off < $pos;  ## no critic (Unless)
    push(@fmt, $off);
  }

  # Adjust the unique identifier definition
  ++$slf->{'-uid'} if exists($slf->{'-uid'}) && $slf->{'-uid'} >= $pos;

  # Adjust the existing formats
  foreach my $rec (@{$slf->{'-fmt'}})
  { next unless ref($rec);
    for (my $off = @{$rec} ; --$off > 0 ;)        ## no critic (Loop)
    { ++$rec->[$off] unless $rec->[$off] < $pos;  ## no critic (Unless)
    }
  }

  # Define the new column
  $nam = _check_name($nam);
  splice(@{$slf->{'-fmt'}}, $pos, 0, [$fmt, @fmt]);
  splice(@{$slf->{'-hdr'}}, $pos, 0, $nam);
  splice(@{$slf->{'-typ'}}, $pos, 0, defined($nam) ? 'FMT' : 'NUL');
  ++$slf->{'-dim'};

  # Adjust current records
  foreach my $rec (@{$slf->{'-dat'}})
  { @tbl = ();
    foreach my $off (@off)
    { push(@tbl, defined($val = $rec->[$off]) ? $val : q{});
    }
    splice(@{$rec}, $pos, 0, sprintf($fmt, @tbl));
  }

  # Indicate the successful completion
  return 1;
}

=head2 S<$h-E<gt>add_row($data)>

This method adds a row in the table.

=cut

sub add_row
{ my ($slf, $dat) = @_;
  my ($dim, $fmt, $off, $rec, $typ, $val, @tbl);

  push(@{$slf->{'-dat'}}, $rec = []);

  # Add data fields
  $dim = $slf->{'-dim'};
  if (ref($dat) eq 'ARRAY')
  { @tbl = @{$dat};
    for ($off = 0 ; $off < $dim ; ++$off)  ## no critic (Loop)
    { $typ = $slf->{'-typ'}->[$off];
      $rec->[$off] = (exists($tb_dec{$typ}) && defined($val = shift(@tbl)))
        ? &{$tb_dec{$typ}}($val)
        : undef;
    }
  }
  else
  { for ($off = 0 ; $off < $dim ; ++$off)  ## no critic (Loop)
    { $typ = $slf->{'-typ'}->[$off];
      $rec->[$off] =
        (!exists($tb_dec{$typ}))
          ? undef :
        ($dat =~ s/^"([^"]*)"(,\s*)?// || $dat =~ s/^([^\,]*)(,\s*|\z)//)
          ? &{$tb_dec{$typ}}($1) : undef;
    }
  }

  # Add format fields
  for ($off = 0 ; $off < $dim ; ++$off)  ## no critic (Loop)
  { next unless ref($fmt = $slf->{'-fmt'}->[$off]);
    ($fmt, @tbl) = @{$fmt};
    $rec->[$off] =
      sprintf($fmt, map{defined($val = $rec->[$_]) ? $val : q{}} @tbl);
  }

  # Index it when needed
  $slf->{'-idx'}->{$val} = $rec
    if exists($slf->{'-uid'}) && defined($val = $rec->[$slf->{'-uid'}]);
  return 1;
}

=head2 S<$h-E<gt>add_uid($off)>

This method defines an unique identifier on a table.

=cut

sub add_uid
{ my ($slf, $off) = @_;
  my ($idx, $val);

  # Normalize the offset
  return 0
    unless exists($tb_enc{$slf->{'-typ'}->[$off = _norm_offset($slf, $off)]});

  # Create the index
  $slf->{'-idx'} = $idx = {};
  $slf->{'-uid'} = $off;
  foreach my $rec (@{$slf->{'-dat'}})
  { $idx->{$val} = $rec if defined($val = $rec->[$off]);
  }
  return 1;
}

=head2 S<$h-E<gt>dump([$level[,$text[,$trace]]])>

This method dumps the table description. You can provide an indentation level,
a prefix text, and a trace indicator as extra parameters.

=cut

sub dump  ## no critic (Builtin)
{ my ($slf, $lvl, $txt) = @_;
  my ($buf, $off, $pre);

  $lvl = 0 unless defined($lvl);
  $txt = q{} unless defined($txt);

  $pre = q{  } x $lvl;
  $buf = $pre.$txt.q{Table }.$slf->{'oid'}.qq{\n};
  $buf .= $pre.q{- #Columns: }.$slf->{'-dim'}.qq{\n};
  $buf .= $pre.qq{- Active Columns:\n};
  for ($off = 0 ; $off < $slf->{'-dim'} ; ++ $off)  ## no critic (Loop)
  { $buf .= $pre.q{  }.$slf->{'-hdr'}->[$off].q{(}.$slf->{'-typ'}->[$off].")\n"
      if defined($slf->{'-hdr'}->[$off]);
  }
  $buf .= $pre.q{- #Rows: }.(scalar @{$slf->{'-dat'}}).qq{\n};
  return $buf;
}

=head2 S<$h-E<gt>get_columns>

This method returns the list of columns names.

=cut

sub get_columns
{ my ($slf) = @_;

  return (grep {defined($_)} @{$slf->{'-hdr'}});
}

=head2 S<$h-E<gt>get_keys($off)>

This method returns the list of distinct values present in a column.

=cut

sub get_keys
{ my ($slf, $off) = @_;
  my ($val, %tbl);

  if (exists($tb_enc{$slf->{'-typ'}->[$off = _norm_offset($slf, $off)]}))
  { foreach my $rec (@{$slf->{'-dat'}})
    { $tbl{$val} = 1 if defined($val = $rec->[$off]);
    }
  }
  return keys(%tbl);
}

=head2 S<$h-E<gt>get_offset($nam)>

This method returns the offset of the specified column name. It returns an
undefined value if it does not find the column.

=cut

sub get_offset
{ my ($slf, $nam) = @_;
  my ($hdr, $off);

  for ($off = 0 ; $off < $slf->{'-dim'} ; ++$off)  ## no critic (Loop)
  { return $off if defined($hdr = $slf->{'-hdr'}->[$off]) && $nam eq $hdr;
  }
  return;
}

=head2 S<$h-E<gt>merge($src,$off,$dst1,$src1,...)>

This method merges source table fields inside the table records. It makes a join
between the specified column and the source table unique identifier.

=cut

sub merge
{ my ($dst, $src, $off, @arg) = @_;
  ## no critic (Numbered)
  my ($idx, $off1, $off2, $ref, $val, @xfr);

  die get_string('BAD_SOURCE') unless ref($src) eq ref($dst);

  # Normalize the offsets
  return 0
    unless exists($tb_enc{$dst->{'-typ'}->[$off = _norm_offset($dst, $off)]});
  while (($off1, $off2) = splice(@arg, 0, 2))
  { push(@xfr, [_norm_offset($dst, $off1), _norm_offset($src, $off2)]);
  }

  # Merge the record
  $idx = $src->{'-idx'};
  foreach my $rec (@{$dst->{'-dat'}})
  { next unless defined($val = $rec->[$off]) && exists($idx->{$val});
    $ref = $idx->{$val};
    foreach my $xfr (@xfr)
    { $rec->[$xfr->[0]] = $ref->[$xfr->[1]];
    }
  }
  return 1;
}

=head2 S<$h-E<gt>set_type($typ,$off,...)>

This method modifies the type of the specified columns. Invalid columns are
discarded. It supports the following types:

=over 9

=item B<    NUM > Numeric value

=item B<    STR > String

=item B<    TSP > Time stamp

=back

It returns the number of modified columns.

=cut

sub set_type
{ my ($slf, $typ, @arg) = @_;
  my ($cnt);

  $cnt = 0;
  if (exists($tb_dec{$typ}))
  { foreach my $off (@arg)
    { eval {
        $slf->{'-typ'}->[_norm_offset($slf, $off)] = $typ;
        ++$cnt;
      };
    }
  }
  return $cnt;
}

=head2 S<$h-E<gt>write($rpt,$srt)>

This method writes the table content in the specified report. It returns the
number of written rows.

=cut

sub write  ## no critic (Builtin)
{ my ($slf, $rpt, $srt) = @_;
  my ($cnt, $dat, $off, $typ, @tbl);

  $cnt = 0;
  if ($rpt)
  { # Sort the record
    if (defined($srt))
    { $srt = [split(/,/, $srt)] unless ref($srt);
      foreach my $off (@{$srt})
      { $typ = ($off =~ s{/([AD])$}{}) ? $1 : 'A';
        $off = _norm_offset($slf, $off);
        next unless exists($tb_srt{$slf->{'-typ'}->[$off]});
        push(@tbl, [$tb_srt{$slf->{'-typ'}->[$off]}.$typ, $off]);
      }
      $dat = [sort {  ## no critic (Reverse,Simple)
        foreach my $stp (@tbl)
        { my ($cmp, $col, $val);

          ($cmp, $col) = @{$stp};
          $val = ($cmp eq 'SA') ? $a->[$col] cmp $b->[$col] :
                 ($cmp eq 'NA') ? $a->[$col] <=> $b->[$col] :
                 ($cmp eq 'SD') ? $b->[$col] cmp $a->[$col] :
                 ($cmp eq 'ND') ? $b->[$col] <=> $a->[$col] :
                 0;
          return $val if $val;
        }
        0;
        } @{$slf->{'-dat'}}];
    }
    else
    { $dat = $slf->{'-dat'};
    }

    # Write the table content
    foreach my $rec (@{$dat})
    { # Write the header of the first row
      unless ($cnt)
      { @tbl = ();
        for ($off = 0 ; $off < $slf->{'-dim'} ; ++$off) ## no critic (Loop)
        { $typ = $slf->{'-typ'}->[$off];
          push(@tbl, &{$tb_ttl{$typ}}($slf->{'-hdr'}->[$off]))
            if exists($tb_enc{$typ});
        }
        $rpt->write(join(q{|}, q{}, @tbl, qq{\n}));
      }

      # Write the row
      @tbl = ();
      for ($off = 0 ; $off < $slf->{'-dim'} ; ++$off)  ## no critic (Loop)
      { $typ = $slf->{'-typ'}->[$off];
        push(@tbl, &{$tb_enc{$typ}}($rec->[$off]))
          if exists($tb_enc{$typ});
      }
      $rpt->write(join(q{|}, q{}, @tbl, qq{\n}));
      ++$cnt;
    }
  }
  return $cnt;
}

# --- Conversion routines -----------------------------------------------------

# Decode a number
sub decode_number
{ return shift;
}

# Decode a string
sub decode_string
{ return shift;
}

# Decode a time stamp
sub decode_timestamp
{ my ($str) = @_;

  return
    (!defined($str) || !length($str))                    ? undef :
    ($str =~ m{^(\d{2})-(\d{2})-(\d{4})\s*(.*)$})        ? $3.$1.$2.$4 :
    ($str =~ m{^(\d{2})/(\d{2})/(\d{4})\s*(.*)$})        ? $3.$1.$2.$4 :
    ($str =~ m{^(\d{2})-([A-Za-z]{3,})-(\d{4})\s*(.*$)}) ? $1._month($2).$3.$4 :
                                                           qq{00000000$str};
}

# Encode a number
sub encode_number
{ my ($str) = @_;

  return defined($str) ? " $str" : q{ };
}

# Encode a string
sub encode_string
{ my ($str) = @_;

  return q{ } unless defined($str) && length($str);
  $str =~ s/\|/&#124;/g;
  return $str;
}

# Encode a time stamp
sub encode_timestamp
{ my ($str) = @_;

  return
    !defined($str)         ? q{ } :
    ($str =~ m/^00000000/) ? substr($str,8) :
                             substr($str,6,2).q{-}.
                             $tb_mon[substr($str,4,2)].q{-}
                             .substr($str,0,4).q{ }.substr($str,8);
}

# Get the month as a number
sub _month
{ my ($str) = @_;

  $str = uc(substr($str, 0, 3));
  return exists($tb_mon{$str}) ? $tb_mon{$str} : '00';
}

# Normalize the column offset
sub _norm_offset
{ my ($slf, $off) = @_;

  die get_string('NO_OFFSET') unless defined($off);

  # Resolve column name
  unless ($off =~ m/^\d+$/)
  { my ($hdr, $pos);

    for ($pos = 0 ; $pos < $slf->{'-dim'} ; ++$pos)  ## no critic (Loop)
    { return $pos if defined($hdr = $slf->{'-hdr'}->[$pos]) && $off eq $hdr;
    }
    die get_string('BAD_COLUMN', $off);
  }

  # Validate the offset
  $off += $slf->{'-dim'} if $off < 0;
  die get_string('BAD_OFFSET', $off)
    unless $off >= 0 && $off < $slf->{'-dim'};  ## no critic (Unless)
  return $off;
}

# Generate a title for a number
sub title_number
{ my ($str) = @_;

  $str = lc($str);
  $str =~ s{\b([a-z])}{\U$1}g;
  $str =~ s{_([a-z])}{ \U$1}g;
  $str =~ s{(\d)([a-z])}{$1 \U$2}g;
  return qq{ *$str*};
}

# Generate a title for a string
sub title_string
{ my ($str) = @_;

  $str = lc($str);
  $str =~ s{\b([a-z])}{\U$1}g;
  $str =~ s{_([a-z])}{ \U$1}g;
  $str =~ s{(\d)([a-z])}{$1 \U$2}g;
  return qq{*$str*};
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object|RDA::Object>,
L<RDA::SDCL::Block|RDA::SDCL::Block>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut