##################################################################
# OBB::Dbs
##################################################################

use strict ;
use warnings ;

package OBB::Dbs ; our @ISA = qw(OBB) ;

use Carp ;
use DBI ;
use OBB ;
use OBB::Base ;

__PACKAGE__ -> Mk_methods
  ( qw(Dbh Tabs Tabl Cnt_que Cnt_rec T_dbs T_tab T_col T_rec) ) ;

sub OBB::_add_pack
  { my $self = _unref shift ;
    my $name = shift ;
    my $pack = "${self}::$name" ;
    my $eval = "{ package $pack ; our \@ISA = qw($self) ; 1 ; }\n" ;
    $self -> Print ( $eval ) if OBB::Dbs -> Debug ;
    _eval $eval ;
    $pack ;
  }

sub OBB::Define_dbs
  { my $self = shift ;
    my $name = shift ;
    confess "no name" unless $name ;
    confess "bad name ($name) ; should be ucfirst"
      unless $name eq ucfirst $name ;
    OBB::Dbs -> _add_pack ( $name ) -> Make
      ( T_tab => OBB::Tab -> _add_pack ( $name )
      , T_col => OBB::Col -> _add_pack ( $name )
      , T_rec => OBB::Rec -> _add_pack ( $name )
      ) ;
  }

sub Init
  { my $self = shift ;
    my %opts =
      ( Dbh     => undef
      , Tabs    => []
      , Tabl    => {}
      , Cnt_que => 0
      , Cnt_rec => 0
      , @_
      ) ;
    $self -> T_dbs ( _unref $self ) ;
    $self -> SUPER::Init ( %opts ) ;
  }

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

sub Define_tab
  { my $self = shift ;
    my %opts =
      ( Base => $self
      , @_
      ) ;
    $opts { Tabl } ||= $opts { Name } ;
    my $name = $opts { Name } ;
    my $tabl = $opts { Tabl } ;
    my $pkey = $opts { Pkey } ;
    confess "add_tab : no name" unless $name ;
    confess "add_tab : no primary key for table $name" unless defined $pkey ;
    my $pack = $self -> T_tab -> _add_pack ( $name ) ;
    my $res  = $pack -> Make ( %opts ) ;
    $res -> T_tab ( $pack ) ;
    $res -> T_rec ( $self -> T_rec -> _add_pack ( $name ) ) ;
    $res -> T_col ( $self -> T_col -> _add_pack ( $name ) ) ;
    $self -> Printf ( "mk_method %s -> %s\n", $self -> T_dbs, $name )
      if $self -> Debug ;
    $self -> T_dbs -> Mk_methods ( [ $name ] ) ;
    push @{ $self -> Tabs }, $res ;
    $self -> { Tabl } { $tabl } = $res ;
    $self -> $name ( $res ) ;
  }

sub Connect
  { my $self = shift ;
    $self -> Dbh ( DBI -> connect ( @_ ) ) ;
  }

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

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 => []
      , attr => {}
      , @_
      ) ;
    my $sql  = $opts { sql  } ;
    my $args = $opts { args } ;
    my $attr = $opts { attr } ;

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

    if ( $opts { debug } or $self -> Debug )
      { $self -> Printf ( "query : %s ;\n", $sql ) ;
        $self -> Printf
          ( "args  : [%s]\n"
          , join ',', map { defined $_ ? $_ : '<undef>' ; } @$args
          ) unless defined $args and ref ( $args ) =~ /ARRAY/ and @$args == 0 ;
      }

    $self -> _incr_cnt ( 'Cnt_que', 1 ) ;

    if ( $sql =~ /^\s*select/i )
      { $self -> Dbh -> selectall_arrayref
          ( $sql, { %$attr, Slice => {} }, @$args ) ;
      }
    elsif ( $sql =~ /^\s*insert/i )
      { my $sth = $self -> Dbh -> prepare ( $sql ) ;
        my $res = $sth -> execute( @$args ) ;
        if ( $self -> Dbh -> {Driver} -> {Name} eq 'Pg' )
          { $res = $sth -> fetch () -> [ 0 ] ; }
        $res ;
      }
    else
      { $self -> Dbh -> do ( $sql, $attr, @$args ) ; }
  }

