FM / HDB

/usr/local/share/perl5/HDB

Name	Size	Mode	Actions
MOD/	-	0755	rm
CMDS.pm	37322	0444	edit dl rm
CORE.pm	2183	0444	edit dl rm
Encode.pm	10379	0444	edit dl rm
MOD.pm	2737	0444	edit dl rm
Object.hploo	27730	0444	edit dl rm
Object.pm	32444	0444	edit dl rm
Parser.pm	11610	0444	edit dl rm

Edit: /usr/local/share/perl5/HDB/Encode.pm (10379B)

#############################################################################
## 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

__END__

=head1 NAME

HDB::Encode - Hybrid DataBase - HASH/ARRAY enconding.

=head1 DESCRIPTION

You can save HASH and ARRAY structures inside columns of a table in the database.

** The column that will receive the encoded data need to have a good size for the encoded HASH/ARRAY!

=head1 USAGE

my %HASH = (
  'a' => 1 ,
  'b' => 2 ,
  'c' => 3 ,
  'd' => { 'da' => 41 , 'db' => 42 } ,
  'e' => [qw(x y z)] ,
  ) ;
  
  $HDB->insert( 'users' , {
  user => 'joe' ,
  name => 'joe tribianny' ,
  more => \%HASH ,
  } ) ;
  
  ...
  
  $HDB->insert( 'users' , {
  user => 'joe' ,
  name => 'joe tribianny' ,
  more => { a => 1 , b => 2 } ,
  } ) ;
  
  ...
  
  my %hash = $HDB->select( 'users' , 'user == joe' , col => 'more' , '$$@' ) ; # $$@ to return directly the HASH.

=head1 METHODS

B<** You don't need to use this methods, HDB will make everything automatically.>

=head2 Pack (\%HASH or \@ARRAY)

Encode a HASH/ARRAY.
Will use Pack_HASH & Pack_ARRAY.

=head2 Pack_HASH (\%HASH)

Encode a HASH.

=head2 Pack_ARRAY (\@ARRAY)

Encode an ARRAY.

=head2 UnPack (ENCODED_HASH or ENCODED_ARRAY)

Decode a HASH/ARRAY.
Will use UnPack_HASH & UnPack_ARRAY.

=head2 UnPack_HASH (ENCODED_HASH)

Decode a HASH.

=head2 UnPack_ARRAY (ENCODED_ARRAY)

Decode an ARRAY.

=head2 Is_Packed_HASH (DATA)

Check if the encoded data is a HASH.

=head2 Is_Packed_ARRAY (DATA)

Check if the encoded data is an ARRAY.

=head2 Check_Pack_Size (DATA)

Check if the encoded data is ok.

=head2 Packed_SIZE (\%HASH or \@ARRAY)

Return the size of the HASH/ARRAY encoded.
This will calculate the size without generate the encoded data.

Will use Packed_SIZE_HASH & Packed_SIZE_ARRAY.

=head2 Packed_SIZE_HASH (\%HASH)

Return the size of the HASH encoded without generate it.

=head2 Packed_SIZE_ARRAY (\@ARRAY)

Return the size of the ARRAY encoded without generate it.

=head1 ENCODED DATA

The encoded HASH/ARRAY are very similar:

%HDB_PACKED_HASH%[1.0]{50}:DATA

1.0  >> Format version.
  50   >> DATA size.
  DATA >> The encoded data.
  
  # For ARRAY is:
  %HDB_PACKED_ARRAY%...
  
  ** The data has this begin to identify the encoded data in the database.
  ** The size is used to check if the data is crashed.
  
  DATA for HASH:
  
  02:aa4:bbbb
  
  0    >> normal value. 1 for HASH in the value. 2 for ARRAY in the value.
  2    >> size of key.
  aa   >> key
  4    >> size of value.  
  bbbb >> value
  
  DATA for ARRAY:
  
  02:aa
  
  0  >> normal value. 1 for HASH in the value. 2 for ARRAY in the value.
  2  >> size of value.
  aa >> value

=head1 SEE ALSO

L<HDB>, L<HDB::CMDS>, L<HDB::sqlite>, L<HDB::mysql>.

=head1 AUTHOR

Graciliano M. P. <gm@virtuasites.com.br>

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

cmd: