File Coverage

blib/lib/HDB/Encode.pm

Criterion	Covered	Total	%
statement	6	177	3.3
branch	0	100	0.0
condition			n/a
subroutine	2	15	13.3
pod	12	13	92.3
total	20	305	6.5

#############################################################################
## Name:        Encode.pm
## Purpose:     HDB::Encode - Common things for HDB modules.
## Author:      Graciliano M. P.
## Modified by:
## Created:     15/01/2003
## RCS-ID:
## Copyright:   (c) 2002 Graciliano M. P.
## Licence:     This program is free software; you can redistribute it and/or
##              modify it under the same terms as Perl itself
#############################################################################

package HDB::Encode ;

use strict qw(vars);
no warnings ;

our $VERSION = '1.0' ;

########
# VARS #
########

  my %VER = (
  PACKED_HASH => '1.0' ,
  PACKED_ARRAY => '1.0' ,
  ) ;

########
# PACK #
########

sub Pack {
  if ( ref($_[0]) eq 'HASH' ) { return &Pack_HASH($_[0]) ;}
  if ( ref($_[0]) eq 'ARRAY' ) { return &Pack_ARRAY($_[0]) ;}
}

#############
# PACK_HASH #
#############

sub Pack_HASH {
  my ( $hash ) = @_ ;

  if (ref($hash) ne 'HASH') { return( undef ) ;}

  my ($pack_init,$pack) ;

  $pack_init = "%HDB_PACKED_HASH%[$VER{PACKED_HASH}]{0}:" if !$_[1] ;

  foreach my $key ( keys %$hash ) {
    my ($blk,$tp,$value) ;
    if    ( ref( $$hash{$key} ) eq 'HASH' ) { $tp = 1 ; $value = &Pack_HASH( $$hash{$key} , 1 ) }
    elsif ( ref( $$hash{$key} ) eq 'ARRAY' ) { $tp = 2 ; $value = &Pack_ARRAY( $$hash{$key} , 1 ) ;}
    elsif ( UNIVERSAL::isa($$hash{$key} ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $tp = 0 ; $value = $$hash{$key} ;}

    $blk .= $tp ;
    $blk .= length($key) . ":" ;
    $blk .= $key ;
    $blk .= length($value) . ":" ;
    $blk .= $value ;

    $pack .= $blk ;
  }

  if ( !$_[1] ) {
    my $sz = length($pack) ;
    $pack_init =~ s/\{0}/\{$sz}/s ;
  }

  return( $pack_init . $pack ) ;
}

##############
# PACK_ARRAY #
##############

sub Pack_ARRAY {
  my ( $array ) = @_ ;

  if (ref($array) ne 'ARRAY') { return( undef ) ;}

  my ($pack_init,$pack) ;

  $pack_init = "%HDB_PACKED_ARRAY%[$VER{PACKED_ARRAY}]{0}:" if !$_[1] ;

  foreach my $array_i ( @$array ) {
    my ($blk,$tp,$value) ;
    if    ( ref( $array_i ) eq 'HASH' ) { $tp = 1 ; $value = &Pack_HASH( $array_i , 1 ) ;}
    elsif ( ref( $array_i ) eq 'ARRAY' ) { $tp = 2 ; $value = &Pack_ARRAY( $array_i , 1 ) ;}
    elsif ( UNIVERSAL::isa($array_i ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $tp = 0 ; $value = $array_i ;}

    $blk .= $tp ;
    $blk .= length($value) . ":" ;
    $blk .= $value ;

    $pack .= $blk ;
  }

  if ( !$_[1] ) {
    my $sz = length($pack) ;
    $pack_init =~ s/\{0}/\{$sz}/s ;
  }

  return( $pack_init . $pack ) ;
}

##########
# UNPACK #
##########

sub UnPack {
  if ( &Is_Packed_HASH($_[0]) ) { return &UnPack_HASH($_[0]) ;}
  if ( &Is_Packed_ARRAY($_[0]) ) { return &UnPack_ARRAY($_[0]) ;}
  return( $_[0] ) ;
}

###############
# UNPACK_HASH #
###############

sub UnPack_HASH {
  my %hash ;

  my $pos = 0 ;

  if ( !$_[1] ) {
    if ( !&Is_Packed_HASH($_[0]) ) { return() ;}
    elsif ( !&Check_Pack_Size($_[0]) ) { return("SIZE_ERROR: $_[0]") ;}
    else { $pos = index($_[0],':') + 1 ;}
  }

  my $lng = length($_[0]) ;

  while( $pos < $lng ) {
    my $tp = substr($_[0],$pos++,1) ;
    my $key = &blk_read($_[0],$pos) ;
    my $val = &blk_read($_[0],$pos) ;

    if ($tp == 1) {
      my %val = &UnPack_HASH($val,1) ;
      $val = \%val ;
    }
    elsif ($tp == 2) {
      my @val = &UnPack_ARRAY($val,1) ;
      $val = \@val ;
    }

    $hash{$key} = $val ;
  }

  if ( wantarray ) { return( %hash ) ;}
  else { return( \%hash ) ;}
}

################
# UNPACK_ARRAY #
################

sub UnPack_ARRAY {
  my @array ;

  my $pos = 0 ;

  if ( !$_[1] ) {
    if ( !&Is_Packed_ARRAY($_[0]) ) { return() ;}
    elsif ( !&Check_Pack_Size($_[0]) ) { return("SIZE_ERROR: $_[0]") ;}
    else { $pos = index($_[0],':') + 1 ;}
  }

  my $lng = length($_[0]) ;

  while( $pos < $lng ) {
    my $tp = substr($_[0],$pos++,1) ;
    my $val = &blk_read($_[0],$pos) ;

    if ($tp == 1) {
      my %val = &UnPack_HASH($val,1) ;
      $val = \%val ;
    }
    elsif ($tp == 2) {
      my @val = &UnPack_ARRAY($val,1) ;
      $val = \@val ;
    }

    push(@array , $val) ;
  }

  if ( wantarray ) { return( @array ) ;}
  else { return( \@array ) ;}
}

############
# BLK_READ #
############

sub blk_read {
  my ( undef , undef , $lng ) = @_ ;

  if (!$lng) { $lng = length( $_[0] ) ;}

  my ($s,$sz) ;

  while( $_[1] <= $lng ) {
    $s = substr( $_[0]  , $_[1] , 1) ;
    $_[1]++ ;
    if ($s eq ':') { last ;}
    $sz .= $s ;
  }

  my $blk = substr( $_[0] , $_[1] , $sz) ;

  $_[1] += $sz ;

  return( $blk ) ;
}

##################
# IS_PACKED_HASH #
##################

sub Is_Packed_HASH {
  if ( $_[0] =~ /^\s*\%HDB_PACKED_HASH%\[[\d\.]+]\{\d+}:/ ) { return( 1 ) ;}
  return( undef ) ;
}

###################
# IS_PACKED_ARRAY #
###################

sub Is_Packed_ARRAY {
  if ( $_[0] =~ /^\s*\%HDB_PACKED_ARRAY%\[[\d\.]+]\{\d+}:/ ) { return( 1 ) ;}
  return( undef ) ;
}

###################
# CHECK_PACK_SIZE #
###################

sub Check_Pack_Size {
  if ( $_[0] =~ /^(\s*\%HDB_PACKED_(?:HASH|ARRAY)%\[[\d\.]+]\{)(\d+)(}:)/s ) {
    my $lng = length($1) + length($3) ;
    my $sz = $2 ;
    $lng += length($sz) + $sz ;
    if ( length($_[0]) == $lng ) { return( 1 ) ;}
  }
  return( undef ) ;
}

###############
# PACKED_SIZE #
###############

sub Packed_SIZE {
  my ( $ref ) = @_ ;
  if ( ref($ref) eq 'HASH' ) { return &Packed_SIZE_HASH($ref) ;}
  if ( ref($ref) eq 'ARRAY' ) { return &Packed_SIZE_ARRAY($ref) ;}
}

####################
# PACKED_SIZE_HASH #
####################

sub Packed_SIZE_HASH {
  my ( $hash ) = @_ ;

  if (ref($hash) ne 'HASH') { return( undef ) ;}

  my ($pack_init,$size) ;

  $pack_init = "%HDB_PACKED_HASH%[$VER{PACKED_HASH}]{0}:" if !$_[1] ;

  foreach my $key ( keys %$hash ) {
    my ($blk_sz,$value_sz) ;
    if    ( ref( $$hash{$key} ) eq 'HASH' ) { $value_sz = &Packed_SIZE_HASH( $$hash{$key} , 1 ) }
    elsif ( ref( $$hash{$key} ) eq 'ARRAY' ) { $value_sz = &Packed_SIZE_ARRAY( $$hash{$key} , 1 ) ;}
    elsif ( UNIVERSAL::isa($$hash{$key} ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $value_sz = length( $$hash{$key} ) ;}

    $blk_sz += 1 ;
    $blk_sz += length(length($key)) + 1 ;
    $blk_sz += length($key) ;
    $blk_sz += length($value_sz) + 1 ;
    $blk_sz += $value_sz ;

    $size += $blk_sz ;
  }

  if ( !$_[1] ) { $pack_init =~ s/\{0}/\{$size}/s ;}

  $size += length($pack_init) if !$_[1] ;

  return( $size ) ;
}

#####################
# PACKED_SIZE_ARRAY #
#####################

sub Packed_SIZE_ARRAY {
  my ( $array ) = @_ ;

  if (ref($array) ne 'ARRAY') { return( undef ) ;}

  my ($pack_init,$size) ;

  $pack_init = "%HDB_PACKED_ARRAY%[$VER{PACKED_ARRAY}]{0}:" if !$_[1] ;

  foreach my $array_i ( @$array ) {
    my ($blk_sz,$value_sz) ;
    if    ( ref( $array_i ) eq 'HASH' ) { $value_sz = &Packed_SIZE_HASH( $array_i , 1 ) ;}
    elsif ( ref( $array_i ) eq 'ARRAY' ) { $value_sz = &Packed_SIZE_ARRAY( $array_i , 1 ) ;}
    elsif ( UNIVERSAL::isa($array_i ,'UNIVERSAL') ) { next ;} ## ignore objects.
    else { $value_sz = length($array_i) ;}

    $blk_sz += 1 ;
    $blk_sz += length($value_sz) + 1 ;
    $blk_sz += $value_sz ;

    $size += $blk_sz ;
  }

  if ( !$_[1] ) { $pack_init =~ s/\{0}/\{$size}/s ;}

  $size += length($pack_init) if !$_[1] ;

  return( $size ) ;
}

#######
# END #
#######

# 0 => key & val || line
# 1 => hash ref
# 2 => array ref

1;

__END__