File Coverage

blib/lib/HDB.pm

Criterion	Covered	Total	%
statement	34	184	18.4
branch	5	82	6.1
condition	3	48	6.2
subroutine	10	29	34.4
pod	4	15	26.6
total	56	358	15.6

#############################################################################
## Name:        HDB.pm
## Purpose:     HDB - Hybrid database
## Author:      Graciliano M. P.
## Modified by:
## Created:     06/01/2003
## RCS-ID:
## Copyright:   (c) 2003 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 ;
use 5.006 ;

use strict qw(vars) ;

use vars qw(@ISA $AUTOLOAD) ;
no warnings ;

our ($VERSION) ;
$VERSION = '1.05' ;

my $REQUIRED ;

###########
# REQUIRE #
###########

sub REQUIRE {
  return if $REQUIRED ;
  require HDB::CORE ;
  require HDB::CMDS ;
  require HDB::Encode ;
  require HDB::MOD ;
  require HDB::Object ;
  $REQUIRED = 1 ;
}

##########
# SCOPES #
##########

  use vars qw($HPL_Run_MAIN $HPL_Run_NOW) ;

  *HPL_Run_MAIN = \$HPL::Run::MAIN ;
  *HPL_Run_NOW = \$HPL::Run::NOW ;

############
# HPL_MAIN #
############

sub HPL_MAIN {
  return $HPL_Run_MAIN if UNIVERSAL::isa($HPL_Run_MAIN,'UNIVERSAL') ;
  return $main::HPL if UNIVERSAL::isa($main::HPL,'UNIVERSAL') ;
  return ${"main::HPL"} ;
}

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

  my %args_types = (
  file     =>  [qw(file dbfile databasefile db database)] ,
  db       =>  [qw(db database)] ,
  host     => [[qw(host hostname)],localhost] ,
  user     =>  [qw(user username)] ,
  pass     =>  [qw(pass password)] ,
  type     => [[qw(type dbtype databasetype dbd)],auto] ,
  cache    => [[qw(cache)],1] ,
  id       =>  [qw(id ident)] ,
  warning  => [[qw(warning warnings error errors alert alerts carp)],1] ,
  dynamic  => [[qw(dynamic dyn)],1] ,
  conf_hpl =>  [qw(confhpl hplconf)] ,
  );

  my (%PASS , %DB , $WITH_HPL , %MOD_LOADED , $RESET_X) ;

##########
# IMPORT #
##########

sub import {
  my $class = shift ;
  if ($_[0] =~ /HPL/i) {
    $WITH_HPL = 1 ;
    &REQUIRE() ;
  }
}

############
# AUTOLOAD #
############

sub AUTOLOAD {

  if ( $#_ == 0 && ref($_[0]) && UNIVERSAL::isa($_[0],'HDB') ) {
    if ( ref($_[0]) eq 'HDB' ) {
      my $this = shift ;
      my $type = $this->{MOD}{type} ;
      bless($this , "HDB::MOD::$type") ;
      $this->connect ;
      my ($method) = ( $AUTOLOAD =~ /(\w+)$/s );
      $this->$method(@_) ;
    }

    my ($table) = ( $AUTOLOAD =~ /(\w+)$/s ) ;
    my $TABLE_OBJ = HDB::TABLE->new($_[0] , $table) ;
    return $TABLE_OBJ ;
  }

  if (ref($_[0])) {
    my @caller = caller ;
    &HDB::Error(undef,qq`Can't find $AUTOLOAD at $caller[1] line $caller[2]!`) ;
    return undef ;
  }

  my ($id0) = ( $AUTOLOAD =~ /(\w+)$/ ) ;
  my $id = lc($id0) ;

  if ( $WITH_HPL && $id ne '' ) {
    my $hpl = &HPL_MAIN() ;

    if ( $hpl ) {
      my $hpl_root = $hpl->pack_root ;

      if ( $id eq 'hploo' && !${"$hpl_root\::MYHDB::DB"}{$id} ) {
        $id = (sort keys %{"$hpl_root\::MYHDB::DB"})[0] ;
        if ( $id ) {
          $hpl->warn(qq`HDB id HPLOO not defined, using 1st defined DB for HDB::Object persistence.` , 1) ;
          ${"$hpl_root\::MYHDB::DB"}{hploo} = ${"$hpl_root\::MYHDB::DB"}{$id} ;
        }
      }

      my $obj = ${"$hpl_root\::MYHDB::DB"}{$id} ;
      if (!$obj) { $hpl->warn(qq`Can't find HDB id "$id" for dynamic access $_[0]\->$id0 !`) ;}
      return $obj ;
    }
  }
  else {
    if (! $DB{$id}) { &HDB::Error(undef,qq`Can't find HDB id "$id" for dynamic access $_[0]\->$id0 !`) ;}
    return $DB{$id} ;
  }

  return undef ;
}

###########
# ALIASES #
###########

sub WITH_HPL { $WITH_HPL ;}

sub open {
  if ( ref $_[0] && UNIVERSAL::isa($_[0],'HDB') ) {
    $_[0]->connect ;
    return $_[0] ;
  }
  else { return &new(@_) ;}
}

sub close { $_[0]->disconnect ;}

#######
# NEW #
#######