sub Table_info
  { my $self = shift ;
    my $tab  = shift ;
    my $res ;
    confess "Table_info: no arg tab" unless $tab ;
    my $sth = $self -> Dbh -> table_info
      ( '', undef, $tab -> Tabl, undef ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; $sth -> finish ; }
    $res ;
  }

sub Column_info
  { my $self = shift ;
    my $col  = shift ;
    my $res ;
    confess "Column_info: no arg col" unless $col ;
    my $sth = $self -> Dbh -> column_info
      ( '', undef, $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 ;
    confess "Foreign_key_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 ;
  }

package OBB::Tab ; our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods
  ( [ qw(Base Name Tabl Pkey Cols Defs Tags T_tab T_col T_rec) ] ) ;

sub Init
  { my $self = shift ;
    $self -> SUPER::Init ( @_, Cols => [], Defs => {}, Tags => [] ) ;
  }

sub Define_col
  { my $self = shift ;
    my %opts = @_ ;
    my $name = $opts { Name } ;
    my $pack = $self -> T_col -> _add_pack ( $name ) ;
    my $res = $pack -> Make ( %opts, Tabl => $self ) ;
    $self -> Printf ( "mk_method %s -> %s\n", $self -> T_tab, $name )
      if $self -> Debug ;
    $self -> T_tab -> Mk_methods ( [ $name ] ) ;
    $self -> Printf ( "mk_method %s -> %s\n", $self -> T_rec, $name )
      if $self -> Debug ;
    $self -> T_rec -> Mk_methods ( [ $name ] ) ;
    push @{ $self -> Cols }, $res ;
    $self -> Defs -> { $name } = $res -> Def ;
    $self -> $name ( $res ) ;
  }

sub Col_names
  { my $self = shift ; map { $_ -> Name ; } $self -> Cols ; }

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 %opts = OBB::Base::_mk_hash ( @_ ) ;
    $self -> T_rec -> Make ( %opts, Tabl => $self ) ;
  }

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

    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  => []
      , debug => $self -> Debug
      , @_
      ) ;
    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 = ?", args => [ $pval ], limit => 1 ) ;
  }

sub Get
  { my $self = shift ;
    my $pval = shift ;
    my $pkey = $self -> Pkey ;
    $self -> Try ( $pval ) or 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 ;
        return 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 , @_ ) ;
    my $where = $opts { where } || '' ;
    $where = 'WHERE ' . $where if $where ;
    my $sql = sprintf "DELETE FROM %s %s" , $self -> Tabl, $where ;
    $sql ;
  }

sub Delete
  { my $self  = shift ;
    my %opts  = ( where => undef, debug => $self -> Debug, @_ ) ;
    my $where = $opts { where } ;
    Carp::confess "where is empty ; use 'tab -> Delete_all'\n"
      unless defined $where and length $where ;
    my $sql  = $self -> _make_sql_delete ( %opts ) ;
    $self -> Base -> Query ( %opts, sql => $sql ) ;
  }

sub Delete_all
  { my $self = shift ;
    my %opts  = ( debug => $self -> Debug, @_ ) ;
    my $sql  = $self -> _make_sql_delete ( where => '' ) ;
    $self -> Base -> Query ( %opts, sql => $sql ) ;
  }

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 ; }
  }

package OBB::Col ; our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods
  ( [ qw(Name Tabl Type Pkey Null Def Uniq Fkey) ] ) ;

