package OBB::Dumper ;

use strict ;
use warnings ;

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

our @ISA = qw(OBB) ;

# OBB -> _VERB ( OBB::_DEBUG ) ;
# __PACKAGE__ -> _VERB ( OBB::_DEBUG ) ;

our $EXCL = '<excluded>' ;
our $ROOT = '$root' ;
our $DTAG = 'Dump' ;
our $MAXW = 8 ;
our $OPTIONS =
  { tag     => $DTAG
  , levels  => undef
  , pretty  => 1
  , prints  => undef
  , verbose => 0
  } ;
our $TOK_HIDDEN = {} ;

__PACKAGE__ -> Mk_methods ( [ sort keys %$OPTIONS ] ) ;

# sub _eval { OBB::_eval ( @_ ) ; }

sub _size
  { my $obj = shift ;
    my $ref = _addr $obj ;
    if ( ! ref $obj )
      { 1 ; }
    elsif ( $ref =~ /HASH/ )
      { scalar keys %$obj ; }
    elsif ( $ref =~ /ARRAY/ )
      { scalar @$obj ; }
    else
      { 1 ; }
  }

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

sub _clone
  { my $self = shift ;
    my $res  = __PACKAGE__ -> Make ( %$self, @_ ) ;
    $res -> My_verbosity ( $self -> My_verbosity ) ;
    $res ;
  }

sub _hidden
  { my $self = shift ;
    my $href = shift ;
    my $attr = shift ;
    _isa_obb $href and $href -> HIDES -> { $attr } ;
#   printf "_hidden (%s,%s,%s)\n", map { __diag $_ ; } $pack, $attr, $res ;
#   printf "HIDD(%s)\n", join ',', keys %$HIDD ;
  }

sub _want_attr
  { my $self = shift ;
    my $href = shift ;
    my $attr = shift ;
    my $res = ( $self -> verbose || ! $self -> _hidden ( $href, $attr ) ) ;
    $res ;
  }

sub _cant
  { my $self = shift ;
    my $obbj = shift ;
    my $pret = $self -> pretty ;
    ( $pret
    ? ( sprintf "%-5s # can't dump", _addr ( $obbj ) )
    : ( sprintf "<ERROR(%s)>", _addr ( $obbj ) )
    ) ;
  }

sub _no_recurse
  { my $self = shift ;
    my $obbj = shift ;
    my $pret = $self -> pretty ;
    ( $pret
    ? ( sprintf "%-5s # level > %s", ref $obbj, $self -> levels )
    : ref $obbj
    ) ;
  }

sub _undef { "undef" ; }

sub _str
  { my $self = shift ;
    my $str = shift ;
    $str =~ s/\n/\\n/g ;
    ( $self -> Debug ? '<str>' : '' ) .
    ( $self -> pretty ? "\"$str\"" : $str ) ;
  }

sub _ref
  { my $self = shift ;
    my $list = shift ;
    my $lvl  = shift ;
    my $work = shift ;
    my $path = shift ;

    my $tabl = [] ;
    my $addr = scalar $list ;
    my $is_a = $addr =~ /ARRAY/ ;
    my $is_h = $addr =~ /HASH/ ;
    my $pret = $self -> pretty ;
    my $brac = $is_a ? '[]' : '{}' ;
    my $w    = '' ;

    $work -> set ( $list, $path ) ;

    if ( $is_h )
      { $tabl =
          [ map
	      { [ $_
	        , ( $self -> _hidden ( $list, $_ )
	          ? $TOK_HIDDEN
		  : $list -> { $_ }
		  )
	        ]
	      } grep { $self -> _want_attr ( $list, $_ ) ; } sort keys %$list
          ] ;
        if ( $pret )
          { $w = 0 ; 
            for ( @$tabl )
              { my $k = $_ -> [ 0 ] ; $w = length $k if length $k > $w ; }
            $w = '' if $w > $MAXW ;
          }
      }
    elsif ( $is_a )
      { my $cnt = -1 ;
        $tabl = [ map { $cnt ++ ; [ $cnt, $list -> [ $cnt ] ] ; } @$list ] ;
      }
    else
      { $self -> _cant ( $list ) ; }

    if ( @$tabl == 0 )
      { $brac ; }
    else
      { my $res = '' ;
        my $s   = ' ' ;
        my $sep = ' ' x ( 2 + 4 * $lvl ) ;
	my $FC  = '=>' ;
        my ( $l, $r ) = split '', $brac ;

        if ( $pret )
	  { $s = ' ' ;
	    if ( @$tabl == 1 and ! ref $tabl -> [ 0 ] [ 1 ] )
	      { $sep = ' ' ; }
	    else
	      { $sep = "\n$sep" ;
	        $l = "${sep}$l" ;
		$r = "${sep}$r" ;
	      }
	  }
	else
	  { $sep = '' ; $s = '' ; $FC = ':' ; }

	$res .= sprintf "$l$s%s$s$r", join "$sep,$s"
	  , map
	      { my ( $key, $val ) = @$_ ;
		my $newp = sprintf
		  '%s->' . ( $is_h ? "{%s}" : '[%s]' ), $path, $key ;
		my $text = $self -> _dmp
		  ( $val, $lvl + 1, $work, $newp ) ;
	        if ( $is_h or $pret )
		  { my $typ = '' ;
		    if ( $pret and $self -> verbose and _blessed $val )
		      { $typ = sprintf '# %s', ref $val ; }
		    join "$s$FC${s}${typ}"
		      , sprintf ( "%-${w}s", $key ), $text ;
		  }
		else
		  { $text ; }
	      } @$tabl ;
      }
  }

