#! /sw/bin/perl

use strict ;

=pod

=head1 Module csbase

  csbase.pm - perl interface to csbase

=head1 USAGE

  $ENV{PGHOST} = 'pghost' ;
  $ENV{"PGDATESTYLE"} = "ISO" ;

  sub Y { print "YYY $_[0]\n" ; } ; # or something like that

  use lib '/sw/pkg/department/lib' ;
  use csbase ;
  use DBI ;

  my $PDB = 'csbase' ;
  my $SCHEME = '/sw/etc/scheme.dat' ;
  my $DBH = DBI ->
         connect( "dbi:Pg:dbname=$PDB", "", ""
                , { RaiseError => 0, AutoCommit => 1 }
                ) or die $DBI::errstr ;

  my $CSBASE = CSBASE -> new ( $SCHEME, $DBH ) ;
  die $CSBASE unless ref $CSBASE ;

  for my $tab ( $CSBASE -> tabs ) { ... }
  for my $col ( $tab -> cols )    { ... }

  print "debug message" if $CSBASE::opt{d} ;

=head1 ENVIRONMENT

  Assumes main::Y($err) to report back database errors.

=cut

package CSBASE ;

=pod

=head1 CSBASE

A CSBASE object represents a list of tables,
ordered by the insertion sequence.

=head2 CSBASE Class Methods

  $CSBASE  = CSBASE -> new ( '/sw/etc/scheme.dat', $dbh ) ;
  $version = CSBASE -> version

  For the required diagnostics level, package CSBASE
  looks at $opt{v}, $opt{d}, $opt{D} in package CSBASE.

  set diagnostics level:
    normal  : CSBASE -> set_opt ( 'n' )  [ default ]
    verbose : CSBASE -> set_opt ( 'v' ) 
    debug   : CSBASE -> set_opt ( 'd' ) 
    heavy   : CSBASE -> set_opt ( 'D' ) 

=head2 CSBASE Object Methods

  db handle      # $dbh     = $CSBASE -> dbh
  list of tables # @tab     = $CSBASE -> tabs
  table by name  # $tab     = $CSBASE -> tabbyname ( $name )

  add a table    # $CSBASE -> addtab ( $tab )

=cut

my $version = '$Id: csbase.pm,v 1.2 2007/03/02 08:32:12 henkp Exp henkp $' ;

require Exporter ;
@CSBASE::ISA = qw/Exporter/ ;
@CSBASE::EXPORT = () ;
@CSBASE::EXPORT_OK = @CSBASE::EXPORT ;

my ( %TYPE, %RW, %ATTR, %opt ) ;

sub set_opt
  { my $self = shift ;
    my $opt  = shift ;
    main::Y ( "illegal option '$opt'" ) unless $opt =~ /^[nvdD]$/ ;
    %CSBASE::opt = () ;
    $CSBASE::opt{n} = 1 ;
    $CSBASE::opt{D} = 4 if $opt eq 'D' ;
    $CSBASE::opt{d} = 2 if ( $opt eq 'd' ) || $CSBASE::opt{D} ;
    $CSBASE::opt{v} = 1 if ( $opt eq 'v' ) || $CSBASE::opt{d} ;
    printf "set_opt: %s\n", $opt if $CSBASE::opt{d} ;
    printf "set_opt: opt n '%s'\n", $CSBASE::opt{n} if $CSBASE::opt{d} ;
    printf "set_opt: opt v '%s'\n", $CSBASE::opt{v} if $CSBASE::opt{d} ;
    printf "set_opt: opt d '%s'\n", $CSBASE::opt{d} if $CSBASE::opt{d} ;
    printf "set_opt: opt D '%s'\n", $CSBASE::opt{D} if $CSBASE::opt{d} ;
  }

sub NULL { 'NULL' ; }

sub dbh { my $self = shift ; $self->{dbh} ; }

#
# prefix table-names in @$tnames with $prefix
#

sub set_dbh { my $self = shift ; $self -> { dbh } = shift ; }

sub new
  { my $type = shift ;
    my $SCHEME = shift ;
    my $prefix = shift ;
    my $tnames = shift ;
    my $self = bless {}, $type ;
    my ( $TAB, $COL, $fkey, @fkey ) ;
    unless ( open SCHEME, $SCHEME )
      { return "CSBASE: can't open '$SCHEME' ($!)" ; }

    while ( <SCHEME> )
      { chop ;
        next if /^\s*$/ ;
        s/\s+$// ;

        my @rec = split ' ' ;
        my $tag = shift @rec ;

        if ( $tag eq 'T')
          { my $name = shift @rec ;
            if ( grep { $_ eq $name } @$tnames )
              { $name = $prefix . $name ; }
            $TAB = CSBASE::Tab -> new ( $self, $name ) ;
            $self -> addtab ( $TAB ) ;
          }
        elsif ( $tag eq 'F')
          { my ( $name, $type, $rw ) = @rec ;
            $TYPE{$type}++ ; $RW{$rw}++ ;

            $COL = CSBASE::Col -> new ( $TAB, @rec ) ;
          }
        elsif ( $tag eq 'A')
          { my $attr = shift @rec ;
            $ATTR{$attr}++ ;
            if ( $attr eq 'pkey' )
              { $TAB -> setpkey ( $COL ) ;
                $COL -> setattr ( 'notnull', 1 ) ;
                $COL -> setattr ( 'unique' , 1 ) ;
                $COL -> setattr ( 'pkey'   , 1 ) ;
              }
            elsif ( $attr eq 'fkey' )
              { my $name = $rec [ 0 ] ;
#               printf "1 fkey %s\n", join ' : ', @rec ;
                if ( grep { $_ eq $name } @$tnames )
                  { $rec [ 0 ] = $prefix . $name ; }
#               printf "2 fkey %s\n", join ' : ', @rec ;
                push @fkey, [ $COL, @rec ] ;
              }
            else
              { $COL -> setattr ( $attr, shift @rec ) ; }
          }
        else
          { return "CSBASE: unknown keytag '$tag'\n" ; }
      }
    close SCHEME ;

    for $fkey ( @fkey )
      { my ( $col, $rtab, $rcol ) = @{ $fkey } ;
        $col -> setfkey ( $self->{tables}{$rtab} -> colbyname ( $rcol ) ) ;
      }

    for $TAB ( @{ $self->{tabs} } )
      { for $COL ( $TAB -> cols )
          { $type  = $COL -> type ;
            my $rwinp = $COL -> rw ( 'inp' ) ;

            $COL -> setrw
              ( 'new', ( ( $type eq 'serial' or $rwinp eq 'system' )
                       ? 'read'
                       : 'write'
                       )
              ) ;
            $COL -> setrw
              ( 'upd', ( ( $COL -> pkey or $rwinp eq 'system' )
                       ? 'read'
                       : $rwinp
                       )
              ) ;
          }
      }

    return $self ;
  }

sub addtab
  { my $self = shift ;
    my $tab = shift ;
    push @{ $self->{tabs} }, $tab ;
    $self->{tables}{$tab->name} = $tab ;
  }

sub tabs { my $self = shift ; @{ $self->{tabs} } ; }

sub tabbyname
  { my $self = shift ;
    my $name = shift ;
    if ( exists $self->{tables}{$name} )
      { $self->{tables}{$name} ; }
    else
      { printf "*** can't tabbyname '$name'\n" ;
        undef ;
      }
  }

