#! /usr/bin/perl -w

# Copyright (c) 2010-2011 Koos van den Hout, Henk P. Penning.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
#   1. Redistributions of source code must retain the above copyright notice,
#      this list of conditions and the following disclaimer.
#
#   2. Redistributions in binary form must reproduce the above copyright
#      notice, this list of conditions and the following disclaimer in the
#      documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY Koos van den Hout, Henk P. Penning, ``AS IS''
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Koos van den Hout or Henk P.
# Penning OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
# TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# The views and conclusions contained in the software and documentation are
# those of the authors and should not be interpreted as representing official
# policies, either expressed or implied, of Koos van den Hout, Henk P. Penning.
# -----------------------------------------------------------------------------
# "Simplified BSD License" or "FreeBSD License"
# http://en.wikipedia.org/wiki/BSD_licenses

use strict ;

package Blib ; ##############################################################

use Exporter ;
use Carp ;

our ( @EXPORT, @EXPORT_OK, @ISA ) ;
BEGIN
  { require Exporter ;
    @EXPORT    = qw() ;
    @EXPORT_OK = qw(mk_method mk_methods new_pack unref) ;
    @ISA       = qw(Exporter)
  }

our %LOGLEVELS =
  ( quiet   => 0
  , terse   => 1
  , verbose => 2
  , debug   => 3
  ) ;

our $MEEK = {} ;

sub unref ;
sub MEEK { $MEEK } ;
sub MEEK_incr
  { my $pack = unref shift ;
    $MEEK -> { $pack } { incr } ++ ;
  }
sub MEEK_decr
  { my $pack = unref shift ;
    $MEEK -> { $pack } { decr } ++ ;
  }
sub MEEK_dump
  { join '', map
      { my $incr = $MEEK -> { $_ } { incr } || 0 ;
        my $decr = $MEEK -> { $_ } { decr } || 0 ;
        sprintf "%6s %6s %s\n", $incr, $incr - $decr, $_ ;
      } sort keys %$MEEK ;
  }

# DESTROY { my $self = shift ; MEEK_decr ( $self ) ; }

sub unref { my $self = shift ; ref $self or $self ; }
sub _bless
  { my $val = shift ;
    my $pac = shift ;
#   MEEK_incr ( $pac ) ;
    bless $val, $pac ;
  }

sub _is_loglevel
  { my $self = shift ; my $cand = shift ; exists $LOGLEVELS { $cand } ; }
sub _loglevels
  { my $self = shift ;
    sort { $LOGLEVELS { $a } <=> $LOGLEVELS { $b } ; } keys %LOGLEVELS ;
  }

sub _pr
  { my @args = @_ ;
    if ( Blib::Mods -> can ( 'print' ) )
      { Blib::Mods::print ( @args ) ; }
    else
      { print @args ; }
  }

sub _pf
  { my @args = @_ ;
    if ( Blib::Mods -> can ( 'printf' ) )
      { Blib::Mods::printf ( @args ) ; }
    else
      { printf @args ; }
  }

sub _pr_hash
  { die "_pr_hash : need 2 args" unless @_ == 2 ;
    my $tag  = shift ;
    my $hash = shift ;
    _pf "%s :\n\{%s\n\}\n", $tag , join "\n, ", map
      { my $val = $hash -> { $_ } ;
        sprintf "%s=>%s", $_, ( defined $val ? $val : 'UNDEF' )
      } sort keys %$hash ;
  }

my %Opts = () ;
sub Opts
  { my $self = shift ;
    $Opts { $self } = { q => 0 , t => 0 , v => 0 , d => 0 , self => $self }
      unless exists $Opts { $self } ;
    $Opts { $self } ;
  }

sub dmp_opt
  { my $hash = shift ;
    sprintf "{%s}\n"
      , join ' , '
      , map { "$_=>$hash->{$_}" }
        ( 'self', sort grep { $_ ne 'self' } keys %{ $hash } ) ;
  }

my $level = 0 ;
sub lvl { my $lvl = shift ; $level = $lvl if defined $lvl ; $lvl ; }
sub xx1 { Blib::_pr ( @_ ) if $level > 0 ; }
sub xx2 { Blib::_pr ( @_ ) if $level > 1 ; }

sub _opt
  { my $self = shift ;
    my ( $recurse, $key, $val ) = @_ ;

    unless ( $self ) { xx1 "self empty ; result=0" ; return 0 ; }

    my $opts   = Opts $self ;
    my $parent = $self -> parent ;

    my $v = ( defined $val ? $val : '<undef>' ) ;
    xx1 "self ($self) key ($key) val ($v) recurse ($recurse)\n" ;
    xx1 dmp_opt $opts ;

    unless ( exists $opts -> { $key } )
      { Carp::confess "_opt : unknown option '$key'\n" ; }
    elsif ( defined $val )
      { Carp::confess "_opt : bad arg ($val)" if $val eq 'Blib' ;
        $opts -> { $key } = $val ;
        xx1 "set key ($key) val ($val)\n" ;
      }

    $val = $opts -> { $key } ;

    xx1 "key ($key) => val ($val)\n" ; xx1 dmp_opt ( $opts ) ;

    my $res = 0 ;
    if ( ! defined $val )
      { $res = 0 ;
        xx2 "undef\n" ;
      }
    elsif ( $val )
      { $res = $val % 2 ;
        xx2 sprintf "result ($val)\n" ;
      }
    elsif ( $recurse and $parent )
      { xx1 "recurse\n" ;
        $res = $parent -> _opt ( $recurse, $key, undef ) ;
      }
    else
      { xx2 "else ($val)\n" ; }
    xx1 "=> self ($self) key ($key) res ($res)\n" ;
    $res ;
  }

sub _dqv { my $self = shift ; xx1 "\n" ; $self -> _opt ( @_ ) ; }

