[perl-cache commit] r561 - progress, but need to add error handling and figure out how to persist between calls to new()
codesite...@google.com
Date: Tue Mar 17 20:29:00 2009
New Revision: 561
Modified:
mma-driver/lib/CHI/Driver/MMA.pm
mma-driver/lib/CHI/t/Driver/MMA.pm
Log:
progress, but need to add error handling and figure out how to persist
between calls to new()
Modified: mma-driver/lib/CHI/Driver/MMA.pm
==============================================================================
--- mma-driver/lib/CHI/Driver/MMA.pm (original)
+++ mma-driver/lib/CHI/Driver/MMA.pm Tue Mar 17 20:29:00 2009
@@ -1,17 +1,15 @@
-package CHI::Driver::DBI;
+package CHI::Driver::MMA;
use strict;
use warnings;
-use DBI;
-use DBI::Const::GetInfoType;
+use IPC::MMA qw(:basic :hash);
use Mouse;
+use File::Spec::Functions qw(catdir tmpdir);
use Carp qw(croak);
our $VERSION = '1.0';
-# TODO: For pg see "upsert" -
http://www.postgresql.org/docs/current/static/plpgsql-control-structures.html#PLPGSQL-UPSERT-EXAMPLE
-
extends 'CHI::Driver';
=head1 NAME
@@ -63,7 +61,19 @@
=cut
-has 'table_prefix' => ( is => 'rw', isa => 'Str', default => 'chi_', );
+has 'root_dir' => (
+ is => 'ro',
+ isa => 'Str',
+ default => tmpdir(),
+);
+
+has 'path_to_namespace' => (
+ is => 'ro',
+ lazy => 1,
+ builder => '_build_path_to_namespace',
+);
+
+has 'size' => ( is => 'ro', isa => 'Int', default => 0 );
=item dbh
@@ -78,7 +88,9 @@
=cut
-has 'dbh' => ( is => 'rw', isa => 'DBI::db', required => 1, );
+has 'mm' => ( is => 'rw', lazy_build => 1, );
+
+has 'hash' => ( is => 'rw', lazy_build => 1, );
=item dbh_ro
@@ -87,8 +99,6 @@
=cut
-has 'dbh_ro' => ( is => 'rw', isa => 'DBI::db', );
-
=item sql_strings
Hashref of SQL strings to use in the different cache operations.
@@ -98,8 +108,6 @@
=cut
-has 'sql_strings' => ( is => 'rw', isa => 'HashRef', lazy_build => 1, );
-
__PACKAGE__->meta->make_immutable;
=head1 METHODS
@@ -118,59 +126,17 @@
sub BUILD {
my ( $self, $args, ) = @_;
- $self->sql_strings;
-
- if ( $args->{create_table} ) {
- $self->{dbh}->do( $self->{sql_strings}->{create} )
- or croak $self->{dbh}->errstr;
- }
-
- return;
-}
-
-sub _table {
- my ( $self, ) = @_;
-
- return $self->table_prefix() . $self->namespace();
+ my $mm = mm_create( $self->size(), $self->path_to_namespace() );
+ my $hash = mm_make_hash($mm);
+ $self->mm($mm);
+ $self->hash($hash);
}
-sub _build_sql_strings {
- my ( $self, ) = @_;
-
- my $table = $self->dbh->quote_identifier( $self->_table );
- my $value = $self->dbh->quote_identifier('value');
- my $key = $self->dbh->quote_identifier('key');
- my $db_name = $self->dbh->get_info( $GetInfoType{SQL_DBMS_NAME} );
-
- my $strings = {
- fetch => "SELECT $value FROM $table WHERE $key = ?",
- store => "INSERT INTO $table ( $key, $value ) VALUES ( ?, ? )",
- store2 => "UPDATE $table SET $value = ? WHERE $key = ?",
- remove => "DELETE FROM $table WHERE $key = ?",
- clear => "DELETE FROM $table",
- get_keys => "SELECT DISTINCT $key FROM $table",
- create => "CREATE TABLE IF NOT EXISTS $table ("
- . " $key VARCHAR( 600 ), $value TEXT,"
- . " PRIMARY KEY ( $key ) )",
- };
-
- if ( $db_name eq 'MySQL' ) {
- $strings->{store} =
- "INSERT INTO $table"
- . " ( $key, $value )"
- . " VALUES ( ?, ? )"
- . " ON DUPLICATE KEY UPDATE $value=VALUES($value)";
- delete $strings->{store2};
- }
- elsif ( $db_name eq 'SQLite' ) {
- $strings->{store} =
- "INSERT OR REPLACE INTO $table"
- . " ( $key, $value )"
- . " values ( ?, ? )";
- delete $strings->{store2};
- }
+sub _build_path_to_namespace {
+ my $self = shift;
- return $strings;
+ return catdir( $self->root_dir,
+ $self->escape_for_filename( $self->namespace ) );
}
=item fetch
@@ -180,13 +146,7 @@
sub fetch {
my ( $self, $key, ) = @_;
- my $dbh = $self->{dbh_ro} ? $self->{dbh_ro} : $self->{dbh};
- my $sth = $dbh->prepare_cached( $self->{sql_strings}->{fetch} )
- or croak $dbh->errstr;
- $sth->execute($key) or croak $sth->errstr;
- my $results = $sth->fetchall_arrayref;
-
- return $results->[0]->[0];
+ return mm_hash_fetch( $self->hash(), $key );
}
=item store
@@ -196,22 +156,7 @@
sub store {
my ( $self, $key, $data, ) = @_;
- my $sth = $self->{dbh}->prepare_cached( $self->{sql_strings}->{store}
);
- if ( not $sth->execute( $key, $data ) ) {
- if ( $self->{sql_strings}->{store2} ) {
- my $sth =
- $self->{dbh}->prepare_cached( $self->{sql_strings}->{store2}
)
- or croak $self->{dbh}->errstr;
- $sth->execute( $data, $key )
- or croak $sth->errstr;
- }
- else {
- croak $sth->errstr;
- }
- }
- $sth->finish;
-
- return;
+ return mm_hash_store( $self->hash(), $key, $data );
}
=item remove
@@ -221,12 +166,7 @@
sub remove {
my ( $self, $key, ) = @_;
- my $sth = $self->dbh->prepare_cached( $self->{sql_strings}->{remove} )
- or croak $self->{dbh}->errstr;
- $sth->execute($key) or croak $sth->errstr;
- $sth->finish;
-
- return;
+ return mm_hash_delete( $self->hash(), $key );
}
=item clear
@@ -234,14 +174,9 @@
=cut
sub clear {
- my ( $self, $key, ) = @_;
-
- my $sth = $self->{dbh}->prepare_cached( $self->{sql_strings}->{clear} )
- or croak $self->{dbh}->errstr;
- $sth->execute() or croak $sth->errstr;
- $sth->finish();
+ my ( $self, ) = @_;
- return;
+ return mm_hash_clear( $self->hash() );
}
=item get_keys
@@ -251,14 +186,15 @@
sub get_keys {
my ( $self, ) = @_;
- my $dbh = $self->{dbh_ro} ? $self->{dbh_ro} : $self->{dbh};
- my $sth = $dbh->prepare_cached( $self->{sql_strings}->{get_keys} )
- or croak $dbh->errstr;
- $sth->execute() or croak $sth->errstr;
- my $results = $sth->fetchall_arrayref( [0] );
- $_ = $_->[0] for @{$results};
+ my @keys;
+ my $hash = $self->hash();
+ for ( my $i = 0 ; $i < mm_hash_scalar($hash) ; $i++ ) {
+ my $key = ( mm_hash_get_entry( $hash, $i ) )[0];
+ if ( !defined $key ) { last }
+ push @keys, $key;
+ }
- return @{$results};
+ return @keys;
}
=item get_namespaces
Modified: mma-driver/lib/CHI/t/Driver/MMA.pm
==============================================================================
--- mma-driver/lib/CHI/t/Driver/MMA.pm (original)
+++ mma-driver/lib/CHI/t/Driver/MMA.pm Tue Mar 17 20:29:00 2009
@@ -8,14 +8,4 @@
sub testing_driver_class { 'CHI::Driver::MMA' }
sub supports_get_namespaces { 0 }
-sub new_cache_options {
- my $self = shift;
-
- return (
- $self->SUPER::new_cache_options(),
- dbh => $self->dbh,
- create_table => 1
- );
-}
-
1;