sub dmp
  { my $self = shift ;
    my ( $tab, $col, $refcol ) ;
    for $tab ( sort { $a->name cmp $b->name ; } $self -> tabs )
      { printf "\nTABLE %s\n", $tab->name ;
        for $col ( $tab->cols )
          { printf "FIELD %s\n", $col->name ;
            printf "TYPE  %s\n", $col->type ;
            printf "RW    %s new=%s upd=%s\n" ,
              $col->rw('inp') , $col->rw('new') , $col->rw('upd') ;
            my %attr = () ;
            $attr{pkey}    = $col -> pkey ;
            $attr{notnull} = $col -> notnull ;
            $attr{unique}  = $col -> unique ;
            $attr{fkey} = sprintf "fkey=%s.%s",
              $col->ftab->name, $col->fkey->name
                if $col -> fkey ;
            printf "ATTRs %s\n",
              join ' ',
                map { $_ eq 'fkey' ? $attr{fkey} : $_ }
                  grep $attr{$_}, sort keys %attr ;
            for $refcol ( $col -> reftabs )
              { printf "  %s.%s\n",
                  $refcol->tab->name, $refcol->name ;
              }
          }
      }
  }

sub debug
  { my $self = shift ;
    for ( sort keys %TYPE ) { print "TYPE '$_'\n" ; } ; print "\n" ;
    for ( sort keys %RW   ) { print "RW   '$_'\n" ; } ; print "\n" ;
    for ( sort keys %ATTR ) { print "ATTR '$_'\n" ; } ; print "\n" ;
  }

sub version { $version ; }

=pod

=head1 CSBASE::Tab

A CSBASE::Tab object represents a table:
a list of columns ordered by the insertion sequence.
A table belongs implicitly to a CSBASE object.
Every table has exactly one primary key.
Primary keys are 'notnull' and 'unique'.

=head2 Tab Class Methods

  new table      # $tab  = CSBASE::Tab -> new ( $base, $name )

=head2 Tab Object Methods

  parent CSBASE  # $base = $tab -> base
  db handle      # $dbh  = $tab -> dbh
  table name     # $name = $tab -> name
  primary key    # $col  = $tab -> pkey
  columns        # @cols = $tab -> cols
  has column     # $bool = $tab -> hascol ($name)
  writable cols  # @cols = $tab -> w_cols ( $action )
  column by name # $col  = $tab -> colbyname ( $name )
  record tags    # $tag  = $tab -> TAG ( $rec )
  undef -> null  # $rec  = $tab -> undef2null ( $rec )
  null record    # $rec  = $tab -> null
  get a record   # $rec  = $tab -> get_rec ( $pval )
  get data       # $recs = $tab -> get_data ( $sql )
  get rows       # $rows = $tab -> get_rows ( $sql )
  width col list # $size = $tab -> width

  add column     # $tab -> addcol ( $col )
  set pkey       # $tab -> setpkey ( $col )

    where $rec  is a CSBASE::Rec
          $recs is a hashref  { pkey_1, hash_1, ..., }
          $rows is a arrayref [ hash_1, hash_2, ..., ]

Method 'get_rows' should be used on tables (views)
without a unique pkey.

=cut

package CSBASE::Tab ;

require Exporter ;
@CSBASE::Tab::ISA = qw/Exporter/ ;
@CSBASE::Tab::EXPORT = () ;
@CSBASE::Tab::EXPORT_OK = @CSBASE::Tab::EXPORT ;

my %TAGS ;

my @RECTAGS =
  ( [ qw(person         lname admtag)  ]
  , [ qw(location       location_id)   ]
  , [ qw(phone          phonenr)       ]
  , [ qw(uu_id          person_id)     ]
  , [ qw(room           room_id type)  ]
  , [ qw(grp            grp_id)        ]
  , [ qw(afdeling       abrv)          ]
  , [ qw(vlan           name)          ]
  , [ qw(host           hostname)      ]
  , [ qw(vhost          hostname)      ]
  , [ qw(owner          owner_id)      ]
  , [ qw(make           name)          ]
  , [ qw(ip             ipnr)          ]
  , [ qw(wc             wc_id vlan_id) ]
  , [ qw(nic            name)          ]
  , [ qw(dhcpgroup      dhcpgroup)     ]
  , [ qw(ethertype      e_type)        ]
  , [ qw(href           href_id text)  ]
  , [ qw(service        service_id)    ]
  , [ qw(service_status status)        ]
  , [ qw(service_host   service_id host_id) ]
  , [ qw(service_href   service_id href_id) ]
  , [ qw(dns_static     name dns_id)   ]
  , [ qw(dns_dynamic    dns_id)        ]
  , [ qw(job            grp_id function_id admtag job_id) ]
  , [ qw(appointment    contractnr) ]
  , [ qw(vacancy        csgkey) ]
  , [ qw(function       function_id) ]
  , [ qw(xscard         xscard_id) ]
  , [ qw(techrep        techrep_id) ]
  , [ qw(techrep_author techrep_id person_id) ]
  , [ qw(salary_scale    scale_id) ]
  , [ qw(account_edu     login purpose) ]
  , [ qw(account_edu_adm login)         ]
  , [ qw(account_staff   login purpose) ]
  , [ qw(account_purpose purpose)       ]
  , [ qw(account_status  status)        ]
  , [ qw(student studentnummer achternaam) ]
  , [ qw(student_opleiding studentnummer) ]
  , [ qw(os              os)            ]
  , [ qw(edupkg          id name)       ]
  , [ qw(secr_sched      person_id)     ]
  ) ;

for my $ref ( @RECTAGS )
  { my ( $key, @lst ) = @{ $ref } ;
    $TAGS{$key} = sub { join ', ', @{$_[0]}{ @lst } ; }
  }

sub TAG
  { my $self = shift ;
    my $item = shift ;

#   printf "TAG TAB->name '%s' item '%s'\n", $self->name, $item ;

    if ( ! defined $item )
      { 'UndefTag' ; }
    elsif ( $item eq CSBASE::NULL )
      { 'NullTag' ; }
    elsif ( ref $item )
      { &{ $TAGS{$self->name} } ( $item ) ; }
    else
      { "noref $item" ; }
  }

sub new
  { my $self = shift ;
    my $base = shift ;
    my $name = shift ;
    return bless
      { 'base', $base
      , 'name', $name
      , 'collist', []
      , 'cols', {}
      } ;
  }

sub base { my $self = shift ; $self -> {base} ; }
sub name { my $self = shift ; $self -> {name} ; }
sub pkey { my $self = shift ; $self -> {pkey} ; }
sub cols { my $self = shift ; @{ $self -> {collist} } ; }
sub dbh  { my $self = shift ; $self -> base -> dbh ; }

sub w_cols
  { my $self = shift ;
    my $act  = shift ;
    grep $_ -> rw ( $act ) eq 'write', $self -> cols ;
  }

sub colbyname
  { my $self = shift ;
    my $name = shift ;
    if ( exists $self -> {cols}{$name} )
      { $self -> {cols}{$name} ; }
    else
      { printf "*** can't colbyname '%s' in tab '%s'\n",
          $name, $self->name ;
        0 ;
      }
  }

sub cv_usr_val
  { my $self = shift ;
    my $rec  = shift ;
    my $res = {} ;

    for my $col ( $self -> cols )
      { $res -> { $col -> name } = $col -> cv_usr_val ( $rec ) ;
      }
    $res ;
  }

sub cv_val_usr
  { my $self = shift ;
    my $rec  = shift ;
    my $res = {} ;

    for my $col ( $self -> cols )
      { $res -> { $col -> name } = $col -> cv_val_usr ( $rec ) ;
      }
    $res ;
  }

sub get_rec
  { my $self = shift ;
    my $key = shift ;

    my ( $st, $sth, $ref ) ;

    $self -> pkey -> get_rec ( $key ) ;
  }

sub get_data
  { my $self = shift ;
    my $sql = shift ;

    $sql = '' unless defined $sql ;

    $self -> pkey -> get_data ( $sql ) ;
  }