sub Init
  { my $self = shift ;
    my %opts =
      ( Null => 1
      , Uniq => 0
      , Pkey => 0
      , @_
      ) ;
    $self -> SUPER::Init ( %opts ) ;
    if ( $self -> Name eq $self -> Tabl -> Pkey )
      { $self -> Pkey ( 1 ) ;
        $self -> Uniq ( 1 ) ;
        $self -> Null ( 0 ) ;
      }
    if ( $self -> Type eq 'serial' )
      { $self -> Null ( 0 ) ;
      }
    if ( $self -> Notnull and ! defined $self -> Def )
      { if ( $self -> Type eq 'text' )
          { $self -> Def ( '' ) ; }
        elsif ( $self -> Type eq 'bool' or $self -> Type eq 'int' )
          { $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 ;
  }

package OBB::Rec ; our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods ( qw(Tabl) ) ;

__PACKAGE__ -> Hide ( 'Tabl' ) ;

sub Init
  { my $self = shift ;
    my %opts = @_ ;
    my $defs = $opts { Tabl } -> Defs ;
    $self -> SUPER::Init ( %$defs, %opts ) ;
  }

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 Pval
  { my $self = shift ;
    my $pkey = $self -> Tabl -> Pkey ;
    $self -> $pkey ;
  }

sub _repr
  { my $self = shift ;
    my $name = shift ;
    my $val  = $self -> $name ;
    my $type = $self -> Tabl -> $name -> Type ;
    unless ( defined $val )
      { $val = '&lt;undef&gt;' ; }
    elsif ( $type eq 'bool' )
      { $val ? '+' : '-' ; }
    elsif ( $type eq 'text' )
      { length ( $val ) ? $val : '&nbsp;' ; }
    else
      { $val ; }
  }

sub _eq
  { my $self = shift ;
    my ( $x, $y ) = @_ ;
    my $res = 0 ;
    if ( ! defined $x and ! defined $y )
      { $res = 1 ; }
    elsif ( defined $x and defined $y )
      { $res = ( $x eq $y ) ; } 
#   print "eq x ($x) y($y) res ($res)\n" ;
    $res ;
  }

sub Tag
  { my $self = shift ;
    my $tabl = $self -> Tabl ;
    my $tags = $tabl -> Tags ;
    my $res  = join ' ', map { $self -> $_ } @$tags ;
    $res or $self -> Pval ;
  }

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  => []
      , debug => $self -> Debug
      , @_
      ) ;
    my %excl = () ; for ( @{ $opts { excl } } ) { $excl { $_ } ++ ; }
    my $tabl = $self -> Tabl ;
    my $pkey = $tabl -> Pkey ;
    my $Dbh  = $tabl -> Base -> Dbh ;
    my $driv = $Dbh -> {Driver} -> {Name} ;
    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) %s"
      , $tabl -> Tabl
      , ( join ',', @$nams )
      , ( join ',', ( '?' ) x scalar @$nams )
      , ( $driv eq 'Pg' ? "RETURNING $pkey" : '' )
      ;
    if ( @$nams )
      { my $res = $tabl -> Base -> Query
          ( %opts, sql => $sql , args => $vals ) ;

	my $last_id ;
        if ( $driv eq 'SQLite' )
          { $last_id = $Dbh -> last_insert_id
	      ( undef, undef, $tabl -> Tabl, $pkey ) ;
          }
        elsif ( $driv eq 'Pg' )
          { $last_id = $res ; }
	if ( $tabl -> $pkey -> Type eq 'serial' )
	  { $self -> $pkey ( $last_id ) ; }

        sprintf "inserted : %s", $self -> Tag ;
      }
    else
      { sprintf "nothing to insert" ; }
  }

sub Update
  { my $self = shift ;
    my %opts =
      ( excl  => []
      , debug => $self -> Debug
      , @_
      ) ;
    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 ( not $self -> _eq ( $curr_val, $prev_val ) )
          { my $name = $col -> Name ;
            push @$nams, "$name  = ?" ;
            push @$vals, $self -> $name ;
            $res .= sprintf "%s [%s] -> [%s]\n"
              , $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
          ;
        $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 = ( debug => $self -> Debug, @_ ) ;
    my $tabl = $self -> Tabl ;
    my $pkey = $tabl -> Pkey ;
    my $pval = $self -> $pkey ;
    $tabl -> Delete ( %opts, where => "$pkey = ?", args => [ $pval ] ) ;
    sprintf "deleted : %s", $self -> Tag ;
  }

1 ;