#!/usr/bin/perl
#-------------------------------------------------------------------------------
# Write data in tabular text format
# Philip R Brenan at gmail dot com, Appa Apps Ltd, 2016
#-------------------------------------------------------------------------------

package Data::Table::Text;
use warnings FATAL => qw(all);
use strict;
use Carp;
use File::Path qw(make_path);
use File::Glob qw(:bsd_glob);
use POSIX qw(strftime);                                                         # http://www.cplusplus.com/reference/ctime/strftime/
use Data::Dump qw(dump);

#-------------------------------------------------------------------------------
# Current date and time
#-------------------------------------------------------------------------------

sub dateTimeStamp() {strftime('%Y-%m-%d at %H:%M:%S', localtime)}
sub dateStamp()     {strftime('%Y-%b-%d', localtime)}
sub timeStamp()     {strftime('%H:%M:%S', localtime)}

#-------------------------------------------------------------------------------
# Get the size of a file
#-------------------------------------------------------------------------------

sub fileSize($)
 {my ($file) = @_;
  (stat($file))[7]
 }

#-------------------------------------------------------------------------------
# Make a path
#-------------------------------------------------------------------------------

sub makePath($)
 {my ($path) = @_;
      $path =~ s/[\\\/]+\Z//;
  return 0 if -d $path;
  eval {make_path($path)};
  -d $path or confess "Cannot makePath $path";
  1
 }

#-------------------------------------------------------------------------------
# File list
#-------------------------------------------------------------------------------

sub fileList($)
 {my ($pattern) = @_;
  bsd_glob($pattern)
 }

#-------------------------------------------------------------------------------
# Read file
#-------------------------------------------------------------------------------

sub readFile($)
 {my ($file) = @_;
  my $f = $file;
  -e $f or confess "Cannot read file $f because it does not exist";
  open(my $F, "<:encoding(UTF-8)", $f) or confess "Cannot open $f for unicode input";
  local $/ = undef;
  my $s = eval {<$F>};
  $@ and confess $@;
  $s
 }

#-------------------------------------------------------------------------------
# Read binary file - a file whose contents are not to be interpreted as unicode
#-------------------------------------------------------------------------------

sub readBinaryFile($)
 {my ($file) = @_;
  my $f = $file;
  -e $f or confess "Cannot read binary file $f because it does not exist";
  open my $F, "<$f" or confess "Cannot open binary file $f for input";
  local $/ = undef;
  <$F>;
 }

#-------------------------------------------------------------------------------
# Write file
#-------------------------------------------------------------------------------

sub writeFile($$)
 {my ($file, $string) = @_;
  $file or confess "No file name supplied";
  $string or carp "No string for file $file";
  if ($file =~ /\A(.+[\\\/])/)
   {makePath($1);
   }
  open my $F, ">$file" or confess "Cannot open $file for write";
  binmode($F, ":utf8");
  print  {$F} $string;
  close  ($F);
  -e $file or confess "Failed to write to file $file";
 }

#-------------------------------------------------------------------------------
# Write binary file
#-------------------------------------------------------------------------------

sub writeBinaryFile($$)
 {my ($file, $string) = @_;
  $file or confess "No file name supplied";
  $string or confess "No string for file $file";
  if ($file =~ /\A(.+[\\\/])/)
   {makePath($1);
   }
  open my $F, ">$file" or confess "Cannot open $file for binary write";
  binmode($F);
  print  {$F} $string;
  close  ($F);
  -e $file or confess "Failed to write in binary to file $file";
 }

#-------------------------------------------------------------------------------
# Tabularize text - basic version
#-------------------------------------------------------------------------------

