The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# field attribute testing

use Test::More tests => 3;
use strict;
use HTML::Tabulate qw(render);
use Data::Dumper;
use FindBin qw($Bin);

# Load result strings
my %result = ();
my $test = "$Bin/t6";
die "missing data dir $test" unless -d $test;
opendir my $datadir, $test or die "can't open directory $test";
for (readdir $datadir) {
  next if m/^\./;
  open my $fh, "<$test/$_" or die "can't read $test/$_";
  { 
    local $/ = undef;
    $result{$_} = <$fh>;
  }
  close $fh;
}
close $datadir;

my $print = shift @ARGV || 0;
my $n = 1;
sub report {
  my ($data, $file, $inc) = @_;
  $inc ||= 1;
  if ($print == $n) {
    print STDERR "--> $file\n";
    print $data;
    exit 0;
  }
  $n += $inc;
}

# Procedural render
my $data = [ [ '123', 'Fred Flintstone', 'CEO', '19710430', ], 
             [ '456', 'Barney Rubble', 'Lackey', '19751212', ] ];
my $table = render($data, {
  fields => [ qw(emp_id emp_name emp_title dob emp_fname emp_surname) ],
  labels => {
    emp_name => 'Fullname',
    emp_title => 'Title',
  },
  field_attr => {
    -defaults => { 
      align => 'left',
    },
    emp_id => {
      format => '%07d',
      link => "emp.html?id=%s&src=a b c",
      label_link => "http://www.openfusion.com.au/t/this.html?order=emp_id desc",
      align => 'center',
    },
    emp_name => {
      format => sub { uc(shift) },
    },
    dob => {
      format => sub { my $x = shift; sprintf "%02d/%02d/%02d", 
        substr($x,6,2), substr($x,4,2), substr($x,0,4) },
      label => 'Date Of Birth',
    },
    emp_fname => {
      value => sub { 
        my ($x,$rec) = @_; 
        my $name = $rec->[1]; 
        $name =~ s/\s+\S+\s*$//;
        $name
      },
      label => 'First Names',
    },
    emp_surname => {
      value => sub { 
        my ($x,$rec) = @_; 
        my $name = $rec->[1]; 
        $name =~ s/^.*?(\S+)\s*$/$1/;
        $name
      },
      format => sub { uc(shift) },
    },
  },
});
report $table, "render1";
is($table, $result{render1}, "render1 result ok");


# Regex field attributes
my $t = HTML::Tabulate->new({
  field_attr => {
    -defaults => {
      align => 'center',
    },
    # Timestamps
    qr/_ts$/i => {
      format => sub { $_ = shift; s/^\s*(\d{4})(\d{2})(\d{2}).*$/$1-$2-$3/; $_ },
      label => sub { 
        $_ = shift; 
        s/^[^_]+_//; 
        s/_[^_]+$/ed/; 
        s/eed$/ed/;
        s/yed$/ied/;
        ucfirst $_ 
      },
      class => 'timestamp',
    },
    # UIDs
    qr/_uid$/i => {
      format => "U%05d",
      label => sub { $_ = shift; s/_([^_]+)$/ \U$1/; s/^.*_(\w+)/\u$1/; $_ },
      class => 'uid',
    },
  },
});
$data = [
  { prod_id => 12345, prod_name => 'Foo', 
    prod_create_uid => 3, prod_create_ts => '20031015114902', },
];
$table = $t->render($data, {
  fields => [ qw(prod_id prod_name prod_create_uid prod_create_ts) ],
  labels => 1,
  field_attr => {
    prod_create_ts => {
      class => 'prod_create_ts',
    },
  },
});
report $table, "render2";
is($table, $result{render2}, "render2 result ok");


# Test merge order
$t = HTML::Tabulate->new({
  field_attr => {
    -defaults => { class => 'default' },
    qr/create/ => { class => 'create' },
    prod_create_ts => { class => 'prod_create_ts' },
  },
});
$table = $t->render($data, {
  fields => [ qw(prod_id prod_name prod_create_uid prod_create_ts) ],
  labels => 1,
});
report $table, "render3";
is($table, $result{render3}, "render3 result ok");