#!/usr/bin/perl
# formless - converts tsv to html forms
#
# License: public domain
#  Author: Sam Watkins <sam@nipl.net>
#     Web: http://sam.nipl.net/
#
# Version: 0.2~9
#    Date: 2012-04-11
#
# Version: 0.1
#    Date: 2010-05-14

use strict;
use warnings;
use Cwd qw(realpath);
use File::Basename;

our ($column_width, $column_input_size, $cell_padding,
	$cell_padding_input_size, $error_messages_tt, $error_messages_star,
	$data_tt, $data_span, $data_default, $options_tt, $metadata_tt,
	$wrap_with_html_body, $stylesheet, @form_attr, $checkbox_value, $file_input_size_sub);

unshift @INC, '.', dirname(realpath($0));
require 'formless.cnf';

sub id { return @_; }

sub set_form_attr {
	my ($k, $v) = @_;
	return if !defined $v;
	for (my $i=0; $i < @form_attr; $i+=2) {
		if ($form_attr[$i] eq $k) {
			$form_attr[$i+1] = $v;
		}
	}
}

sub slurp {
    my ($file) = @_;
    my $fh;
    if (ref $file) {
        $fh = $file;
    } else {
        open $fh, '<', $file or
            die "can't open file to read: $file: $!";
    }
    local $/;
    return <$fh>;
}

sub enen {
    local ($_) = @_;
    if (defined $_) {
        s/&/&amp;/g;
        s/</&lt;/g;
        s/>/&gt;/g;
        s/"/&quot;/g;
    } else {
        $_ = 'NULL';
    }
    return $_;
}

sub tag {
    my ($tag, @attrs) = @_;
    my $single = $tag =~ s{/$}{} ? '/' : '';
    my $attr = '';
    while (my ($name, $value) = splice @attrs, 0, 2) {
        next if !defined $value;
        my $venc = enen($value);
        $attr .= qq{ $name="$venc"};
    }
    return "<$tag$attr$single>";
}

sub wrap {
    my ($tag, @elements) = @_;
    my $attrs = ref $elements[0] ? shift @elements : [];
    my $content = join('', grep {defined $_} @elements);
    return tag($tag, @$attrs)
        .$content
        .tag("/$tag");
}

our (@grid, @size, @span, @card, @border, @boxes, %need_hidden, @need_hidden, %metadata, @metadata);

our $td_col;
our ($n_rows, $n_cols);

our %bracket_pair = ( '['=>']', '<'=>'>', '('=>')', '{'=>'}' );
our %card_class = (''=>'single required', '?'=>'optional', '*'=>'multi optional', '+'=>'multi required');

sub td {
    my ($r, $c) = @_;
    my $text = $grid[$r][$c];
    return undef if !defined $text;
    my $colspan = $span[$r][$c] || 1;
    my $class = join ' ', sort keys %{$border[$r][$c]};
    my $tag = $text =~ /:$/ ? 'th' : 'td';
    my $align;
    $text = "&nbsp;" if $text eq "";
    if ($tag eq "th") {
        my $t = $grid[$r][$c+$colspan];
        if (!defined($t) || $t =~ /:$/) {
            $align = "left";
        } else {
            $align = "right";
        }
    }
    if ($class) {
        $class =~ s/^ //;
    } else {
        $class = undef;
    }
    return wrap($tag, [colspan=>$colspan == 1 ? undef : $colspan, class => $class, align => $align], $text);
}

sub search_for_boxes {
    for my $r (0..$n_rows-1) {
        for my $c (0..$n_cols-1) {
            if ($grid[$r][$c] =~ s{^/}{}) {
                add_box($r, $c);
            }
        }
    }
    return;
}

