#!/usr/bin/perl -w
# Freetable html tables generator
# Copyright (c) 1999, 2000, 2001 Tomasz Wegrzanowski <taw@users.sourceforge.net>
#
# Freetable is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# Thanks to Denis Barbier <barbier@imacs.polytechnique.fr> for contribution
#
# On Debian GNU/Linux systems, the complete text of the GNU General
# Public License can be found in `/usr/share/common-licenses/GPL'.

$version = '2.3';

$warning =
'<!-- WARNING: The following table was produced by freetable.               -->
<!--          Unless know what you are doing, you should not edit it here,  -->
<!--          but edit sources and then run freetable to rebuild this table -->

';

$help = 
'Usage: freetable [options] filename

Options:
  -h, --help             Print this message
  -V, --version          Just print version information and exit
  -c, --comment          Do comment before every cell to point its location
  -b, --no-nbsp          Do not insert &nbsp; to empty cells to make lowered
                         3D apperance
  -w, --warning          Print a warning before each generated table that you
                         should not change generated file, but source.
  -l, --location         Location tags substitution
  -m, --macro [program]  Use macro processor for cells content (default: m4)
';

use Getopt::Long;
$Getopt::Long::bundling=1;
my (@opts) = ("b|no-nbsp","c|comment","w|warning","h|help","V|version","m|macro:s","l|location");
$opt_h=$opt_V=$opt_b=$opt_c=$opt_w=$opt_m=$opt_l=0;
GetOptions(@opts);
if ($opt_m eq "") { $opt_m = 'm4' }
if ($opt_h) { print $help; exit 0 }
if ($opt_V) { print "Freetable $version\n"; exit 0 }
$defaultcell = ($opt_b)?'':'&nbsp;';
($min_row,$min_col) = (1,1);
$tablewarn   = ($opt_w)?$warning:'';

while (<>)  { if ( /<wwwtable(.*)>/i ) { table_parse($1,0) } else { print } }

sub table_parse {
    my ( $table_open_data, $level ) = @_;
    my ( $table_close_data, $table_started ) = ( '', 0 );
    my ( %cell,%entry );
    my @Seq_data = (1,1,1,1); # max_row, max_col, cur_row, cur_col

    while (<>) {
	if ( /<wwwtable(.*)>/i )
	    { table_entry_content_append_block (\%entry,table_parse($1, $level+1)); }
        elsif ( /<\/wwwtable(.*)>/i )
	    { $table_close_data = $1; last }
	elsif ( /^\s*\(\(\s*\{(.*?)\}\s*,\s*\{(.*?)\}\s*\)\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data, $1,$2,$3,'c',1); $table_started = 1; }
	elsif ( /^\s*\(\(\s*(.*?)\s*;\s*(.*?)\s*\)\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data,$1,$2,$3,'r',1); $table_started = 1; }
	elsif ( /^\s*\(\(\s*(.*?)\s*,\s*(.*?)\s*\)\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data,$1,$2,$3,'t',1); $table_started = 1; }
	elsif ( /^\s*\(\s*\{(.*?)\}\s*,\s*\{(.*?)\}\s*\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data,$1,$2,$3,'c',0); $table_started = 1; }
	elsif ( /^\s*\(\s*(.*?)\s*;\s*(.*?)\s*\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data,$1,$2,$3,'r',0); $table_started = 1; }
	elsif ( /^\s*\(\s*(.*?)\s*,\s*(.*?)\s*\)(.*)$/ )
	    { table_entry_new (\%entry,\@Seq_data,$1,$2,$3,'t',0); $table_started = 1; }
	elsif ( $table_started )
	    { table_entry_content_append_line (\%entry,$_) }
	else
	    { print }
    }
    expand_rx (\%entry, $Seq_data[0], $Seq_data[1]);
    entries2table  (\%entry,\%cell,$Seq_data[0],$Seq_data[1]);
    complete_table (\%cell,$Seq_data[0],$Seq_data[1]);
    return table_render ($level,\%cell,$Seq_data[0],$Seq_data[1],$table_open_data,$table_close_data);
}