sub formatTableBasic($)
 {my ($data) = @_;
  my $d = $data;
  ref($d) =~ /array/i or confess "Array reference required";
  my @D;
  for   my $e(@$d)
   {ref($e) =~ /array/i or confess "Array reference required";
    for my $D(0..$#$e)
     {my $a = $D[$D]           // 0;                                            # Maximum length of data so far
      my $b = length($e->[$D]) // 0;                                            # Length of current item
      $D[$D] = ($a > $b ? $a : $b);                                             # Update maximum length
     }
   }

  my @t;                                                                        # Formatted data
  for   my $e(@$d)
   {my $t = '';                                                                 # Formatted text
    for my $D(0..$#$e)
     {my $m = $D[$D];                                                           # Maximum width
      my $i = $e->[$D]//'';                                                     # Current item
      if ($i !~ /\A\s*[-+]?\s*\d+(\.\d+)?([Ee]\s*[-+]?\s*\d+)?\s*\Z/)           # Not a number - left justify
       {$t .= substr($i.(' 'x$m), 0, $m)."  ";
       }
      else                                                                      # Number - right justify
       {$t .= substr((' 'x$m).$i, -$m)."  ";
       }
     }
    push @t, $t;
   }

  join "\n", @t
 }

#-------------------------------------------------------------------------------
# Tabularize text depending on structure
#-------------------------------------------------------------------------------

sub formatTableAA($)                                                            # Array of Arrays
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /array/i and @$data;
  my $d = [['', @{$data->[0]}]];                                                # Column headers are row 0
  push @$d, [$_, @{$data->[$_]}] for 1..$#$data;
  formatTableBasic($d);
 }

sub formatTableHA($)                                                            # Hash of Arrays
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /hash/i and keys %$data;
  my $d;                                                                        # Column headers are row 0
  push @$d, [$_, @{$data->{$_}}] for sort keys %$data;
  formatTableBasic($d);
 }

sub formatTableAH($)                                                            # Array of hashes
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /array/i and @$data;

  my %k; @k{keys %$_}++ for @$data;                                             # Column headers
  my @k = sort keys %k;
  $k{$k[$_-1]} = $_ for 1..@k;

  my $d = [['', @k]];
  for(1..@$data)
   {push @$d, [$_];
    my %h = %{$data->[$_-1]};
    $d->[-1][$k{$_}] = $h{$_} for keys %h;
   }
  formatTableBasic($d);
 }

sub formatTableHH($)                                                            # Hash of hashes
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /hash/i and keys %$data;

  my %k; @k{keys %$_}++ for values %$data;                                      # Column headers
  my @k = sort keys %k;
  $k{$k[$_-1]} = $_ for 1..@k;

  my $d = [['', @k]];
  for(sort keys %$data)
   {push @$d, [$_];
    my %h = %{$data->{$_}};
    $d->[-1][$k{$_}] = $h{$_} for keys %h;
   }
  formatTableBasic($d);
 }

sub formatTableA($)                                                             # Array with mixed elements
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /array/i and @$data;

  my $d;
  for(keys @$data)
   {push @$d, @$data > 1 ? [$_, $data->[$_]] : [$data->[$_]];                   # Skip line number if the array is degenerate
   }
  formatTableBasic($d);
 }

sub formatTableH($)                                                             # Hash with mixed elements
 {my ($data) = @_;
  return dump($data) unless ref($data) =~ /hash/i and keys %$data;

  my $d;
  for(sort keys %$data)
   {push @$d, [$_, $data->{$_}];
   }
  formatTableBasic($d);
 }

sub formatTable($)                                                              # Format various data structures
 {my ($data) = @_;
  my ($a, $h, $o) = (0, 0, 0);
  my $checkStructure = sub
   {for(@_)
     {my $r = ref($_[0]);
      if ($r =~ /array/i) {++$a} elsif ($r =~ /hash/i) {++$h} else {++$o}
     }
   };
  if    (ref($data) =~ /array/i)
   {$checkStructure->(       @$data);
    return formatTableAA($data) if  $a and !$h and !$o;
    return formatTableAH($data) if !$a and  $h and !$o;
    return formatTableA ($data);
   }
  elsif (ref($data) =~ /hash/i)
   {$checkStructure->(values %$data);
    return formatTableHA($data) if  $a and !$h and !$o;
    return formatTableHH($data) if !$a and  $h and !$o;
    return formatTableH ($data);
   }
 }

#-------------------------------------------------------------------------------
# Indent lines contained in a string by the specified amount
#-------------------------------------------------------------------------------

