##################################################################
# OBB::Levels::Store
##################################################################
package OBB::Levels::Store ;

use strict ;
use warnings ;

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

our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods ( [ qw(base tabl) ] ) ;

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

sub get
  { my $self = shift ;
    my $obbj = shift ;
    confess "get : undefined obbj" unless defined $obbj ;
    $self -> tabl -> { $obbj } ;
  }

sub set
  { my $self = shift ;
    my $obbj = shift ;
    my $levl = shift ;
    my $tabl = $self -> tabl ;
    if ( ! defined $levl )
      { delete $tabl -> { $obbj }  ; }
    else
      { $tabl -> { $obbj } = $levl ; }
  }

sub search
  { my $self = shift ;
    my $obbj = shift ;
    my $tabl = $self -> tabl ;
    my @queue = ( $obbj ) ;
    push @queue, ref $obbj if _blessed $obbj ;
    my %tried = () ;
    while ( @queue )
      { my $item = shift @queue ;
        return $tabl -> { $item } if exists $tabl -> { $item } ;
	$tried { $item } ++ ;
	unless ( _blessed $obbj )
	  { no strict 'refs' ;
            push @queue, grep { ! $tried { $_ } } @{"${item}::ISA"} ;
          }
#	printf "search $obbj $item [@queue]\n" ;
      }
    undef ;
  }

sub dump_me
  { my $self = shift ;
    $self -> Printf
      ( "store :\n  [ %s\n  ]\n"
      , join "\n,   ", map
          { my $val = $self -> tabl -> { $_ } 
          ; sprintf "%s => %s", $_ , $val
	  } sort keys %{ $self -> tabl }
      ) ;
  }

DESTROY
  { my $self = shift ;
    return unless defined $self ;
    _destroy ( __PACKAGE__, $self ) ;
  }

##################################################################
# OBB::Levels
##################################################################
package OBB::Levels ;

use strict ;
use warnings ;

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

our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods ( [ qw(pack names deft ranks store) ] ) ;

sub Init
  { my $self = shift ;
    my %opts =
      ( names => []
      , deft  => undef
      , @_
      ) ;
    $self -> SUPER::Init ( %opts ) ;
    my $cnt = 0 ;
    $self -> ranks ( {} ) ;
    for my $name ( @{ $self -> names } )
      { confess "name '$name' must be ucfirst lc alphanum"
          unless $name eq ucfirst lc $name and $name =~ /^[a-z]\w*$/i ;
        $self -> ranks -> { $name } = $cnt ++ ;
      }
    my $store = OBB::Levels::Store -> Make
      ( base => $self
      ) ;
    $self -> store ( $store ) ;
    $self -> deft  ( $self -> names -> [ 0 ] ) ;
    $self ;
  }

sub _cmp
  { _args_cnt 3, scalar @_ ;
    my $self = shift ;
    my $nam1 = shift ;
    my $nam2 = shift ;
    my $rnk1 =  $self -> ranks -> { $nam1 } ;
    my $rnk2 =  $self -> ranks -> { $nam2 } ;
    Carp::confess "_cmp : name1 undefined" unless defined $nam1 ;
    Carp::confess "_cmp : name2 undefined" unless defined $nam2 ;
    Carp::confess "_cmp : no rank for name1 ($nam1)" unless defined $rnk1 ;
    Carp::confess "_cmp : no rank for name2 ($nam2)" unless defined $rnk2 ;
    $rnk1 <=> $rnk2 ;
  }

##################################################################
# verbosity methods
##################################################################

sub do_level
  { my $self = shift ;
    my $obbj = shift ;
    my $name = shift ;
    my $ismy = shift ;
    my $res = '' ; # bool operators return '' for false
    if ( @_ )
      { my $levl = shift @_ ? $name : undef ;
	$res = $self -> my_verbosity ( $obbj, $levl ) ;
      }
    else
      { my $meth = ( $ismy ? 'my_' : '' ) . 'verbosity' ;
        my $verb = $self -> $meth ( $obbj ) ;
	$res = $self -> _cmp ( $verb, $name ) >= 0 if defined $verb ;
      }
    $res ;
  }

sub _mk_verbosity_method
  { my $pack = shift ;
    my $name = shift ;
    my $rank = shift ;
    my $fmt = <<'FMT' ;
sub %s
  { my $self = shift ; $self -> OBB_LEVELS -> do_level($self,'%s',0,@_) ; }
sub My_%s
  { my $self = shift ; $self -> OBB_LEVELS -> do_level($self,'%s',1,@_) ; }
FMT
    my $subs = sprintf $fmt, $name, $name, lc $name, $name ;
    _eval ( "package $pack ;\n$subs" ) ;
  }

sub _mk_verbosity_methods
  { my $pack  = shift ;
    my $names = shift ;
    my $rank  = 0 ;
    for my $name ( @$names )
      { _mk_verbosity_method ( $pack, $name, $rank ++ ) ; }
  }

sub _rm_verbosity_methods
  { my $pack  = shift ;
    my $names = shift ;
    for my $name ( @$names )
      { _eval ( sprintf 'undef $%s::{%s}', $pack, $name )
	  if $pack -> can ( $name ) ;
        my $meth = "My_\L$name" ;
	_eval ( sprintf 'undef $%s::{%s}', $pack, $meth )
	  if $pack -> can ( $meth ) ;
      }
  }