sub early_seq {
    my ($str, $addr_type, $max, $cur) = @_;
    my (@a, %h);
    if ($str eq '*') {
	$address = '.*';
	$addr_type='x';
    } elsif ($str eq '=' or $str eq '')  {
	$address = [$cur];
	$addr_type='a'; 
    } elsif ($str =~ /^([\+-])(\d*)$/) {
	$cur += ((($1 eq '+')?1:-1) * (($2 eq '')?1:$2));
	$address = [$cur];
	$addr_type='a';
    } elsif ($addr_type eq 'c') {
	eval "\@a=($str)";
	$cur = $a[-1];
	@h{@a} = 1;
	@a = sort {$a <=> $b} keys %h;
	$address = \@a;
	$addr_type = 'a'
    } elsif ($addr_type eq 'r') {
	foreach my $r(split /\s*,\s*/,$str)
	{
	    if ($r =~ /(\d+)-(\d+)/) { push @a, $1..$2 }
	    else { push @a, $r }
	}
	$cur = $a[-1];
	@h{@a} = 1;
	@a = sort {$a <=> $b} keys %h;
	$address = \@a;
	$addr_type = 'a'
    } elsif ($str =~ /^\d+$/) {
	$cur = $str;
	$address = [$cur];
	$addr_type = 'a';
    } else {
	$address = $str;
	$addr_type = 'x';
    }
    if ($addr_type eq 'a' and $address->[-1] > $max) {
	$max = $address->[-1]
    }

#   $addr_type.in  ::= 't', 'r', 'c'
#   $addr_type.out ::= 'x', 'a'
    return ($addr_type, $address, $max, $cur);
}

sub expand_rx {
    my %entries = %{$_[0]};
    my ($max_row, $max_col) = ($_[1], $_[2]);
    my $len = $#{$entries{head}};
    for $entrynr(0..$len) {
	if ( ${$entries{at_c}}[$entrynr] eq 'x' ) {
	    my $rx = '^'.${$entries{col}}[$entrynr].'$';
	    $rx = qr/$rx/;
	    my @a = grep { /$rx/ } 1..$max_col;
	    ${$entries{col}}[$entrynr] = \@a;
	    ${$entries{at_c}}[$entrynr] = 'a';
	}
	if ( ${$entries{at_r}}[$entrynr] eq 'x' ) {
	    my $rx = '^'.${$entries{row}}[$entrynr].'$';
	    $rx = qr/$rx/;
	    my @a = grep { /$rx/ } 1..$max_row;
	    ${$entries{row}}[$entrynr] = \@a;
	    ${$entries{at_r}}[$entrynr] = 'a';
	}
    }
}

sub table_entry_new {
    my ($entry,$Seq_data,$row,$col,$data,$addr_type,$is_header) = @_;
    my ($at_r, $ar, $at_c, $ac);
    ($at_r, $ar, $Seq_data->[0], $Seq_data->[2]) = early_seq($row, $addr_type, $Seq_data->[0], $Seq_data->[2]);
    ($at_c, $ac, $Seq_data->[1], $Seq_data->[3]) = early_seq($col, $addr_type, $Seq_data->[1], $Seq_data->[3]);
    push @{$$entry{at_r}},$at_r;
    push @{$$entry{at_c}},$at_c;
    push @{$$entry{row}},$ar;
    push @{$$entry{col}},$ac;
    push @{$$entry{head}},$data;
    push @{$$entry{is_h}},$is_header;
    push @{$$entry{cont}},'';
}

sub table_entry_content_append_line {
    my ( $entry, $data ) = @_;
    $data =~ /^\s*(.*)$/;
    $$entry{cont}[-1] .= (($$entry{cont}[-1] and $1)?"\n":'').$1;
}

sub table_entry_content_append_block {
    my ( $entry, $data ) = @_;
    $$entry{cont}[-1] .= "\n".$data;
}

