#! /usr/bin/perl -w

use strict ;

my $SCHEME_DEF = 'scheme.new' ;
my $SCHEME_TST = 'scheme.dat' ;
my $OUT_DEF = 'Tabs.pm' ;
my $OUT_TST = 'zzz' ;
my $MOD_DEF = 'Foo' ;

my $prog = substr($0,rindex($0,'/')+1) ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-d] [-t] [scheme [out] ] 
option v : be verbose
option q : be quiet
option d : show debug info
default scheme : $SCHEME_DEF ;
default out    : $OUT_DEF ;
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "$prog: $_[0]\n" ; }
sub Warn  { warn "$prog: $_[0]\n" ; }

# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config('no_ignore_case') ;
my %opt = () ; Usage('') unless GetOptions
  ( \%opt, qw(v q d) ) ;
Usage("Arg count\n") unless @ARGV <= 2 ;

$opt{v} ||= $opt{d} ;

my $INP = shift || $SCHEME_TST ;
my $OUT = shift || $OUT_DEF ;
my $MOD = $MOD_DEF ;

@ARGV = ( $INP ) ;

printf "IN  $INP\n" ;
printf "OUT $OUT\n" ;

my %tabs  = () ;
my @tabs  = () ;
my $tab   = '' ;
my $fld   = {} ;
my $fkeys = {} ;

while ( <> )
  { chop ;
    next if /^\s*$/ ;
    next if /^#/ ;
    my $tabl = '' ;
    my ( $key, $val ) = split ' ', $_, 2 ;
    $val = '' unless defined $val ;
    if ( $key eq 'T' )
      { ( $tab, $tabl ) = split ' ', $val ;
        $tabl = $tab unless $tabl ;
        $tabs { $tab } { cols } = [] ;
        $tabs { $tab } { tabl } = $tabl ;
        push @tabs, $tab ;
	print "tab ($tab) tabl($tabl)\n" if $opt{d} ;
      }
    elsif ( $key eq 'F' )
      { my ( $name, $type, $rw ) = split ' ', lc $val, 3 ;
        Error "bad F ($val)" unless $rw =~ /^(system|read|write)$/ ;
        $fld = 
          { name => $name
          , type => $type
          , rorw => $rw
          , uniq => 0
          , null => 1
          , def  => undef
#         , fkey => undef
          } ;
        $tabs { $tab } { cnam } { $name } ++ ;
        push @{ $tabs { $tab } { cols } }, $fld ;
      }
    elsif ( $key eq 'A' )
      { my $name = $fld -> { name } ;
        if ( $val eq 'pkey' )
          { $tabs { $tab } { pkey } = $name ;
            $fld -> { uniq } = 1 ;
            $fld -> { null } = 0 ;
          }
        elsif ( $val eq 'notnull' )
          { $fld -> { null } = 0 ; }
        elsif ( $val eq 'unique' )
          { $fld -> { uniq } = 1 ; }
        elsif ( $val =~ /^fkey\s+(\w+)\s+(\w+)$/ )
          { my $rtab = $1 ;
            my $rcol = $2 ;
#           $fld -> { fkey } { $rtab } = $rcol ;
	    $fkeys -> { $tab } { $name } = [ $rtab, $rcol ] ;
          }
        else
          { Error "bad A ($val)" ;
          }
      }
    elsif ( $key eq 'D' )
      { $fld -> { def } = $val ; }
    else
      { Error "unknown key ($key) ($_)" ; }
  }

# sub par { sprintf "-$_[0] => $_[1]" ; }
sub par { sprintf "%s => %s", ucfirst $_[0], $_[1] ; }
sub quo { "'$_[0]'" ; }
sub brc { "{$_[0]}" ; }

my @defs = qw(name type rorw uniq null def fkey) ;
my %defs = 
  ( name => ''
  , type => ''
  , rorw => ''
  , uniq => '0'
  , null => '1'
  , def  => 'undef'
  , fkey => 'undef'
  ) ;

