#! /usr/bin/perl -w

use strict ;

use Carp ;
use OBB ;

# sub is_undef  ;
# sub is_empty  ;
# sub is_string ;
# sub is_true   ;
# sub is_false  ;

my $PACK = 'FUNC' ;
my $NO_SPEC = 'not specified' ;
my $FAIL = 'FAIL' ;

BEGIN
  { our %funcs =
      ( is_undef  => '! defined $_[0]'
      , is_empty  => 'defined $_[0] and "$_[0]" eq ""'
      , is_string => 'defined $_[0] and not ref $_[0]'
      , is_true   => 'defined $_[0] and $_[0]'
      , is_false  => '! $_[0]'
      ) ;
    for my $key ( keys %funcs )
      { my $exp = $funcs { $key } ;
        my $sub = sprintf 'sub { @_ ? ( %s ) : \'%s()\' ; }'
          , $exp, $key ;
        eval "sub $key { bless $sub, \$PACK }" ;
        die $@ if $@ ;
      }
  }

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-d] [-V] [-Q] [-D] [-u] args
option v : be verbose
option q : be quiet
option d : show debug info
option V : OBB verbose
option Q : OBB quiet
option D : OBB debug
option f : don't stop at the first unexpected result
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "$prog: $_[0]\n" ; }
sub Warn  { warn "$prog: $_[0]\n" ; }

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

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ; Usage '' unless GetOptions
  ( \%opt, qw(V Q D v q d f) ) ;
Usage("Arg count\n") unless @ARGV >= 0 ;

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

my $OBB_LVL1 = OBB::DEF_LEVELS ;
my $OBB_DEF1 = OBB::DEF_LEVEL ;
my $OBB_DEFx = 'Verbose' ;
my $OBB_LVL2 = [ qw(Info Warning Debug Debug1) ] ;
my $OBB_DEF2 = 'Info' ;
my $OBB_OPTS = "D Debug V Verbose Q Quiet" ;
my %OBB_OPTS = split ' ', $OBB_OPTS ;
my $db ;
my $rec ;

system "cp tst/test.db test.db" ;

sub FAIL { $FAIL ; }

sub obb_verb
  { for my $opt ( qw(D V Q) )
      { return $OBB_OPTS { $opt } if $opt{$opt} ; }
    'Terse' ;
  }

sub obb_levl
  { my $arg = shift ;
    my $cnt = 0 ;
    my $res = 1 ;
    for my $opt ( qw(Q xxxx V D) )
      { if ( $opt{$opt} ) { $res = $cnt ; last ; } else { $cnt ++ ; } }
    ( $res >= $arg ? 1 : '' ) ;
  }

sub _match
  { my $arg = shift ;
    my $pat = shift ;
    defined $arg and $arg =~ /$pat/ ;
  }

sub match
  { my $pat = shift ;
    bless sub { @_ ? _match $_[0], $pat : "match /$pat/" ; }, $PACK ;
  }

# sub is_undefx
#   { bless sub { @_ ? ( ! defined $_[0] ) : 'is_undef()' ; }, $PACK ; }

sub anything
  { bless sub
      { @_
      ? 0
      : $NO_SPEC
      }, $PACK ;
  }

sub diag ;
sub diag
  { my $obj = shift ;
    my $res ;
#   printf "REF (%s)\n", ref $obj if defined $obj ;
    unless ( defined $obj )
      { $res = '<undef>' ; }
    elsif ( ref $obj )
      { if ( ref ( $obj ) =~ /ARRAY/ )
          { $res = sprintf '[%s]', join ',', map { diag $_ } @$obj ; }
        elsif ( ref ( $obj ) =~ /HASH/ )
          { $res = sprintf '{%s}', join ','
	      , map { sprintf "%s=>%s", $_, diag ( $obj -> { $_ } ) ; }
	        sort keys %$obj ;
	  }
        elsif ( ref ( $obj ) =~ /$PACK/ )
          { $res = &$obj () ; }
	else
	  { $res = $obj ; }
      }
    elsif ( $obj eq '' )
      { $res = '<empty>' ; }
    else
      { $res = $obj ; }
    $res ;
  } 

sub compare
  { my $exp = shift ;
    my $got = shift ;
    my $res = 0 ;
    my $typ = 'no check done' ;
    if ( ! ref $exp )
      { if ( defined $exp )
          { $res = $exp eq ( defined $got ? $got : '<UNDEF>' ) ; }
	else
	  { $res = ! defined $got ; }
        $typ = 'compared as scalars' ;
      }
    elsif ( ref ( $exp ) =~ /ARRAY/ and ref ( $got ) =~ /ARRAY/ )
      { $res = "@$exp" eq "@$got" ;
        $typ = 'compared as arrayrefs' ;
      }
    elsif ( ref ( $exp ) =~ /HASH/ and ref ( $got ) =~ /HASH/ )
      { $res = 1 ;
        $res = scalar keys %$exp eq scalar keys %$got ;
        for my $pair ( [$exp,$got], [$got,$exp] )
	  { my ( $a, $b ) = @$pair ;
	    if ( $res )
	      { for ( keys %$a ) { $res &&= exists $b -> { $_ } ; } }
            if ( $res )
	      { for ( keys %$a ) { $res &&= "$a->{$_}" eq "$b->{$_}" ; } }
	  }
        $typ = 'compared as hashrefs' ;
      }
    elsif ( ref ( $exp ) =~ /$PACK/ )
      { $res = &$exp ( $got ) ;
        $typ = 'result callback' ;
      }
    return $res, $typ ;
  }