sub indentString($$)
 {my ($string, $indent) = @_;                                                   # The string of lines to indent, the indenting string
  join "\n", map {$indent.$_} split "\n", $string
 }

#-------------------------------------------------------------------------------
# Load an array from lines of text in a striung
#-------------------------------------------------------------------------------

sub loadArrayFromLines($)
 {my ($string) = @_;                                                            # The string of lines from which to create an array
  [split "\n", $string]
 }

#-------------------------------------------------------------------------------
# Load a hash: first word of each line is the key and the rest is the value
#-------------------------------------------------------------------------------

sub loadHashFromLines($)
 {my ($string) = @_;                                                            # The string of lines from which to create a hash
  +{map{split /\s+/, $_, 2} split "\n", $string}
 }

#-------------------------------------------------------------------------------
# Load an array of arrays from lines of text: each line is an array of words
#-------------------------------------------------------------------------------

sub loadArrayArrayFromLines($)
 {my ($string) = @_;                                                            # The string of lines from which to create an array of arrays
  [map{[split /\s+/]} split "\n", $string]
 }

#-------------------------------------------------------------------------------
# Load a hash of arrays from lines of text: the first word of each line
# is the key, the remaining words are the array contents
#-------------------------------------------------------------------------------

sub loadHashArrayFromLines($)
 {my ($string) = @_;                                                            # The string of lines from which to create a hash of arrays
  +{map{my @a = split /\s+/; (shift @a, [@a])} split "\n", $string}
 }

#-------------------------------------------------------------------------------
# Normalize white space
#-------------------------------------------------------------------------------

sub normalizeWhiteSpace($)
 {my ($string) = @_;                                                            # The string in which to normalize the whitespace
  $string =~ s/\s+/ /gr =~ s/\A\s+//r =~ s/\s+\Z//r
 }

#-------------------------------------------------------------------------------
# Check the keys in a hash
#-------------------------------------------------------------------------------

sub checkKeys($$)
 {my ($test, $permitted) = @_;                                                  # The hash to test, the permitted keys and their meanings
  my %parms = %$test;
  delete @parms{$_} for keys %$permitted;
  return '' unless keys %parms;                                                 # Success - all the keys in the test hash are permitted

  join "\n",                                                                    # Failure - explain what went wrong
   "Invalid options chosen:",
    indentString(formatTable([sort keys %parms]), '  '),
   "",
   "Permitted options are:",
    indentString(formatTable($permitted),         '  ');
 }

#-------------------------------------------------------------------------------
# Examples
#-------------------------------------------------------------------------------

if (0)
 {say STDERR "\n","\nsay STDERR formatTable(",dump($_), ");\n# ", formatTable($_) =~ s/\n/\n# /gr for
[[qw(. aa bb cc)], [qw(1 A B C)], [qw(2 AA BB CC)], [qw(3 AAA BBB CCC)],  [qw(4 1 22 333)]],
[{aa=>'A', bb=>'B', cc=>'C'}, {aa=>'AA', bb=>'BB', cc=>'CC'}, {aa=>'AAA', bb=>'BBB', cc=>'CCC'}, {aa=>'1', bb=>'22', cc=>'333'}],
{''=>[qw(aa bb cc)], 1=>[qw(A B C)], 22=>[qw(AA BB CC)], 333=>[qw(AAA BBB CCC)],  4444=>[qw(1 22 333)]},
{a=>{aa=>'A', bb=>'B', cc=>'C'}, aa=>{aa=>'AA', bb=>'BB', cc=>'CC'}, aaa=>{aa=>'AAA', bb=>'BBB', cc=>'CCC'}, aaaa=>{aa=>'1', bb=>'22', cc=>'333'}},
[qw(a bb ccc 4444)],
{aa=>'A', bb=>'B', cc=>'C'};
 }

#-------------------------------------------------------------------------------
# Test
#-------------------------------------------------------------------------------

eval join('', <Data::Table::Text::DATA>) || die $@ unless caller();

#say STDERR formatTable(\%Data::Table::Text::);

#-------------------------------------------------------------------------------
# Export
#-------------------------------------------------------------------------------

require 5;
require Exporter;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);