sub gen_col
  { my $col = shift ;
    my $type = $col -> { type } ;
    my $_def = $col -> { def } ;
    my %res  = () ;
    $res { name } = quo $col -> { name } ;
    $res { type } = quo $col -> { type } ;
    $res { uniq } = $col -> { uniq } ;
    $res { null } = $col -> { null } ;
    $res { def  } = 
      ( defined $_def ? ( $type eq 'text' ? quo $_def : $_def ) : 'undef' ) ;
    $res { fkey } = join
      ( ','
      , map
          { sprintf "\$self -> %s -> %s" , $_ , $col -> { fkey } { $_ } ;
          } keys %{ $col -> { fkey } }
      ) || 'undef' ;
    my $res = join "\n      , ",
      map { par $_, $res { $_ } }
      grep { exists $res { $_ } and $res { $_ } ne $defs { $_ } ; 
           } @defs ;
    <<COL ;
\$res -> Define_col
      ( $res
      ) ;
COL
  }

sub gen_cols
  { my @cols = @_ ; join "    ", map { gen_col $_ ; } @cols ; }

sub gen_tab
  { my $tab  = shift ; 
    my $pkey = $tabs { $tab } { pkey } ;
    my $tabl = $tabs { $tab } { tabl } ;
    Error "no table ($tab)" unless defined $tabl ;
    my $cols = gen_cols @{ $tabs { $tab } { cols } } ;
    Error "no pkey for table ($tab)" unless defined $pkey ;
    <<FMT ;
sub init_$tab
  { my \$self = shift ;
    my \$res  = \$self -> Define_tab
      ( Name => '$tab'
      , Tabl => '$tabl'
      , Pkey => '$pkey' 
      ) ;
    $cols
    \$res ; 
  }

FMT
  }

sub gen_fkeys
  { my @res = () ;
    for my $tab ( sort keys %$fkeys )
      { my $cols = $fkeys -> { $tab } ;
        for my $col ( sort keys %$cols )
	  { my ( $rtab, $rcol ) = @{ $cols -> { $col } } ;
            Error "remote tab not found $rtab" unless exists $tabs { $rtab } ;
            Error "remote col not found ($tab,$col) => ($rtab,$rcol)"
	      unless $tabs { $rtab } { cnam } { $rcol } ;
	    push @res, [ $tab, $col, $rtab, $rcol ] ;
	  }
      }
    @res ;
  }

sub width
  { my @tabs = @_ ;
    my $res = 0 ;
    for my $tab ( @tabs )
      { $res = length $tab if length $tab > $res ; }
    $res ;
  }

sub gen_tabs
  { my $res = "package OBB::Dbs::${MOD} ;\n\n"
      . "use strict ;\n\n" ;
    my $fmt = <<'FMT' ;
sub define_tables
  { my $self = shift ;
%s
%s
    $self ;
  }

1 ;

FMT

    for my $tab ( @tabs )
      { $res .= gen_tab $tab ; }
    my @fkeys = gen_fkeys ;
    my $W = width @tabs ;
    my @W = () ;
    for my $i ( 0..3 )
      { push @W, sprintf "%%-%ss", width map { $_ -> [ $i ] } @fkeys ; }
    $res .= sprintf $fmt
      , ( join "\n"
        , map
            { sprintf "    my \$%-${W}s = \$self -> init_%s ;" , $_, $_ ;
	    } @tabs
        )
      , ( join "\n"
        , map 
            { sprintf "    \$$W[0] -> $W[1] -> "
	        . "Fkey ( \$self -> $W[2] > $W[3] ) ;"
	        , @$_ ;
	    } @fkeys
        ) || "    # no foreign keys"
      ;
    $res ;
  }
  
my $OLD = "$OUT.old" ;
rename $OUT, $OLD ; # ignore error
open OUT, ">$OUT" or Error "can't write $OUT ($!)" ;
print OUT gen_tabs ;
close OUT ;