sub quiet      { my $self = shift ; $self -> _dqv ( 1, 'q', shift ) ; }
sub quiet_me   { my $self = shift ; $self -> _dqv ( 0, 'q', shift ) ; }
sub terse      { my $self = shift ; $self -> _dqv ( 1, 't', shift ) ; }
sub terse_me   { my $self = shift ; $self -> _dqv ( 0, 't', shift ) ; }
sub verbose    { my $self = shift ; $self -> _dqv ( 1, 'v', shift ) ; }
sub verbose_me { my $self = shift ; $self -> _dqv ( 0, 'v', shift ) ; }
sub debug      { my $self = shift ; $self -> _dqv ( 1, 'd', shift ) ; }
sub debug_me   { my $self = shift ; $self -> _dqv ( 0, 'd', shift ) ; }

sub set_opts
  { my $self = shift ;
    my %opts = @_ ;
    if ( $opts{d} )
      { $self -> set_loglevel ( 'debug' ) ; }
    elsif ( $opts{v} )
      { $self -> set_loglevel ( 'verbose' ) ; }
    elsif ( $opts{q} )
      { $self -> set_loglevel ( 'quiet' ) ; }
    else
      { $self -> set_loglevel ( 'terse' ) ; }
  }

# parent '' is '' ; the parent of an object instance is it's class
sub parent
  { my $self = shift ;
    if ( ref $self )
      { ref $self ; }
    elsif ( $self =~ /^\w*$/ )
      { '' ; }
    elsif ( $self =~ /::\w+$/ )
      { $` ; }
    else
      { Carp::confess "parent : bad arg ($self)" ; }
  }

sub set_loglevel
  { my $self  = shift ;
    my $level = shift ;
    my $where = shift ;

    if ( Blib -> _is_loglevel ( $level ) )
      { my $mark = $LOGLEVELS { $level } ;
        for my $llvl ( keys %LOGLEVELS )
          { $self -> $llvl ( $LOGLEVELS { $llvl } <= $mark ) ; }
        Blib::_pf
          ( "set loglevel $self '%s' (%s)\n"
          , $level , ( $where || 'somewhere' )
          ) if $where or $self -> debug ;
      }
    else
      { Carp::confess "set_log_level : bad level ($level)" ; }
  }

sub new
  { my $self = shift ;
    my $name = shift ;
    if ( defined $name )
      { $self = "${self}::${name}" ;
        Carp::confess "Blib::new : bad name ($name)"
          if $name =~ /^Dbs|Tab|Rec|Mods$/ ;
        new_pack ( 'Blib', 'Mods' ) ;
        new_pack ( 'Blib', $name ) ;
        new_pack ( $self ) ;
      }
    _bless {}, $self ;
  }

sub make
  { my $self = shift ;
    my @args = @_ ;
    $self -> new -> init ( @args ) ;
  }

sub add_ISA
  { my $self = shift ;
    my $pack = shift ;
    my $isa  = sprintf 'push @%s::ISA, "%s" ;', $self, $pack ;
    Blib::_pr ( "\n# multiple inheritance for $self\n$isa\n\n" )
      if Blib -> debug ;
    my $res = eval "$isa 1 ;" ;
    Carp::confess "add_isa : $@" unless defined $res ;
    $res ;
  }

my %_dumped ;
my %_nodump ;
my $_verbos ;

sub _dmpval
  { my $self  = shift ;
    my $val   = shift ;
    my $depth = shift ;
    my $sep = ' ' x ( 2 * $depth ) ;
    
    my $dmp ;

    if ( ! defined $val )
      { $dmp = '<undef>' ; }
    elsif ( ref $val and eval { $val -> can ( 'dmp' ) } )
      { if ( exists $_dumped { $val } ) 
          { $dmp = "recursed ($val)" ; }
        else
          { $_dumped { $val } ++ ;
            $dmp = $val -> _dmp ( $depth + 1 ) ;
          } ;
      }
    elsif ( ref $val eq 'ARRAY' )
      { my $can = ( @$val and eval { $val -> [ 0 ] -> can ( 'dmp' ) } ) ;
        $dmp =
          ( scalar @$val
          ? sprintf "\n${sep}  [ %s\n$sep  ]"
              , join "\n$sep  , "
              , ( $can
                ? map { $_ -> _dmp ( $depth + 1 ) } @$val
                : @$val 
                ) 
          : '[]'
          ) ;
      }
    elsif ( ref $val eq 'HASH' )
      { $dmp =
          ( scalar keys %$val
          ? sprintf "\n${sep}  { %s\n$sep  }"
              , join "\n$sep  , "
              , map { sprintf "%s => %s", $_, $val -> { $_ } }
                  sort keys %$val
          : '{}'
          ) ;
      }
    elsif ( ! ref $val and $val eq '' )
      { $dmp = '<empty>' ; }
    else
      { $val =~ s/(ARRAY|HASH)\(\w+\)/$1/ ;
        $dmp = $val ;
      }
    $dmp ;
  }

sub _dmp
  { my $self  = shift ;
    my $depth = shift ;
    my $ref = ref $self ;
    %_dumped = () if $depth == 0 ;
    my $sep = ' ' x ( 2 * $depth ) ;
    my $slf = $depth ? '' : 'self ' ;
    my $res = sprintf "%sis a '%s'\n", $slf, $ref ;
    $res .= sprintf "${sep}ISA (%s)\n", eval '@' . "${ref}::ISA" ;
    my $w = 0 ;
    if ( ref $self and $self =~ /HASH/ )
      { for my $key ( keys %$self ) { $w = length $key if length $key > $w ; }
        for my $key ( sort keys %$self )
          { my $val = $self -> { $key } ;
            my $dmp ;
            if ( $_nodump { $key } )
              { next unless $_verbos ; $dmp = "<excluded> $val" ; }
            else
              { $dmp = $self -> _dmpval ( $val, $depth ) ; }
            my $nl = ( "\n" eq substr ( $dmp, -1, 1 ) ? '' : "\n" ) ;
            $res .= sprintf "%s%-${w}s : %s%s" , $sep , $key , $dmp, $nl ;
          }
      }
    elsif ( ref $self and $self =~ /ARRAY/ )
      { my $can = ( @$self and eval { $self -> [ 0 ] -> can ( 'dmp' ) } ) ;
        $res .=
          ( scalar @$self
          ? sprintf "${sep}  [ %s\n$sep  ]"
             , join "\n$sep  , "
             , ( $can
               ? map { $_ -> _dmp ( $depth + 1 ) } @$self
               : @$self
               )
          : '[]'
          ) ;
      }
    $res ;
  }

sub dmp
  { my $self = shift ;
    my %opts =
      ( -excl => [ qw(_cafe _tabl _base) ]
      , -incl => []
      , -verb => 1
      , @_
      ) ;
    %_dumped = () ;
    %_nodump = () ;
    $_verbos = $opts { -verb } ;
    for my $key ( @{ $opts { -excl } } ) { $_nodump { $key } ++ ; }
    for my $key ( @{ $opts { -incl } } ) { delete $_nodump { $key } ; }
    Blib::_pf ( "excluding [%s]\n", join ',', sort keys %_nodump ) if $_verbos ;
    Blib::_pr ( $self -> _dmp ( 0 ) ) ;
  }

sub _getset
  { my $self = shift ;
    my $attr = shift ;
    Carp::confess "self not ref ($self)" unless ref $self ;
    if ( @_ ) { $self -> { $attr } = shift ; }
    Carp::confess "no attr '$attr' ($self)" unless exists $self -> { $attr } ;
    my $res = $self -> { $attr } ;
    ( wantarray and ref $res eq 'ARRAY' ) ? @$res : $res ;
  }

sub mk_typ
  { my $self = shift ;
    my $d = shift ;
    my $type = ref $self || $self ;
    die "mk_typ : bad type ($type)"
      unless $type =~ /Blib::(Dbs|Tab|Col|Rec)(::|$)?/ ;
    my $s = ( split /::/, $type ) [ 1 ] ;
    $type =~ s/$s/$d/ ;
    $type ;
  }

sub mk_method
  { my $self = shift ;
    my $attr = shift ;
    sprintf 'sub %s { my $self = shift ; $self -> _getset ( "%s",  @_ ) ; }'
      , $attr, $attr ;
  }

sub mk_methods
  { my $self = shift ;
    join "\n", map { Blib -> mk_method ( $_ ) ; } @_ ;
  }

sub new_pack
  { my $type = shift ;
    my $name = shift ;
    my @isa  = split /::/, $type ;
    my $isa  = shift @isa ; $isa .= '::' . shift @isa if @isa ;
    my $new_typ = $type ;
    my $new_isa = $isa  ;
    if ( defined $name )
      { $new_typ = "${type}::${name}" ; $new_isa = $type ; }
    my $fmt  = <<'PACK' ;

{ package %s ; }
{ @%s::ISA = qw(%s) ; }
PACK
    my $pack = sprintf $fmt, $new_typ, $new_typ, $new_isa ;
    Blib::_pr $pack if Blib -> debug ;
    my $res = eval "$pack ; 1 ;" ;
    Carp::confess "new_pack : $@" unless defined $res ;
    $pack ;
  }

sub new_method
  { my $pack = shift ;
    my $attr = shift ;
    my $fmt  = "{ package %s ; eval Blib -> mk_method ( '%s' ) ; }\n" ;
    my $mth = sprintf $fmt, $pack, $attr, $attr ;
    Blib::_pr ( $mth ) if Blib -> debug ;
    my $res = eval "$mth ; 1 ;" ;
    Carp::confess "new_method : $@" unless defined $res ;
  }

### Dbs #####################################################################

package Blib::Dbs ;

use DBI ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods ( qw(_tabs _dbh _tabl _que_cnt _rec_cnt) ) ;

sub make
  { my $self = shift ; $self -> new ( shift ) -> init ; }

sub init
  { my $self = shift ;
    $self -> _tabs ( [] ) ;
    $self -> _dbh  ( undef ) ;
    $self -> _tabl ( {} ) ;
    $self -> _que_cnt ( 0 ) ;
    $self -> _rec_cnt ( 0 ) ;
    $self ;
  }

sub _incr_cnt
  { my $self = shift ;
    my $cntr = shift ;
    my $incr = shift ;
    $self -> $cntr ( $self -> $cntr + $incr ) ;
  }

sub connect
  { my $self = shift ;
    my @args = @_ ;
    my $dbh = DBI -> connect
      ( @args
      , { RaiseError => 1, AutoCommit => 1 }
      ) or die $DBI::errstr ;
    $self -> _dbh ( $dbh ) ;
  }

sub disconnect
  { my $self = shift ;
    $self -> _dbh -> disconnect if $self -> _dbh ;
    $self -> _dbh ( undef ) ;
  }

sub add_tab
  { my $self = shift ;
    my %opts =
      ( -list => []
      , -tags => []
      , -pkey => undef
      , @_
      ) ;
    $opts { -tabl } ||= $opts { -name } ;
    my $name = $opts { -name } ;
    my $pkey = $opts { -pkey } ;
    my $tabl = $opts { -tabl } ;
    die "add_tab : name ($name) can't start with '_'" if $name =~ /^_/ ;
    die "add_tab : no primary key for table $name" unless defined $pkey ;

    my $typ_dbs = $self -> unref ;
    my $typ_tab = $self -> mk_typ ( 'Tab' ) ;
    my $typ_rec = $self -> mk_typ ( 'Rec' ) ;

    Blib::new_method ( $typ_dbs, $name ) ;
    Blib::new_pack ( $typ_tab ) unless @{ $self -> _tabs } ;
    Blib::new_pack ( $typ_rec ) unless @{ $self -> _tabs } ;
    Blib::new_pack ( $typ_tab, $name ) ;
    Blib::new_pack ( $typ_rec, $name ) ;

    my $res = "${typ_tab}::$name" -> make ( %opts, _base => $self ) ;
    push @{ $self -> _tabs }, $res ;
    $self -> { _tabl } { $tabl } = $res ;
    $self -> $name ( $res ) ;
  }

sub _has_tab
  { my $self = shift ;
    my $name = shift ;
    my $res ;
    if ( scalar grep { $name eq $_ -> _name ; } @{ $self -> _tabs } )
      { $res = $self -> $name ; }
    $res ;
  }

sub _as_tab
  { my $self = shift ;
    my $tabl = shift ;
    $self -> _tabl -> { $tabl }
  }

sub query
  { my $self = shift ;
    my %opts =
      ( -sql   => ''
      , -args  => []
      , @_
      ) ;
    my $sql  = $opts { -sql  } ;
    my $args = $opts { -args } ;
    my @res  = () ;

    Carp::confess "query : sql 'empty' ($self)\n"
      unless defined $sql and length $sql ;

    if ( $opts { -debug } or $self -> debug )
      { Blib::_pf
          ( "%s ;\n[%s]\n"
          , $sql
          , join ',', map { defined $_ ? $_ : '<undef>' ; } @$args
          ) ;
      }

    my $sth = $self -> _dbh -> prepare ( $sql ) ;
    $sth -> execute ( @$args ) or die $self -> _dbh -> errstr ;
    $self -> _incr_cnt ( '_que_cnt', 1 ) ;

    if ( wantarray )
      { while ( my $rec = $sth -> fetchrow_hashref )
          { $self -> _incr_cnt ( '_rec_cnt', 1 ) ; push @res, $rec ; }
        @res ;
      }
    else
      { $sth -> finish ; }
  }

sub _table_info
  { my $self = shift ;
    my $tab  = shift ;
    my $res ;
    die "table_info: no arg tab" unless $tab ;
    my $sth = $self -> _dbh -> table_info
      ( '', 'public', $tab -> _tabl, undef ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; $sth -> finish ; }
    $res ;
  }

sub _column_info
  { my $self = shift ;
    my $col  = shift ;
    my $res ;
    die "column_info: no arg col" unless $col ;
    my $sth = $self -> _dbh -> column_info
      ( '', 'public', $col -> _tabl -> _tabl, $col -> _name ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; $sth -> finish ; }
    $res ;
  }

sub _foreign_key_info
  { my $self = shift ;
    my $tab  = shift ;
    my $res ;
    die "table_info: no arg tab" unless $tab ;
    my $sth = $self -> _dbh -> foreign_key_info
      ( undef, undef, undef, '', 'public', $tab -> _tabl ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; $sth -> finish ; }
    $res ;
  }

### Tab ####################################################################

package Blib::Tab ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods ( qw(_base _name _tabl _pkey _cols _list _tags) ) ;

sub init
  { my $self = shift ;
    my %opts = @_ ;
    $self -> { _base } = $opts { _base } ;
    $self -> { _name } = $opts { -name } ;
    $self -> { _tabl } = $opts { -tabl } ;
    $self -> { _pkey } = $opts { -pkey } ;
    $self -> { _list } = $opts { -list } ;
    $self -> { _tags } = $opts { -tags } ;
    $self -> { _cols } = [] ;
    $self ;
  }

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

sub _col_names
  { my $self = shift ; map { $_ -> _name ; } $self -> _cols ; }

sub _clist
  { my $self = shift ;
    my $list = $self -> _list ;
    my %seen = () ;
    my @res  = () ;
    for my $name ( @{ $list } )
      { die "no col $name" unless $self -> $name ;
        push @res, $self -> $name ;
        $seen { $name } ++ ;
      }
    for my $col ( $self -> _cols )
      { push @res, $col unless $seen { $col -> _name } ; }
    @res ;
  }

sub add_col
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $opts { -head } ||= $opts { -name } ;

    my $name = $opts { -name } ;
    die "add_col : name ($name) can't start with '_'" if $name =~ /^_/ ;

    my $typ_tab = $self -> mk_typ ( 'Tab' ) ;
    my $typ_col = $self -> mk_typ ( 'Col' ) ;
    my $typ_rec = $self -> mk_typ ( 'Rec' ) ;

    Blib::new_pack ( $typ_col ) unless @{ $self -> _cols } ;
    Blib::new_pack ( $typ_col, $name ) ;
    Blib::new_method ( $typ_tab, $name ) ;
    Blib::new_method ( $typ_rec, $name ) ;

    my $col = "${typ_col}::${name}" -> make ( %opts, -tabl => $self ) ;
    push @{ $self -> { _cols } }, $col ;
    $self -> { $name } = $col ;
  }

sub _has_col
  { my $self = shift ;
    my $name = shift ;
    my $res ;
    if ( scalar grep { $name eq $_ -> _name ; } @{ $self -> _cols } )
      { $res = $self -> $name ; }
    $res ;
  }

sub new_rec
  { my $self = shift ;
    my $hash = shift || {} ;
    $hash -> { _tabl } = $self ;
    my $typ_rec = $self -> mk_typ ( 'Rec' ) ;
    $typ_rec -> new -> init ( $hash ) ;
  }

sub _make_sql
  { my $self = shift ;
    my $tabl = $self -> _tabl ;
    my %opts =
      ( -fields => "$tabl.*"
      , -from   => $tabl
      , -where  => ''
      , -group  => ''
      , -having => ''
      , -order  => ''
      , -limit  => ''
      , -sql    => ''
      , @_
      ) ;

    my $where  = '' ;
    my $group  = '' ;
    my $having = '' ;
    my $order  = '' ;
    my $limit  = '' ;

    $where  = 'WHERE '    . $opts { -where  } if $opts { -where  } ;
    $group  = 'GROUP BY ' . $opts { -group  } if $opts { -group  } ;
    $having = 'HAVING '   . $opts { -having } if $opts { -having } ;
    $order  = 'ORDER BY ' . $opts { -order  } if $opts { -order  } ;
    $limit  = 'LIMIT '    . $opts { -limit  } if $opts { -limit  } ;

    sprintf "SELECT %s FROM %s %s %s %s %s %s"
      , $opts { -fields }, $opts { -from }
      , $where, $group, $having, $order, $limit ;
  }

sub select
  { my $self = shift ;
    my %opts =
      ( -args => []
      , @_
      ) ;
    my $sql = $opts { -sql } || $self -> _make_sql ( %opts ) ;
    my @res = () ;
    for my $tup ( $self -> _base -> query ( %opts, -sql => $sql ) )
      { push @res, $self -> new_rec ( $tup ) ; }
    @res ;
  }

sub select1
  { my $self = shift ;
    my %opts =
      ( -args => []
      , @_
      ) ;
    my @res  = $self -> select ( %opts, -limit => 1 ) ;
    $res [ 0 ] ;
  }

sub try
  { my $self = shift ;
    my $pval = shift ;
    my $pkey = $self -> _pkey ;
    $self -> select1 ( -where => "$pkey = '$pval'", -limit => 1 ) ;
  }

sub get
  { my $self = shift ;
    my $pval = shift ;
    my $pkey = $self -> _pkey ;
    $self -> try ( $pval ) || Carp::confess
      ( sprintf "can't get '%s = %s' from %s\n"
      , $pkey, $pval, $self -> _name
      ) ;
  }

sub select_hash
  { my $self = shift ;
    my $key  = shift ;
    my %opts = @_ ;
    my $res  = {} ;
    for my $rec ( $self -> select ( %opts ) )
      { my $val = $rec -> $key ;
        die sprintf "(%s=%s) not uniq in selection of tab (%s)"
          , $key, $val, $self -> _name
            if exists $rec -> { $val } ;
        $res -> { $val } = $rec ;
      }
    $res ;
  }

sub _make_sql_delete
  { my $self = shift ;
    my %opts =
      ( -where => undef
      , -sql   => ''
      , @_
      ) ;
    my $where = 'WHERE ' . $opts { -where  }
      if defined $opts { -where } and length $opts { -where  } ;
    my $sql = sprintf
      ( "DELETE FROM %s %s" , $self -> _tabl , ( $where || '' ) ) ;
    $sql ;
  }

sub _delete
  { my $self = shift ;
    my %opts = @_ ;
    unless
      ( ( defined $opts { -sql }   and length $opts { -sql } )
     or ( defined $opts { -where } and length $opts { -where } )
      )
      { Carp::confess "-sql/-where is empty ; use 'tab -> _delete_all'\n" ; }
    my $sql  = $opts { -sql } || $self -> _make_sql_delete ( %opts ) ;
    scalar $self -> _base -> query ( %opts, -sql => $sql ) ;
  }

sub _delete_all
  { my $self = shift ;
    my %opts = @_ ;
    my $sql  = $self -> _make_sql_delete ( -where => '' ) ;
    scalar $self -> _base -> query ( %opts, -sql => $sql ) ;
  }

sub info_head
  { my $self = shift ;
    my %opts =
      ( -incl => []
      , -excl => []
      , -pref => []
      , @_
      ) ;
    my @incl = @{ $opts { -incl } } ;
    my @excl = @{ $opts { -excl } } ;
    my %excl ; for ( @excl ) { $excl { $_ } ++ ; }
    my $ths = join '', map { TH ( $_ ) } @{ $opts { -pref } } ;
    my @cols ;
    if ( @incl )
      { @cols = map { $self -> $_ ; } @incl ; }
    else
      { @cols = $self -> _clist ; }

    for my $col ( @cols )
      { next if $col -> _hide or exists $excl { $col -> _name } ;
        $ths .= TH ( $col -> _head || $col -> _name ) ;
      }
    TRx $ths ;
  }

sub _table_info
  { my $self = shift ;
    $self -> _base -> _table_info ( $self ) ;
  }

sub _in_db
  { my $self = shift ;
    my $info = $self -> _table_info ( $self ) ;
    defined $info and @$info == 1 ;
  }

sub _foreign_key_info
  { my $self = shift ;
    my $base = $self -> _base ;
    my $info = $base -> _foreign_key_info ( $self ) ;
    if ( defined $info )
      { [ map
           { my $_ptab = $_ -> [ 6 ] ;
             my $_pkey = $_ -> [ 7 ] ;
             my $_ftab = $_ -> [ 2 ] ;
             my $_fkey = $_ -> [ 3 ] ;
             my $ptab  = $base -> _as_tab ( $_ptab ) ;
             my $ftab  = $base -> _as_tab ( $_ftab ) ;
             my $pnam = $ptab ? $ptab -> _name : $_ptab ;
             my $fnam = $ftab ? $ftab -> _name : $_ftab ;
             { ptab  => ( $ptab || $_ptab )
             , pkey  => ( $ptab ? $ptab -> $_pkey : $_pkey )
             , ftab  => ( $ftab || $_ftab )
             , fkey  => ( $ftab ? $ftab -> $_fkey : $_fkey )
             , rule  => $_ -> [ 10 ]
             , name  => $_ -> [ 11 ]
             , ptxt  => "$pnam.$_pkey"
             , ftxt  => "$fnam.$_fkey"
             , _ptab => $_ -> [ 6 ]
             , _pkey => $_ -> [ 7 ]
             , _ftab => $_ -> [ 2 ]
             , _fkey => $_ -> [ 3 ]
             , INFO  => $info
             } ;
           } @$info
        ] ;
      }
    else
      { undef ; }
  }

### Col #####################################################################

package Blib::Col ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods
  ( qw(_tabl _name _type _pkey _null _def _uniq _fkey _head _hide) ) ;

sub init
  { my $self = shift ;
    my %opts =
      ( -null => 1
      , -uniq => 0
      , -fkey => undef
      , -def  => undef
      , -head => ''
      , -hide => 0
      , @_
      ) ;
    $self -> _tabl ( $opts { -tabl } ) ;
    $self -> _name ( $opts { -name } ) ;
    $self -> _type ( $opts { -type } ) ;
    $self -> _null ( $opts { -null } ) ;
    $self -> _def  ( $opts { -def  } ) ;
    $self -> _uniq ( $opts { -uniq } ) ;
    $self -> _fkey ( $opts { -fkey } ) ;
    $self -> _head ( $opts { -head } ) ;
    $self -> _hide ( $opts { -hide } ) ;
    $self -> _pkey ( $self -> _name eq $self -> _tabl -> _pkey ) ;
    if ( $self -> _notnull and ! defined $self -> _def )
      { if ( $self -> _type eq 'text' )
          { $self -> _def ( '' ) ; }
        elsif ( $self -> _type eq 'bool' )
          { $self -> _def ( 0 ) ; }
      }
    $self ;
  }

sub _notnull { my $self = shift ; not $self -> _null ; }

sub _column_info
  { my $self = shift ;
    $self -> _tabl -> _base -> _column_info ( $self ) ;
  }

sub _in_db
  { my $self = shift ;
    my $info = $self -> _column_info ( $self ) ;
    defined $info and @$info == 1 ;
  }

### Rec #####################################################################

package Blib::Rec ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods ( qw(_tabl) ) ;

sub init
  { my $self = shift ;
    my $hash = shift ;
    my $tabl = $self -> _tabl ( $hash -> { _tabl } ) ;

    for my $col ( $tabl -> _cols )
      { my $fld = $col -> _name ;
        $self -> $fld
          ( exists $hash -> { $fld }
          ? $hash -> { $fld }
          : $col -> _def
          ) ;
      }
    $self ;
  }

sub _base { my $self = shift ; $self -> _tabl -> _base ; }
sub _cols { my $self = shift ; $self -> _tabl -> _cols ; }
sub _pkey { my $self = shift ; $self -> _tabl -> _pkey ; }

sub _tag
  { my $self = shift ;
    my $tabl = $self -> _tabl ;
    my $tags = @{ $tabl -> _tags } ? $tabl -> _tags : [ $tabl -> _pkey ] ;
    my @res  = () ;
    for my $name ( @$tags )
      { push @res, $self -> $name ; }
    join ( ' ', grep $_, @res ) || 'no_tag' ;
  }

sub _repr
  { my $self = shift ;
    my $name = shift ;
    my $val  = $self -> $name ;
    my $type = $self -> _tabl -> $name -> _type ;
    if ( $type eq 'bool' )
      { $val ? '+' : '-' ; }
    elsif ( $type eq 'text' )
      { length ( $val ) ? $val : '&nbsp;' ; }
    else
      { $val ; }
  }

sub _check
  { my $self = shift ;
    my %opts =
      ( -excl => []
      , @_
      ) ;
    my %excl = () ; for ( @{ $opts { -excl } } ) { $excl { $_ } ++ ; }
    my $tabl = $self -> _tabl ;
    my $res  = '' ;
    for my $col ( $tabl -> _cols )
      { my $name = $col -> _name ;
        next if $excl { $name } ;
        next if $col -> _type eq 'serial' ;
        my $val  = $self -> $name ;
        if ( $col -> _notnull and ! defined $val )
          { $res .= sprintf "field $name violates 'notnull' constraint\n" ; }
        else
          { if ( my $fkey = $col -> _fkey )
              { my $fld = $fkey -> _name ;
                my $qwe = "$fld = ?" ;
                my $rec = $fkey -> _tabl -> select1
                  ( -where => $qwe , -args  => [ $val ] ) ;
                unless ( $rec )
                  { $res .= sprintf "%s (%s) not in %s.%s"
                      , $name
                      , ( defined $val ? $val : '<undef>' )
                      , $fkey -> _tabl -> _name
                      , $fld
                      ;
                  }
              }
          }
      }
    $res ;
  }

sub _insert
  { my $self = shift ;
    my %opts =
      ( -excl => []
      , @_
      ) ;
    my %excl = () ; for ( @{ $opts { -excl } } ) { $excl { $_ } ++ ; }
    my $tabl = $self -> _tabl ;
    my $nams = [] ;
    my $vals = [] ;
    for my $col ( $tabl -> _cols )
      { my $name = $col -> _name ;
        next if exists $excl { $name } ;
        next if $col -> _type eq 'serial' ;
        push @$nams, $name ;
        push @$vals, $self -> $name ;
      }
    my $sql = sprintf "INSERT INTO %s (%s) VALUES (%s)"
      , $tabl -> _tabl
      , ( join ',', @$nams )
      , ( join ',', ( '?' ) x scalar @$nams )
      ;
    if ( @$nams )
      { scalar $tabl -> _base -> query
          ( %opts, -sql => $sql , -args => $vals ) ;
        sprintf "inserted : %s", $self -> _tag ;
      }
    else
      { sprintf "nothing to insert" ; }
  }

sub _update
  { my $self = shift ;
    my %opts =
      ( -excl => []
      , @_
      ) ;
    my %excl = () ; for ( @{ $opts { -excl } } ) { $excl { $_ } ++ ; }
    my $tabl = $self -> _tabl ;
    my $nams = [] ;
    my $vals = [] ;
    my $res  = '' ;
    my $pkey = $tabl -> _pkey ;
    my $pval = $self -> $pkey ;
    my $prev = $tabl -> get ( $pval ) ;
    for my $col ( $tabl -> _cols )
      { my $name = $col -> _name ;
        next if exists $excl { $name } ;
        next if $col -> _type eq 'serial' ;
        my $curr_val = $self -> $name ;
        my $prev_val = $prev -> $name ;
        if ( $curr_val ne $prev_val )
          { my $name = $col -> _name ;
            my $head = $col -> _head ;
            push @$nams, "$name  = ?" ;
            push @$vals, $self -> $name ;
            $res .= sprintf "%s [%s] -> [%s]\n"
              , ( $head || $name )
              , $prev -> _repr ( $name )
              , $self -> _repr ( $name )
              ;
          }
      }
    if ( @$nams )
      { my $sql = sprintf "UPDATE %s SET %s WHERE %s = '%s'"
          , $tabl -> _tabl
          , ( join ',', @$nams )
          , $pkey
          , $pval
          ;
        scalar $tabl -> _base -> query
          ( %opts, -sql => $sql , -args => $vals ) ;
      }
    $res ? $res : 'no change' ;
  }

sub _save
  { my $self = shift ;
    my %opts = @_ ;
    my $tabl = $self -> _tabl ;
    my $pkey = $tabl -> _pkey ;
    my $pval = $self -> $pkey ;
    if ( defined $pval )
      { $self -> _update ( %opts ) ; }
    else
      { $self -> _insert ( %opts ) ; }
  }

sub _delete
  { my $self = shift ;
    my %opts = @_ ;
    my $tabl = $self -> _tabl ;
    my $pkey = $tabl -> _pkey ;
    my $pval = $self -> $pkey ;
    $tabl -> _delete ( %opts, -where => "$pkey = ?", -args => [ $pval ] ) ;
    sprintf "deleted : %s", $self -> _tag ;
  }

### JSON ####################################################################

package Blib::JSON ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods ( qw(__) ) ;

my %name4key ;
sub add_name4key
  { my $self = shift ;
    my %opts = @_ ;
    for my $key ( keys %opts ) { $name4key { $key } = $opts { $key } ; }
  }
sub name4key
  { my $self = shift ;
    my $x = shift ;
    $name4key { $x } || $x ;
  }

my %name4row ;
sub add_name4row
  { my $self = shift ;
    my %opts = @_ ;
    for my $key ( keys %opts )
      { $name4row { $key } = $opts { $key } ; }
  }
sub name4row
  { my $self = shift ;
    my $x = shift ;
    my $n = $x ;
    $n =~ s/=.*// ;
    $name4row { $n } ;
  }

sub make
  { my $self = shift ;
    my %opts = @_ ;
    my $name = $opts { -name } ;
    $self -> new ( $name ) -> init ( %opts ) ;
  }

sub init
  { my $self = shift ;
    my %opts = @_ ;
    $self -> __ ( undef ) ;
    for my $opt ( keys %opts ) { $self -> $opt ( $opts { $opt } ) ; }
    $self ;
  }

sub add
  { my $self = shift ;
    my $type = Blib::unref $self ;
    my %opts = @_ ;
    my $name = $opts { -name } ;
    my $kind = $opts { -kind } ;
    my $tsub = "${type}::$name" ;

    Blib::new_method ( $type, $name ) ;
    Blib::new_pack ( $tsub ) if $kind ;
    my $res = Blib::_bless {}, $tsub ;
    if ( ref $self )
      { $self -> { $name } = ( $kind ? $res : 'scalar' ) ; }
    $res ;
  }

sub mk_sub_model ;

sub mk_sub_model
  { my $self = shift ;
    my $base = shift ;
    my $name = shift ;
    my $json = shift ;
    my $kind = ref $json ;

    my $type = $base -> add ( -name => $name , -kind => $kind ) ;

    if ( $kind eq 'HASH' )
      { for my $key ( sort keys %$json )
          { my $name = Blib::JSON -> name4key ( $key ) ;
            $self -> mk_sub_model ( $type, $name, $json -> { $key } ) ;
          }
      }
    elsif ( $kind eq 'ARRAY' and @$json )
      { my $elem = $json -> [ 0 ] ;
        my $name = Blib::JSON -> name4row ( $type ) ;
        die "no name for $type" unless $name ;
        $self -> mk_sub_model ( $type, $name, $elem ) ;
      }

    $type ;
  }

sub mk_model
  { my $self = shift ;
    my $name  = shift ;
    my $json  = shift ;
    $self -> mk_sub_model ( 'Blib::JSON', $name, $json ) ;
  }

sub bless
  { my $type = shift ;
    my $json = shift ;
    my $kind = ref $json ;

    Blib::_bless ( $json, Blib::unref $type ) ;

    if ( $kind eq 'HASH' )
      { for my $key ( sort keys %$json )
          { my $name = Blib::JSON -> name4key ( $key ) ;
            if ( $name ne $key )
              { $json -> { $name } = $json -> { $key } ;
                delete $json -> { $key } ;
              }
            if ( ref $type -> $name )
              { $type -> $name -> bless ( $json -> { $name } ) ; }
          }
      }
    elsif ( $kind eq 'ARRAY' and @$json and ref ( $json -> [ 0 ] ) )
      { my $name = Blib::JSON -> name4row ( $type ) || 'elem' ;
        for my $elem ( @$json )
          { $type -> $name -> bless ( $elem ) ; }
      }

    $json ;
  }

1 ;

__END__

=pod

=head1 NAME

=head1 SYNOPSIS

  use Blib ;

  $base = Blib::Dbs -> make ( 'Foo' ) ; # symbolic name for your database
  $base -> connect ( "dbi:Pg:dbname=...;host=...", 'user', 'pswd' ) ;

  $tabl = $base -> add_tab
    ( -name => 'zoo'     # table name
    , -pkey => 'key'     # primary key
    , -tabl => 'tab_zoo' # real table name, default -name
    ) ;

  $col  = $tabl -> add_col
    ( -name => 'bar'
    , -type => 'int'  # or text, bool, serial
    , -uniq => 1      # values are uniq
    , -null => 1      # values may be NULL
    ) ;

  $zoo = $base -> zoo ; # yields table 'zoo'
  $bar = $zoo  -> bar ; # yields column 'bar'
  $val = $rec > bar ;   # yields value in column 'bar' ;

  $rec  = $tabl -> select1 ( -where => "bar = 'some value'" ) ;

=head1 EXAMPLE

Let's start with an example and leave the details for later.

Suppose we want to model a school where there are teachers, pupils
and courses. We have a database I<school> with tables
I<teachers>, I<pupils> and I<courses> and many-to-many tables
I<teaches> (which teacher teaches what courses) and
I<follows> (which pupil follows what courses).

Suppose the Blib::Dbs::School object is set up with all the tables
and columns added. Now we want to add some functions to the models

  # create Blib::Dbs::School etc ; define_tables is done elsewhere
  my $school = Blib::Dbs -> make ( 'School' ) -> define_tables ;

  # add to the model for 'a teacher'
  Package Blib::Rec::School::teacher ;

  # the teacher's name
  # uses the field-names as methods
  sub name
    { my $self = shift ;
      $self -> last_name . ', ' . $self -> initials ;
    }

  # the courses a teacher gives
  # a Blib::Rec::School::teacher knows the database it belongs to,
  # It finds table 'teaches' as $self -> _base -> teaches
  sub courses
    { my $self = shift ; my $id = $self -> id ;
      my $course_ids = $self -> _name -> _base -> teaches -> _make_sql
        ( -fields => 'course_id', -where => "teacher_id = '$id' ) ;
      $self -> _base -> courses -> select
        ( -where => "id in ( $course_ids )" ) ;
    }

  # add to the model for 'a course'
  Package Blib::Rec::School::course ;

  # the pupils following a course
  sub pupils
    { my $self = shift ; my $id = $self -> id ;
      my $pupil_ids = $self -> _base -> follows -> _make_sql
        ( -fields => 'pupil_id', -where => "course_id = '$id' ) ;
      $self -> _base -> courses -> select
        ( -where => "id in ( $pupil_ids )"
        , -order => 'name'
        ) ;
    }

  # back to the teacher's model
  Package Blib::Rec::School::teacher ;

  # a teacher's pupils
  # uses Blib::Tab -> _make_sql to formulate a query for a specific table
  sub pupils
    { my $self = shift ; my $id = $self -> id ;
      # the query that yields her course_id's
      my $course_ids = $self -> _base -> teaches -> _make_sql
        ( -fields => 'course_id', -where => "teacher_id = '$id' ) ;
      # the query that yields the unique pupil_id's
      my $pupil_ids = $self -> _base -> follows -> make _sql
        ( -fields => 'distinct ( pupil_id )'
        , -where  => "course_id in ( $course_ids )
        ) ;
      # select the pupils
      my $pupils  = $self -> _base -> pupils -> select
        ( -where => "id in ( $pupil_ids )"
        , -order => 'name'
        ) ;
    }

  # or a teacher's pupils, with a join
  sub pupils
    { my $self = shift ;
      $self -> _base -> pupils -> select
        ( -fields => 'distinct pupils.*'
        , -from   => "gives, follows, pupils"
        , -where  => "gives.teacher_id = '$id' "
             . "and gives.course_id  = follows.course_id "
             . "and follows.pupil_id = pupil.pupil_id"
        , -order  => 'name'
        ) ;
    }

  # or a teacher's pupils, with plain perl
  # for each teacher's course, find the pupils ; hash for uniqueness.
  sub pupils
    { my $self = shift ;
      my %pupils = () ;
      for my $course ( $self -> courses )
        { my @pupils = $course -> pupils ; @pupils { @pupils } = @pupils ; }
      sort { $a -> name cmp $b -> name } keys %pupils ;
    }

The point here is that we can select the required objects
without writing too much, and build up the model in small steps.

=head1 Blib::Dbs class methods

=over 4

=item $base = new ( I<name> )

Function I<new> creates class Blib::Dbs::I<name>
and yields an object of that class.
Blib::Dbs::I<name> is a subclass of Blib::Dbs.
It is the basis of the model of your database.

=head1 Blib::Dbs object methods

=item $base = add_tab ( I<options> )

=over 4

=item * option -name => table-name

=item * option -pkey => column-name

=item * option -tags => list of column-names

The I<tags> are used to create a sensible tag for a table record ;
The I<tag> of the record is a space-separated list of the field-values
as specified by the list, as in C<deleted 'Jones'> as opposed to
C<deleted record 722>. Default C<[]>.

=item * option -tabl => real table name

Set the real table names when they are user-configurable, for instance
prefixed with some fixed string. Default C<-name>.

=back

If the table is the first table added to the Blib::Dbs object,
function C<add_tab> also creates classes
Blib::Tab::I<name> (a subclass of Blib::Tab) and
Blib::Rec::I<name> (a subclass of Blib::Rec).
These classes can be used later to implement functionality common
to all tables and all records of the database.

=back

=cut