sub new {
  &REQUIRE() ;

  my $class = shift ;
  my $this = {} ;

  &HDB::CORE::parse_args($this , \%args_types , @_) ;
  $this->{file} = &HDB::CORE::path($this->{file}) if defined $this->{file} ;

  $this->{id} =~ s/\W//s ;
  $this->{id} = lc( $this->{id} ) ;

  if ( $this->{type} eq 'auto' ) {
    if ( defined $this->{file} ) { $this->{type} = 'sqlite' ;}
    else { $this->{type} = 'mysql' ;}
  }
  else {
    my $type = $this->{type} ;
    $this->{type} =~ s/\W//gs ;
    $this->{type} = lc( $this->{type} ) ;
  }

  return Error($this,"Invalid type!") if $this->{type} eq '' ;

  my $type = $this->{type} ;

  if ( !&_require_module($type) ) { return Error($this,"Can't find HDB module for $type (HDB::MOD::$type)!") ;}

  &{"HDB::MOD::$type\::new"}($this) ;

  return $this->Error("Error on loanding HDB module $type (HDB::MOD::$type)!") if !$this ;

  if ( ($this->{conf_hpl} || $WITH_HPL ) && $this->{file} ) {
    my $hpl = &HPL_MAIN() ;
    if ( defined $hpl->env->{DOCUMENT_ROOT} ) {
      $this->{file} =~ s/^[\/\\][\/\\]/$hpl->env->{DOCUMENT_ROOT}/se ;
    }
  }

  ## "HIDDE" PASS:
  $PASS{$this} = $this->{pass} ;
  delete $this->{pass} ;

  eval { $this->connect };

  if ( !$this || !$this->connected || !$this->dbh ) { $this->Error("Can't connect to DB. Load error!") ; return ;}

  if ($this->{dynamic} && $this->{id} ne '') {
    if ( $WITH_HPL ) {
      $this->{WITH_HPL} = 1 ;
      my $hpl = &HPL_MAIN() ;
      if ( $hpl ) {
        my $hpl_root = $hpl->pack_root ;
        ${"$hpl_root\::MYHDB::DB"}{ $this->{id} } = $this ;
      }
    }
    else { $DB{ $this->{id} } = $this ;}
  }


  if ( $WITH_HPL ) {
    $this->dbh->{HandleError} = \&HPL_show_error ;
  }

  return $this ;
}

##################
# HPL_SHOW_ERROR #
##################

sub HPL_show_error {
  my $hpl = &HPL_MAIN() ;
  $hpl->warn($_[0]) if $hpl ;
  return $_[2] ;
}

###########
# CONNECT #
###########

sub connect {
  if ( $_[0]->{dbh} ) { return $_[0]->{dbh} ;}
  $_[0]->MOD_connect( $PASS{$_[0]} ) ;
  return $_[0]->{dbh} ;
}

#############
# RECONNECT #
#############

sub reconnect {
  $_[0]->disconnect ;
  $_[0]->connect ;
}

#########
# ERROR #
#########

sub Error {

  if ( $_[0]->{sth} ) {
    $_[0]->{sth}->finish ;
    $_[0]->{sth} = undef ;
  }

  if ($_[0] && !$_[0]->{warning}) { return ;}
  if ($_[0] && ref $_[0]->{warning} eq 'CODE') { &{$_[0]->{warning}}($_[1]) }
  else {
    if ($WITH_HPL) {
      my $hpl = &HPL_MAIN() ;
      $hpl->warn($_[1] , $_[2]) if $hpl ;
    }
    else {
      eval {
        require Carp ;
        Carp::carp($_[1]) ;
      };
    }
  }

  return ;
}

###################
# _REQUIRE_MODULE #
###################

sub _require_module {
  my ( $module ) = @_ ;
  return 1 if $MOD_LOADED{$module} ;
  eval("require HDB::MOD::$module ;") ;
  return undef if $@ ;
  return $MOD_LOADED{$module} = 1 ;
}

###########
# DESTROY #
###########

sub DESTROY {
  delete $PASS{$_[0]} ;
  $_[0]->disconnect ;
}

#########
# RESET #
#########

sub RESET {
  ++$RESET_X ;

  HDB::Object::RESET() if defined &HDB::Object::RESET && (!$WITH_HPL || $RESET_X > 10) ;

  if ( $WITH_HPL ) {
    my $hpl = &HPL_MAIN() ;
    if ( $hpl ) {
      my $HDB_LINKED = \%{ $hpl->pack_root ."::MYHDB::DB"} ;
      %$HDB_LINKED = () ;
      undef %$HDB_LINKED ;
      eval {
        foreach my $Key ( keys %$HDB_LINKED ) { $$HDB_LINKED{$Key}->UNLINK ;}
      };
    }
  }

  %DB = () ;

  HDB::Parser::RESET() if defined &HDB::Parser::RESET && (!$WITH_HPL || $RESET_X > 10) ;

  $RESET_X = 0 if $RESET_X > 10 ;

  return 1 ;
}

sub END { &RESET }

#########
# TABLE #
#########

sub TABLE { HDB::TABLE->new(@_) ;}

##############
# HDB::TABLE #
##############

package HDB::TABLE ;

use vars qw($AUTOLOAD) ;

#######
# NEW #
#######

sub new {
  bless({
  hdb => $_[1] ,
  table => $_[2] ,
  },$_[0]) ;
}

sub DESTROY {
  ##print main::STDOUT "DESTROY>> @_\n" ;
}

sub AUTOLOAD {
  my $obj = shift ;
  my ($method) = ( $AUTOLOAD =~ /(\w+)$/s ) ;
  my $class = ref $obj->{hdb} ;
  return ($obj->{hdb})->$method($obj->{table} , @_) ;
}

#############
# HDB::CMDS #
#############

package HDB::CMDS ;

sub default_types { require HDB::CMDS ; &default_types ;}
sub predefined_columns { require HDB::CMDS ; &predefined_columns ;}
sub default_mod { require HDB::CMDS ; &default_mod ;}

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

1;

__END__