@ISA          = qw(Exporter);
@EXPORT       = qw(formatTable);
@EXPORT_OK    = qw(checkKeys dateStamp dateTimeStamp fileList fileSize
indentString
loadArrayArrayFromLines loadArrayFromLines  loadHashArrayFromLines loadHashFromLines
makePath normalizeWhiteSpace
readBinaryFile readFile timeStamp writeBinaryFile writeFile);
%EXPORT_TAGS  = (all=>[@EXPORT_OK]);

$VERSION = '1.004'; # Wednesday 14 December 2016

1;

=encoding utf-8

=head1 Name

Data::Table::Text - Write data in tabular text format

=head1 Synopsis

 use Data::Table::Text;

 say STDERR formatTable([
   [".", "aa", "bb", "cc"],
   [1, "A", "B", "C"],
   [2, "AA", "BB", "CC"],
   [3, "AAA", "BBB", "CCC"],
   [4, 1, 22, 333],
 ]);
 #    .  aa   bb   cc
 # 1  1  A    B    C
 # 2  2  AA   BB   CC
 # 3  3  AAA  BBB  CCC
 # 4  4    1   22  333

 say STDERR formatTable([
   { aa => "A", bb => "B", cc => "C" },
   { aa => "AA", bb => "BB", cc => "CC" },
   { aa => "AAA", bb => "BBB", cc => "CCC" },
   { aa => 1, bb => 22, cc => 333 },
 ]);
 #    aa   bb   cc
 # 1  A    B    C
 # 2  AA   BB   CC
 # 3  AAA  BBB  CCC
 # 4    1   22  333

 say STDERR formatTable({
   "" => ["aa", "bb", "cc"],
   "1" => ["A", "B", "C"],
   "22" => ["AA", "BB", "CC"],
   "333" => ["AAA", "BBB", "CCC"],
   "4444" => [1, 22, 333],
 });
 #       aa   bb   cc
 #    1  A    B    C
 #   22  AA   BB   CC
 #  333  AAA  BBB  CCC
 # 4444    1   22  333

 say STDERR formatTable({
   a => { aa => "A", bb => "B", cc => "C" },
   aa => { aa => "AA", bb => "BB", cc => "CC" },
   aaa => { aa => "AAA", bb => "BBB", cc => "CCC" },
   aaaa => { aa => 1, bb => 22, cc => 333 },
 });
 #       aa   bb   cc
 # a     A    B    C
 # aa    AA   BB   CC
 # aaa   AAA  BBB  CCC
 # aaaa    1   22  333

 say STDERR formatTable(["a", "bb", "ccc", 4444]);
 # 0  a
 # 1  bb
 # 2  ccc
 # 3  4444

 say STDERR formatTable({ aa => "A", bb => "B", cc => "C" });
 # aa  A
 # bb  B
 # cc  C

=head1 Description

 Prints an array or a hash or an array of arrays or an array of hashes or a
 hash of arrays or a hash of hashes in a tabular format that is easier to read
 than a raw data dump.

=head1 Installation

Standard Module::Build process for building and installing modules:

  perl Build.PL
  ./Build
  ./Build test
  ./Build install

=head1 Author

philiprbrenan@gmail.com

http://www.appaapps.com

=head1 Copyright

Copyright (c) 2016 Philip R Brenan.

This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.

=cut

__DATA__
use Test::More tests => 24;
if (1)                                                                          # Unicode
 {use utf8;
  my $z = "𝝰𝝱𝝲";
  my $f = "$z/$z.data";
  unlink $f if -e $f;
  ok !-e $f;
  writeFile($f, $z);
  ok  -e $f;
  my $s = readFile($f);
  ok $s eq $z;
  ok length($s) == 3;
  unlink $f;
  ok !-e $f;
  print STDERR qx(rmdir $z);
  ok !-d $z;
 }
if (1)                                                                          # Binary
 {my $z = "𝝰𝝱𝝲";
  my $f = "$z/$z.data";
  unlink $f if -e $f;
  ok !-e $f;
  writeBinaryFile($f, $z);
  ok  -e $f;
  my $s = readBinaryFile($f);
  ok $s eq $z;
  ok length($s) == 12;
  unlink $f;
  ok !-e $f;
  print STDERR qx(rmdir $z);
  ok !-d $z;
 }