my $tries = 0 ;
my $oks   = 0 ;

sub try
  { my $arg = shift ; 
    my $show = $opt{v} ;
    my $exp = anything ;
    if ( @_ ) { $exp = shift ; } else { $show = 1 ; }
    print "eval '$arg'\n" if $opt{d} ;
    my $got = eval $arg ;
    if ( $@ )
      { $show = 1 if $exp ne FAIL ;
        if ( $show )
	  { print "FAIILED [$arg]\n" ;
            if ( $exp eq FAIL )
	      { Carp::cluck $@ ; }
	    else
	      { confess $@ ; }
	  }
        $got = FAIL ;
      }

    my ( $ok, $typ ) = compare $exp, $got ;
    $show ||= ! $ok ;
    $oks ++ if $ok ;

    if ( $show )
      { my $diag_exp = diag $exp ;
        printf "try : %s\n", $arg  ;
        printf "here got(%s) ref(%s)\n", $got, ref $got if $opt{d} ;
        printf "  got    : %s\n", diag $got ;
	unless ( $diag_exp eq $NO_SPEC )
	  { printf "  expect : %s\n", $diag_exp ;
            printf "  result : %s [%s]\n", diag ( $ok ), $typ ;
          }
        print "\n" ;
      }
    $tries ++ ;
    exit unless $ok or $opt{f} ; # if ! $ok and ! $opt{f}
  } 

try "OBB -> OBB_WANT_ARRAY", 1 ;
try "OBB -> OBB_WANT_ARRAY ( 0 )", 0 ;
try "OBB -> OBB_WANT_ARRAY", 0 ;
try "OBB -> OBB_WANT_ARRAY ( 1 )", 1 ;
try "OBB -> OBB_WANT_ARRAY", 1 ;

try 'OBB -> Verbosity_levels', $OBB_LVL1 ;
try 'OBB -> OBB_LEVELS', match '^OBB::Levels=HASH' ;
try 'OBB::Levels -> OBB_LEVELS', match '^OBB::Levels=HASH' ;
try 'OBB -> Default_verbosity', $OBB_DEF1 ;
try 'OBB::Levels -> Default_verbosity', $OBB_DEF1 ;
try "OBB -> Default_verbosity ( '$OBB_DEFx' )", $OBB_DEFx ;
try "OBB -> Default_verbosity", $OBB_DEFx ;
try "OBB -> Default_verbosity ( '$OBB_DEF1' )", $OBB_DEF1 ;

try 'OBB -> My_verbosity'        , is_undef ;
try 'OBB::Levels -> My_verbosity', is_undef ;
try 'OBB -> Verbosity'        , $OBB_DEF1 ;
try 'OBB::Levels -> Verbosity', $OBB_DEF1 ;

try 'OBB -> Set_verbosity ( "D Debug V Verbose Q Quiet", %opt )', obb_verb ;
try 'OBB -> My_verbosity', obb_verb ;
try 'OBB -> Verbosity'   , obb_verb ;
try 'OBB::Levels -> My_verbosity', is_undef ;
try 'OBB::Levels -> Verbosity'   , obb_verb;

try "OBB -> can ( 'My_quiet' )", is_true ;
try 'OBB -> My_quiet  ', obb_levl ( 0 ) ;
try 'OBB -> My_terse  ', obb_levl ( 1 ) ;
try 'OBB -> My_verbose', obb_levl ( 2 ) ;
try 'OBB -> My_debug  ', obb_levl ( 3 ) ;
try 'OBB::Levels -> My_quiet  ', '' ;
try 'OBB::Levels -> My_terse  ', '' ;
try 'OBB::Levels -> My_verbose', '' ;
try 'OBB::Levels -> My_debug  ', '' ;
try 'OBB -> Quiet  ', obb_levl ( 0 ) ;
try 'OBB -> Terse  ', obb_levl ( 1 ) ;
try 'OBB -> Verbose', obb_levl ( 2 ) ;
try 'OBB -> Debug  ', obb_levl ( 3 ) ;

try 'OBB::Levels -> Quiet  ', obb_levl ( 0 ) ;
try 'OBB::Levels -> Terse  ', obb_levl ( 1 ) ;
try 'OBB::Levels -> Verbose', obb_levl ( 2 ) ;
try 'OBB::Levels -> Debug  ', obb_levl ( 3 ) ;

try "OBB -> Verbosity_levels ( qw(@$OBB_LVL2) )"
  , match '^OBB::Levels=HASH' ;