sub _dmp
  { my $self = shift ;
    my $obbj = shift ;
    my $lvl  = shift ;
    my $work = shift ;
    my $path = shift ;

    my $ref  = ref $obbj ;
    my $max  = $self -> levels ;
    my $res  = '' ;

    if ( ! defined $obbj )
      { $res .= _undef ; }
    elsif ( ! $ref )
      { $res .= $self -> _str ( $obbj ) ; }
    elsif ( _addr ( $obbj ) eq _addr ( $TOK_HIDDEN ) )
      { $res .= $EXCL ; }
    elsif ( $work -> done ( $obbj ) )
      { $res .= $work -> text ( $obbj, $path, $self -> pretty ) ; }
    elsif ( ref $obbj and defined $max and $lvl > $max )
      { $res .= $self -> _no_recurse ( $obbj ) ; }
    elsif ( ref $obbj )
      { $res .= $self -> _ref ( $obbj, $lvl, $work, $path ) ; }
    else
      { $res .= $self -> _cant ( $obbj ) ; }
    $res ;
  }

sub Text
  { my $self = shift ;
    my $obbj = shift ;
    my @args = @_ ;
    my $dmpr = $self -> _clone ( @args ) ;
#   printf "dumper: %s tag[%s] levels[%s], args[%s]\n"
#     , $dmpr
#     , __diag ( $dmpr -> tag )
#     , __diag ( $dmpr -> levels )
#     , join ',', map { __diag ( $_ ) } @args ;
    my $work = OBB::Dumper::Done -> Make ;
    my $res ;
    my $dmp = $dmpr -> _dmp ( $obbj, 0, $work, $ROOT ) ;
    my $tag = $dmpr -> tag ;
    $tag = $DTAG unless defined $tag ;
    if ( $dmpr -> pretty )
      { my $addr = _addr ( $obbj ) ;
        my $size = _size ( $obbj ) ;
	if ( ref $obbj and $size )
	  { $addr .= " == $ROOT" ; }
        $res = sprintf "%s%s %s\n"
	  , ( $tag ? "$tag : " : '' )
	  , $addr
	  , $dmp ;
      }
    else
      { $res = sprintf ( "%s%s", ( $tag ? "$tag:" : '' ), $dmp ) ; }
    my $prints = $dmpr -> prints ;
    if ( defined ( $prints ) ? $prints : $dmpr -> pretty )
      { if ( _isa_obb $obbj )
          { $obbj -> Print ( $res ) ; }
	else
          { print ( $res ) ; }
      }
    $res ;
  }

# BEGIN
  { __PACKAGE__ -> Mk_class_methods
      ( OPTIONS => $OPTIONS
      , DEF_TAG => $DTAG
      ) ;

    __PACKAGE__ -> Hide ( 'verbose' ) ;
  }

package OBB::Dumper::Done ;

use strict ;
use warnings ;

use Carp ;
use OBB::Base ;

our @ISA = qw(OBB) ;

__PACKAGE__ -> Mk_methods ( [ qw(path) ] ) ;

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

sub set
  { my $self = shift ;
    my $item = shift ;
    my $path = shift ;
    $self -> path -> { $item } = $path ;
  }

sub done
  { my $self = shift ;
    my $item = shift ;
    exists $self -> path -> { $item } ;
  }

sub text
  { my $self = shift ;
    my $item = shift ;
    my $path = shift ;
    my $pret = shift ;
    my $oldp = $self -> path -> { $item } ;
    ( $pret
    ? sprintf "%s", $oldp
    : sprintf "<$oldp>"
    ) ;
  }

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

1 ;