sub get_rows
  { my $self = shift ;
    my $sql  = shift ;

    $sql = '' unless defined $sql ;

    my $rec ;

    my $dbh = $self -> dbh ;

    my $st = sprintf "SELECT * FROM %s %s;", $self->name, $sql ;
    print "get_rows: $st\n" if $CSBASE::opt{v} ;
    my $sth = $dbh -> prepare ( $st ) ;
    if ( $dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;
    $sth -> execute ( ) ;
    if ( $dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;

    my $res = [] ;

    while ( $rec = $self -> undef2null ( $sth->fetchrow_hashref )  )
      { push @{ $res }, $rec ; }

    if ( $sth->err ) { main::Y ( $sth->errstr ) ; exit ; }

    $res ;
  }

sub maxlen { length( (sort { length($b) <=> length($a) ; } @_ )[0] ) ; }
sub names { map { $_ -> name ; } @_ ; }

sub width
  { my $self = shift ;
    1 + maxlen names $self -> cols ;
  }

sub undef2null
  { my $self = shift ;
    my $rec  = shift ;

    printf "undef2null tab->name '%s'\n", $self->name if $CSBASE::opt{D} ;

    if ( defined $rec )
      { for my $col ( $self -> cols )
         { my $cname = $col -> name ;
#          printf "undef2null: col-name '%s' not found\n", $cname
#            unless exists $rec->{$cname} ;
           $rec->{$cname} = $col -> cv_sql_val ( $rec ) ;
           printf "undef2null cname '%s' val '%s'\n",
             $cname, $rec->{$cname}
               if $CSBASE::opt{D} ;
         }
      }
    $rec ;
  }

sub null
  { my $self = shift ;
    CSBASE::Rec -> new ( $self, CSBASE::NULL ) ;
#   my $res = {} ;
#   for my $col ( $self -> cols ) { $res -> { $col->name } = NULL ; }
#   $res ;
  }

sub setpkey
  { my $self = shift ;
    $self -> {pkey} = shift ;
  }

sub addcol
  { my $self = shift ;
    my $col  = shift ;
    my $name = $col -> name ;
    push @{ $self -> {collist} }, $col ;
    $self -> {cols}{$name} = $col ;
  }

=pod

=head1 CSBASE::Tab::View

CSBASE::Tab::View handles views on a table.

=head2 new

  CSBASE::Tab::View -> new ( $tab, $parent_window )

=head2 picker, picked, refill

  $view = CSBASE::Tab::View -> new ( $tab, $frame )
  $view -> picker ( $sql, $sub )
  $view -> picked
  $view -> refill

Method picker() generate a frame with quickindex and listbox for $tab.
By default the whole table is presented. An optional,
additional WHERE clause may be added.
A callback $sub me be specified, called after selection,
as $sub(selected_key).

Method picked() yields the key of the selected record in the table,
or NULL if nothing was selected.

Method refill() assumes a picker object, and refills the listbox
from the database.

=cut

package CSBASE::Tab::View ;

require Exporter ;
@CSBASE::Tab::View::ISA = qw/Exporter CSBASE::Tab/ ;
@CSBASE::Tab::View::EXPORT = () ;
@CSBASE::Tab::View::EXPORT_OK = @CSBASE::Tab::View::EXPORT ;

sub frm { my $self = shift ; $self -> {frm} ; }

sub new
  { my $type  = shift ;
    my $tab   = shift ;
    my $frame = shift ;

    printf "CSBASE::Tab::View->new: tab '%s'\n",
      $tab->name if $CSBASE::opt{d} ;

    my $self = { %{ $tab } } ;

    $self -> {frm} = $frame ;

    return bless $self, $type ;
}

sub picker
  { my $self = shift ;
    my $sql = shift ;
    my $sub = shift ;

    $self -> {sql} = $sql ;

    my ( $sink ) ;

    my $res = $self->frm -> Frame () ;

    my $lt = $self -> {lt} = $res -> Entry
      ( -text, ""
      , -textvariable, \$sink
      ) ;
    $lt -> bind
      ( '<Key>'
      , sub { my $txt = $self->{lt}->get() ;
              my @tgs = $self->{lb}->get(0,'end') ;
              my $max = scalar @tgs - 1 ;
              my $idx = 0 ;
              while ( $idx < $max && $tgs[$idx] lt $txt ) { $idx++ ; }
              $self -> {lb} -> see ( $idx ) ; # 0 <= $idx <= $max
            }
      ) ;
    $lt -> pack ( -side, 'top', -anchor, 'w', -fill, 'x' ) ;

    my $lb = $self -> {lb} = $res -> Scrolled
      ( 'Listbox'
      , -scrollbars, 'e'
      , -height, 25
      , -exportselection, 0
      , -selectforeground, 'red'
      ) ;


    $lb -> bind
      ( '<Button-1>',
          sub { my $IDX = $self->{lb}->curselection() ;
                if ( ref $IDX )
                  { $IDX = $IDX -> [ 0 ] ; }
                elsif ( $IDX eq '' )
                  { $IDX = undef ; }
                printf "picker curselection tab '%s itm '%s'\n",
                  $self->name, $IDX if $CSBASE::opt{d} ;
                $self->{LBK} = $self->{LBL}->[$IDX] ;
                &{ $sub } ( $self->{LBK} ) if defined $sub ;
              }
      ) ;
    $lb -> pack ( -side, 'top', -anchor, 'w', -fill, 'x' ) ;

    $self -> refill ;

    return $res ;
  }

sub refill
  { my $self = shift ;

    my ( %tag ) ;

    $self -> {ITM} = $self -> get_data ( $self->{sql} ) ;

    $self -> {lb} -> delete ( 0, 'end' ) ;
    $self -> {LBL} = [] ;

    for my $key ( keys %{ $self->{ITM} } )
      { $tag{$key} = $self -> TAG ( $self->{ITM} -> { $key } ) ; }

    for my $key ( sort { $tag{$a} cmp $tag{$b} ; } keys %{ $self->{ITM} })
      { $self->{lb} -> insert ( 'end', $tag{$key} ) ;
        push @{ $self -> {LBL} }, $key ;
      }

    $self->{LBK} = CSBASE::NULL ;
  }

sub picked { my $self = shift ; $self->{LBK} ; }

=pod

=head1 CSBASE::Col

A CSBASE::Col object represents a column.
A column belongs implicitly to a CSBASE::Tab object.
The 'type' specification is an sql data type.
The 'rw' specification is 'read|write|system'.
The 'rw attribute for action 'new' and 'upd' is defined as:

  'new' => ( $type eq 'serial' || $rw eq 'system' ? 'read' : 'write' )
  'upd' => ( $COL -> pkey || $rw eq 'system' ? 'read' : $rw )

=head2 Col Class Methods

  new column     # $col  = CSBASE::Col -> new ( $tab, $name, $type, $rw )

=head2 Col Object Methods

  parent table   # $tab  = $col -> tab
  column name    # $name = $col -> name
  type           # $name = $col -> type
  'read' or 'write' permission on INSERT/UPDATE
                 # $rw   = $col -> rw ( $action )
  notnull        # $bool = $col -> notnull
  unique         # $bool = $col -> unique
  col is pkey    # $bool = $col -> pkey
  foreign key    # $rcol = $col -> fkey
  foreign tab    # $rtab = $col -> ftab
  refering tabs  # @rcol = $col -> reftabs
  sql to perl    # $pval = $col -> cv_sql_val ( $rec )
  perl to sql    # @sval = $col -> cv_val_sql ( $rec )
  get a record   # $rec  = $col -> get_rec ( $pval )
  get data       # $recs = $col -> get_data ( $sql )
  has data       # $num  = $col -> has ( $val )

  set fkey       # $col -> setfkey ( $rcol     )
  set pkey       # $col -> setattr ( 'pkey'    )
  set unique     # $col -> setattr ( 'unique'  )
  set notnull    # $col -> setattr ( 'notnull' )
  set rw action  # $col -> setrw   ( $action   )

    where $action is 'upd' or 'new'
          $rec  is a CSBASE::Rec
          $recs is a hashref { pkey_1, rec_1, ..., }

=cut

package CSBASE::Col ;

require Exporter ;
@CSBASE::Col::ISA = qw/Exporter/ ;
@CSBASE::Col::EXPORT = () ;
@CSBASE::Col::EXPORT_OK = @CSBASE::Col::EXPORT ;

sub new
  { my $TYPE = shift ;
    my $tab  = shift ;
    my $name = shift ;
    my $type = shift ;
    my $rw   = shift ;
    my $self =  bless
      { 'name', $name
      , 'type', $type
      , 'attr', { }
      , 'rw',   { 'inp', $rw }
      , 'tab', $tab
      }, $TYPE ;
    $tab -> addcol ( $self ) ;
    return $self ;
  }

sub dbh  { my $self = shift ; return $self -> {tab} -> dbh ; }
sub tab  { my $self = shift ; return $self -> {tab}  ; }
sub name { my $self = shift ; return $self -> {name} ; }
sub type { my $self = shift ; return $self -> {type} ; }
sub rw   { my $self = shift ; my $act = shift ; $self -> {rw}{$act} ; }
sub notnull { my $self = shift ; exists $self -> {attr}{notnull} ; }
sub unique  { my $self = shift ; exists $self -> {attr}{unique} ; }
sub pkey    { my $self = shift ; exists $self -> {attr}{pkey} ; }
sub fkey
  { my $self = shift ;
    exists $self -> {attr}{fkey} ?  $self -> {attr}{fkey} : undef ;
  }
sub ftab
  { my $self = shift ;
    exists $self -> {attr}{fkey} ?  $self -> {attr}{fkey} -> tab : undef ;
  }

sub reftabs
  { my $self = shift ;

    my $colname = $self -> name ;
    my $tabname = $self -> tab -> name ;
    my $base    = $self -> tab -> base  ;

    my ( @res, $tab, $col ) ;

    for $tab ( sort $base->tabs )
      { for $col ( $tab -> cols )
          { my $fkey = $col -> fkey ;
            if ( $fkey )
              { my $rtabname = $fkey -> tab -> name ;
                my $rcolname = $fkey -> name ;
                push @res, $col
                  if $rtabname eq $tabname && $rcolname eq $colname ;
              }
          }
      }
    return @res ;
  }

sub get_rec
  { my $self = shift ;
    my $key  = shift ;

    CSBASE::Rec -> new_bycol ( $self, $key ) ;
  }

sub get_data
  { my $self = shift ;
    my $sql  = shift ;

    $sql = '' unless defined $sql ;

    my $res = {} ;

    unless ( $self -> notnull && $self -> unique )
      { main::Y
         ( sprintf "get_data: field must be 'notnull' and 'unique'\n",
             $self->name, $self->tab->name
         ) ;
        return undef ;
      }

    my $st = sprintf "SELECT * FROM %s %s;",
      $self->tab->name, $sql ;
    print "get_data: $st\n" if $CSBASE::opt{v} ;
    my $sth = $self->dbh -> prepare ( $st ) ;
    if ( $self->dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;
    $sth -> execute ( ) ;
    if ( $self->dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;

    my $name = $self -> name ;
    my $tab  = $self -> tab ;

    while ( my $rec = $tab -> undef2null ( $sth->fetchrow_hashref )  )
      { $res -> { $rec->{$name} } = $rec ; }

    if ( $sth->err ) { main::Y ( $sth->errstr ) ; exit ; }

    $res ;
  }

sub has
  { my $self = shift ;
    my $pkey = shift ;
    my $data = $self -> get_data
      ( sprintf "WHERE %s = %s"
          , $self -> name
          , CSBASE::Val -> cv_val_sql ( $self, $pkey )
      ) ;
    return scalar ( keys % { $data } ) ;
  }

# sql to perl    # $pval = $col -> cv_sql_val ( $record )
# perl to sql    # @sval = $col -> cv_val_sql ( $record )

sub cv_sql_val
  { my $self = shift ;
    my $rec  = shift ;
    CSBASE::Val -> cv_sql_val ( $self, $rec -> { $self -> name } ) ;
  }

sub cv_val_sql
  { my $self = shift ;
    my $rec  = shift ;
    CSBASE::Val -> cv_val_sql ( $self, $rec -> { $self -> name } ) ;
  }

sub cv_usr_val
  { my $self = shift ;
    my $rec  = shift ;
    CSBASE::Val -> cv_usr_val ( $self, $rec -> { $self -> name } ) ;
  }

sub cv_val_usr
  { my $self = shift ;
    my $rec  = shift ;
    CSBASE::Val -> cv_val_usr ( $self, $rec -> { $self -> name } ) ;
  }

sub setrw
  { my $self = shift ;
    my $act  = shift ;
    $self -> {rw}{$act} = shift ;
  }

sub setattr
  { my $self = shift ;
    my $attr = shift ;
    my $val = shift ;
    $self -> {attr}{$attr} = $val ;
  }

sub setfkey
  { my $self = shift ;
    my $rcol = shift ;
    $self -> {attr}{fkey} = $rcol ;
  }

=pod

=head1 CSBASE::Val

=head2 Val Class Methods

  convert sql data to perl values

                 # $prl_val = cv_sql_val ( $col, $sql_val )

  convert perl data to (posibly quoted) sql values
  quotes text etc using quote ( $val ) --- ' -> '' and \ -> \\

                 # $sql_val = cv_val_sql ( $col, $prl_val )

  convert usr data to perl values

                 # $prl_val = cv_usr_val ( $col, $usr_val )

  convert perl data to usr values

                 # $usr = cv_val_usr ( $col, $prl_val )

=cut

package CSBASE::Val ;

require Exporter ;
@CSBASE::Val::ISA = qw/Exporter/ ;
@CSBASE::Val::EXPORT = () ;
@CSBASE::Val::EXPORT_OK = @CSBASE::Val::EXPORT ;

sub quote
  { my $type = shift ;
    my $val = shift ;
    $val =~ s/([\\'])/$1$1/g ;
    sprintf "'%s'", $val ;
  }

sub cv_sql_val
  { my $self = shift ;
    my $col = shift ;
    my $val = shift ;
    my $type = $col -> type ;

    printf "Val->cv_sql_val '%s', type '%s', val '%s'\n",
      $col->name, $type, ( defined $val ? $val : 'undef' )
        if $CSBASE::opt{D} ;

    if ( ! defined ( $val ) or length ( $val ) == 0 )
      { $val = CSBASE::NULL ; }
    elsif ( $type eq 'text' )
      { $val = CSBASE::NULL if $val =~ m/^\s*$/ ; }
    elsif ( $type eq 'bool' )
      { $val = ( $val ? 'TRUE' : 'FALSE')  ; }
    $val ;
  }

sub cv_val_sql
  { my $self = shift ;
    my $col = shift ;
    my $val = shift ;
    my $type = $col -> type ;

    printf "Val->cv_val_sql '%s', type '%s', val '%s'\n",
      $col->name, $type, $val if $CSBASE::opt{D} ;

    if ( $val ne CSBASE::NULL
      && ( $type eq 'text' or $type eq 'cidr' or $type eq 'ether'
        or $type eq 'date' or $type eq 'datetime'
         )
       )
      { $val = $self -> quote ($val) ; }
    $val ;
  }

sub cv_val_usr
  { my $self = shift ;
    my $col = shift ;
    my $val = shift ;
    my $type = $col -> type ;

    printf "Val->cv_val_usr '%s', type '%s', val '%s'\n",
      $col->name, $type, $val if $CSBASE::opt{D} ;

    if ( ( $val eq CSBASE::NULL ) || ( ! length ( $val ) ) )
      { '' ; }
    else
      { $val ; }
  }

sub cv_usr_val
  { my $self = shift ;
    my $col = shift ;
    my $val = shift ;
    my $type = $col -> type ;

    printf "Val->cv_usr_val '%s', type '%s', val '%s'\n",
      $col->name, $type, $val if $CSBASE::opt{D} ;

    if ( $type eq 'text' )
      { $val = CSBASE::NULL if $val =~ /^\s*$/ ; }
    elsif ( length ( $val ) == 0 )
      { $val = CSBASE::NULL ; }
    $val ;
  }

=pod

=head1 CSBASE::Rec

A CSBASE::Rec object represents a new record,
or a record in a database.

=head2 new

  CSBASE::Rec -> new ( $tab, $PVL )

=over 4

=item *

If $PVL is a hashref, the hash must contain
(col_name, value) pairs. It is used to (partially)
initialise the record data. Missing values become NULL.
This is only useful for the creation of new records.

=item *

If $PVL is NULL, a NULL record (all NULL's) is created.

=item *

If $PVL isn't a hashref or NULL, it is considered
the value of the primary key of a record
in table $tab in the appropriate database.
The record is fetched from the datebase
using DBI database handle $dbh.

=back

=head2 new_bycol

  CSBASE::Rec -> new_bycol ( $col, $PVL )

Get a record from the database,
by specifying a value $PVL
for column $col.
The specified column must have attributes
'notnull' and 'unique' set.

=head2 tab, PVL, dbh, val, etc

  $tab = $REC -> tab  #  parent table
  $PVL = $REC -> PVL  #  value of primary key
  $dbh = $REC -> dbh  #  db handle
  $val = $REC -> val  #  { col_1, val_1, ..., }
  $val = $REC -> val ( $key )
  $tag = $REC -> TAG  #  $rec->tab->TAG ( $REC->val )

yield the appropriate attributes.

=head2 set

  $rec -> set ( $key, $val )

sets record item $key to $val

=head2 insert

  $rec -> insert

inserts the record into the database.

=head2 update

  $rec -> update

updates the record in the database.
It updates all writeble columns.

=head2 delete

  $rec -> delete

deletes the record from the database.
Returns 1 if successful.

=head2 $rec -> check_new_upd

  $err = $rec -> check_new_upd ( 'new' )
  $err = $rec -> check_new_upd ( 'upd' )

checks the record for 'notnull' and 'unique' requirements
and foreign key constraints for non-null values.
The method returns an error message in case of problems.

=head2 check_delete

  $err = $rec -> check_delete

checks the record for violation of foreign key constraints.
The method returns an error message in case of problems.

=head2 dump

  $str = $rec -> dump ( $act )

return formatted content of the record.
$act can be 'new', 'upd' or 'all', showing
$tab -> w_cols ( 'new' ), $tab -> 'w_cols ( 'upd' )
or all columns.

=cut

package CSBASE::Rec ;

sub get_rec
  { my $tab = shift ;
    my $col = shift ;
    my $key = shift ;

    my ( $st, $sth, $ref ) ;

    unless ( $col -> notnull && $col -> unique )
      { main::Y
         ( sprintf "get_rec: field must be 'notnull' and 'unique'\n",
             $col->name, $tab->name
         ) ;
        return undef ;
      }

    $st = sprintf "SELECT * FROM %s WHERE %s = %s ;",
      $tab->name, $col->name,
      CSBASE::Val->cv_val_sql ( $col, $key) ;
    print "CSBASE::Rec::get_rec: $st\n" if $CSBASE::opt{v} ;
    $sth = $tab->dbh -> prepare ( $st ) ;
    if ( $tab->dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;
    $sth -> execute ( ) ;
    if ( $tab->dbh -> err ) { main::Y ( $DBI::errstr ) ; exit ; } ;

    $tab -> undef2null ( $sth->fetchrow_hashref ) ;
  }

sub new_rec
  { my $self = bless {} ;

    $self -> {tab} = shift ;
    $self -> {PVL} = shift ;

    return $self ;
  }

sub names { map { $_ -> name ; } @_ ; }

sub new
  { my $type = shift ;
    my $self = new_rec ( @_ ) ;

    my $fmt = "*** CSBASE::Rec->new: unknown col spec %s for tab %s\n" ;

    my $tab = $self -> {tab} ;
    my $PVL = $self -> {PVL} ;

    if ( ref $PVL )
      { $self = $tab -> null ;
        for my $key ( keys %{ $PVL } )
          { unless ( defined $self -> {val} -> {$key} )
              { printf $fmt, $key, $tab->name ; exit ; }
            else
              { $self -> {val} -> {$key} = $PVL->{$key} ; }
          }
      }
    elsif ( $PVL eq CSBASE::NULL )
      { for my $col ( $tab -> cols )
          { $self -> {val} -> { $col->name } = CSBASE::NULL ; }
      }
    else
      { $self -> {val} = get_rec ( $tab, $tab -> pkey, $PVL ) ; }

    return $self ;
  }

sub dump
  { my $self = shift ;
    my $act  = shift ;
    my $tab = $self -> tab ;
    my $w = $tab -> width () + length ( $tab -> name ) ;
    my $res = '' ;
    my @cols = 
      ( $act eq 'all'
      ? $self->{tab} -> cols
      : $self->{tab} -> w_cols ( $act )
      ) ;
    my @vals = map { $_ -> cv_val_sql ( $self->{val} ) ; } @cols ;
    for my $col ( @cols )
      { $res .= sprintf "%-${w}s -> %s\n",
          $tab->name . '.' . $col->name, shift @vals ;
      }
    return $res ;
  }

sub new_bycol
  { my $type = shift ;
    my $col  = shift ;
    my $PVL  = shift ;
    my $tab = $col -> tab ;
    my $res  = new_rec ( $col->tab, $PVL ) ;

    my $val = get_rec ( $col->tab, $col, $PVL ) ;

    if ( defined $val )
      { $res -> {val} = get_rec ( $col->tab, $col, $PVL ) ;
        $res -> {PVL} = $res -> val ( $tab -> pkey -> name ) ;
      }
    else
      { $res = undef ; }

    return $res ;
  }

sub tab { my $self = shift ; $self -> {tab} ; }
sub PVL { my $self = shift ; $self -> {PVL} ; }

sub TAG { my $self = shift ; $self -> tab -> TAG ( $self->val ) ; }

sub val
  { my $self = shift ;
    if ( ! exists $self -> {val} or ! defined $self -> {val} )
      { undef ; }
    if ( @_ == 0 )
      { $self -> {val} ; }
    else
      { $self -> {val} -> { $_[0] } ; }
  }

sub set
  { my $self = shift ;
    my $key = shift ;
    my $val = shift ;
    $self -> {val} -> { $key } = $val ;
  }

sub dbh { my $self = shift ; $self -> tab -> dbh ; }

sub insert
  { my $self = shift ;
    my $dbh  = $self -> dbh ;

    printf "Rec->insert: tab '%s' PVL '%s'\n" ,
      $self->tab->name, $self->PVL if $CSBASE::opt{v} ;

    my ( $res, $st, @cols, @vals ) ;

    @cols = $self->{tab} -> w_cols ( 'new' ) ;
    @vals = map { $_ -> cv_val_sql ( $self->{val} ) ; } @cols ;

    unless ( @cols )
      { printf "Rec->insert: no cols to update\n" ;
        return 1 ;
      }

    my $cols = join ( ', ', map { $_->name ; } @cols ) ;
    my $vals = join ( ', ', @vals ) ;
    $st = sprintf "INSERT INTO %s (%s) VALUES (%s) ;",
       $self->tab->name, $cols, $vals ;

    print "Rec->insert: $st\n" if $CSBASE::opt{v} ;

    if ( $dbh -> do ( $st ) )
      { $res = $dbh->{AutoCommit} ? 'ok' : $dbh->commit ;
        main::Y ( $DBI::errstr ) unless $res ;
      }
    else
      { main::Y ( $DBI::errstr ) ;
        $res = 0 ;
        $dbh -> rollback unless $dbh->{AutoCommit} ;
      }
    $res ;
  }

sub update
  { my $self = shift ;
    my $dbh  = $self -> dbh ;

    printf "Rec->update: tab '%s' PVL '%s'\n" ,
      $self->tab->name, $self->PVL if $CSBASE::opt{d} ;

    my ( $res, $st, @cols, @vals ) ;

    @cols = $self->{tab} -> w_cols ( 'upd' ) ;
    @vals = map { $_ -> cv_val_sql ( $self->{val} ) ; } @cols ;

    unless ( @cols )
      { printf "Rec->update: no cols to update\n" if $CSBASE::opt{d} ;
        return 1 ;
      }

    my $pkey = $self->tab->pkey ;
    my $pval = $pkey -> cv_val_sql ( $self->{val} ) ;
    my @asig ;
    while ( @cols )
      { my $col = shift @cols ; my $val = shift @vals ;
        push @asig, sprintf '%s=%s', $col->name, $val ;
      }
    $st = sprintf "UPDATE %s SET %s WHERE %s=%s ;",
      $self->tab->name,
      join ( ', ', @asig ),
      $pkey->name, $pval ;

    print "Rec->update: $st\n" ;

    if ( $dbh -> do ( $st ) )
      { $res = $dbh->{AutoCommit} ? 'ok' : $dbh->commit ;
        main::Y ( "Rec->update: $DBI::errstr" ) unless $res ;
      }
    else
      { main::Y ( "Rec->update: $DBI::errstr" ) ;
        $res = 0 ;
        $dbh -> rollback unless $dbh->{AutoCommit} ;
      }
    $res ;
  }

sub delete
  { my $self = shift ;
    my $dbh  = $self -> dbh ;

    printf "Rec->delete: tab '%s' PVL '%s'\n" ,
      $self->tab->name, $self->PVL if $CSBASE::opt{v} ;

    my ( $res, $st ) ;

    $st = sprintf "DELETE FROM %s WHERE %s = %s ;" ,
      $self->tab->name , $self->tab->pkey->name,
      CSBASE::Val->cv_val_sql ($self->tab->pkey, $self->PVL ) ;

    print "Rec->delete: $st\n" ;

    if ( $dbh -> do ( $st ) )
      { $res = $dbh->{AutoCommit} ? 'ok' : $dbh->commit ;
        main::Y ( $DBI::errstr ) unless $res ;
      }
    else
      { main::Y ( $DBI::errstr ) ;
        $dbh -> rollback unless $dbh->{AutoCommit} ;
        $res = 0 ;
      }
    $res ;
  }

sub not_uniq
  { my $self = shift ;
    my $col = shift ;
    my $act = shift ;

    my $colval = $self -> val ( $col->name ) ;

    my $sql = sprintf 'WHERE %s = %s ',
      $col->name, CSBASE::Val->cv_val_sql ($col, $colval ) ;

    if ( $act eq 'upd' )
      { my $pkey = $self -> tab -> pkey ;
        my $pval = $self->val ( $pkey->name ) ;
        $sql .= sprintf 'AND %s <> %s', $pkey->name,
          CSBASE::Val->cv_val_sql ( $pkey, $pval ) ;
      }

    my $itm = $col -> tab -> get_data ( $sql ) ;

    scalar keys %{ $itm } ;
  }

sub check_new_upd
  { my $self = shift ;
    my $act = shift ;

    printf "Rec->check_new_upd tab '%s' PVL '%s' act '%s'\n",
      $self->tab->name, $self->PVL, $act if $CSBASE::opt{d} ;

    my ( $col, @null, @uniq, @rcol, $err ) ;

    for $col ( $self -> tab -> w_cols ( $act ) )
      { my $val = $self -> val ( $col->name ) ;
        my $rcol = $col -> fkey ;

        printf "Rec->check_new_upd: write %s = %s\n", $col -> name,
          CSBASE::Val->cv_val_sql($col, $val) if $CSBASE::opt{v} ;

        if ( $val eq CSBASE::NULL and $col -> notnull )
          { push @null, $col ; }
        if ( $val ne CSBASE::NULL and $col -> unique
               and $self -> not_uniq ( $col, $act )
           )
          { push @uniq, $col ; }
        if ( $val ne CSBASE::NULL
         and defined $rcol
         and ! $rcol -> has ( $val )
           )
          { push @rcol, sprintf "%s '%s' not found in %s.%s",
              $col -> name, $val, $rcol -> tab -> name, $rcol -> name ;
          }
      }

    $err .= sprintf "illegal NULL in [ %s ]\n"
      , join ', ', names @null if @null ;
    $err .= sprintf "new value not uniq in [ %s ]\n"
      , join ', ', names @uniq if @uniq ;
    $err .= sprintf "foreign key violation: %s"
      , join "\n  ", @rcol if @rcol ;
    $err ;
  }

sub check_delete
  { my $self = shift ;

    my $pkey = $self -> tab -> pkey ;
    my $ptag = $self -> tab -> TAG ( $self -> val ) ;
    my $sval = $pkey -> cv_val_sql ( $self -> val ) ;

    printf "Rec::View->check_delete: tab '%s' PVL '%s' ptag '%s'\n",
      $self->tab->name, $self->PVL, $ptag if $CSBASE::opt{d} ;

    my ( $itm, $err ) ;

    $err = '' ;

    for my $col ( $self -> tab -> cols )
      { for my $rcol ( $col -> reftabs )
          { my $rtab = $rcol -> tab ;
            my $sql = sprintf "WHERE %s = %s", $rcol->name, $sval ;
            $itm = $rtab -> get_data ( $sql ) ;
            for my $rkey ( sort keys %{ $itm } )
              { $err .= sprintf "table %-12s col %-12s record %-12s\n",
                  $rtab->name, $rcol->name, $rtab -> TAG ( $itm->{$rkey} ) ;
              }
          }
      }
    $err = sprintf
             "You can't delete this record, "
           . "'%s' is refered to in:\n"
           . "%s", $ptag, $err if $err ;

    $err ;
  }

=pod

=head1 CSBASE::Rec::View

=head2 new, show

  $rec = CSBASE::Rec::View -> new ( $tab, $PVL, $action, $frame )
  $rec -> show

A CSBASE::Rec::View objects represents a record presentation.
The record, identified by $tab and $PVL, is presented in $frame.
All necessary information is fetched through database handle of $tab.

The presentation comes in 4 forms:

=over 4

=item 'blank'

Only the column names and attributes ('notnull' and 'unique')
are given. $PVL is ignored.

=item 'shw'

For each column, the following is presented:

  attributes
  name
  value of the field in record ($tab, $PVL)

=item 'new'

For each column, the following is presented:

  attributes
  name
  data entry field

The content of the data entry field depents on the type and attributes
of the column. A foreign key is represented by a listbox, a bool by
a true/false-menu button, others by a text box.
Null values are pre-selected where permitted.
$PVL may be a hashref containing initial values for the new record.

=item 'upd'

For each column, the following is presented:

  attributes
  name
  value of the field in record ($tab, $PVL)
  data entry field

=back

A CSBASE::Rec::View objects maintains two versions of the record data:
a val-version and a usr-version. The first uses the internal value
format (eg 'NULL' for NULL values), the second uses the 'user' format
(eg '' for NULL values). In the 'new' and 'upd' presentations,
the user manipulates the usr-version of the data.

=head2 cv_usr_val

  $rec -> cv_usr_val

The usr-version of the record data is converted to value-format
and copied to the val-version of the record data.

=head2 change

  $rec -> change

Insert/update the record in the database;
only meaningfull after a 'new' or 'upd'.
Uses the val-version of the record data.

=head2 check_change

  $rec -> check_change

Check 'notnull' and 'unique' requirements for the record;
Uses the val-version of the record data.
only meaningfull after a 'new' or 'upd'.
Uses the val-version of the record data.

=head2 col_fk, set_col_fk

  $bool = $rec -> set_col_fk ( $col_name, $sql )
  $sql  = $rec -> col_fk ( $col_name )

Sets additional sql for remote key $colname of $rec->tab.
It is used in 'new' and 'upd' presentations.
$col_name must be the name of some column $col of $rec->tab
where $col refers to a foreign key ($rtab, $rcol).
$sql is added to the query to fetch the content of $rtab
(default "SELECT * FROM $rtab->name") so must be like
"WHERE some_col_name = NULL".

=cut

package CSBASE::Rec::View ;

@CSBASE::Rec::View::ISA = qw(CSBASE::Rec) ;

sub names { map { $_ -> name ; } @_ ; }

sub new
  { my $type   = shift ;
    my $tab    = shift ;
    my $PVL    = shift ;
    my $action = shift ;
    my $frame  = shift ;

    printf "Rec::View->new: act '%s' tab '%s' PVL '%s'\n",
      $action, $tab->name, $PVL if $CSBASE::opt{d} ;

    $PVL = CSBASE::NULL if $action eq 'blank' ;
    $PVL = CSBASE::NULL if $action eq 'new' && ! ref $PVL ;

    my $NEW = bless CSBASE::Rec -> new ( $tab, $PVL ), $type ;

    $NEW -> {act} = $action ;
    $NEW -> {usr} = $tab -> cv_val_usr ( $NEW->{val} ) ;
    $NEW -> {frm} = $frame ;

    for my $col ( $tab -> cols )
      { $NEW -> {sql} -> { $col->name } = '' ; }

    return $NEW ;
}

sub act { my $self = shift ; $self -> {act} ; }
sub usr { my $self = shift ; $self -> {usr} ; }
sub frm { my $self = shift ; $self -> {frm} ; }
sub sql { my $self = shift ; $self -> {sql} ; }

sub show
  { my $self = shift ;

    printf "Rec::View->show: act '%s' tab '%s' PVL '%s'\n",
      $self->{act}, $self->tab->name, $self->{PVL} if $CSBASE::opt{d} ;

    my ( $col, $lab ) ;

    my $col_width = $self->{tab} -> width ;

    for $col ( $self->tab->cols )
      { my $cname = $col->name ;
        my $val_col = $self->{val}{$cname} ;
        my $usr_col = $self->{usr}{$cname} ;
        my $val_lab = $val_col ;
        my $fkey = $col -> fkey ;
        my $null = not $col -> notnull ;
        my $uniq = $col -> unique ;
        my $alab = sprintf "%4s %4s "
          , ( $null ? 'null' : '' )
          , ( $uniq ? 'uniq' : '' )
          ;
        my $red = ( $self->{act} eq 'new' || $self->{act} eq 'upd' )
          && ( ! $null ) && ( $col -> rw ( $self->{act} ) eq 'write' ) ;

        if ( $self->{act} eq 'shw' || $self->{act} eq 'upd' )
          { if ( $fkey && $val_col ne CSBASE::NULL )
              { my $rcol = $fkey ;
                my $rtab = $rcol -> tab ;
                my $rec = $rcol -> get_rec ( $val_col ) ;
                printf "*** can't get_rec(%s,%s)\n", $rcol->name, $val_col
                  unless $rec ;
                $lab = $rec -> TAG ;
                $val_lab .= sprintf " (%s)", $lab if $lab ne $val_lab ;
              }
          }

        my $fr_col = $self->{frm}  -> Frame ( ) ;
        $fr_col -> pack ( -side, 'top', -expand, 1, -fill, 'x' ) ;

        $fr_col -> Label ( -text, $alab, -width, 10, -anchor, 'w' )
          -> pack ( -side, 'left' ) ;

        $fr_col -> Label
          ( -text, $cname, -width, $col_width
          , -anchor, 'w'
          , -foreground, ( $red ? 'red' : 'blue' )
          ) -> pack ( -side, 'left' ) ;

        if ( $self->{act} eq 'shw' )
          { $fr_col -> Label
              ( -text, $val_lab, -justify, 'left', -anchor, 'w' )
                -> pack ( -side, 'left' ) ;
          }
        elsif ( $self->{act} eq 'new' )
          { $self -> genNEW ( $col, $fr_col )
              -> pack ( -side, 'left' ) ;
          }
        elsif ( $self->{act} eq 'upd' )
          { $fr_col
              -> Label ( -text, $val_lab, -width, 35, -anchor, 'w'
                       , -justify, 'left'
                       )
                -> pack ( -side, 'left' )
                  if ( $self->{act} eq 'upd' ) ;
            $self -> genNEW ( $col, $fr_col )
              -> pack ( -side, 'left' ) ;
          }
      }
  }

sub col_sql
  { my $self = shift ;
    my $col = shift ;
    $self -> {sql} -> { $col->name } ;
  }

sub set_col_sql
  { my $self = shift ;
    my $colname = shift ;
    my $sql = shift ;
    my $res = undef ;
    my $col ;

    unless ( $col = $self -> tab -> colbyname ( $colname ) )
      { main::Y ( sprintf "col %s not in tab %s",
          $colname, $self->tab->name ) ;
      }
    elsif ( ! $col->fkey )
      { main::Y ( sprintf "col %s tab %s not an fkey",
          $col->name, $col->tab->name ) ;
      }
    else
      { $self -> {sql} -> { $colname } = $sql ; $res = 1 ; }
    $res ;
  }

sub cv_usr_val
  { my $self = shift ;
    $self -> {val} = $self -> tab -> cv_usr_val ( $self -> {usr} ) ;
  }

sub check_change
  { my $self = shift ; $self -> check_new_upd ( $self -> act ) ; }

sub change
  { my $self = shift ;
    if ( $self -> act eq 'new' )
      { $self -> insert ; }
    elsif ( $self -> act eq 'upd' )
      { $self -> update ; }
    else
      { printf "*** Rec::View->change: unknown action '%s'\n", $self->act ; }
  }

sub genNEWselect
  { my $self = shift ;
    my $col = shift ;
    my $parent = shift ;

    my $null = not $col -> notnull ;
    my $rcol = $col -> fkey ;

    my $cname  = $col  -> name ;
    my $rcname = $rcol -> name ;
    my $rtab   = $rcol -> tab ;
    my $rtname = $rtab -> name ;

    print "genNEWselect: col '$cname' rtab '$rtname' rcol '$rcname'\n"
      if $CSBASE::opt{d} ;

    my ( $res, $st, $sth, $ref, $rkey, @itms, $tag, %rkey ) ;
    my ( @idx, %idx, $idx ) ;

    $st = sprintf "SELECT * FROM %s %s ;",
      $rtab -> name, $self->{sql}{$col->name} ;
    print "genNEWselect: $st\n" if $CSBASE::opt{v} ;
    $sth = $self->dbh->prepare($st)
      or do { $self->dbh->disconnect ; die ; } ;
    $sth->execute or do { $self->dbh->disconnect ; die ; } ;

    while ( $ref = $rtab -> undef2null ( $sth->fetchrow_hashref ) )
      { $rkey = $rcol -> cv_val_usr ( $ref ) ;
        $tag = $rtab -> TAG ( $ref ) ;
        push @itms, [ $rkey, $tag ] ;
        print "*** tag $tag ($rkey) is not uniq in ($rtname,$rcname)\n"
          if exists $rkey{$tag} ;
        $rkey{$tag} = $rkey ;
      }

    @itms = sort { $a->[1] cmp $b->[1] } @itms ;

    if ( $null )
      { unshift @itms, [ '' , CSBASE::NULL ] ;
        $rkey{CSBASE::NULL} = '' ;
      }

    $res = $parent -> Scrolled
      ( "Listbox"
      , -selectmode, 'browse'
      , -scrollbars, 'e'
      , -exportselection, 0
      , -height, 6
      , -selectforeground, 'red'
      ) ;
    for $ref ( @itms )
      { $res -> insert ( 'end', $ref->[1] ) ;
        push @idx, $ref->[0] ;
        $idx{$ref->[0]} = $idx++ ;
      }
    $res -> bind
      ( '<Button-1>'
      , sub { my $idx = $res -> curselection() ;
              $idx = $idx -> [ 0 ] if ref $idx ; 
              printf "picker curselection col '%s' itm '%s'\n",
                $col->name, $idx if $CSBASE::opt{d} ;
              $self->{usr}{$col->name} = $idx[$idx] ;
            }
      ) ;
    $res -> bind
      ( '<Key-Return>'
      , sub { my $idx = $res -> index ( 'active' ) ;
              printf "picker curselection col '%s' itm '%s'\n",
                $col->name, $idx if $CSBASE::opt{d} ;
              $self->{usr}{$col->name} = $idx[$idx] ;
            }
      ) ;
    if ( exists $idx{$self->{usr}{$cname}} )
      { my $idx = $idx{$self->{usr}{$cname}} ;
        $res -> selectionSet ( $idx ) ;
        $res -> see ( $idx ) ;
      }
    elsif ( $self->{usr}{$cname} ne
            CSBASE::Val -> cv_val_usr ( $col, CSBASE::NULL )
          )
      { print "*** no rkey '%s' in tab '%s.%s'\n",
          $self->{usr}{$cname}, $rtname, $rcname ;
      }
    return $res ;
  }

sub genNEWbool
  { my $self = shift ;
    my $col  = shift ;
    my $parent = shift ;

    my $null = not $col -> notnull ;

    printf "genNEWbool: col '%s' null '%s'\n",
      $col->name, $null if $CSBASE::opt{d} ;

    my ( $res, $options ) ;

    $options = [ 'TRUE', 'FALSE' ] ;

    if ( $null ) { unshift @{ $options }, CSBASE::NULL ; }

    $res = $parent -> Optionmenu
       ( -textvariable, \$self->{usr}{$col->name}
       , -options, $options
       ) ;
    return $res ;
  }

sub genNEWether
  { my $self = shift ;
    my $col  = shift ;
    my $parent = shift ;

    printf "genNEWint: col '%s'\n", $col->name if $CSBASE::opt{d} ;

    my $res ;

    $res = $parent -> Entry
      ( -textvariable, \$self->{usr}{$col->name}, -width, 12 ) ;

    $res -> bind
      ( '<Key>'
      , sub
         { $res->bell() if $self->{usr}{$col->name} =~ s/[^0-9a-fA-F]//g ;
           if ( length $self->{usr}{$col->name} > 12 )
             { $res->bell() ;
               $self->{usr}{$col->name} =
                 substr $self->{usr}{$col->name}, 0, 12 ;
             }
         }
      ) ;

    return $res ;
  }

sub genNEWint
  { my $self = shift ;
    my $col  = shift ;
    my $parent = shift ;

    printf "genNEWint: col '%s'\n", $col->name if $CSBASE::opt{d} ;

    my $res ;

    $res = $parent -> Entry ( -textvariable, \$self->{usr}{$col->name} ) ;

    $res -> bind
      ( '<Key>'
      , sub { $res->bell() if $self->{usr}{$col->name} =~ s/\D//g ; }
      ) ;

    return $res ;
  }

sub genNEWdate
  { my $self = shift ;
    my $col  = shift ;
    my $parent = shift ;

    printf "genNEWdate: col '%s'\n", $col->name if $CSBASE::opt{d} ;

    my $res ;
    my ( $dd, $mm, $yy ) = ( '', '', '' ) ;

    ( $yy, $mm, $dd ) = split /-/, $self->{usr}{$col->name}
        if defined $self->{usr}{$col->name}
          and $self->{usr}{$col->name} =~ /-/ ;


    $res = $parent -> Frame () ;
    $res -> pack ( -side, 'top', -anchor, 'w' ) ;
    $res -> Label ( -text, 'd' ) -> pack ( -side, 'left' ) ;
    my $wdd = $res -> Entry ( -textvariable, \$dd , -width, 2 )
      -> pack ( -side, 'left' ) ;
    $res -> Label ( -text, 'm' ) -> pack ( -side, 'left' ) ;
    my $wmm = $res -> Entry ( -textvariable, \$mm , -width, 2 )
      -> pack ( -side, 'left' ) ;
    $res -> Label ( -text, 'y' ) -> pack ( -side, 'left' ) ;
    my $wyy = $res -> Entry ( -textvariable, \$yy , -width, 4 )
      -> pack ( -side, 'left' ) ;

    $wdd -> bind
      ( '<Key>'
      , sub { $res->bell() if $dd =~ s/\D//g ;
              if ( length $dd > 2 )
                { $dd = substr $dd, 0, 2 ; $res->bell() ; }
              $self->{usr}{$col->name} =
                ( length "$yy$mm$dd" == 0 
                ? ''
                : sprintf "%04d-%02d-%02d" , $yy, $mm, $dd
                ) ;
            }
      ) ;

    $wmm -> bind
      ( '<Key>'
      , sub { $res->bell() if $mm =~ s/\D//g ;
              if ( length $mm > 2 )
                { $mm = substr $mm, 0, 2 ; $res->bell() ; }
              $self->{usr}{$col->name} =
                ( length "$yy$mm$dd" == 0 
                ? ''
                : sprintf "%04d-%02d-%02d" , $yy, $mm, $dd
                ) ;
            }
      ) ;

    $wyy -> bind
      ( '<Key>'
      , sub { $res->bell() if $yy =~ s/\D//g ;
              if ( length $yy > 4 )
                { $yy = substr $yy, 0, 4 ; $res->bell() ; }
              $self->{usr}{$col->name} =
                ( length "$yy$mm$dd" == 0 
                ? ''
                : sprintf "%04d-%02d-%02d" , $yy, $mm, $dd
                ) ;
            }
      ) ;
    return $res ;
  }

sub genNEW
  { my $self   = shift ;
    my $col    = shift ;
    my $fr_col = shift ;

    my $action = $self->{act} ;
    my $cname = $col->name ;

    printf "genNEW: tab '%s' col '%s'\n",
      $col -> tab -> name, $col -> name if $CSBASE::opt{d} ;

    my $fkey = $col -> fkey ;
    my $type = $col -> type ;
    my $null = not $col -> notnull ;
    my $res ;

    if ( $col -> rw ( $action ) eq 'read' )
      { $res = $fr_col ->
          Label ( -text, ( $action eq 'new' ? 'generated' : 'readonly' )
                , -anchor, 'w'
                ) ;
      }
    elsif ( $fkey )
      { $res = $self -> genNEWselect ( $col, $fr_col ) ; }
    elsif ( $type eq 'bool' )
      { $res = $self -> genNEWbool ( $col, $fr_col ) ; }
    elsif ( $type =~ /^int/ )
      { $res = $self -> genNEWint ( $col, $fr_col ) ; }
    elsif ( $type eq 'ether' )
      { $res = $self -> genNEWether ( $col, $fr_col ) ; }
    elsif ( $type eq 'date' )
      { $res = $self -> genNEWdate ( $col, $fr_col ) ; }
    else # text
      { $res = $fr_col -> Entry ( -textvariable, \$self->{usr}{$cname} ) ; }

    return $res ;
  }

1 ;