sub add_box {
    my ($r0, $c0) = @_;
    my ($r1, $c1);

    # find top-right
    for ($c1=$c0; $c1<$n_cols; ++$c1) {
        last if $grid[$r0][$c1] =~ s{\\$}{};
    }
    die "could not find top-right \ of box" if $c1 == $n_cols;
            
    # find bottom
    for ($r1=$r0; $r1<$n_rows; ++$r1) {
        my $a = $grid[$r1][$c0] =~ s{^\\}{};
        my $b = $grid[$r1][$c1] =~ s{/$}{};
        last if $a && $b;
        die "misaligned bottom of box" if $a || $b;
    }
    die "could not find bottom of box" if $r1 == $n_rows;

    # create borders for this box
    for my $r ($r0..$r1) {
        $border[$r][$c0]{left} = 1;
        $border[$r][$c1]{right} = 1;
    }
    for my $c ($c0..$c1) {
        $border[$r0][$c]{top} = 1;
        $border[$r1][$c]{bottom} = 1;
    }

    push @boxes, [$r0, $c0, $r1, $c1];   # TODO remove?

    return;
}

sub widget_size {
    my ($r, $c, $open) = @_;
    my $expect = $bracket_pair{$open};
    for my $c1 ($c..$n_cols-1) {
        my ($close, $card);
        if ($grid[$r][$c1] =~ s/([]>}])([?*+]|)$//) {
            ($close, $card) = ($1, $2);
        }
        undef $grid[$r][$c1] if $c1 > $c;
        if ($close) {
            return ($c1 - $c + 1, $card) if $close eq $expect;
            die "mismatched widget brackets";
        }
    }
    die "did not find widget's closing bracket";
}

sub colspan {
    my ($r, $c) = @_;
    my $span = 1;
    for my $c1 ($c+1..$n_cols-1) {
        last if (defined $grid[$r][$c1] && $grid[$r][$c1] ne "") || $border[$r][$c1-1]{right} || $border[$r][$c1]{left};
        undef $grid[$r][$c1];
        ++$span;
    }
    return $span;
}

sub need_hidden {
    my ($id) = @_;
    $need_hidden{$id} ||= do {
        push @need_hidden, $id; 1;
    };
}

sub data_value {
    my ($id, $stash, $opt) = @_;
	my $enc = \&enen;
	my $tt_enc = ' | html';
	if (($opt||'') eq 'html') {
		$enc = \&id;
		$tt_enc = '';
	}
	my $ret;
	if (defined $stash->{$id}) {
		$ret = $enc->($stash->{$id});
	} elsif ($data_tt) {
		$ret = "[% $id$tt_enc %]";
	} else {
		$ret = $enc->($data_default);
	}
	if ($data_span) {
		$ret = wrap('span', [id=>"text_".$id], $ret);
	}
	return $ret;
}

