view release on metacpan or  search on metacpan

lib/Apache2/Translation/DB.pm  view on Meta::CPAN

package Apache2::Translation::DB;

use 5.008008;
use strict;
use warnings;
no warnings qw(uninitialized);

use DBI;
use Class::Member::HASH -CLASS_MEMBERS=>qw/database user password table
					   key uri block order action notes
					   cachesize cachetbl cachecol
					   singleton id is_initialized
					   seqtbl seqnamecol seqvalcol
					   idseqname dbinit
					   _existing_keys
					   _cache _cache_version _dbh/;
our @CLASS_MEMBERS;

our $VERSION = '0.07';

sub new {
  my $parent=shift;
  my $class=ref($parent) || $parent;
  my $I=bless {}=>$class;
  my $x=0;
  my %o=map {($x=!$x) ? lc($_) : $_} @_;

  if( ref($parent) ) {         # inherit first
    foreach my $m (@CLASS_MEMBERS) {
      $I->$m=$parent->$m;
    }
  }

  $I->cachesize=1000;
  $I->singleton=0;

  # then override with named parameters
  foreach my $m (@CLASS_MEMBERS) {
    $I->$m=$o{$m} if( exists $o{$m} );
  }

  $I->_existing_keys={};
  $I->_cache={};
  if( $I->cachesize=~/^\d/ ) {
    eval "use Tie::Cache::LRU";
    die "$@" if $@;
    tie %{$I->_cache}, 'Tie::Cache::LRU', $I->cachesize;
  }

  return $I;
}

sub connect {
  my $I=shift;

  my $dbh=$I->_dbh=DBI->connect( $I->database, $I->user, $I->password,
				{
				 AutoCommit=>1,
				 PrintError=>0,
				 RaiseError=>1,
				} );
  $dbh->do($I->dbinit) if( length $I->dbinit );
  return $dbh;
}

sub start {
  my $I=shift;
  unless( $I->_dbh and eval {$I->start_common} ) {
    $I->_dbh->disconnect if( $I->_dbh );
    $I->connect;
    $I->start_common;
  }
}

sub stop {
  my $I=shift;
  undef $I->_dbh if( !$I->singleton and
		     ($I->_dbh->isa( 'Apache::DBI::Cache::db' ) or
		      $I->_dbh->isa( 'Apache::DBI::db' )) );
}

sub start_common {
  my $I=shift;

  my ($cache_tbl,$cache_col)=map {$I->$_} qw/cachetbl cachecol/;

  my $sql=<<"SQL";
SELECT MAX($cache_col)
FROM $cache_tbl
SQL

  my $stmt=$I->_dbh->prepare_cached( $sql );
  $stmt->execute;
  my $cache_version=$stmt->fetchall_arrayref->[0]->[0];

  unless( $cache_version eq $I->_cache_version ) {
    %{$I->_cache}=();
    $I->_cache_version=$cache_version;

    my ($tbl, $key, $uri)=map {$I->$_} qw/table key uri/;
    $sql=<<"SQL";
SELECT DISTINCT $key, $uri FROM $tbl
SQL

    $stmt=$I->_dbh->prepare_cached( $sql );
    $stmt->execute;
    $I->_existing_keys=+{map {("$_->[0]\0$_->[1]"=>1)}
			 @{$stmt->fetchall_arrayref}};
  }

  return 1;
}

sub fetch {
  my $I=shift;
  my ($key, $uri, $with_notes)=@_;