##################################################################
# verbosity levels
##################################################################

sub mk_verbosity_levels
  { my $self  = shift ;
    my $pack  = shift ;
    my $names = shift ;
    confess "no names" unless @$names ;
    my $res = $self -> Make ( pack => $pack, names => $names ) ;
    if ( $pack -> can ( 'OBB_LEVELS' ) )
      { # scalar ; we want an arrayref here
        my $names = $pack -> OBB_LEVELS -> names ;
        _rm_verbosity_methods ( $pack, $names ) ;
      }
    else
      { $pack -> Mk_class_methods ( OBB_LEVELS => $res ) ; }
    confess "duplicate names"
      unless scalar keys %{ $res -> ranks } == @$names ;
    _mk_verbosity_methods ( $pack, $names ) ;
    $pack -> OBB_LEVELS ( $res ) ;
    $res ;
  }

sub OBB::Verbosity_levels
  { my $pack = shift ;
    my @nams = OBB::Base::_mk_array ( @_ ) ;
    if ( @_ )
      { __PACKAGE__ -> mk_verbosity_levels ( $pack, [ @nams ]  ) ; }
    else
      { $pack -> OBB_LEVELS -> names ; }
  }

sub default_verbosity
  { my $self = shift ;
    if ( @_ )
      { my $name = shift ;
        confess "name == undef" unless defined $name ;
        confess "bad verbosity name ($name)"
	  unless exists $self -> ranks -> { $name } ;
        $self -> deft ( $name ) ;
      }
    $self -> deft ;
  }

sub OBB::Default_verbosity
  { my $self = shift ;
    $self -> OBB_LEVELS -> default_verbosity ( @_ ) ;
  } 

sub my_verbosity
  { my $self = shift ;
    my $obbj = shift ;

    if ( scalar @_ )
      { # $name must be undef or level-name
        my $name = shift ;
        confess "bad verbosity ($name)"
	  if defined $name and ! exists $self -> ranks -> { $name } ;
	$self -> store -> set ( $obbj, $name ) ;
      }
    else
      { $self -> store -> get ( $obbj ) ; }
  }

# only used to get verbosity ;
sub verbosity
  { _args_cnt 2, scalar @_ ;
    my $self = shift ;
    my $obbj = shift ;
    $self -> store -> search ( $obbj ) || $self -> deft ;
  }

sub OBB::My_verbosity
  { my $self = shift ;
    $self -> OBB_LEVELS -> my_verbosity ( $self, @_ ) ;
  }

sub OBB::Verbosity
  { my $self = shift ;
    if ( @_ )
      { $self -> My_verbosity ( @_ ) ; }
    else
      { $self -> OBB_LEVELS -> verbosity ( $self ) ; }
  }

##################################################################
# tie prog option [-v -d -q] to obb verbosity settings
##################################################################

# _verbosity_opts ( 'd Debug v Verbose q Quiet', %opts )
# returns { d => 'Debug', v => 'Verbose, ... }, [ qw(d v q) ]
sub _verbosity_opts
  { my $self = shift ;
    my $strg = shift ;
    my @strg = split ' ', $strg ;
    my @list = () ;
    confess "set_verbosity: odd #items in '$strg'" if @strg % 2 ; 
    for ( my $x = 0 ; $x < @strg ; $x ++ )
      { my $y = $strg [ $x ] ;
        if ( $x % 2 )
          { confess "set_verbosity: weird name ($y) at position $x\n"
              unless exists $self -> ranks -> { $y } ;
          }
        else
          { push @list, $y ; }
      }
    return { @strg }, [ @list ] ;
  }

# OBB -> set_verbosity ( 'd Debug v Verbose q Quiet', %opts )
# Order defines precedence ; the first option found, wins.
sub set_verbosity
  { my $self = shift ;
    my $obbj = shift ;
    my $strg = shift ;
    confess "set_verbosity: odd #args" if @_ % 2 ; 
    my %args = @_ ;
    my ( $opts, $list ) = $self -> _verbosity_opts ( $strg ) ;
    my $name = $self -> default_verbosity ;
    for my $opt ( @$list )
      { if ( $args { $opt } )
	  { $name = $opts -> { $opt } ; last ; }
      }
    $self -> my_verbosity ( $obbj, $name ) ;
  }

sub OBB::Set_verbosity
  { my $self = shift ;
    $self -> OBB_LEVELS -> set_verbosity ( $self, @_ ) ;
  }

# BEGIN
  { OBB -> Mk_class_methods
      ( DEF_LEVELS => [ qw(Silent Quiet Terse Verbose Debug) ]
      , DEF_LEVEL  => 'Terse'
      ) ;
    OBB -> Verbosity_levels ( OBB -> DEF_LEVELS ) ;
    OBB -> Default_verbosity ( OBB -> DEF_LEVEL ) ;
  }


DESTROY
  { my $self = shift ;
    return unless defined $self ;
    _destroy ( __PACKAGE__, $self ) ;
  }

1 ;