sub text2form {
    my ($tmpl, $stash) = @_;

    @grid = @size = @span = @card = @border = @boxes = %need_hidden = @need_hidden = %metadata = @metadata = ();
    $n_rows = $n_cols = 0;

    # read TSV lines into table cells
    my @lines = split /\r?\n/, $tmpl;
    for (@lines) {
        s/\r//g; chomp; s/\t+$//;
        my @cells = split /\t/, $_, -1;
        push @grid, \@cells;
        if (@cells > $n_cols) {
            $n_cols = @cells;
        }
    }

    # get any metadata
    while (@{$grid[0]} == 2 && $grid[0][0] =~ /:$/) {
        my ($k, $v) = @{shift @grid};
        $k =~ s/:$//;
        push @metadata, $k;
        $metadata{$k} = $v;
    }
    die "missing well-formed metadata section\n" if @{shift @grid} != 0;

    my $metadata = "";
    my $hidden = "";
    my $meta_hidden = delete $metadata{hidden};
    my $meta_method = delete $metadata{method};
    my $meta_action = delete $metadata{action};
    my $meta_form = delete $metadata{form};
	if (!defined $meta_form) { $meta_form = 1; }
    my $meta_form_id = delete $metadata{form_id};
    my $meta_expand = delete $metadata{expand};
    my $meta_min_width = delete $metadata{min_width};
    my $meta_width = delete $metadata{width};
    my $meta_class = delete $metadata{class};
	if ($meta_width) {
		$column_input_size *= $meta_width / $column_width;
		$column_width = $meta_width;
	}

    $n_rows = @grid;

    # pad each row to be the same length
    for my $row (@grid) {
        while (@$row < $n_cols) {
            push @$row, '';
        }
    }

    # search for boxes
    search_for_boxes();

    my ($r, $c);

    # calculate colspan for each cell, and undef unused cells:
    # [inputs], <selects> and {buttons} can have tabs inside to indicate colspan
    # labels, data, links and checkbox+label followed by blank cells are extended into those cells
    for $r (0..$n_rows-1) {
        for $c (0..$n_cols-1) {
            local $_ = $grid[$r][$c];
            next if !defined $_;
            my ($size, $colspan, $card);
            if (my ($open) = /^([[<{])/) {
                ($size, $card) = widget_size($r, $c, $open);
                $card[$r][$c] = $card;
            }
            ($colspan) = colspan($r, $c);
            if ($colspan > 1) {
                $border[$r][$c] = {map {$_=>1} keys %{$border[$r][$c]}, keys %{$border[$r][$c + $colspan-1]}};
            }
            $span[$r][$c] = $colspan;
            $size[$r][$c] = $size || $colspan;
        }
    }

    # generate html for each cell
    for $r (0..$n_rows-1) {
        for $c (0..$n_cols-1) {
            local $_ = $grid[$r][$c];
            next if !defined $_;
            my $colspan = $span[$r][$c] || 1;
            my $size = $size[$r][$c] || 1;
            my $card = $card[$r][$c] || '';
            my $width = $column_width * $size - $cell_padding;
			my @style_width;
#			if ($c + $colspan < $n_cols) {
#				@style_width = (style => "width: ${width}px;");
#			}
#			@style_width = (style => "min-width: ${width}px;");
			@style_width = (style => "width: ${width}px;");
            my $input_size = int($column_input_size * $size - $cell_padding_input_size + 1e-9);
            my ($id, $label, $maxlength);

            # entry
            if (s/^([[<{?])//) {
                my ($type) = ($1);
                if ($type eq '[') {
                    ($id, $maxlength) = /^(\S+)\s*(\d+)?/;
					my $input_type = 'text';
					if ($id =~ s/^(file)://) {
						$input_type = $1;
						$input_size -= $file_input_size_sub;
					}
                    $_ = tag('input/', name=>$id, id=>$id, type=>$input_type, value=>$stash->{$id}, maxlength=>$maxlength, class => $card_class{$card}, size => $input_size, @style_width);

                # TODO textarea

                # select
                } elsif ($type eq '<') {
                    $id = $_;
                    my @options;
                    if ($options_tt) {
                        push @options, qq{[% FOREACH x IN options.$id %]<option value="[% x.id %]">[% x.nm | html %]</option>[% END %]};
                    }
                    $_ = wrap('select', [name=>$id, id=>$id, value=>$stash->{$id}, class => $card_class{$card}, @style_width], @options)

                # button
                } elsif ($type eq '{') {
                    $label = $_;
					my @default = $label =~ s/^!// ? (class => 'default') : ();
					($id = $label) =~ s/\W/_/g;
                    $_ = tag('input/', type=>'submit', name=>$id, id=>$id, value=>$stash->{$id}||$label, @style_width, @default)

                # checkbox with label
                } elsif ($type eq '?') {
                    ($id, $card, $label) = /^(\S+?)([?*+]|\b)(.*)/;
                    die "bad checkbox widget: $_\n" if !defined $id;
                    $_ = tag('input/', type => 'checkbox', name=>$id, id=>$id, value=>$checkbox_value||1, checked => $stash->{$id} ? 1 : undef, class => $card_class{$card});
                    $_ .= wrap('label', [for=>$id], enen($label)) if $label ne '';

                } else {
                    die "invalid syntax for input item";
                }

                # error messages per field, via template toolkit at the moment.  not for buttons!
                if ($error_messages_tt && $type ne '{') {
                    $_ .= " [% errors.$id %]";
                } elsif ($error_messages_star) {
                    $_ .= " *";
                }

            # text (maybe with $data and links, etc)
            # The following is not ideal, it would be better to step through it
            # than to do multiple substitution passes like this.
            } else {

                # remove a lone . (placeholder)
                s{^\.$}{};

                # entities
                $_ = enen($_);

                # data / variables
                s{\$(\$|\d|<\S+>|\S+)}{
                    my ($id) = ($1);
                    if ($id eq '$') {
                        '$'
                    } elsif ($id =~ /^\d/) {
                        "\$$id"
                    } elsif ($id =~ /^&lt;(.*)&gt;$/) {
						$id = $1;
                        need_hidden($id);
                        data_value($id, $stash, 'html');
                    } else {
                        need_hidden($id);
                        data_value($id, $stash);
                    }
                }ge;

                # spacing
                s/  /&nbsp; /g;

                # links
                s{\b_(.+?)_\b}{
                    my $label = $1;
                    (my $id = lc $label) =~ s/\s/_/g;
                    my $href = $stash->{$id}||'#';
                    wrap('a', [href=>$href], enen($label));
                }ge;

                # code - javascript links
                s{(^|\s)!(.+?)!($|\s)}{
                    my ($pre, $label, $post) = ($1, $2, $3);
                    (my $id = lc $label) =~ s/\s/_/g;
                    my $href = $stash->{$id}||"javascript:$id()";
                    $pre . wrap('a', [href=>$href], enen($label)) . $post;
                }ge;
            }

            $grid[$r][$c] = $_;
        }
    }

    # build html table
    my $body;
    for $r (0..$n_rows-1) {
        for $c (0..$n_cols-1) {
            $grid[$r][$c] = td($r, $c);
        }
        $body .= wrap('tr', @{$grid[$r]}) . "\n";
    }

	set_form_attr('method', $meta_method);
	set_form_attr('action', $meta_action);
	set_form_attr('id', $meta_form_id);
	set_form_attr('name', $meta_form_id);

    # add metadata
    if ($metadata_tt) {
        for my $k (@metadata) {
            my $v = $metadata{$k};
            $metadata .= "[% META $k = '$v' -%]\n"  if defined $v;
        }
    }

    # add hidden form elements for each $data displayed - for use by javascript
    unshift @need_hidden, split /\s+/, $meta_hidden  if $meta_hidden;
    for my $id (@need_hidden) {
        $hidden .= tag('input/', type=>'hidden', name=>$id, id=>$id, value=>$stash->{$id})."\n";
    }

    # add one blank row with all the cells, with widths, to ensure sensible layout
	# hopefully min-width would work on IE6, but I doubt it.
    my $column_width_minus_padding = $column_width - $cell_padding;
	if ($meta_min_width) {
		$column_width_minus_padding = $meta_min_width;
	}
#    $body .= wrap('tr', map {wrap('td', [style=>"min-width: ${column_width_minus_padding}px;"])} 1..$n_cols);
#    $body .= wrap('tr', (map {wrap('td', [style=>"width: ${column_width_minus_padding}px;"])} 1..($n_cols-1)), wrap('td'));   # I.e. limits the width MORE if use min-width than width!!! wtf
	my @expand;
	@expand = (style=>"width: 100%;") if $meta_expand;
    $body .= wrap('tr', (map {wrap('td', [style=>"width: ${column_width_minus_padding}px; min-width: ${column_width_minus_padding}px; max-width: ${column_width_minus_padding}px;"])} 1..($n_cols-1)),
		wrap('td', [@expand]));

    # wrap with form and table tags
	my $form_body = $hidden .
            wrap('table', [class=>($meta_class||'layout')], $body);
	if ($meta_form) {
    return $metadata .
			wrap('form', [@form_attr], $form_body);
	} else {
		return $metadata . $form_body;
	}
}

sub formless {
    my $tmpl = slurp(\*STDIN);
    my $stash = {};

    my $html = text2form($tmpl, $stash);

    # wrap with html (with head) and body tags
    if ($wrap_with_html_body) {
        $html = wrap('html',
            wrap('head',
                tag('link/', rel=>'stylesheet', type=>'text/css', href=>$stylesheet)),
            wrap('body', $html));
    }

    $html .= "\n";

    # output html
    print $html;
}

formless();