try "OBB -> Verbosity_levels", $OBB_LVL2 ;
try "OBB -> Default_verbosity", $OBB_DEF2 ;
try "OBB -> Verbosity_levels ( qw(@$OBB_LVL1) )"
  , match '^OBB::Levels=HASH' ;
try "OBB -> Default_verbosity", $OBB_LVL1 -> [ 0 ] ;
try "OBB -> Default_verbosity ( '$OBB_DEF1' )", $OBB_DEF1 ;
try 'OBB -> Default_verbosity', $OBB_DEF1 ;
try 'OBB -> Debug', is_false ;
try 'OBB -> Debug (1)', is_true ;
try 'OBB -> Debug', is_true ;
try "OBB -> My_verbosity", 'Debug' ;
try "OBB -> My_verbosity ( 'Terse' )", 'Terse' ;
try "OBB -> Verbosity", 'Terse' ;
try "OBB -> Mk_methods ( [ qw(aap noot mies) ] )", 3 ;
try "OBB -> Mk_class_methods ( AAP => 22, UND => undef, EMP => {a=>12} )", 3 ;
try "OBB -> AAP", 22 ;
try "OBB -> UND", is_undef ;
try "OBB -> EMP", {a=>12} ;
try "OBB::Mk_methods ( 'OBB::Base', [ qw(_unref) ] )", FAIL ;
try "OBB -> can ( 'PRG' )", is_true ;
try "OBB -> PRG", "OBB" ;
try '$OBB::PRG', "OBB" ;
try "OBB::Base::_has_var ( qw(OBB PRG) )", is_true ;
try "OBB::Base::_has_var ( qw(OBB XXX) )", '' ;
try "OBB::Base::_has_sub ( qw(OBB xxx) )", is_undef ;

try "OBB -> DUMPER", match '^OBB::Dumper=HASH' ;
try "OBB -> Inline", 'OBB' ;
try "OBB -> DUMPER -> Dump ( tag => 'as Dump', verbose => 1 ) ; 1", 1 ;
try "OBB -> DUMPER -> Text ( OBB -> DUMPER, tag => 'as Text' ) ; 1", 1 ;
# try "OBB::Dumper -> DUMPER -> Dump ( tag => 'not1', pretty => 1 )" ;
# try "OBB -> OBB_LEVELS -> Pretty ( tag => 'aap' )" ;
# try "OBB -> OBB_LEVELS -> Dump ( 'aap' )" ;
# try "OBB -> OBB_LEVELS -> Dump ( levels => 0 )" ;
# try "OBB -> OBB_LEVELS -> Dump ( levels => 1 )" ;
# try "OBB -> OBB_LEVELS -> Dump ( levels => 0, pretty => 0)" ;
# try "OBB -> OBB_LEVELS -> Dump ( levels => 0, pretty => 0, tag => 'aap')" ;
try "Inline { x => 2, y => 3 }, tag => 'AAP'", 'AAP:{x:2,y:3}' ;
try "Pretty { x => 2, y => 3 }, tag => '', prints => 0", is_string ;
OBB -> DUMPER -> Text ( OBB -> HIDES, tag => 'HIDES' ) ;
# OBB::Dbs -> Debug ( 1 ) ;
$db = OBB::Dbs -> Define_dbs ( 'Foo' ) ;
$db -> Debug ( 1 ) ;
use tst::Cars ;
$db -> define_tables ;
$db -> cars -> Pretty ;
try '$db -> Connect ( "dbi:SQLite:dbname=/test.db")', is_undef ;
try '$db -> Connect ( "dbi:SQLite:dbname=test.db")', match '^DBI::db=' ;
my $res = [ $db -> cars -> Select ] ;
OBB::Hide ( 'OBB::Rec::Foo::cars', 'Tabl' ) ;
Pretty ( $res, verbose => 1 ) ;
Pretty ( OBB::Rec -> HIDES ) ;
Pretty ( $db -> cars -> Table_info ) ;
Pretty ( $db -> cars -> id -> Column_info ) ;
try '$rec = $db -> cars -> Select1 ( where => "id >= 4" )'
  , match '^OBB::Rec::Foo::cars=HASH' ;
try '$rec -> Pval', 4 ;
try '$rec -> Save', 'no change' ;
try '$rec -> price ( 22 )', 22 ;
try '$rec -> Save', match '22' ;
try '$rec -> Tabl -> Delete ( where => "id >= ?", args => [ $rec -> id ] )', 5 ;
$rec = $db -> cars -> New_rec ( name => 'my car', price => 100 ) ;
Pretty $rec, tag => 'rec befor' ;
try '$rec -> Insert', 'inserted : 9' ;
# $rec = $db -> cars -> Select1 ( where => "name = 'my car'" ) ;
Pretty $rec, tag => 'rec after' ;
try '$rec -> Pkey', 'id' ;
try '$rec -> id', 9 ;
try '$rec -> Tabl -> Tags', [] ;
try '$rec -> Tag', 9 ;

printf "tries       : %s\n", $tries ;
printf "as expected : %s\n", $oks ;
printf "un-expected : %s\n", $tries - $oks ;

printf "\n" ;