package OBB::Base ;

use strict ;
use warnings ;
use Carp ;
use Scalar::Util 'blessed' ;

use Exporter qw(import) ;
our @EXPORT =
  qw(_args_cnt _args_minmax _args_even _args_odd
     _terse _verbose _debug _bugs1
     __diag _blessed _addr _eval _unref _mk_hash _isa_obb _destroy
     _QUIET _TERSE _VERBO _DEBUG _BUGS1
    ) ;

sub _QUIET { 0 ; }
sub _TERSE { 1 ; }
sub _VERBO { 2 ; }
sub _DEBUG { 3 ; }
sub _BUGS1 { 4 ; }

sub _quiet ;
sub _verbo ;
sub _debug ;
sub _bugs1 ;

sub _eval
  { my $eval = shift ;
    printf "%s\n", $eval if __PACKAGE__ -> _bugs1 ;
    my $res = eval $eval ;
    confess $@ if $@ ;
    $res ;
  }

sub __diag
  { my $x = shift ;
    ( ! defined $x ) ? '<undef>' : ( ( "$x" eq '' ) ? '<empty>' : $x ) ;
  }

sub _argsub ($$)
  { my $sub = shift ;
    my $got = shift ;
    my $res = &$sub ( $got ) ;
    my $tag = &$sub () ;
    unless ( $res )
      { my $cal = ( caller ( 2 ) ) [ 3 ] ;
        my $cl = $Carp::CarpLevel ;
        $Carp::CarpLevel = 2 ;
        confess "Arg count : $cal() wants $tag BUT got $got" ;
        $Carp::CarpLevel = $cl ;
      }
    $res ;
  }

sub _args_cnt
  { my $want = shift ;
    my $got  = shift ;
    _argsub sub { @_ ? $want == $got : $want ; }, $got ;
  }
sub _args_minmax
  { my $min = shift ;
    my $max = shift ;
    my $got = shift ;
    _argsub sub
      { @_ ? ( $min <= $got and $got <= $max ) : "in $min..$max" ;
      }, $got ;
  }
sub _args_min
  { my $min = shift ;
    my $got = shift ;
    _argsub sub { @_ ? ( $min <= $got ) : "#args >= $min" ; }, $got ;
  }
sub _args_even
  { my $got  = shift ;
    _argsub sub { @_ ? $got % 2 == 0 : "#args even" ; }, $got ;
  }
sub _args_odd
  { my $got  = shift ;
    _argsub sub { @_ ? $got % 2 == 1 : "#args odd" ; }, $got ;
  }

sub _destroy
  { my $pack = shift ;
    my $item = shift ;
    printf "%s Destroy %s\n", __diag ( $pack ), __diag ( $item )
      if OBB::Base -> _bugs1 () ;
  }

sub _has_xxx
  { my $pack = shift ;
    my $name = shift ;
    my $type = shift ;
    my $test = sprintf '*%s::%s{%s}', $pack, $name, $type ;
    my $res = eval $test ;
#   printf "_has_xxx : %s (%s)\n", $test, __diag $res ;
    $res ;
  }

sub _has_sub { _has_xxx @_, 'CODE' ; }

sub _has_var
  { my $pack = shift ;
    my $name = shift ;
    my $test = sprintf 'my $x = $%s::{%s} ; defined $x and defined $$x'
      , $pack, $name ;
#   printf "has_var : %s\n", $test ;
    _eval $test ;
  }

sub _is_pack
  { my $p = shift ;
    defined $p and not ref $p and UNIVERSAL::isa ( $p, 'UNIVERSAL' ) ;
  }

sub _blessed
  { my $r = shift ;
    my $p = shift || 'UNIVERSAL' ;
    defined $r and ref $r and UNIVERSAL::isa ( $r, $p ) ;
  }

sub _isa_obb { my $r = shift ; _blessed $r, 'OBB' ; }

sub _addr
  { my $x = shift ;
    ( defined $x and ref $x ) ? sprintf ( "%s", $x ) : ref $x ;
  }

sub _unref { my $pack = shift ; ref $pack or $pack ; }

sub _mk_hash
  { ( @_ == 1 and 'HASH' eq ref $_[0] ) ? %{ $_[0] } : @_ ; }

# use only where @_ can't/shouldn't contain arrayrefs
sub _mk_array
  { ( @_ == 1 and 'ARRAY' eq ref $_[0] ) ? @{ $_[0] } : @_ ; }

sub _getset
  { my $self = shift ;
    my $attr = shift ;
    confess ( "self not ref ($self)" ) unless ref $self ;
    if ( @_ ) { $self -> { $attr } = shift ; }
    $self -> { $attr } ;
  }

my $SUBS = {} ; sub SUBS { $SUBS ; }

sub _mk_method
  { my $pack = shift ;
    my $name = shift ;
    _args_even ( scalar @_ ) ;
    my %opts =
      ( attr => $name
      , tmpl => undef
      , @_
      ) ;
    my $dflt = 'sub %s '
      . '{ my $self = shift ; OBB::Base::_getset ( $self, \'%s\',  @_ ) ; }' ;
    print "_mk_method: method name ($pack,$name)\n" if _debug ( 'OBB' ) ;
    warn "method name ($name) should be lowercase"
      if _debug ( $pack ) and $name ne "\L$name" ;
    confess "method name ($name) must be alphanum"
      unless $name =~ /^[a-z_]\w*$/i ;
    confess "package ${pack} already implements method $name"
      if _has_sub ( $pack, $name ) ;
    my $pack_name = "${pack}::${name}" ;
    confess "shouldn't happen ; already have sub $pack_name" 
      if exists $SUBS -> { $pack_name } ;
#   $SUBS -> { $pack_name } = $opts { tmpl } || \&_getset ;
    my $default = OBB::DEFAULT_ACCESS_METHOD () ;
    $SUBS -> { $pack_name } = $opts { tmpl } || $default ;
    _eval <<SUB ;
sub ${pack}::${name}
  { my \$self = shift ;
    \&{ OBB::Base::SUBS () -> { '$pack_name' } }
      ( \$self, '$name', \@_ ) ;
  }
SUB
    confess $@ if $@ ;
    1 ;
  }

