Tie-DBI-1.06/000750 000765 000024 00000000000 12127565406 012655 5ustar00toddstaff000000 000000 Tie-DBI-1.06/Changes000644 000765 000024 00000003613 12127565233 014156 0ustar00toddstaff000000 000000 Revision history for Perl extension Tie::DBI. 1.06 Fri Apr 5 2013 Todd Rinaldo Bump to production release now tests all pass on cpan testers 1.05_01 Thu Mar 28 2013 Todd Rinaldo Fix for RT 58813 - Fix for File based DBDs Fix for RT 84125 - Fix for mysqlPP 1.05 Sat Apr10 01:00 2010 need to make DBD::SQLite to pre-req to get tests to succeed. This shouldn't really be an undue burden 1.04 Mon Mar 31 22:25 2010 Add DBD::SQLite to build_requires meta so automated testing won't fail 1.03 Mon Mar 29 13:00 2010 RT 3695 - SQLite support - Thanks RURBAN RT 19833 - Don't Chomp blanks. The user can do that in their script if they intended it. NOTE!!! This may break your code if you were depending on this behavior. Please open an RT ticket if you feel this needs to be put back in. Test suite to Test::More 1.02 Wed Dec 28 12:57:18 EST 2005 Clarified requirement that column used as hash key must be declared unique when table is created. 1.01 Mon Mar 7 18:51:27 EST 2005 More minor documentation fixes. (darn!) 1.00 Mon Mar 7 18:47:59 EST 2005 Minor documentation fix. 0.95 Wed Jan 19 13:03:54 EST 2005 Autrijus Tang fix for clobbered $_. 0.94 Wed Nov 17 17:05:07 EST 2004 Fix tests so that they work under PostGres, courtesy Arshavir Grigora 0.93 Fri Jul 18 13:24:30 EDT 2003 Improved support for Oracle data types courtesy Luogang . 0.92 Tue Dec 31 12:50:33 EST 2002 ODBC support courtesy Autrijus Tang 0.86 August 7, 2000 Fixed bug in EXISTS that shows up when using DBD::InterBase. Thanks to Michael Samanov for this. 0.85 April 26, 1999 Fixed stupid mistake: $DBI::error should be $DBI::err. 0.70 September 25, 1998 - Now correctly supports Oracle. 0.60 January 28, 1998 - Tested on mSQL and mySQL - Does not work correctly with Oracle or Sybase 0.01 Sun Jan 11 16:50:57 1998 - original version; created by h2xs 1.18 Tie-DBI-1.06/lib/000750 000765 000024 00000000000 12127565405 013422 5ustar00toddstaff000000 000000 Tie-DBI-1.06/Makefile.PL000644 000765 000024 00000002770 12127565102 014633 0ustar00toddstaff000000 000000 use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Tie::DBI', 'AUTHOR' => 'Lincoln D. Stein ', 'VERSION_FROM' => 'lib/Tie/DBI.pm', # finds $VERSION 'ABSTRACT_FROM' => 'lib/Tie/DBI.pm', 'PREREQ_PM' => { 'Test::More' => 0, 'DBI' => 0, 'DBD::SQLite' => 0, }, ( $ExtUtils::MakeMaker::VERSION >= 6.3002 ? ( 'LICENSE' => 'perl', ) : () ), 'DISTNAME' => 'Tie-DBI', 'linkext' => { LINKTYPE => '' }, # no link needed 'dist' => { 'COMPRESS' => 'gzip -9f', 'SUFFIX' => 'gz', 'ZIP' => '/usr/bin/zip', 'ZIPFLAGS' => '-rl' }, 'clean' => { FILES => 'Tie-DBI-* test:* depth_test' }, 'META_MERGE' => { build_requires => { 'Test::More' => 0, # For testing 'DBD::SQLite' => 0, # Make sure at least one DBD is there for automated testing }, resources => { license => 'http://dev.perl.org/licenses/', homepage => 'http://wiki.github.com/toddr/Tie-DBI/', # bugtracker => 'http://code.google.com/p/Tie-DBI/issues/list', repository => 'http://github.com/toddr/Tie-DBI', # MailingList => 'http://groups.google.com/group/Tie-DBI', }, }, ) Tie-DBI-1.06/MANIFEST000644 000765 000024 00000000405 12127565406 014012 0ustar00toddstaff000000 000000 Changes MANIFEST MANIFEST.SKIP Makefile.PL README lib/Tie/DBI.pm lib/Tie/RDBM.pm t/DBI.t t/RDBM.t META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Tie-DBI-1.06/MANIFEST.SKIP000644 000765 000024 00000000243 11355010320 014535 0ustar00toddstaff000000 000000 \bRCS\b \bCVS\b \.bak$ ^Makefile$ ~$ ^# \.gz$ ^t\d*\.pl \.old$ ^benchmarks/ ^blib/ ^MakeMaker-\d ^tmon.out$ ^test ^creat ^devel\. ^devel\. ^foo ^pm_to_blib /#.+#$ Tie-DBI-1.06/META.json000640 000765 000024 00000002330 12127565406 014275 0ustar00toddstaff000000 000000 { "abstract" : "Tie hashes to DBI relational databases", "author" : [ "Lincoln D. Stein " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120351", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Tie-DBI", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "DBD::SQLite" : "0", "ExtUtils::MakeMaker" : "0", "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "DBD::SQLite" : "0", "DBI" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "homepage" : "http://wiki.github.com/toddr/Tie-DBI/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/toddr/Tie-DBI" } }, "version" : "1.06" } Tie-DBI-1.06/META.yml000640 000765 000024 00000001273 12127565406 014132 0ustar00toddstaff000000 000000 --- abstract: 'Tie hashes to DBI relational databases' author: - 'Lincoln D. Stein ' build_requires: DBD::SQLite: 0 ExtUtils::MakeMaker: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120351' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tie-DBI no_index: directory: - t - inc requires: DBD::SQLite: 0 DBI: 0 Test::More: 0 resources: homepage: http://wiki.github.com/toddr/Tie-DBI/ license: http://dev.perl.org/licenses/ repository: http://github.com/toddr/Tie-DBI version: 1.06 Tie-DBI-1.06/README000644 000765 000024 00000007453 11355011472 013542 0ustar00toddstaff000000 000000 This distribution contains Tie::DBI and Tie::RDBM, two modules that allow you to tie associative arrays to relational databases using the DBI library. The hash is tied to a table in a local or networked database. Reading from the hash retrieves values from the datavbase. Storing into the hash updates the database (if you have sufficient privileges). Tie::DBI implements a fully general binding between the hash and the table, allowing you to access fields in this manner: $h{strawberries}->{quantity} = 228; Tie::RDBM implements a more limited binding which gives you access to only one column of the table. However it is faster, can create and destroy tables on the fly, and provides an interface whereby you can store and retrieve complex Perl objects from the database table. In addition to this package, you will need the DBI database interface module, plus the DBD driver for the database of your choice. To be able to store and retrieve non-scalar values via the Tie::RDBM interface you will also need Storable.pm These are all available at a CPAN near you: http://www.perl.com/CPAN/ To install: 1. perl Makefile.PL 2. make 3. make test [optional] 4. make install To read the documentation: perldoc Tie::DBI perldoc Tie::RDBM "make test" requires you to have a database named "test" up and running on the local machine. The database must allow table add and drop privileges for the current user. The test script will search for an installed DBD driver to use. You can override its choice by specifying DRIVER= on the command line. For example: make test DRIVER=mysql If you need to specify a different database, or need to provide a username and password to log in, you can provide these values as DB, USER, PASS and HOST, respectively, as in: make test DRIVER=Oracle DB=DEMO USER=fred PASS=xyzzy HOST=localhost And some drivers, such as Pg, want funny database names, as in: make test DRIVER=Pg DB=dbname=test USER=fred PASS=xyzzy Databases differ in their capabilities, and some can't support binary data types (or support them in a difficult, non-standard way). Such databases include mSQL, Postgres and Informix. On those databases, it is not possible to store arbitrary Perl data structures into Tie::RDBM hashes. For this reason Tie::RDBM tests #13 and #14 will be skipped. The test will fail if you do not have Storable.pm installed on your system. The Postgres driver breaks when you try to set a field to null by passing it an under variable. This causes Tie::DBI test #29 to fail. In addition, there is vast heterogeneity among DBD drivers which renders this interface inoperative for certain databases. It has been tested and is known to work on the following databases: 1) DBD::mysql 2) DBD::Oracle 3) DBD::mSQL (skips Tie::RDB tests 13-14) 4) DBD::CSV (skips Tie::DBI test #29) 5) DBD::Postgres (skips Tie::RDBM tests 13-14 and flunks Tie::DBI test #29) 6) DBD::Informix (skips Tie::RDBM tests 13-14) 7) DBD::Sybase (partial, croaks on each()) 8) DBD::Solid 9) DBD::ODBC (on mysql ODBC driver) 10) DBD::SQLite Microsoft SQL server works partially with Tie::DBI (everything but "each") and not at all with Tie::RDBM. This is because SQL server doesn't allow there to be multiple pending queries on the database. Let me know if you can get it to run with true Sybase servers, and any other drivers you try. For more information, see the perldoc documentation. Also be sure to check out Gerald Richter's DBIx::Recordset, which puts a tied array interface on the results of arbitrary SQL expressions and is optimized for use in embperl. The latest version of this module is available on CPAN. References: The DBI home page: http://www.hermetica.com/technologia/perl/DBI Gerald Richter's DBIx::Recordset: http://perl.apache.org/embperl.html. Lincoln Stein lstein@cshl.org Tie-DBI-1.06/t/000750 000765 000024 00000000000 12127565405 013117 5ustar00toddstaff000000 000000 Tie-DBI-1.06/t/DBI.t000644 000765 000024 00000012441 12127565011 013702 0ustar00toddstaff000000 000000 use strict; use warnings; use Test::More; my $DRIVER = $ENV{DRIVER}; use constant USER => $ENV{USER} || $ENV{DBI_USER}; use constant PASS => $ENV{PASS} || $ENV{DBI_PASS}; use constant DBNAME => $ENV{DB} || 'test'; use constant HOST => $ENV{HOST} || ( $^O eq 'cygwin' ) ? '127.0.0.1' : 'localhost'; use DBI; use Tie::DBI; ######################### End of black magic. if ( $ENV{DBI_DSN} && !$DRIVER ) { ( $DRIVER = $ENV{DBI_DSN} ) =~ s/^dbi:([^:]+):.*$/$1/i; } unless ($DRIVER) { local ($^W) = 0; # kill uninitialized variable warning # I like mysql best, followed by Oracle and Sybase my ($count) = 0; my (%DRIVERS) = map { ( $_, $count++ ) } qw(Informix Pg Ingres mSQL Sybase Oracle mysql SQLite); # ExampleP doesn't work; ($DRIVER) = sort { $DRIVERS{$b} <=> $DRIVERS{$a} } grep { exists $DRIVERS{$_} } DBI->available_drivers(1); } if ($DRIVER) { plan tests => 26; diag("DBI.t - Using DBD driver $DRIVER..."); } else { plan skip_all => "Found no DBD driver to use.\n"; } my %TABLES = ( 'CSV' => < < < <connect( $dsn, USER, PASS, { PrintError => 0 } ) || return undef; $dbh->do("DROP TABLE testTie"); return $dbh if $DRIVER eq 'ExampleP'; my $table = $TABLES{$DRIVER} || DEFAULT_TABLE; foreach ( split( ';', $table ) ) { $dbh->do($_) || warn $DBI::errstr; } $dbh; } sub insert_data { my $h = shift; my ( $record, $count ); foreach $record (@test_data) { my %record = map { $fields[$_] => $record->[$_] } ( 0 .. $#fields ); $h->{ $record{produce_id} } = \%record; $count++; } return $count == @test_data; } sub chopBlanks { my $a = shift; $a =~ s/\s+$//; $a; } my %h; my $dbh = initialize_database; { local ($^W) = 0; ok( $dbh, "DBH returned from init_db" ) or die("Couldn't create test table: $DBI::errstr"); } isa_ok( tie( %h, 'Tie::DBI', { db => $dbh, table => 'testTie', key => 'produce_id', CLOBBER => 3, WARN => 0 } ), 'Tie::DBI' ); %h = () unless $DRIVER eq 'ExampleP'; is( scalar( keys %h ), 0, '%h is empty' ); { local $^W = 0; ok( insert_data( \%h ), "Insert data into db" ); } ok( exists( $h{strawberries} ) ); ok( defined( $h{strawberries} ) ); is( join( " ", map { chopBlanks($_) } sort keys %h ), "apricots bananas eggs kiwis strawberries" ); is( $h{eggs}->{quantity}, 12 ); $h{eggs}->{quantity} *= 2; is( $h{eggs}->{quantity}, 24 ); my $total_price = 0; my $count = 0; my ( $key, $value ); while ( ( $key, $value ) = each %h ) { $total_price += $value->{price} * $value->{quantity}; $count++; } is( $count, 5 ); cmp_ok( abs( $total_price - 85.2 ), '<', 0.01 ); $h{'cherries'} = { description => 'Vine-ripened cherries', price => 2.50, quantity => 200 }; is( $h{'cherries'}{quantity}, 200 ); $h{'cherries'} = { price => 2.75 }; is( $h{'cherries'}{quantity}, 200 ); is( $h{'cherries'}{price}, 2.75 ); is( join( " ", map { chopBlanks($_) } sort keys %h ), "apricots bananas cherries eggs kiwis strawberries" ); ok( delete $h{'cherries'} ); is( exists $h{'cherries'}, '' ); my $array = $h{ 'eggs', 'strawberries' }; is( $array->[1]->{'description'}, 'Fresh Maine strawberries' ); my $another_array = $array->[1]->{ 'produce_id', 'quantity' }; is( "@{$another_array}", 'strawberries 8' ); is( @fields = tied(%h)->select_where('quantity > 10'), 2 ); is( join( " ", sort @fields ), 'bananas eggs' ); SKIP: { skip "Skipping test for CSV driver...", 1 if ( $DRIVER eq 'CSV' ); delete $h{strawberries}->{quantity}; ok( !defined $h{strawberries}->{quantity}, 'Quantity was deleted' ); } ok( $h{strawberries}->{quantity} = 42 ); ok( $h{strawberries}->{quantity} = 42 ); # make sure update statement works when nothing changes is( $h{strawberries}->{quantity}, 42 ); # RT 19833 - Trailing space inappropriatley stripped. use constant TEST_STRING => ' extra spaces '; my $before = TEST_STRING; $h{strawberries}->{description} = $before; my $after = $h{strawberries}->{description}; is( $after, $before, "blanks aren't chopped" ); Tie-DBI-1.06/t/RDBM.t000644 000765 000024 00000004042 12127565011 014026 0ustar00toddstaff000000 000000 use strict; use warnings; use Test::More tests => 19; my $DRIVER = $ENV{DRIVER}; use constant USER => $ENV{USER}; use constant PASS => $ENV{PASS}; use constant DBNAME => $ENV{DB} || 'test'; use constant HOST => $ENV{HOST} || ( $^O eq 'cygwin' ) ? '127.0.0.1' : 'localhost'; use DBI; use Tie::RDBM; unless ($DRIVER) { local ($^W) = 0; # kill uninitialized variable warning # Test using the mysql, sybase, oracle and mSQL databases respectively my ($count) = 0; my (%DRIVERS) = map { ( $_, $count++ ) } qw(Informix Pg Ingres mSQL Sybase Oracle mysql SQLite); # ExampleP doesn't work ($DRIVER) = sort { $DRIVERS{$b} <=> $DRIVERS{$a} } grep { exists $DRIVERS{$_} } DBI->available_drivers(1); } if ($DRIVER) { diag("RDBM.t - Using DBD driver $DRIVER..."); } else { die "Found no DBD driver to use.\n"; } my $dsn; if ( $DRIVER eq 'Pg' ) { $dsn = "dbi:$DRIVER:dbname=${\DBNAME}"; } else { $dsn = "dbi:$DRIVER:${\DBNAME}:${\HOST}"; } my %h; isa_ok( tie( %h, 'Tie::RDBM', $dsn, { create => 1, drop => 1, table => 'PData', 'warn' => 0, user => USER, password => PASS } ), 'Tie::RDBM' ); %h = (); is( scalar( keys %h ), 0 ); is( $h{'fred'} = 'ethel', 'ethel' ); is( $h{'fred'}, 'ethel' ); is( $h{'ricky'} = 'lucy', 'lucy' ); is( $h{'ricky'}, 'lucy' ); is( $h{'fred'} = 'lucy', 'lucy' ); is( $h{'fred'}, 'lucy' ); ok( exists( $h{'fred'} ) ); ok( delete $h{'fred'} ); ok( !exists( $h{'fred'} ) ); SKIP: { if ( !tied(%h)->{canfreeze} ) { $h{'fred'} = 'junk'; skip 'Not working on this DBD', 2; } local ($^W) = 0; # avoid uninitialized variable warning ok( $h{'fred'} = { 'name' => 'my name is fred', 'age' => 34 } ); is( $h{'fred'}->{'age'}, 34 ); } is( join( " ", sort keys %h ), "fred ricky" ); is( $h{'george'} = 42, 42 ); is( join( " ", sort keys %h ), "fred george ricky" ); untie %h; my %i; isa_ok( tie( %i, 'Tie::RDBM', $dsn, { table => 'PData', user => USER, password => PASS } ), 'Tie::RDBM' ); is( $i{'george'}, 42 ); is( join( " ", sort keys %i ), "fred george ricky" ); Tie-DBI-1.06/lib/Tie/000750 000765 000024 00000000000 12127565405 014143 5ustar00toddstaff000000 000000 Tie-DBI-1.06/lib/Tie/DBI.pm000644 000765 000024 00000110353 12127565243 015107 0ustar00toddstaff000000 000000 package Tie::DBI; use strict; use vars qw($VERSION); use Carp; use DBI; $VERSION = '1.06'; BEGIN { eval { require Encode::compat if $] < 5.007001; require Encode; }; } # Default options for the module my %DefaultOptions = ( 'user' => '', 'password' => '', 'AUTOCOMMIT' => 1, 'WARN' => 0, 'DEBUG' => 0, 'CLOBBER' => 0, 'CASESENSITIV' => 0, ); # DBD drivers that work correctly with bound variables my %CAN_BIND = ( 'ODBC' => 1, 'AnyData' => 1, 'mysql' => 1, 'mSQL' => 1, 'Oracle' => 1, 'CSV' => 1, 'DBM' => 1, 'Sys' => 1, 'Pg' => 1, 'PO' => 1, 'Informix' => 1, 'Solid' => 1, ); my %CANNOT_LISTFIELDS = ( 'SQLite' => 1, 'Oracle' => 1, 'CSV' => 1, 'DBM' => 1, 'PO' => 1, 'AnyData' => 1, 'mysqlPP' => 1, ); my %CAN_BINDSELECT = ( 'mysql' => 1, 'mSQL' => 1, 'CSV' => 1, 'Pg' => 1, 'Sys' => 1, 'DBM' => 1, 'AnyData' => 1, 'PO' => 1, 'Informix' => 1, 'Solid' => 1, 'ODBC' => 1, ); my %BROKEN_INSERT = ( 'mSQL' => 1, 'CSV' => 1, ); my %NO_QUOTE = ( 'Sybase' => { map { $_ => 1 } ( 2, 6 .. 17, 20, 24 ) }, ); my %DOES_IN = ( 'mysql' => 1, 'Oracle' => 1, 'Sybase' => 1, 'CSV' => 1, 'DBM' => 1, # at least with SQL::Statement 'AnyData' => 1, 'Sys' => 1, 'PO' => 1, ); # TIEHASH interface # tie %h,Tie::DBI,[dsn|dbh,table,key],\%options sub TIEHASH { my $class = shift; my ( $dsn, $table, $key, $opt ); if ( ref( $_[0] ) eq 'HASH' ) { $opt = shift; ( $dsn, $table, $key ) = @{$opt}{ 'db', 'table', 'key' }; } else { ( $dsn, $table, $key, $opt ) = @_; } croak "Usage tie(%h,Tie::DBI,dsn,table,key,\\%options)\n or tie(%h,Tie::DBI,{db=>\$db,table=>\$table,key=>\$key})" unless $dsn && $table && $key; my $self = { %DefaultOptions, defined($opt) ? %$opt : () }; bless $self, $class; my ( $dbh, $driver ); if ( UNIVERSAL::isa( $dsn, 'DBI::db' ) ) { $dbh = $dsn; $driver = $dsn->{Driver}{Name}; $dbh->{Warn} = $self->{WARN}; } else { $dsn = "dbi:$dsn" unless $dsn =~ /^dbi/; ($driver) = $dsn =~ /\w+:(\w+)/; # Try to establish connection with data source. delete $ENV{NLS_LANG}; # this gives us 8 bit characters ?? $dbh = $class->connect( $dsn, $self->{user}, $self->{password}, { AutoCommit => $self->{AUTOCOMMIT}, #ChopBlanks=>1, # Removed per RT 19833 This may break legacy code. PrintError => 0, Warn => $self->{WARN}, } ); $self->{needs_disconnect}++; croak "TIEHASH: Can't open $dsn, ", $class->errstr unless $dbh; } if ( $driver eq 'Oracle' ) { #set date format my $sth = $dbh->prepare("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'"); $sth->execute(); } # set up more instance variables @{$self}{ 'dbh', 'table', 'key', 'driver' } = ( $dbh, $table, $key, $driver ); $self->{BrokenInsert} = $BROKEN_INSERT{$driver}; $self->{CanBind} = $CAN_BIND{$driver}; $self->{CanBindSelect} = $self->{CanBind} && $CAN_BINDSELECT{$driver}; $self->{NoQuote} = $NO_QUOTE{$driver}; $self->{DoesIN} = $DOES_IN{$driver}; $self->{CannotListfields} = $CANNOT_LISTFIELDS{$driver}; return $self; } sub DESTROY { $_[0]->{'dbh'}->disconnect if defined $_[0]->{'dbh'} && $_[0]->{needs_disconnect}; } sub FETCH { my ( $s, $key ) = @_; # user could refer to $h{a,b,c}: handle this case my (@keys) = split( $;, $key ); my ( $tag, $query ); if ( @keys > 1 ) { # need an IN clause my ($count) = scalar(@keys); $tag = "fetch$count"; if ( !$s->{CanBindSelect} ) { foreach (@keys) { $_ = $s->_quote( $s->{key}, $_ ); } } if ( $s->{DoesIN} ) { $query = "SELECT $s->{key} FROM $s->{table} WHERE $s->{key} IN (" . join( ",", ('?') x $count ) . ')'; } else { $query = "SELECT $s->{key} FROM $s->{table} WHERE " . join( ' OR ', ("$s->{key}=?") x $count ); } } else { $tag = "fetch1"; @keys = $s->_quote( $s->{key}, $key ) unless $s->{CanBindSelect}; $query = "SELECT $s->{key} FROM $s->{table} WHERE $s->{key} = ?"; } my $st = $s->_run_query( $tag, $query, @keys ) || croak "FETCH: ", $s->errstr; # slightly more efficient for one key if ( @keys == 1 ) { my $r = $st->fetch; $st->finish; return undef unless $r; my $h = {}; tie %$h, 'Tie::DBI::Record', $s, $r->[0]; return $h; } # general case -- multiple keys my ( $r, %got ); while ( $r = $st->fetch ) { my $h = {}; tie %$h, 'Tie::DBI::Record', $s, $r->[0]; $got{ $r->[0] } = $h; } $st->finish; @keys = split( $;, $key ); return ( @keys > 1 ) ? [ @got{@keys} ] : $got{ $keys[0] }; } sub FIRSTKEY { my $s = shift; my $st = $s->_prepare( 'fetchkeys', "SELECT $s->{key} FROM $s->{table}" ) || croak "FIRSTKEY: ", $s->errstr; $st->execute() || croak "FIRSTKEY: ", $s->errstr; my $ref = $st->fetch; unless ( defined($ref) ) { $st->finish; delete $s->{'fetchkeys'}; #freakin' sybase bug return undef; } return $ref->[0]; } sub NEXTKEY { my $s = shift; my $st = $s->_prepare( 'fetchkeys', '' ); # no statement handler defined, so nothing to iterate over return wantarray ? () : undef unless $st; my $r = $st->fetch; if ( !$r ) { $st->finish; delete $s->{'fetchkeys'}; #freakin' sybase bug return wantarray ? () : undef; } # Should we do a tie here? my ( $key, $value ) = ( $r->[0], {} ); return wantarray ? ( $key, $value ) : $key; } # Unlike fetch, this never goes to the cache sub EXISTS { my ( $s, $key ) = @_; $key = $s->_quote( $s->{key}, $key ) unless $s->{CanBindSelect}; my $st = $s->_run_query( 'fetch1', "SELECT $s->{key} FROM $s->{table} WHERE $s->{key} = ?", $key ); croak $DBI::errstr unless $st; $st->fetch; my $rows = $st->rows; $st->finish; $rows != 0; } sub CLEAR { my $s = shift; croak "CLEAR: read-only database" unless $s->{CLOBBER} > 2; my $st = $s->_prepare( 'clear', "delete from $s->{table}" ); $st->execute() || croak "CLEAR: delete statement failed, ", $s->errstr; $st->finish; } sub DELETE { my ( $s, $key ) = @_; croak "DELETE: read-only database" unless $s->{CLOBBER} > 1; $key = $s->_quote( $s->{key}, $key ) unless $s->{CanBindSelect}; my $st = $s->_run_query( 'delete', "delete from $s->{table} where $s->{key} = ?", $key ) || croak "DELETE: delete statement failed, ", $s->errstr; $st->finish; } sub STORE { my ( $s, $key, $value ) = @_; # There are two cases where this can be called. In the first case, we are # passed a hash reference to field names and their values. In the second # case, we are passed a Tie::DBI::Record, for the purposes of a cloning # operation. croak "STORE: attempt to store non-hash value into record" unless ref($value) eq 'HASH'; croak "STORE: read-only database" unless $s->{CLOBBER} > 0; my (@fields); my $ok = $s->_fields(); foreach ( sort keys %$value ) { if ( $_ eq $s->{key} ) { carp qq/Ignored attempt to change value of key field "$s->{key}"/ if $s->{WARN}; next; } if ( !$ok->{$_} ) { carp qq/Ignored attempt to set unknown field "$_"/ if $s->{WARN}; next; } push( @fields, $_ ); } return undef unless @fields; my (@values) = map { $value->{$_} } @fields; # Attempt an insert. If that fails (usually because the key already exists), # perform an update. For this to work correctly, the key field MUST be marked unique my $result; if ( $s->{BrokenInsert} ) { # check for broken drivers $result = $s->EXISTS($key) ? $s->_update( $key, \@fields, \@values ) : $s->_insert( $key, \@fields, \@values ); } else { eval { local ( $s->{'dbh'}->{PrintError} ) = 0; # suppress warnings $result = $s->_insert( $key, \@fields, \@values ); }; $result or $result = $s->_update( $key, \@fields, \@values ); } croak "STORE: ", $s->errstr if $s->error; # Neat special case: If we are passed an empty anonymous hash, then # we must tie it to Tie::DBI::Record so that the correct field updating # behavior springs into existence. tie %$value, 'Tie::DBI::Record', $s, $key unless %$value; } sub fields { my $s = shift; return keys %{ $s->_fields() }; } sub dbh { $_[0]->{'dbh'}; } sub commit { $_[0]->{'dbh'}->commit(); } sub rollback { $_[0]->{'dbh'}->rollback(); } # The connect() method is responsible for the low-level connect to # the database. It should return a database handle or return undef. # You may want to override this to connect via a subclass of DBI, such # as Apache::DBI. sub connect { my ( $class, $dsn, $user, $password, $options ) = @_; return DBI->connect( $dsn, $user, $password, $options ); } # Return a low-level error. You might want to override this # if you use a subclass of DBI sub errstr { return $DBI::errstr; } sub error { return $DBI::err; } sub select_where { my ( $s, $query ) = @_; # get rid of everything but the where clause $query =~ s/^\s*(select .+)?where\s+//i; my $st = $s->{'dbh'}->prepare("select $s->{key} from $s->{table} where $query") || croak "select_where: ", $s->errstr; $st->execute() || croak "select_where: ", $s->errstr; my ( $key, @results ); $st->bind_columns( undef, \$key ); while ( $st->fetch ) { push( @results, $key ); } $st->finish; return @results; } # ---------------- everything below this line is private -------------------------- sub _run_query { my $self = shift; my ( $tag, $query, @bind_variables ) = @_; if ( $self->{CanBind} ) { unless ( !$self->{CanBindSelect} && $query =~ /\bwhere\b/i ) { my $sth = $self->_prepare( $tag, $query ); return unless $sth->execute(@bind_variables); return $sth; } } local ($^W) = 0; # kill uninitialized variable warning # if we get here, then we can't bind, so we replace ? with escaped parameters while ( ( my $pos = index( $query, '?' ) ) >= 0 ) { my $value = shift(@bind_variables); substr( $query, $pos, 1 ) = ( defined($value) ? ( $self->{CanBind} ? $self->{'dbh'}->quote($value) : $value ) : 'null' ); } my $sth = $self->{'dbh'}->prepare($query); return unless $sth && $sth->execute; return $sth; } sub _fields { my $self = shift; unless ( $self->{'fields'} ) { my ( $dbh, $table ) = @{$self}{ 'dbh', 'table' }; local ($^W) = 0; # kill uninitialized variable warning my $sth = $dbh->prepare("LISTFIELDS $table") unless ( $self->{CannotListfields} ); # doesn't support LISTFIELDS, so try SELECT * unless ( !$self->{CannotListfields} && defined($sth) && $sth->execute ) { $sth = $dbh->prepare("SELECT * FROM $table WHERE 0=1") || croak "_fields() failed during prepare(SELECT) statement: ", $self->errstr; $sth->execute() || croak "_fields() failed during execute(SELECT) statement: ", $self->errstr; } # if we get here, we can fetch the names of the fields my %fields; if ( $self->{'CASESENSITIV'} ) { %fields = map { $_ => 1 } @{ $sth->{NAME} }; } else { %fields = map { lc($_) => 1 } @{ $sth->{NAME} }; } $sth->finish; $self->{'fields'} = \%fields; } return $self->{'fields'}; } sub _types { my $self = shift; return $self->{'types'} if $self->{'types'}; my ( $sth, %types ); if ( $self->{'driver'} eq 'Oracle' ) { $sth = $self->{'dbh'}->prepare( "SELECT column_name,data_type FROM ALL_TAB_COLUMNS WHERE TABLE_NAME = " . $self->{'dbh'}->quote("$self->{table}") ); $sth->execute() || croak "_types() failed during execute(SELECT) statement: $DBI::errstr"; while ( my ( $col_name, $col_type ) = $sth->fetchrow() ) { $types{$col_name} = $col_type; } } else { $sth = $self->{'dbh'}->prepare("SELECT * FROM $self->{table} WHERE 0=1") || croak "_types() failed during prepare(SELECT) statement: $DBI::errstr"; $sth->execute() || croak "_types() failed during execute(SELECT) statement: $DBI::errstr"; my $types = $sth->{TYPE}; my $names = $sth->{NAME}; %types = map { shift(@$names) => $_ } @$types; } return $self->{'types'} = \%types; } sub _fetch_field ($$) { my ( $s, $key, $fields ) = @_; $key = $s->_quote( $s->{key}, $key ) unless $s->{CanBindSelect}; my $valid = $s->_fields(); my @valid_fields = grep( $valid->{$_}, @$fields ); return undef unless @valid_fields; my $f = join( ',', @valid_fields ); my $st = $s->_run_query( "fetch$f", "SELECT $f FROM $s->{table} WHERE $s->{key}=?", $key ) || croak "_fetch_field: ", $s->errstr; my ( @r, @results ); while ( @r = $st->fetchrow_array ) { my @i = map { $valid->{$_} ? shift @r : undef } @$fields; if ( $s->{ENCODING} ) { @i = map { _decode( $s->{ENCODING}, $_ ) } @i; } push( @results, ( @$fields == 1 ) ? $i[0] : [@i] ); } $st->finish; return ( @results > 1 ) ? \@results : $results[0]; } sub _insert { my ( $s, $key, $fields, $values ) = @_; push( @$fields, $s->{key} ); push( @$values, $key ); my @values = $s->_quote_many( $fields, $values ); my (@Qs) = ('?') x @$values; local ($") = ','; my $st = $s->_run_query( "insert@$fields", "insert into $s->{table} (@$fields) values (@Qs)", @values ); pop(@$fields); pop(@$values); return $st ? $st->rows : 0; } sub _update { my ( $s, $key, $fields, $values ) = @_; my (@set) = map { "$_=?" } @$fields; my @values = $s->_quote_many( $fields, $values ); $key = $s->_quote( $s->{key}, $key ) unless $s->{CanBindSelect}; local ($") = ','; my $st = $s->_run_query( "update@$fields", "update $s->{table} set @set where $s->{key}=?", @values, $key ); return unless $st; return $st->rows; } sub _quote_many { my ( $s, $fields, $values ) = @_; if ( $s->{CanBind} ) { if ( $s->{ENCODING} ) { return map { _encode( $s->{ENCODING}, $_ ) } @$values; } else { return @$values; } } my $noquote = $s->{NoQuote}; unless ($noquote) { if ( $s->{ENCODING} ) { return map { $s->{'dbh'}->quote( _encode( $s->{ENCODING}, $_ ) ) } @$values; } else { return map { $s->{'dbh'}->quote($_) } @$values; } } my @values = @$values; my $types = $s->_types; for ( my $i = 0; $i < @values; $i++ ) { next if $noquote->{ $types->{ $fields->[$i] } }; if ( $s->{'driver'} eq 'Oracle' && $types->{ $fields->[$i] } eq 'DATE' ) { my $epoch_date = str2time( $values[$i] ); my $temp = time2iso($epoch_date); $temp = $s->{'dbh'}->quote($temp); $values[$i] = $temp; } else { $values[$i] = $s->{'dbh'}->quote( $values[$i] ); } } return @values; } sub _quote { my ( $s, $field, $value ) = @_; my $types = $s->_types; if ( my $noquote = $s->{NoQuote} ) { return $noquote->{ $types->{$field} } ? $value : $s->{'dbh'}->quote($value); } if ( $s->{'driver'} eq 'Oracle' && $types->{$field} eq 'DATE' ) { my $epoch_date = str2time($value); my $temp = time2iso($epoch_date); $temp = $s->{'dbh'}->quote($temp); #my $temp = $s->{'dbh'}->quote($value); $temp = "to_date($temp,'YYYY-MM-DD HH24:MI:SS')"; return $temp; } else { $value = _encode( $s->{ENCODING}, $value ) if $s->{ENCODING}; $value = $s->{'dbh'}->quote($value); return $value; } } sub _prepare ($$$) { my ( $self, $tag, $q ) = @_; unless ( exists( $self->{$tag} ) ) { return undef unless $q; warn $q, "\n" if $self->{DEBUG}; my $sth = $self->{'dbh'}->prepare($q); $self->{$tag} = $sth; } else { $self->{$tag}->finish if $q; # in case we forget } $self->{$tag}; } sub _encode { eval { return Encode::encode( $_[0], $_[1] ); }; } sub _decode { eval { return Encode::decode( $_[0], $_[1] ); }; } package Tie::DBI::Record; use strict; use vars qw($VERSION); use Carp; use DBI; $VERSION = '0.50'; # TIEHASH interface # tie %h,Tie::DBI::Record,dbh,table,record sub TIEHASH { my $class = shift; my ( $table, $record ) = @_; return bless { 'table' => $table, # table object 'record' => $record, # the record we're keyed to }, $class; } sub FETCH { my ( $s, $field ) = @_; return undef unless $s->{'table'}; my (@fields) = split( $;, $field ); return $s->{'table'}->_fetch_field( $s->{'record'}, \@fields ); } sub DELETE { my ( $s, $field ) = @_; $s->STORE( $field, undef ); } sub STORE { my ( $s, $field, $value ) = @_; $s->{'table'}->STORE( $s->{'record'}, { $field => $value } ); } # Can't delete the record in this way, but we can # clear out all the fields by setting them to undef. sub CLEAR { my ($s) = @_; croak "CLEAR: read-only database" unless $s->{'table'}->{CLOBBER} > 1; my %h = map { $_ => undef } keys %{ $s->{'table'}->_fields() }; delete $h{ $s->{'record'} }; # can't remove key field $s->{'table'}->STORE( $s->{'record'}, \%h ); } sub FIRSTKEY { my $s = shift; my $a = scalar keys %{ $s->{'table'}->_fields() }; each %{ $s->{'table'}->_fields() }; } sub NEXTKEY { my $s = shift; each %{ $s->{'table'}->_fields() }; } sub EXISTS { my $s = shift; return $s->{'table'}->_fields()->{ $_[0] }; } sub DESTROY { my $s = shift; warn "$s->{table}:$s->{value} has been destroyed" if $s->{'table'}->{DEBUG}; } =head1 NAME Tie::DBI - Tie hashes to DBI relational databases =head1 SYNOPSIS use Tie::DBI; tie %h,'Tie::DBI','mysql:test','test','id',{CLOBBER=>1}; tie %h,'Tie::DBI',{db => 'mysql:test', table => 'test', key => 'id', user => 'nobody', password => 'ghost', CLOBBER => 1}; # fetching keys and values @keys = keys %h; @fields = keys %{$h{$keys[0]}}; print $h{'id1'}->{'field1'}; while (($key,$value) = each %h) { print "Key = $key:\n"; foreach (sort keys %$value) { print "\t$_ => $value->{$_}\n"; } } # changing data $h{'id1'}->{'field1'} = 'new value'; $h{'id1'} = { field1 => 'newer value', field2 => 'even newer value', field3 => "so new it's squeaky clean" }; # other functions tied(%h)->commit; tied(%h)->rollback; tied(%h)->select_where('price > 1.20'); @fieldnames = tied(%h)->fields; $dbh = tied(%h)->dbh; =head1 DESCRIPTION This module allows you to tie Perl associative arrays (hashes) to SQL databases using the DBI interface. The tied hash is associated with a table in a local or networked database. One column becomes the hash key. Each row of the table becomes an associative array, from which individual fields can be set or retrieved. =head1 USING THE MODULE To use this module, you must have the DBI interface and at least one DBD (database driver) installed. Make sure that your database is up and running, and that you can connect to it and execute queries using DBI. =head2 Creating the tie tie %var,'Tie::DBI',[database,table,keycolumn] [,\%options] Tie a variable to a database by providing the variable name, the tie interface (always "Tie::DBI"), the data source name, the table to tie to, and the column to use as the hash key. You may also pass various flags to the interface in an associative array. =over 4 =item database The database may either be a valid DBI-style data source string of the form "dbi:driver:database_name[:other information]", or a database handle that has previously been opened. See the documentation for DBI and your DBD driver for details. Because the initial "dbi" is always present in the data source, Tie::DBI will add it for you if necessary. Note that some drivers (Oracle in particular) have an irritating habit of appending blanks to the end of fixed-length fields. This will screw up Tie::DBI's routines for getting key names. To avoid this you should create the database handle with a B option of TRUE. You should also use a B option of true to avoid complaints during STORE and LISTFIELD calls. =item table The table in the database to bind to. The table must previously have been created with a SQL CREATE statement. This module will not create tables for you or modify the schema of the database. =item key The column to use as the hash key. This column must prevoiusly have been defined when the table was created. In order for this module to work correctly, the key column I be declared unique and not nullable. For best performance, the column should be also be declared a key. These three requirements are automatically satisfied for primary keys. =back It is possible to omit the database, table and keycolumn arguments, in which case the module tries to retrieve the values from the options array. The options array contains a set of option/value pairs. If not provided, defaults are assumed. The options are: =over 4 =item user Account name to use for database authentication, if necessary. Default is an empty string (no authentication necessary). =item password Password to use for database authentication, if necessary. Default is an empty string (no authentication necessary). =item db The database to bind to the hash, if not provided in the argument list. It may be a DBI-style data source string, or a previously-opened database handle. =item table The name of the table to bind to the hash, if not provided in the argument list. =item key The name of the column to use as the hash key, if not provided in the argument list. =item CLOBBER (default 0) This controls whether the database is writable via the bound hash. A zero value (the default) makes the database essentially read only. An attempt to store to the hash will result in a fatal error. A CLOBBER value of 1 will allow you to change individual fields in the database, and to insert new records, but not to delete entire records. A CLOBBER value of 2 allows you to delete records, but not to erase the entire table. A CLOBBER value of 3 or higher will allow you to erase the entire table. Operation Clobber Comment $i = $h{strawberries}->{price} 0 All read operations $h{strawberries}->{price} += 5 1 Update fields $h{bananas}={price=>23,quant=>3} 1 Add records delete $h{strawberries} 2 Delete records %h = () 3 Clear entire table undef %h 3 Another clear operation All database operations are contingent upon your access privileges. If your account does not have write permission to the database, hash store operations will fail despite the setting of CLOBBER. =item AUTOCOMMIT (default 1) If set to a true value, the "autocommit" option causes the database driver to commit after every store statement. If set to a false value, this option will not commit to the database until you explicitly call the Tie::DBI commit() method. The autocommit option defaults to true. =item DEBUG (default 0) When the DEBUG option is set to a non-zero value the module will echo the contents of SQL statements and other debugging information to standard error. Higher values of DEBUG result in more verbose (and annoying) output. =item WARN (default 1) If set to a non-zero value, warns of illegal operations, such as attempting to delete the value of the key column. If set to a zero value, these errors will be ignored silently. =item CASESENSITIV (default 0) If set to a non-zero value, all Fieldnames are casesensitiv. Keep in mind, that your database has to support casesensitiv Fields if you want to use it. =back =head1 USING THE TIED ARRAY The tied array represents the database table. Each entry in the hash is a record, keyed on the column chosen in the tie() statement. Ordinarily this will be the table's primary key, although any unique column will do. Fetching an individual record returns a reference to a hash of field names and values. This hash reference is itself a tied object, so that operations on it directly affect the database. =head2 Fetching information In the following examples, we will assume a database table structured like this one: -produce- produce_id price quantity description strawberries 1.20 8 Fresh Maine strawberries apricots 0.85 2 Ripe Norwegian apricots bananas 1.30 28 Sweet Alaskan bananas kiwis 1.50 9 Juicy New York kiwi fruits eggs 1.00 12 Farm-fresh Atlantic eggs We tie the variable %produce to the table in this way: tie %produce,'Tie::DBI',{db => 'mysql:stock', table => 'produce', key => 'produce_id', CLOBBER => 2 # allow most updates }; We can get the list of keys this way: print join(",",keys %produce); => strawberries,apricots,bananas,kiwis Or get the price of eggs thusly: $price = $produce{eggs}->{price}; print "The price of eggs = $price"; => The price of eggs = 1.2 String interpolation works as you would expect: print "The price of eggs is still $produce{eggs}->{price}" => The price of eggs is still 1.2 Various types of syntactic sugar are allowed. For example, you can refer to $produce{eggs}{price} rather than $produce{eggs}->{price}. Array slices are fully supported as well: ($apricots,$kiwis) = @produce{apricots,kiwis}; print "Kiwis are $kiwis->{description}; => Kiwis are Juicy New York kiwi fruits ($price,$description) = @{$produce{eggs}}{price,description}; => (2.4,'Farm-fresh Atlantic eggs') If you provide the tied hash with a comma-delimited set of record names, and you are B requesting an array slice, then the module does something interesting. It generates a single SQL statement that fetches the records from the database in a single pass (rather than the multiple passes required for an array slice) and returns the result as a reference to an array. For many records, this can be much faster. For example: $result = $produce{apricots,bananas}; => ARRAY(0x828a8ac) ($apricots,$bananas) = @$result; print "The price of apricots is $apricots->{price}"; => The price of apricots is 0.85 Field names work in much the same way: ($price,$quantity) = @{$produce{apricots}{price,quantity}}; print "There are $quantity apricots at $price each"; => There are 2 apricots at 0.85 each"; Note that this takes advantage of a bit of Perl syntactic sugar which automagically treats $h{'a','b','c'} as if the keys were packed together with the $; pack character. Be careful not to fall into this trap: $result = $h{join( ',', 'apricots', 'bananas' )}; => undefined What you really want is this: $result = $h{join( $;, 'apricots', 'bananas' )}; => ARRAY(0x828a8ac) =head2 Updating information If CLOBBER is set to a non-zero value (and the underlying database privileges allow it), you can update the database with new values. You can operate on entire records at once or on individual fields within a record. To insert a new record or update an existing one, assign a hash reference to the record. For example, you can create a new record in %produce with the key "avocados" in this manner: $produce{avocados} = { price => 2.00, quantity => 8, description => 'Choice Irish avocados' }; This will work with any type of hash reference, including records extracted from another table or database. Only keys that correspond to valid fields in the table will be accepted. You will be warned if you attempt to set a field that doesn't exist, but the other fields will be correctly set. Likewise, you will be warned if you attempt to set the key field. These warnings can be turned off by setting the WARN option to a zero value. It is not currently possible to add new columns to the table. You must do this manually with the appropriate SQL commands. The same syntax can be used to update an existing record. The fields given in the hash reference replace those in the record. Fields that aren't explicitly listed in the hash retain their previous values. In the following example, the price and quantity of the "kiwis" record are updated, but the description remains the same: $produce{kiwis} = { price=>1.25,quantity=>20 }; You may update existing records on a field-by-field manner in the natural way: $produce{eggs}{price} = 1.30; $produce{eggs}{price} *= 2; print "The price of eggs is now $produce{eggs}{price}"; => The price of eggs is now 2.6. Obligingly enough, you can use this syntax to insert new records too, as in $produce{mangoes}{description}="Sun-ripened Idaho mangoes". However, this type of update is inefficient because a separate SQL statement is generated for each field. If you need to update more than one field at a time, use the record-oriented syntax shown earlier. It's much more efficient because it gets the work done with a single SQL command. Insertions and updates may fail for any of a number of reasons, most commonly: =over 4 =item 1. You do not have sufficient privileges to update the database =item 2. The update would violate an integrity constraint, such as making a non-nullable field null, overflowing a numeric field, storing a string value in a numeric field, or violating a uniqueness constraint. =back The module dies with an error message when it encounters an error during an update. To trap these erorrs and continue processing, wrap the update an eval(). =head2 Other functions The tie object supports several useful methods. In order to call these methods, you must either save the function result from the tie() call (which returns the object), or call tied() on the tie variable to recover the object. =over 4 =item connect(), error(), errstr() These are low-level class methods. Connect() is responsible for establishing the connection with the DBI database. Errstr() and error() return $DBI::errstr and $DBI::error respectively. You may may override these methods in subclasses if you wish. For example, replace connect() with this code in order to use persistent database connections in Apache modules: use Apache::DBI; # somewhere in the declarations sub connect { my ($class,$dsn,$user,$password,$options) = @_; return Apache::DBI->connect($dsn,$user, $password,$options); } =item commit() (tied %produce)->commit(); When using a database with the autocommit option turned off, values that are stored into the hash will not become permanent until commit() is called. Otherwise they are lost when the application terminates or the hash is untied. Some SQL databases don't support transactions, in which case you will see a warning message if you attempt to use this function. =item rollback() (tied %produce)->rollback(); When using a database with the autocommit option turned off, this function will roll back changes to the database to the state they were in at the last commit(). This function has no effect on database that don't support transactions. =item select_where() @keys=(tied %produce)->select_where('price > 1.00 and quantity < 10'); This executes a limited form of select statement on the tied table and returns a list of records that satisfy the conditions. The argument you provide should be the contents of a SQL WHERE clause, minus the keyword "WHERE" and everything that ordinarily precedes it. Anything that is legal in the WHERE clause is allowed, including function calls, ordering specifications, and sub-selects. The keys to those records that meet the specified conditions are returned as an array, in the order in which the select statement returned them. Don't expect too much from this function. If you want to execute a complex query, you're better off using the database handle (see below) to make the SQL query yourself with the DBI interface. =item dbh() $dbh = (tied %produce)->dbh(); This returns the tied hash's underlying database handle. You can use this handle to create and execute your own SQL queries. =item CLOBBER, DEBUG, WARN You can get and set the values of CLOBBER, DEBUG and WARN by directly accessing the object's hash: (tied %produce)->{DEBUG}++; This lets you change the behavior of the tied hash on the fly, such as temporarily granting your program write permission. There are other variables there too, such as the name of the key column and database table. Change them at your own risk! =back =head1 PERFORMANCE What is the performance hit when you use this module rather than the direct DBI interface? It can be significant. To measure the overhead, I used a simple benchmark in which Perl parsed a 6180 word text file into individual words and stored them into a database, incrementing the word count with each store. The benchmark then read out the words and their counts in an each() loop. The database driver was mySQL, running on a 133 MHz Pentium laptop with Linux 2.0.30. I compared Tie::RDBM, to DB_File, and to the same task using vanilla DBI SQL statements. The results are shown below: UPDATE FETCH Tie::DBI 70 s 6.1 s Vanilla DBI 14 s 2.0 s DB_File 3 s 1.06 s There is about a five-fold penalty for updates, and a three-fold penalty for fetches when using this interface. Some of the penalty is due to the overhead for creating sub-objects to handle individual fields, and some of it is due to the inefficient way the store and fetch operations are implemented. For example, using the tie interface, a statement like $h{record}{field}++ requires as much as four trips to the database: one to verify that the record exists, one to fetch the field, and one to store the incremented field back. If the record doesn't already exist, an additional statement is required to perform the insertion. I have experimented with cacheing schemes to reduce the number of trips to the database, but the overhead of maintaining the cache is nearly equal to the performance improvement, and cacheing raises a number of potential concurrency problems. Clearly you would not want to use this interface for applications that require a large number of updates to be processed rapidly. =head1 BUGS =head1 BUGS The each() call produces a fatal error when used with the Sybase driver to access Microsoft SQL server. This is because this server only allows one query to be active at a given time. A workaround is to use keys() to fetch all the keys yourself. It is not known whether real Sybase databases suffer from the same problem. The delete() operator will not work correctly for setting field values to null with DBD::CSV or with DBD::Pg. CSV files do not have a good conception of database nulls. Instead you will set the field to an empty string. DBD::Pg just seems to be broken in this regard. =head1 AUTHOR Lincoln Stein, lstein@cshl.org =head1 COPYRIGHT Copyright (c) 1998, Lincoln D. Stein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AVAILABILITY The latest version can be obtained from: http://www.genome.wi.mit.edu/~lstein/Tie-DBI/ =head1 SEE ALSO perl(1), DBI(3), Tie::RDBM(3) =cut 1; Tie-DBI-1.06/lib/Tie/RDBM.pm000644 000765 000024 00000056520 12127565011 015233 0ustar00toddstaff000000 000000 package Tie::RDBM; use strict; use vars qw($VERSION %Types); use Carp; use DBI; $VERSION = '0.73'; # %Types is used for creating the data table if it doesn't exist already. # You may want to edit this. %Types = ( # key value frozen freeze keyless 'mysql' => [qw/ varchar(127) longblob tinyint 1 0 /], 'mSQL' => [qw/ char(255) char(255) int 0 0 /], 'Pg' => [qw/ varchar(127) varchar(2000) int 0 0 /], 'Sybase' => [qw/ varchar(255) varbinary(255) tinyint 1 0 /], 'Oracle' => [qw/ varchar(255) varchar2(2000) integer 1 0 /], 'CSV' => [qw/ varchar(255) varchar(255) integer 1 1 /], 'Informix' => [qw/ nchar(120) nchar(2000) integer 0 0 /], 'Solid' => [qw/ varchar(255) varbinary(2000) integer 1 0 /], 'ODBC' => [qw/ varchar(255) varbinary(2000) integer 1 0 /], 'default' => [qw/ varchar(255) varchar(255) integer 0 0 /], #others ); # list drivers that do run-time binding correctly my %CAN_BIND = ( 'mysql' => 1, 'mSQL' => 1, 'Oracle' => 1, 'Pg' => 1, 'Informix' => 1, 'Solid' => 1, 'ODBC' => 1, ); # Default options for the module my %DefaultOptions = ( 'table' => 'pdata', 'key' => 'pkey', 'value' => 'pvalue', 'frozen' => 'pfrozen', 'user' => '', 'password' => '', 'autocommit' => 1, 'create' => 0, 'drop' => 0, 'DEBUG' => 0, ); sub TIEHASH { my $class = shift; my ( $dsn, $opt ) = ref( $_[0] ) ? ( undef, $_[0] ) : @_; $dsn ||= $opt->{'db'}; croak "Usage tie(%h,Tie::RDBM,,\%options)" unless $dsn; if ($opt) { foreach ( keys %DefaultOptions ) { $opt->{$_} = $DefaultOptions{$_} unless exists( $opt->{$_} ); } } else { $opt = \%DefaultOptions; } my ( $dbh, $driver ); if ( UNIVERSAL::isa( $dsn, 'DBI::db' ) ) { $dbh = $dsn; $driver = $dsn->{Driver}{Name}; } else { $dsn = "dbi:$dsn" unless $dsn =~ /^dbi/; ($driver) = $dsn =~ /\w+:(\w+)/; # Try to establish connection with data source. delete $ENV{NLS_LANG} if $driver eq 'Oracle'; # allow 8 bit connections? $dbh = DBI->connect( $dsn, $opt->{user}, $opt->{password}, { AutoCommit => $opt->{autocommit}, PrintError => 0, ChopBlanks => 1, Warn => 0 } ); croak "TIEHASH: Can't open $dsn, $DBI::errstr" unless $dbh; } # A variety of shinanegans to handle freeze/thaw option. # We will serialize references if: # 1. The database driver supports binary types. # 2. The database table has a boolean field to indicate that a value is frozen. # 3. The Storable module is available. # we also check that "primary key" is recognized my $db_features = $Types{$driver} || $Types{'default'}; my ($canfreeze) = $db_features->[3]; my ($keyless) = $db_features->[4]; my ($haveStorable) = eval 'require Storable;'; Storable->import(qw/nfreeze thaw/) if $haveStorable; $canfreeze &&= $haveStorable; # Check that the indicated table exists. If it doesn't, # try to create it.... # This query tests that a table with the correct fields is present. # I would prefer to use a where clause of 1=0 but some dumb drivers (mSQL) # treat this as a syntax error!!! my $q = "select * from $opt->{table} where $opt->{key}=''"; my $sth = $dbh->prepare($q); my $structure_ok = 0; local ($^W) = 0; # uninitialized variable problem if ( defined($sth) && $sth->execute() ne '' ) { # At least the key field exists. Check whether the others do too. my (%field_names); grep( $field_names{ lc($_) }++, @{ $sth->{NAME} } ); $structure_ok++ if $field_names{ $opt->{'value'} }; $canfreeze &&= $field_names{ $opt->{'frozen'} }; } unless ($structure_ok) { unless ( $opt->{'create'} || $opt->{'drop'} ) { my $err = $DBI::errstr; $dbh->disconnect; croak "Table $opt->{table} does not have expected structure and creation forbidden: $err"; } $dbh->do("drop table $opt->{table}") if $opt->{'drop'}; my ( $keytype, $valuetype, $frozentype ) = @{$db_features}; my (@fields) = ( $keyless ? "$opt->{key} $keytype" : "$opt->{key} $keytype primary key", "$opt->{value} $valuetype" ); push( @fields, ( $keyless ? "$opt->{frozen} $frozentype" : "$opt->{frozen} $frozentype not null" ) ) if $canfreeze; $q = "create table $opt->{table} (" . join( ',', @fields ) . ")"; warn "$q\n" if $opt->{DEBUG}; $dbh->do($q) || do { my $err = $DBI::errstr; $dbh->disconnect; croak("Can't initialize data table: $err"); } } return bless { 'dbh' => $dbh, 'table' => $opt->{'table'}, 'key' => $opt->{'key'}, 'value' => $opt->{'value'}, 'frozen' => $opt->{'frozen'}, 'canfreeze' => $canfreeze, 'brokenselect' => $driver eq 'mSQL' || $driver eq 'mysql', 'canbind' => $CAN_BIND{$driver}, 'DEBUG' => $opt->{DEBUG}, }, $class; } sub FETCH { my ( $self, $key ) = @_; # this is a hack to avoid doing an unnecessary SQL select # during an each() loop. return $self->{'cached_value'}->{$key} if exists $self->{'cached_value'}->{$key}; # create statement handler if it doesn't already exist. my $cols = $self->{'canfreeze'} ? "$self->{'value'},$self->{'frozen'}" : $self->{'value'}; my $sth = $self->_run_query( 'fetch', <{table} where $self->{key}=? END my $result = $sth->fetchrow_arrayref(); $sth->finish; return undef unless $result; $self->{'canfreeze'} && $result->[1] ? thaw( $result->[0] ) : $result->[0]; } sub STORE { my ( $self, $key, $value ) = @_; my $frozen = 0; if ( ref($value) && $self->{'canfreeze'} ) { $frozen++; $value = nfreeze($value); } # Yes, this is ugly. It is designed to minimize the number of SQL statements # for both database whose update statements return the number of rows updated, # and those (like mSQL) whose update statements don't. my ($r); if ( $self->{'brokenselect'} ) { return $self->EXISTS($key) ? $self->_update( $key, $value, $frozen ) : $self->_insert( $key, $value, $frozen ); } return $self->_update( $key, $value, $frozen ) || $self->_insert( $key, $value, $frozen ); } sub DELETE { my ( $self, $key ) = @_; my $sth = $self->_run_query( 'delete', <{table} where $self->{key}=? END croak "Database delete statement failed: $DBI::errstr" if $sth->err; $sth->finish; 1; } sub CLEAR { my $self = shift; my $dbh = $self->{'dbh'}; my $sth = $self->_prepare( 'clear', "delete from $self->{table}" ); $sth->execute(); croak "Database delete all statement failed: $DBI::errstr" if $dbh->err; $sth->finish; } sub EXISTS { my ( $self, $key ) = @_; my $sth = $self->_run_query( 'exists', <{key} from $self->{table} where $self->{key}=? END croak "Database select statement failed: $DBI::errstr" unless $sth; $sth->fetch; my $rows = $sth->rows; $sth->finish; $rows >= 1; } sub FIRSTKEY { my $self = shift; delete $self->{'cached_value'}; if ( $self->{'fetchkeys'} ) { $self->{'fetchkeys'}->finish(); # to prevent truncation in ODBC driver delete $self->{'fetchkeys'}; } my $sth = $self->_prepare( 'fetchkeys', $self->{'canfreeze'} ? <{'key'},$self->{'value'},$self->{'frozen'} from $self->{'table'} END1 select $self->{'key'},$self->{'value'} from $self->{'table'} END2 $sth->execute() || croak "Can't execute select statement: $DBI::errstr"; my $ref = $sth->fetch(); return defined($ref) ? $ref->[0] : undef; } sub NEXTKEY { my $self = shift; # no statement handler defined, so nothing to iterate over return wantarray ? () : undef unless my $sth = $self->{'fetchkeys'}; my $r = $sth->fetch(); if ( !$r ) { $sth->finish; delete $self->{'cached_value'}; return wantarray ? () : undef; } my ( $key, $value ) = ( $r->[0], $r->[2] ? thaw( $r->[1] ) : $r->[1] ); $self->{'cached_value'}->{$key} = $value; return wantarray ? ( $key, $value ) : $key; } sub DESTROY { my $self = shift; foreach (qw/fetch update insert delete clear exists fetchkeys/) { $self->{$_}->finish if $self->{$_}; } $self->{'dbh'}->disconnect() if $self->{'dbh'}; } sub commit { $_[0]->{'dbh'}->commit(); } sub rollback { $_[0]->{'dbh'}->rollback(); } # utility routines sub _update { my ( $self, $key, $value, $frozen ) = @_; my ($sth); if ( $self->{'canfreeze'} ) { $sth = $self->_run_query( 'update', "update $self->{table} set $self->{value}=?,$self->{frozen}=? where $self->{key}=?", $value, $frozen, $key ); } else { $sth = $self->_run_query( 'update', "update $self->{table} set $self->{value}=? where $self->{key}=?", $value, $key ); } croak "Update: $DBI::errstr" unless $sth; $sth->rows > 0; } sub _insert { my ( $self, $key, $value, $frozen ) = @_; my ($sth); if ( $self->{'canfreeze'} ) { $sth = $self->_run_query( 'insert', "insert into $self->{table} ($self->{key},$self->{value},$self->{frozen}) values (?,?,?)", $key, $value, $frozen ); } else { $sth = $self->_run_query( 'insert', "insert into $self->{table} ($self->{key},$self->{value}) values (?,?)", $key, $value ); } ( $sth && $sth->rows ) || croak "Update: $DBI::errstr"; } sub _run_query { my $self = shift; my ( $tag, $query, @bind_variables ) = @_; if ( $self->{canbind} ) { my $sth = $self->_prepare( $tag, $query ); return undef unless $sth->execute(@bind_variables); return $sth; } # if we get here, then we can't bind, so we replace ? with escaped parameters $query =~ s/\?/$self->{'dbh'}->quote(shift(@bind_variables))/eg; my $sth = $self->{'dbh'}->prepare($query); return undef unless $sth && $sth->execute; return $sth; } sub _prepare ($$$) { my ( $self, $tag, $q ) = @_; unless ( exists( $self->{$tag} ) ) { return undef unless $q; warn $q, "\n" if $self->{DEBUG}; my $sth = $self->{'dbh'}->prepare($q); croak qq/Problems preparing statement "$q": $DBI::errstr/ unless $sth; $self->{$tag} = $sth; } else { $self->{$tag}->finish if $q; # in case we forget } $self->{$tag}; } 1; __END__ =head1 NAME Tie::RDBM - Tie hashes to relational databases =head1 SYNOPSIS use Tie::RDBM; tie %h,'Tie::RDBM','mysql:test',{table=>'Demo',create=>1,autocommit=>0}; $h{'key1'} = 'Some data here'; $h{'key2'} = 42; $h{'key3'} = { complex=>['data','structure','here'],works=>'true' }; $h{'key4'} = new Foobar('Objects work too'); print $h{'key3'}->{complex}->[0]; tied(%h)->commit; untie %h; =head1 DESCRIPTION This module allows you to tie Perl associative arrays (hashes) to SQL databases using the DBI interface. The tied hash is associated with a table in a local or networked database. One field of the table becomes the hash key, and another becomes the value. Once tied, all the standard hash operations work, including iteration over keys and values. If you have the Storable module installed, you may store arbitrarily complex Perl structures (including objects) into the hash and later retrieve them. When used in conjunction with a network-accessible database, this provides a simple way to transmit data structures between Perl programs on two different machines. =head1 TIEING A DATABASE tie %VARIABLE,Tie::RDBM,DSN [,\%OPTIONS] You tie a variable to a database by providing the variable name, the tie interface (always "Tie::RDBM"), the data source name, and an optional hash reference containing various options to be passed to the module and the underlying database driver. The data source may be a valid DBI-style data source string of the form "dbi:driver:database_name[:other information]", or a previously-opened database handle. See the documentation for DBI and your DBD driver for details. Because the initial "dbi" is always present in the data source, Tie::RDBM will automatically add it for you. The options array contains a set of option/value pairs. If not provided, defaults are assumed. The options are: =over 4 =item user [''] Account name to use for database authentication, if necessary. Default is an empty string (no authentication necessary). =item password [''] Password to use for database authentication, if necessary. Default is an empty string (no authentication necessary). =item db [''] The data source, if not provided in the argument. This allows an alternative calling style: tie(%h,Tie::RDBM,{db=>'dbi:mysql:test',create=>1}; =item table ['pdata'] The name of the table in which the hash key/value pairs will be stored. =item key ['pkey'] The name of the column in which the hash key will be found. If not provided, defaults to "pkey". =item value ['pvalue'] The name of the column in which the hash value will be found. If not provided, defaults to "pvalue". =item frozen ['pfrozen'] The name of the column that stores the boolean information indicating that a complex data structure has been "frozen" using Storable's freeze() function. If not provided, defaults to "pfrozen". NOTE: if this field is not present in the database table, or if the database is incapable of storing binary structures, Storable features will be disabled. =item create [0] If set to a true value, allows the module to create the database table if it does not already exist. The module emits a CREATE TABLE command and gives the key, value and frozen fields the data types most appropriate for the database driver (from a lookup table maintained in a package global, see DATATYPES below). The success of table creation depends on whether you have table create access for the database. The default is not to create a table. tie() will fail with a fatal error. =item drop [0] If the indicated database table exists, but does not have the required key and value fields, Tie::RDBM can try to add the required fields to the table. Currently it does this by the drastic expedient of DROPPING the table entirely and creating a new empty one. If the drop option is set to true, Tie::RDBM will perform this radical restructuring. Otherwise tie() will fail with a fatal error. "drop" implies "create". This option defaults to false. A future version of Tie::RDBM may implement a last radical restructuring method; differences in DBI drivers and database capabilities make this task harder than it would seem. =item autocommit [1] If set to a true value, the "autocommit" option causes the database driver to commit after every store statement. If set to a false value, this option will not commit to the database until you explicitly call the Tie::RDBM commit() method. The autocommit option defaults to true. =item DEBUG [0] When the "DEBUG" option is set to a true value the module will echo the contents of SQL statements and other debugging information to standard error. =back =head1 USING THE TIED ARRAY The standard fetch, store, keys(), values() and each() functions will work as expected on the tied array. In addition, the following methods are available on the underlying object, which you can obtain with the standard tie() operator: =over 4 =item commit() (tied %h)->commit(); When using a database with the autocommit option turned off, values that are stored into the hash will not become permanent until commit() is called. Otherwise they are lost when the application terminates or the hash is untied. Some SQL databases don't support transactions, in which case you will see a warning message if you attempt to use this function. =item rollback() (tied %h)->rollback(); When using a database with the autocommit option turned off, this function will roll back changes to the database to the state they were in at the last commit(). This function has no effect on database that don't support transactions. =back =head1 DATABASES AND DATATYPES Perl is a weakly typed language. Databases are strongly typed. When translating from databases to Perl there is inevitably some data type conversion that you must worry about. I have tried to keep the details as transparent as possible without sacrificing power; this section discusses the tradeoffs. If you wish to tie a hash to a preexisting database, specify the database name, the table within the database, and the fields you wish to use for the keys and values. These fields can be of any type that you choose, but the data type will limit what can be stored there. For example, if the key field is of type "int", then any numeric value will be a valid key, but an attempt to use a string as a key will result in a run time error. If a key or value is too long to fit into the data field, it will be truncated silently. For performance reasons, the key field should be a primary key, or at least an indexed field. It should also be unique. If a key is present more than once in a table, an attempt to fetch it will return the first record found by the SQL select statement. If you wish to store Perl references in the database, the module needs an additional field in which it can store a flag indicating whether the data value is a simple or a complex type. This "frozen" field is treated as a boolean value. A "tinyint" data type is recommended, but strings types will work as well. In a future version of this module, the "frozen" field may be turned into a general "datatype" field in order to minimize storage. For future compatability, please use an integer for the frozen field. If you use the "create" and/or "drop" options, the module will automatically attempt to create a table for its own use in the database if a suitable one isn't found. It uses information defined in the package variable %Tie::RDBM::Types to determine what kind of data types to create. This variable is indexed by database driver. Each index contains a four-element array indicating what data type to use for each of the key, value and frozen fields, and whether the database can support binary types. Since I have access to only a limited number of databases, the table is currently short: Driver Key Field Value Field Frozen Field Binary? mysq varchar(127) longblob tinyint 1 mSQL char(255) char(255) int 0 Sybase varchar(255) varbinary(255) tinyint 1 default varchar(255) varbinary(255) tinyint 1 The "default" entry is used for any driver not specifically mentioned. You are free to add your own entries to this table, or make corrections. Please send me e-mail with any revisions you make so that I can share the wisdom. =head1 STORABLE CAVEATS Because the Storable module packs Perl structures in a binary format, only those databases that support a "varbinary" or "blob" type can handle complex datatypes. Furthermore, some databases have strict limitations on the size of these structures. For example, SyBase and MS SQL Server have a "varbinary" type that maxes out at 255 bytes. For structures larger than this, the databases provide an "image" type in which storage is allocated in 2K chunks! Worse, access to this image type uses a non-standard SQL extension that is not supported by DBI. Databases that do not support binary fields cannot use the Storable feature. If you attempt to store a reference to a complex data type in one of these databases it will be converted into strings like "HASH(0x8222cf4)", just as it would be if you tried the same trick with a conventional tied DBM hash. If the database supports binary fields of restricted length, large structures may be silently truncated. Caveat emptor. It's also important to realize the limitations of the Storable mechanism. You can store and retrieve entire data structures, but you can't twiddle with individual substructures and expect them to persist when the process exits. To update a data structure, you must fetch it from the hash, make the desired modifications, then store it back into the hash, as the example below shows: B tie %h,'Tie::RDBM','mysql:Employees:host.somewhere.com', {table=>'employee',user=>'fred',password=>'xyzzy'}; $h{'Anne'} = { office=>'999 Infinity Drive, Rm 203', age => 29, salary => 32100 }; $h{'Mark'} = { office=>'000 Iteration Circle, Rm -123', age => 32, salary => 35000 }; B tie %i,'Tie::RDBM','mysql:Employees:host.somewhere.com', {table=>'employee',user=>'george',password=>'kumquat2'}; foreach (keys %i) { $info = $i{$_}; if ($info->{age} > 30) { # Give the oldies a $1000 raise $info->{salary} += 1000; $i{$_} = $info; } } This example also demonstrates how two Perl scripts running on different machines can use Tie::RDBM to share complex data structures (in this case, the employee record) without resorting to sockets, remote procedure calls, shared memory, or other gadgets =head1 PERFORMANCE What is the performance hit when you use this module? It can be significant. I used a simple benchmark in which Perl parsed a 6180 word text file into individual words and stored them into a database, incrementing the word count with each store. The benchmark then read out the words and their counts in an each() loop. The database driver was mySQL, running on a 133 MHz Pentium laptop with Linux 2.0.30. I compared Tie::RDBM, to DB_File, and to the same task using vanilla DBI SQL statements. The results are shown below: STORE EACH() LOOP Tie::RDBM 28 s 2.7 s Vanilla DBI 15 s 2.0 s DB_File 3 s 1.08 s During stores, there is an approximately 2X penalty compared to straight DBI, and a 15X penalty over using DB_File databases. For the each() loop (which is dominated by reads), the performance is 2-3 times worse than DB_File and much worse than a vanilla SQL statement. I have not investigated the bottlenecks. =head1 TO DO LIST - Store strings, numbers and data structures in separate fields for space and performance efficiency. - Expand data types table to other database engines. - Catch internal changes to data structures and write them into database automatically. =head1 BUGS Yes. =head1 AUTHOR Lincoln Stein, lstein@w3.org =head1 COPYRIGHT Copyright (c) 1998, Lincoln D. Stein This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AVAILABILITY The latest version can be obtained from: http://www.genome.wi.mit.edu/~lstein/Tie-DBM/ =head1 SEE ALSO perl(1), DBI(3), Storable(3) =cut