if (1)                                                                          # Format table and AA
 {my $d = [[qw(. aa bb cc)], [qw(1 A B C)], [qw(2 AA BB CC)], [qw(3 AAA BBB CCC)],  [qw(4 1 22 333)]];
  ok formatTableBasic($d) =~ s/\n/ /gr eq '.  aa   bb   cc    1  A    B    C     2  AA   BB   CC    3  AAA  BBB  CCC   4    1   22  333  ';
  ok formatTable     ($d) =~ s/\n/ /gr eq '   .  aa   bb   cc    1  1  A    B    C     2  2  AA   BB   CC    3  3  AAA  BBB  CCC   4  4    1   22  333  ';
 }
if (1)                                                                          # AH
 {my $d = [{aa=>'A', bb=>'B', cc=>'C'}, {aa=>'AA', bb=>'BB', cc=>'CC'}, {aa=>'AAA', bb=>'BBB', cc=>'CCC'}, {aa=>'1', bb=>'22', cc=>'333'}];
  ok formatTable     ($d) =~ s/\n/ /gr eq '   aa   bb   cc    1  A    B    C     2  AA   BB   CC    3  AAA  BBB  CCC   4    1   22  333  ';
 }
if (1)                                                                          # HA
 {my $d = {''=>[qw(aa bb cc)], 1=>[qw(A B C)], 22=>[qw(AA BB CC)], 333=>[qw(AAA BBB CCC)],  4444=>[qw(1 22 333)]};
  ok formatTable     ($d) =~ s/\n/ /gr eq '      aa   bb   cc       1  A    B    C       22  AA   BB   CC     333  AAA  BBB  CCC   4444    1   22  333  ';
 }
if (1)                                                                          # HH
 {my $d = {a=>{aa=>'A', bb=>'B', cc=>'C'}, aa=>{aa=>'AA', bb=>'BB', cc=>'CC'}, aaa=>{aa=>'AAA', bb=>'BBB', cc=>'CCC'}, aaaa=>{aa=>'1', bb=>'22', cc=>'333'}};
  ok formatTable     ($d) =~ s/\n/ /gr eq '      aa   bb   cc    a     A    B    C     aa    AA   BB   CC    aaa   AAA  BBB  CCC   aaaa    1   22  333  ';
 }
if (1)                                                                          # A
 {my $d = [qw(a bb ccc 4444)];
  ok formatTable     ($d) =~ s/\n/ /gr eq '0  a      1  bb     2  ccc    3  4444  ';
 }
if (1)                                                                          # H
 {my $d = {aa=>'A', bb=>'B', cc=>'C'};
  ok formatTable     ($d) =~ s/\n/ /gr eq 'aa  A   bb  B   cc  C  ';
 }

if (1)                                                                          # H
 {my $s = normalizeWhiteSpace
    checkKeys({qw(go 1 Went 2 gone 3)},
              {qw(go present went past gone presentPast)});
  my $S = normalizeWhiteSpace <<END;
Invalid options chosen:
  Went
Permitted options are:
  go    present
  gone  presentPast
  went  past
END
  ok $s eq $S;
 }

if (1)                                                                          # AL
 {my $s = loadArrayFromLines <<END;
a a
b b
END
  ok dump($s) eq '["a a", "b b"]';
 }

if (1)                                                                          # HL
 {my $s = loadHashFromLines <<END;
a 10 11 12
b 20 21 22
END
  ok dump($s) eq '{ a => "10 11 12", b => "20 21 22" }';
 }

if (1)                                                                          # AAL
 {my $s = loadArrayArrayFromLines <<END;
A B C
AA BB CC
END
  ok dump($s) eq '[["A", "B", "C"], ["AA", "BB", "CC"]]';
 }

if (1)                                                                          # HAL
 {my $s = loadHashArrayFromLines <<END;
a A B C
b AA BB CC
END
  ok dump($s) eq '{ a => ["A", "B", "C"], b => ["AA", "BB", "CC"] }';
 }