sub OBB::Mk_methods
  { _args_min ( 2, scalar @_ ) ;
    my $pack = shift ;
    my @nams = @_ ;
    my $tmpl ;
    $tmpl = pop @nams if @nams and ref ( $nams [ $#nams ] ) eq 'CODE' ;
    confess "self ($pack) is not a package" unless _is_pack ( $pack ) ;
    confess "no names for $pack ??" unless @nams ;
    my $nam0 = $nams [ 0 ] ;
    @nams = @$nam0 if @nams == 1 and ref $nam0 eq 'ARRAY' ;
    _mk_method ( $pack, $_, tmpl => $tmpl ) for @nams ;
    scalar @nams ;
  }

sub OBB::Mk_method
  { _args_minmax ( 2, 6, scalar @_ ) ;
    my $pack = shift ;
    my $name = shift ;
    _args_even ( scalar @_ ) ;
    _mk_method $pack, $name, @_ ;
  }

sub _mk_class_method
  { my $pack = shift ;
    my $attr = shift ;
    my $init = shift ;
    confess "class-method name ($attr) must be uppercase alphanum"
      if $attr ne "\U$attr" or $attr !~ /^[A-Z_]\w*$/ ;
    my $eval = sprintf <<'FMT', $pack, $attr, $attr, $attr, $attr ;
{ package %s ; our $%s ;
  sub %s { my $pack = shift ; if ( @_ ) { $%s = shift ; } $%s ; }
}
FMT
    _eval $eval  ;
    confess $@ if $@ ;
  }

sub _mk_class_methods
  { my $pack = shift ;
    my %hash = _mk_hash @_ ;
    for my $name ( keys %hash )
      { my $init = $hash { $name } ;
        _mk_class_method ( $pack, $name, $hash { $name } ) ;
        $pack -> $name ( $init ) if defined $init ;
      }
    scalar keys %hash ;
  }

sub OBB::Mk_class_methods
  { my $pack = _unref ( shift ) ;
    confess "self ($pack) is not a package" unless _is_pack ( $pack ) ;
    _mk_class_methods ( $pack, @_ ) ;
  } 

sub OBB::New { my $pack = shift ; bless {}, $pack ; }

sub OBB::Make
  { _args_odd scalar @_ ;
    my $self = shift ;
    my @args = @_ ;
    $self -> New -> Init ( @args ) ;
  }

sub OBB::Init
  { _args_odd scalar @_ ;
    my $self = shift ;
    my %opts = _mk_hash ( @_ ) ;
    for my $opt ( keys %opts )
      { if ( $self -> can ( $opt ) )
          { $self -> $opt ( $opts { $opt } ) ; }
        elsif
          ( ( OOB -> can ( 'Debug' ) and OBB -> Debug )
         or ( OOB -> can ( '_debug' ) and OBB -> _debug )
          )
          { warn sprintf "%s::%s : %s can't %s()\n"
              , __PACKAGE__, 'init', ref ( $self ), $opt ;
          }
      }
    $self ;
  }

sub OBB::Print  { my $self = shift ; print  @_ ; }
sub OBB::Printf { my $self = shift ; printf @_ ; }

our $_VERB = {} ;
sub _VERB
  { my $pack = _unref shift ;
    my $arg ;
    if ( @_ ) { $arg = shift ; $_VERB -> { $pack } = $arg ; }
    printf "VERB pack(%s), arg(%s)\n", $pack, __diag $arg
      if _debug ( __PACKAGE__ ) ;
    $_VERB -> { $pack } || 0 ;
  }

sub __test
  { my ($pack,$v) = @_ ;
    exists $_VERB->{$pack}
      and do { my $s = $_VERB->{$pack} ; defined $s and $s >= $v ; } ;
  }
sub _quiet { __test shift, _QUIET ; }
sub _terse { __test shift, _TERSE ; }
sub _verbo { __test shift, _VERBO ; }
sub _debug { __test shift, _DEBUG ; }
sub _bugs1 { __test shift, _BUGS1 ; }

  __PACKAGE__ -> _VERB ( _QUIET ) ;
# __PACKAGE__ -> _VERB ( _DEBUG ) ;
# __PACKAGE__ -> _VERB ( _BUGS1 ) ;

sub OBB::Hide
  { _args_min  ( 2, scalar @_ ) ;
    my $pack = shift ;
    my @attr = shift ;
    $pack -> Mk_class_methods ( HIDES => {} )
      unless _has_sub ( $pack, 'HIDES' ) ;
    $pack -> HIDES -> { $_ } = 1 for @attr ;
  }

sub _dmp_hides
  { my $H = OBB -> HIDES ;
    for my $p ( sort keys %$H )
      { printf "{%s}\n", join ','
          , map { sprintf "%s=>%s", $_, $H->{$p}{$_} }
        keys %{ $H -> { $p } } ;
      }
  }

# BEGIN
{ Mk_class_methods
    { 'OBB'
    , PRG => 'OBB'
    , OBB_WANT_ARRAY => 1
    , DEFAULT_ACCESS_METHOD => \&_getset
    , VERSION => '0.1.0'
    , HIDES => {}
    } ;
}

sub OBB::version { sprintf '%s-%s', $OBB::PRG, $OBB::VERSION ; }
sub OBB::Version { sprintf '%s version %s', $OBB::PRG, $OBB::VERSION ; }

1 ;