sub table_render {
    my ( $level,$cell,$max_row,$max_col,$table_open_data,$table_close_data ) = @_;
    my ( $table_text,$processed_text );
    $table_text .= $tablewarn;
    $table_text .= "<table$table_open_data>\n";
    foreach my $row ($min_row..$max_row) {
	$table_text .= "  <tr>\n";
	foreach my $col ($min_col..$max_col) {
	    $table_text .= "    <!-- cell ($row,$col) -->\n" if ($opt_c);
	    location_tags_substitute (\$$cell{content}[$row][$col],$row,$col) if ($opt_l);
	    $table_text .= "    <t$$cell{type}[$row][$col]$$cell{header}[$row][$col]>$$cell{content}[$row][$col]</t$$cell{type}[$row][$col]>\n" unless ($$cell{void}[$row][$col])
	}
	$table_text .= "  </tr>\n"
    }
    $table_text.= "</table$table_close_data>\n";
    if ( $opt_m ) {
	if ( $level ) {
	    use IPC::Open2;
	    pipe MACROR,MACROW;
	    open2 \*MACROR,\*MACROW,$opt_m;
	    print MACROW $table_text;
	    close MACROW;
	    foreach (<MACROR>) { $processed_text.=$_ }
	    close MACROR;
	    return $processed_text;
	} else {
	    open MACROW,"|$opt_m";
	    print MACROW $table_text;
	    close MACROW;
	}
    } else {
	if ( $level ) { return $table_text }
	else { print $table_text }
    }
}

sub location_tags_substitute {
    my ( $cell,$row,$col ) = @_;
    $$cell =~ s/<row>/$row/gi;
    $$cell =~ s/<col>/$col/gi;
}

sub entries2table {
    my ($entryref,$cellref,$max_row,$max_col) = @_;
    my %entry = %$entryref;
    my $len = $#{$entry{head}};; ## row-P ?
    foreach my $entrynr (0..$len) {
	my @rowmask = @{${$entry{row}}[$entrynr]};
	my @colmask = @{${$entry{col}}[$entrynr]};
	foreach my $row (@rowmask) {
	    foreach my $col (@colmask) {
	        complete_cell ($entryref,$cellref,$row,$col,$entrynr)
	    }
	}
    }
}

sub complete_cell {
    my ( $entry,$cell,$row,$col,$entrynr ) = @_;
    my ( $colspan,$rowspan ) = (0,0);

    $$cell{header} [$row][$col] .= $$entry{head}[$entrynr];
    $$cell{content}[$row][$col] .= (($$cell{content}[$row][$col] and $$entry{cont}[$entrynr])?' ':'').$$entry{cont}[$entrynr];
    $$cell{type}   [$row][$col]  = $$entry{is_h}[$entrynr];
    $colspan = $1 if ($$entry{head}[$entrynr] =~ /colspan\s*=\s*(\S+)/i);
    $rowspan = $1 if ($$entry{head}[$entrynr] =~ /rowspan\s*=\s*(\S+)/i);

    if ($colspan) {
	if ($rowspan) {
	        foreach my $void_col(($col+1)..($col+$colspan-1))
		{$$cell{void}[$row][$void_col] = 1}
	    foreach my $void_row(($row+1)..($row+$rowspan-1)) {
	        foreach my $void_col(($col)..($col+$colspan-1))
		{ $$cell{void}[$void_row][$void_col] = 1 }
	    }
	} else {
	    foreach my $void_col(($col+1)..($col+$colspan-1))
		{ $$cell{void}[$row][$void_col] = 1 }
	}
    } elsif ($rowspan) {
	    foreach my $void_row(($row+1)..($row+$rowspan-1))
		{ $$cell{void}[$void_row][$col] = 1 }
    }
}

sub complete_table {
    my ( $cell,$max_row,$max_col ) = @_;
    foreach my $row ($min_row..$max_row) {
	foreach my $col ($min_col..$max_col) {
	    $$cell{type}[$row][$col] = $$cell{type} [$row][$col] ? 'h':'d'; # header-set-once or overwrite ?
	    $$cell{header}[$row][$col] = ''            unless ($$cell{header}[$row][$col]);
	    $$cell{content}[$row][$col] = $defaultcell unless ($$cell{content}[$row][$col]);
	}
    }
}
