diff options
Diffstat (limited to 'lib/DBD')
-rw-r--r-- | lib/DBD/DBM.pm | 1461 | ||||
-rw-r--r-- | lib/DBD/ExampleP.pm | 428 | ||||
-rw-r--r-- | lib/DBD/File.pm | 1637 | ||||
-rw-r--r-- | lib/DBD/File/Developers.pod | 556 | ||||
-rw-r--r-- | lib/DBD/File/HowTo.pod | 270 | ||||
-rw-r--r-- | lib/DBD/File/Roadmap.pod | 176 | ||||
-rw-r--r-- | lib/DBD/Gofer.pm | 1292 | ||||
-rw-r--r-- | lib/DBD/Gofer/Policy/Base.pm | 162 | ||||
-rw-r--r-- | lib/DBD/Gofer/Policy/classic.pm | 79 | ||||
-rw-r--r-- | lib/DBD/Gofer/Policy/pedantic.pm | 53 | ||||
-rw-r--r-- | lib/DBD/Gofer/Policy/rush.pm | 90 | ||||
-rw-r--r-- | lib/DBD/Gofer/Transport/Base.pm | 410 | ||||
-rw-r--r-- | lib/DBD/Gofer/Transport/corostream.pm | 144 | ||||
-rw-r--r-- | lib/DBD/Gofer/Transport/null.pm | 111 | ||||
-rw-r--r-- | lib/DBD/Gofer/Transport/pipeone.pm | 253 | ||||
-rw-r--r-- | lib/DBD/Gofer/Transport/stream.pm | 292 | ||||
-rw-r--r-- | lib/DBD/NullP.pm | 166 | ||||
-rw-r--r-- | lib/DBD/Proxy.pm | 997 | ||||
-rw-r--r-- | lib/DBD/Sponge.pm | 305 |
19 files changed, 8882 insertions, 0 deletions
diff --git a/lib/DBD/DBM.pm b/lib/DBD/DBM.pm new file mode 100644 index 0000000..3c621a3 --- /dev/null +++ b/lib/DBD/DBM.pm @@ -0,0 +1,1461 @@ +####################################################################### +# +# DBD::DBM - a DBI driver for DBM files +# +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand +# +# All rights reserved. +# +# You may freely distribute and/or modify this module under the terms +# of either the GNU General Public License (GPL) or the Artistic License, +# as specified in the Perl README file. +# +# USERS - see the pod at the bottom of this file +# +# DBD AUTHORS - see the comments in the code +# +####################################################################### +require 5.008; +use strict; + +################# +package DBD::DBM; +################# +use base qw( DBD::File ); +use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed); +$VERSION = '0.06'; +$ATTRIBUTION = 'DBD::DBM by Jens Rehsack'; + +# no need to have driver() unless you need private methods +# +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + return $drh if ($drh); + + # do the real work in DBD::File + # + $attr->{Attribution} = 'DBD::DBM by Jens Rehsack'; + $drh = $class->SUPER::driver($attr); + + # install private methods + # + # this requires that dbm_ (or foo_) be a registered prefix + # but you can write private methods before official registration + # by hacking the $dbd_prefix_registry in a private copy of DBI.pm + # + unless ( $methods_already_installed++ ) + { + DBD::DBM::st->install_method('dbm_schema'); + } + + return $drh; +} + +sub CLONE +{ + undef $drh; +} + +##################### +package DBD::DBM::dr; +##################### +$DBD::DBM::dr::imp_data_size = 0; +@DBD::DBM::dr::ISA = qw(DBD::File::dr); + +# you could put some :dr private methods here + +# you may need to over-ride some DBD::File::dr methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::db; +##################### +$DBD::DBM::db::imp_data_size = 0; +@DBD::DBM::db::ISA = qw(DBD::File::db); + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + # carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W ); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_STORE_attr( $attrib, $value ); +} + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + # carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W ); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_FETCH_attr($attrib); +} + +sub set_versions +{ + my $this = $_[0]; + $this->{dbm_version} = $DBD::DBM::VERSION; + return $this->SUPER::set_versions(); +} + +sub init_valid_attributes +{ + my $dbh = shift; + + # define valid private attributes + # + # attempts to set non-valid attrs in connect() or + # with $dbh->{attr} will throw errors + # + # the attrs here *must* start with dbm_ or foo_ + # + # see the STORE methods below for how to check these attrs + # + $dbh->{dbm_valid_attrs} = { + dbm_type => 1, # the global DBM type e.g. SDBM_File + dbm_mldbm => 1, # the global MLDBM serializer + dbm_cols => 1, # the global column names + dbm_version => 1, # verbose DBD::DBM version + dbm_store_metadata => 1, # column names, etc. + dbm_berkeley_flags => 1, # for BerkeleyDB + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + dbm_tables => 1, # DBD::DBM public access for f_meta + }; + $dbh->{dbm_readonly_attrs} = { + dbm_version => 1, # verbose DBD::DBM version + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + }; + + $dbh->{dbm_meta} = "dbm_tables"; + + return $dbh->SUPER::init_valid_attributes(); +} + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + + $dbh->SUPER::init_default_attributes($phase); + $dbh->{f_lockfile} = '.lck'; + + return $dbh; +} + +sub get_dbm_versions +{ + my ( $dbh, $table ) = @_; + $table ||= ''; + + my $meta; + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) ); + + my $dver; + my $dtype = $meta->{dbm_type}; + eval { + $dver = $meta->{dbm_type}->VERSION(); + + # *) when we're still alive here, everthing went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + if ( $meta->{dbm_mldbm} ) + { + $dtype .= ' + MLDBM'; + eval { + $dver = MLDBM->VERSION(); + $dtype .= " ($dver)"; # (*) + }; + eval { + my $ser_class = "MLDBM::Serializer::" . $meta->{dbm_mldbm}; + my $ser_mod = $ser_class; + $ser_mod =~ s|::|/|g; + $ser_mod .= ".pm"; + require $ser_mod; + $dver = $ser_class->VERSION(); + $dtype .= ' + ' . $ser_class; # (*) + $dver and $dtype .= " ($dver)"; # (*) + }; + } + return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype ); +} + +# you may need to over-ride some DBD::File::db methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::st; +##################### +$DBD::DBM::st::imp_data_size = 0; +@DBD::DBM::st::ISA = qw(DBD::File::st); + +sub FETCH +{ + my ( $sth, $attr ) = @_; + + if ( $attr eq "NULLABLE" ) + { + my @colnames = $sth->sql_get_colnames(); + + # XXX only BerkeleyDB fails having NULL values for non-MLDBM databases, + # none accept it for key - but it requires more knowledge between + # queries and tables storage to return fully correct information + $attr eq "NULLABLE" and return [ map { 0 } @colnames ]; + } + + return $sth->SUPER::FETCH($attr); +} # FETCH + +sub dbm_schema +{ + my ( $sth, $tname ) = @_; + return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname; + return $sth->set_err( $DBI::stderr, "Unknown table '$tname'!" ) + unless ( $sth->{Database}->{f_meta} + and $sth->{Database}->{f_meta}->{$tname} ); + return $sth->{Database}->{f_meta}->{$tname}->{schema}; +} +# you could put some :st private methods here + +# you may need to over-ride some DBD::File::st methods here +# but you can probably get away with just letting it do the work +# in most cases + +############################ +package DBD::DBM::Statement; +############################ + +@DBD::DBM::Statement::ISA = qw(DBD::File::Statement); + +######################## +package DBD::DBM::Table; +######################## +use Carp; +use Fcntl; + +@DBD::DBM::Table::ISA = qw(DBD::File::Table); + +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; + +sub file2table +{ + my ( $self, $meta, $file, $file_is_table, $quoted ) = @_; + + my $tbl = $self->SUPER::file2table( $meta, $file, $file_is_table, $quoted ) or return; + + $meta->{f_dontopen} = 1; + + return $tbl; +} + +my %reset_on_modify = ( + dbm_type => "dbm_tietype", + dbm_mldbm => "dbm_tietype", + ); +__PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +my %compat_map = ( + ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ), + dbm_ext => 'f_ext', + dbm_file => 'f_file', + dbm_lockfile => ' f_lockfile', + ); +__PACKAGE__->register_compat_map (\%compat_map); + +sub bootstrap_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{dbm_type} ||= $dbh->{dbm_type} || 'SDBM_File'; + $meta->{dbm_mldbm} ||= $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} ); + $meta->{dbm_berkeley_flags} ||= $dbh->{dbm_berkeley_flags}; + + defined $meta->{f_ext} + or $meta->{f_ext} = $dbh->{f_ext}; + unless ( defined( $meta->{f_ext} ) ) + { + my $ext; + if ( $meta->{dbm_type} eq 'SDBM_File' or $meta->{dbm_type} eq 'ODBM_File' ) + { + $ext = '.pag/r'; + } + elsif ( $meta->{dbm_type} eq 'NDBM_File' ) + { + # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley + # behind the scenes and so create a single .db file. + if ( $^O =~ /bsd/i or lc($^O) eq 'darwin' ) + { + $ext = '.db/r'; + } + elsif ( $^O eq 'SunOS' or $^O eq 'Solaris' or $^O eq 'AIX' ) + { + $ext = '.pag/r'; # here it's implemented like dbm - just a bit improved + } + # else wrapped GDBM + } + defined($ext) and $meta->{f_ext} = $ext; + } + + $self->SUPER::bootstrap_table_meta( $dbh, $meta, $table ); +} + +sub init_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + unless ( defined( $meta->{dbm_tietype} ) ) + { + my $tie_type = $meta->{dbm_type}; + $INC{"$tie_type.pm"} or require "$tie_type.pm"; + $tie_type eq 'BerkeleyDB' and $tie_type = 'BerkeleyDB::Hash'; + + if ( $meta->{dbm_mldbm} ) + { + $INC{"MLDBM.pm"} or require "MLDBM.pm"; + $meta->{dbm_usedb} = $tie_type; + $tie_type = 'MLDBM'; + } + + $meta->{dbm_tietype} = $tie_type; + } + + unless ( defined( $meta->{dbm_store_metadata} ) ) + { + my $store = $dbh->{dbm_store_metadata}; + defined($store) or $store = 1; + $meta->{dbm_store_metadata} = $store; + } + + unless ( defined( $meta->{col_names} ) ) + { + defined( $dbh->{dbm_cols} ) and $meta->{col_names} = $dbh->{dbm_cols}; + } + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); +} + +sub open_file +{ + my ( $self, $meta, $attrs, $flags ) = @_; + $self->SUPER::open_file( $meta, $attrs, $flags ); + unless ( $flags->{dropMode} ) + { + # TIEING + # + # XXX allow users to pass in a pre-created tied object + # + my @tie_args; + if ( $meta->{dbm_type} eq 'BerkeleyDB' ) + { + my $DB_CREATE = BerkeleyDB::DB_CREATE(); + my $DB_RDONLY = BerkeleyDB::DB_RDONLY(); + my %tie_flags; + if ( my $f = $meta->{dbm_berkeley_flags} ) + { + defined( $f->{DB_CREATE} ) and $DB_CREATE = delete $f->{DB_CREATE}; + defined( $f->{DB_RDONLY} ) and $DB_RDONLY = delete $f->{DB_RDONLY}; + %tie_flags = %$f; + } + my $open_mode = $flags->{lockMode} || $flags->{createMode} ? $DB_CREATE : $DB_RDONLY; + @tie_args = ( + -Filename => $meta->{f_fqbn}, + -Flags => $open_mode, + %tie_flags + ); + } + else + { + my $open_mode = O_RDONLY; + $flags->{lockMode} and $open_mode = O_RDWR; + $flags->{createMode} and $open_mode = O_RDWR | O_CREAT | O_TRUNC; + + @tie_args = ( $meta->{f_fqbn}, $open_mode, 0666 ); + } + + if ( $meta->{dbm_mldbm} ) + { + $MLDBM::UseDB = $meta->{dbm_usedb}; + $MLDBM::Serializer = $meta->{dbm_mldbm}; + } + + $meta->{hash} = {}; + my $tie_class = $meta->{dbm_tietype}; + eval { tie %{ $meta->{hash} }, $tie_class, @tie_args }; + $@ and croak "Cannot tie(\%h $tie_class @tie_args): $@"; + -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" ); + } + + unless ( $flags->{createMode} ) + { + my ( $meta_data, $schema, $col_names ); + if ( $meta->{dbm_store_metadata} ) + { + $meta_data = $col_names = $meta->{hash}->{"_metadata \0"}; + if ( $meta_data and $meta_data =~ m~<dbd_metadata>(.+)</dbd_metadata>~is ) + { + $schema = $col_names = $1; + $schema =~ s~.*<schema>(.+)</schema>.*~$1~is; + $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is; + } + } + $col_names ||= $meta->{col_names} || [ 'k', 'v' ]; + $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' ); + if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} ) + { + $schema or $schema = ''; + $meta->{hash}->{"_metadata \0"} = + "<dbd_metadata>" + . "<schema>$schema</schema>" + . "<col_names>" + . join( ",", @{$col_names} ) + . "</col_names>" + . "</dbd_metadata>"; + } + + $meta->{schema} = $schema; + $meta->{col_names} = $col_names; + } +} + +# you must define drop +# it is called from execute of a SQL DROP statement +# +sub drop ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + $self->SUPER::drop($data); + # XXX extra_files + -f $meta->{f_fqbn} . $dirfext + and $meta->{f_ext} eq '.pag/r' + and unlink( $meta->{f_fqbn} . $dirfext ); + return 1; +} + +# you must define fetch_row, it is called on all fetches; +# it MUST return undef when no rows are left to fetch; +# checking for $ary[0] is specific to hashes so you'll +# probably need some other kind of check for nothing-left. +# as Janis might say: "undef's just another word for +# nothing left to fetch" :-) +# +sub fetch_row ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + # fetch with %each + # + my @ary = each %{ $meta->{hash} }; + $meta->{dbm_store_metadata} + and $ary[0] + and $ary[0] eq "_metadata \0" + and @ary = each %{ $meta->{hash} }; + + my ( $key, $val ) = @ary; + unless ($key) + { + delete $self->{row}; + return; + } + my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val ); + $self->{row} = @row ? \@row : undef; + return wantarray ? @row : \@row; +} + +# you must define push_row except insert_new_row and update_specific_row is defined +# it is called on inserts and updates as primitive +# +sub insert_new_row ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + my $ncols = scalar( @{ $meta->{col_names} } ); + my $nitems = scalar( @{$row_aryref} ); + $ncols == $nitems + or croak "You tried to insert $nitems, but table is created with $ncols columns"; + + my $key = shift @$row_aryref; + my $exists; + eval { $exists = exists( $meta->{hash}->{$key} ); }; + $exists and croak "Row with PK '$key' already exists"; + + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row_aryref : $row_aryref->[0]; + + return 1; +} + +# this is where you grab the column names from a CREATE statement +# if you don't need to do that, it must be defined but can be empty +# +sub push_names ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + + # some sanity checks ... + my $ncols = scalar(@$row_aryref); + $ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ..."; + !$meta->{dbm_mldbm} + and $ncols > 2 + and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols"; + $meta->{col_names} = $row_aryref; + return unless $meta->{dbm_store_metadata}; + + my $stmt = $data->{sql_stmt}; + my $col_names = join( ',', @{$row_aryref} ); + my $schema = $data->{Database}->{Statement}; + $schema =~ s/^[^\(]+\((.+)\)$/$1/s; + $schema = $stmt->schema_str() if ( $stmt->can('schema_str') ); + $meta->{hash}->{"_metadata \0"} = + "<dbd_metadata>" + . "<schema>$schema</schema>" + . "<col_names>$col_names</col_names>" + . "</dbd_metadata>"; +} + +# fetch_one_row, delete_one_row, update_one_row +# are optimized for hash-style lookup without looping; +# if you don't need them, omit them, they're optional +# but, in that case you may need to define +# truncate() and seek(), see below +# +sub fetch_one_row ($$;$) +{ + my ( $self, $key_only, $key ) = @_; + my $meta = $self->{meta}; + $key_only and return $meta->{col_names}->[0]; + exists $meta->{hash}->{$key} or return; + my $val = $meta->{hash}->{$key}; + $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val]; + my $row = [ $key, @$val ]; + return wantarray ? @{$row} : $row; +} + +sub delete_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + delete $meta->{hash}->{ $aryref->[0] }; +} + +sub update_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + my $key = shift @$aryref; + defined $key or return; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +sub update_specific_row ($$$$) +{ + my ( $self, $data, $aryref, $origary ) = @_; + my $meta = $self->{meta}; + my $key = shift @$origary; + my $newkey = shift @$aryref; + return unless ( defined $key ); + $key eq $newkey or delete $meta->{hash}->{$key}; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +# you may not need to explicitly DESTROY the ::Table +# put cleanup code to run when the execute is done +# +sub DESTROY ($) +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + + $self->SUPER::DESTROY(); +} + +# truncate() and seek() must be defined to satisfy DBI::SQL::Nano +# *IF* you define the *_one_row methods above, truncate() and +# seek() can be empty or you can use them without actually +# truncating or seeking anything but if you don't define the +# *_one_row methods, you may need to define these + +# if you need to do something after a series of +# deletes or updates, you can put it in truncate() +# which is called at the end of executing +# +sub truncate ($$) +{ + # my ( $self, $data ) = @_; + return 1; +} + +# seek() is only needed if you use IO::File +# though it could be used for other non-file operations +# that you need to do before "writes" or truncate() +# +sub seek ($$$$) +{ + # my ( $self, $data, $pos, $whence ) = @_; + return 1; +} + +# Th, th, th, that's all folks! See DBD::File and DBD::CSV for other +# examples of creating pure perl DBDs. I hope this helped. +# Now it's time to go forth and create your own DBD! +# Remember to check in with dbi-dev@perl.org before you get too far. +# We may be able to make suggestions or point you to other related +# projects. + +1; +__END__ + +=pod + +=head1 NAME + +DBD::DBM - a DBI driver for DBM & MLDBM files + +=head1 SYNOPSIS + + use DBI; + $dbh = DBI->connect('dbi:DBM:'); # defaults to SDBM_File + $dbh = DBI->connect('DBI:DBM(RaiseError=1):'); # defaults to SDBM_File + $dbh = DBI->connect('dbi:DBM:dbm_type=DB_File'); # defaults to DB_File + $dbh = DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # MLDBM with SDBM_File + + # or + $dbh = DBI->connect('dbi:DBM:', undef, undef); + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + f_ext => '.db/r', + f_dir => '/path/to/dbfiles/', + f_lockfile => '.lck', + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'FreezeThaw', + dbm_store_metadata => 1, + dbm_berkeley_flags => { + '-Cachesize' => 1000, # set a ::Hash flag + }, + }); + +and other variations on connect() as shown in the L<DBI> docs, +L<DBD::File/Metadata|DBD::File metadata> and L</Metadata> +shown below. + +Use standard DBI prepare, execute, fetch, placeholders, etc., +see L<QUICK START> for an example. + +=head1 DESCRIPTION + +DBD::DBM is a database management system that works right out of the +box. If you have a standard installation of Perl and DBI you can +begin creating, accessing, and modifying simple database tables +without any further modules. You can add other modules (e.g., +SQL::Statement, DB_File etc) for improved functionality. + +The module uses a DBM file storage layer. DBM file storage is common on +many platforms and files can be created with it in many programming +languages using different APIs. That means, in addition to creating +files with DBI/SQL, you can also use DBI/SQL to access and modify files +created by other DBM modules and programs and vice versa. B<Note> that +in those cases it might be necessary to use a common subset of the +provided features. + +DBM files are stored in binary format optimized for quick retrieval +when using a key field. That optimization can be used advantageously +to make DBD::DBM SQL operations that use key fields very fast. There +are several different "flavors" of DBM which use different storage +formats supported by perl modules such as SDBM_File and MLDBM. This +module supports all of the flavors that perl supports and, when used +with MLDBM, supports tables with any number of columns and insertion +of Perl objects into tables. + +DBD::DBM has been tested with the following DBM types: SDBM_File, +NDBM_File, ODBM_File, GDBM_File, DB_File, BerkeleyDB. Each type was +tested both with and without MLDBM and with the Data::Dumper, +Storable, FreezeThaw, YAML and JSON serializers using the DBI::SQL::Nano +or the SQL::Statement engines. + +=head1 QUICK START + +DBD::DBM operates like all other DBD drivers - it's basic syntax and +operation is specified by DBI. If you're not familiar with DBI, you should +start by reading L<DBI> and the documents it points to and then come back +and read this file. If you are familiar with DBI, you already know most of +what you need to know to operate this module. Just jump in and create a +test script something like the one shown below. + +You should be aware that there are several options for the SQL engine +underlying DBD::DBM, see L<Supported SQL syntax>. There are also many +options for DBM support, see especially the section on L<Adding +multi-column support with MLDBM>. + +But here's a sample to get you started. + + use DBI; + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{RaiseError} = 1; + for my $sql( split /;\n+/," + CREATE TABLE user ( user_name TEXT, phone TEXT ); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + INSERT INTO user VALUES ('Sanjay Patel','777-3333'); + INSERT INTO user VALUES ('Junk','xxx-xxxx'); + DELETE FROM user WHERE user_name = 'Junk'; + UPDATE user SET phone = '999-4444' WHERE user_name = 'Sanjay Patel'; + SELECT * FROM user + "){ + my $sth = $dbh->prepare($sql); + $sth->execute; + $sth->dump_results if $sth->{NUM_OF_FIELDS}; + } + $dbh->disconnect; + +=head1 USAGE + +This section will explain some useage cases in more detail. To get an +overview about the available attributes, see L</Metadata>. + +=head2 Specifying Files and Directories + +DBD::DBM will automatically supply an appropriate file extension for the +type of DBM you are using. For example, if you use SDBM_File, a table +called "fruit" will be stored in two files called "fruit.pag" and +"fruit.dir". You should B<never> specify the file extensions in your SQL +statements. + +DBD::DBM recognizes following default extensions for following types: + +=over 4 + +=item .pag/r + +Chosen for dbm_type C<< SDBM_File >>, C<< ODBM_File >> and C<< NDBM_File >> +when an implementation is detected which wraps C<< -ldbm >> for +C<< NDBM_File >> (e.g. Solaris, AIX, ...). + +For those types, the C<< .dir >> extension is recognized, too (for being +deleted when dropping a table). + +=item .db/r + +Chosen for dbm_type C<< NDBM_File >> when an implementation is detected +which wraps BerkeleyDB 1.x for C<< NDBM_File >> (typically BSD's, Darwin). + +=back + +C<< GDBM_File >>, C<< DB_File >> and C<< BerkeleyDB >> don't usually +use a file extension. + +If your DBM type uses an extension other than one of the recognized +types of extensions, you should set the I<f_ext> attribute to the +extension B<and> file a bug report as described in DBI with the name +of the implementation and extension so we can add it to DBD::DBM. +Thanks in advance for that :-). + + $dbh = DBI->connect('dbi:DBM:f_ext=.db'); # .db extension is used + $dbh = DBI->connect('dbi:DBM:f_ext='); # no extension is used + + # or + $dbh->{f_ext}='.db'; # global setting + $dbh->{f_meta}->{'qux'}->{f_ext}='.db'; # setting for table 'qux' + +By default files are assumed to be in the current working directory. +To use other directories specify the I<f_dir> attribute in either the +connect string or by setting the database handle attribute. + +For example, this will look for the file /foo/bar/fruit (or +/foo/bar/fruit.pag for DBM types that use that extension) + + my $dbh = DBI->connect('dbi:DBM:f_dir=/foo/bar'); + # and this will too: + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{f_dir} = '/foo/bar'; + # but this is recommended + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { f_dir => '/foo/bar' } ); + + # now you can do + my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM fruit }); + +You can also use delimited identifiers to specify paths directly in SQL +statements. This looks in the same place as the two examples above but +without setting I<f_dir>: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT x FROM "/foo/bar/fruit" + }); + +You can also tell DBD::DBM to use a specified path for a specific table: + + $dbh->{dbm_tables}->{f}->{file} = q(/foo/bar/fruit); + +Please be aware that you cannot specify this during connection. + +If you have SQL::Statement installed, you can use table aliases: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT f.x FROM "/foo/bar/fruit" AS f + }); + +See the L<GOTCHAS AND WARNINGS> for using DROP on tables. + +=head2 Table locking and flock() + +Table locking is accomplished using a lockfile which has the same +basename as the table's file but with the file extension '.lck' (or a +lockfile extension that you supply, see below). This lock file is +created with the table during a CREATE and removed during a DROP. +Every time the table itself is opened, the lockfile is flocked(). For +SELECT, this is a shared lock. For all other operations, it is an +exclusive lock (except when you specify something different using the +I<f_lock> attribute). + +Since the locking depends on flock(), it only works on operating +systems that support flock(). In cases where flock() is not +implemented, DBD::DBM will simply behave as if the flock() had +occurred although no actual locking will happen. Read the +documentation for flock() for more information. + +Even on those systems that do support flock(), locking is only +advisory - as is always the case with flock(). This means that if +another program tries to access the table file while DBD::DBM has the +table locked, that other program will *succeed* at opening unless +it is also using flock on the '.lck' file. As a result DBD::DBM's +locking only really applies to other programs using DBD::DBM or other +program written to cooperate with DBD::DBM locking. + +=head2 Specifying the DBM type + +Each "flavor" of DBM stores its files in a different format and has +different capabilities and limitations. See L<AnyDBM_File> for a +comparison of DBM types. + +By default, DBD::DBM uses the C<< SDBM_File >> type of storage since +C<< SDBM_File >> comes with Perl itself. If you have other types of +DBM storage available, you can use any of them with DBD::DBM. It is +strongly recommended to use at least C<< DB_File >>, because C<< +SDBM_File >> has quirks and limitations and C<< ODBM_file >>, C<< +NDBM_File >> and C<< GDBM_File >> are not always available. + +You can specify the DBM type using the I<dbm_type> attribute which can +be set in the connection string or with C<< $dbh->{dbm_type} >> and +C<< $dbh->{f_meta}->{$table_name}->{type} >> for per-table settings in +cases where a single script is accessing more than one kind of DBM +file. + +In the connection string, just set C<< dbm_type=TYPENAME >> where +C<< TYPENAME >> is any DBM type such as GDBM_File, DB_File, etc. Do I<not> +use MLDBM as your I<dbm_type> as that is set differently, see below. + + my $dbh=DBI->connect('dbi:DBM:'); # uses the default SDBM_File + my $dbh=DBI->connect('dbi:DBM:dbm_type=GDBM_File'); # uses the GDBM_File + + # You can also use $dbh->{dbm_type} to set the DBM type for the connection: + $dbh->{dbm_type} = 'DB_File'; # set the global DBM type + print $dbh->{dbm_type}; # display the global DBM type + +If you have several tables in your script that use different DBM +types, you can use the $dbh->{dbm_tables} hash to store different +settings for the various tables. You can even use this to perform +joins on files that have completely different storage mechanisms. + + # sets global default of GDBM_File + my $dbh->('dbi:DBM:type=GDBM_File'); + + # overrides the global setting, but only for the tables called + # I<foo> and I<bar> + my $dbh->{f_meta}->{foo}->{dbm_type} = 'DB_File'; + my $dbh->{f_meta}->{bar}->{dbm_type} = 'BerkeleyDB'; + + # prints the dbm_type for the table "foo" + print $dbh->{f_meta}->{foo}->{dbm_type}; + +B<Note> that you must change the I<dbm_type> of a table before you access +it for first time. + +=head2 Adding multi-column support with MLDBM + +Most of the DBM types only support two columns and even if it would +support more, DBD::DBM would only use two. However a CPAN module +called MLDBM overcomes this limitation by allowing more than two +columns. MLDBM does this by serializing the data - basically it puts +a reference to an array into the second column. It can also put almost +any kind of Perl object or even B<Perl coderefs> into columns. + +If you want more than two columns, you B<must> install MLDBM. It's available +for many platforms and is easy to install. + +MLDBM is by default distributed with three serializers - Data::Dumper, +Storable, and FreezeThaw. Data::Dumper is the default and Storable is the +fastest. MLDBM can also make use of user-defined serialization methods or +other serialization modules (e.g. L<YAML::MLDBM> or +L<MLDBM::Serializer::JSON>. You select the serializer using the +I<dbm_mldbm> attribute. + +Some examples: + + $dbh=DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # use MLDBM with Storable + $dbh=DBI->connect( + 'dbi:DBM:dbm_mldbm=MySerializer' # use MLDBM with a user defined module + ); + $dbh=DBI->connect('dbi::dbm:', undef, + undef, { dbm_mldbm => 'YAML' }); # use 3rd party serializer + $dbh->{dbm_mldbm} = 'YAML'; # same as above + print $dbh->{dbm_mldbm} # show the MLDBM serializer + $dbh->{f_meta}->{foo}->{dbm_mldbm}='Data::Dumper'; # set Data::Dumper for table "foo" + print $dbh->{f_meta}->{foo}->{mldbm}; # show serializer for table "foo" + +MLDBM works on top of other DBM modules so you can also set a DBM type +along with setting dbm_mldbm. The examples above would default to using +SDBM_File with MLDBM. If you wanted GDBM_File instead, here's how: + + # uses DB_File with MLDBM and Storable + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'DB_File', + dbm_mldbm => 'Storable', + }); + +SDBM_File, the default I<dbm_type> is quite limited, so if you are going to +use MLDBM, you should probably use a different type, see L<AnyDBM_File>. + +See below for some L<GOTCHAS AND WARNINGS> about MLDBM. + +=head2 Support for Berkeley DB + +The Berkeley DB storage type is supported through two different Perl +modules - DB_File (which supports only features in old versions of Berkeley +DB) and BerkeleyDB (which supports all versions). DBD::DBM supports +specifying either "DB_File" or "BerkeleyDB" as a I<dbm_type>, with or +without MLDBM support. + +The "BerkeleyDB" dbm_type is experimental and it's interface is likely to +change. It currently defaults to BerkeleyDB::Hash and does not currently +support ::Btree or ::Recno. + +With BerkeleyDB, you can specify initialization flags by setting them in +your script like this: + + use BerkeleyDB; + my $env = new BerkeleyDB::Env -Home => $dir; # and/or other Env flags + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'Storable', + dbm_berkeley_flags => { + 'DB_CREATE' => DB_CREATE, # pass in constants + 'DB_RDONLY' => DB_RDONLY, # pass in constants + '-Cachesize' => 1000, # set a ::Hash flag + '-Env' => $env, # pass in an environment + }, + }); + +Do I<not> set the -Flags or -Filename flags as those are determined and +overwritten by the SQL (e.g. -Flags => DB_RDONLY is set automatically +when you issue a SELECT statement). + +Time has not permitted us to provide support in this release of DBD::DBM +for further Berkeley DB features such as transactions, concurrency, +locking, etc. We will be working on these in the future and would value +suggestions, patches, etc. + +See L<DB_File> and L<BerkeleyDB> for further details. + +=head2 Optimizing the use of key fields + +Most "flavors" of DBM have only two physical columns (but can contain +multiple logical columns as explained above in +L<Adding multi-column support with MLDBM>). They work similarly to a +Perl hash with the first column serving as the key. Like a Perl hash, DBM +files permit you to do quick lookups by specifying the key and thus avoid +looping through all records (supported by DBI::SQL::Nano only). Also like +a Perl hash, the keys must be unique. It is impossible to create two +records with the same key. To put this more simply and in SQL terms, +the key column functions as the I<PRIMARY KEY> or UNIQUE INDEX. + +In DBD::DBM, you can take advantage of the speed of keyed lookups by using +DBI::SQL::Nano and a WHERE clause with a single equal comparison on the key +field. For example, the following SQL statements are optimized for keyed +lookup: + + CREATE TABLE user ( user_name TEXT, phone TEXT); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + # ... many more inserts + SELECT phone FROM user WHERE user_name='Fred Bloggs'; + +The "user_name" column is the key column since it is the first +column. The SELECT statement uses the key column in a single equal +comparison - "user_name='Fred Bloggs'" - so the search will find it +very quickly without having to loop through all the names which were +inserted into the table. + +In contrast, these searches on the same table are not optimized: + + 1. SELECT phone FROM user WHERE user_name < 'Fred'; + 2. SELECT user_name FROM user WHERE phone = '233-7777'; + +In #1, the operation uses a less-than (<) comparison rather than an equals +comparison, so it will not be optimized for key searching. In #2, the key +field "user_name" is not specified in the WHERE clause, and therefore the +search will need to loop through all rows to find the requested row(s). + +B<Note> that the underlying DBM storage needs to loop over all I<key/value> +pairs when the optimized fetch is used. SQL::Statement has a massively +improved where clause evaluation which costs around 15% of the evaluation +in DBI::SQL::Nano - combined with the loop in the DBM storage the speed +improvement isn't so impressive. + +Even if lookups are faster by around 50%, DBI::SQL::Nano and +SQL::Statement can benefit from the key field optimizations on +updating and deleting rows - and here the improved where clause +evaluation of SQL::Statement might beat DBI::SQL::Nano every time the +where clause contains not only the key field (or more than one). + +=head2 Supported SQL syntax + +DBD::DBM uses a subset of SQL. The robustness of that subset depends on +what other modules you have installed. Both options support basic SQL +operations including CREATE TABLE, DROP TABLE, INSERT, DELETE, UPDATE, and +SELECT. + +B<Option #1:> By default, this module inherits its SQL support from +DBI::SQL::Nano that comes with DBI. Nano is, as its name implies, a *very* +small SQL engine. Although limited in scope, it is faster than option #2 +for some operations (especially single I<primary key> lookups). See +L<DBI::SQL::Nano> for a description of the SQL it supports and comparisons +of it with option #2. + +B<Option #2:> If you install the pure Perl CPAN module SQL::Statement, +DBD::DBM will use it instead of Nano. This adds support for table aliases, +functions, joins, and much more. If you're going to use DBD::DBM +for anything other than very simple tables and queries, you should install +SQL::Statement. You don't have to change DBD::DBM or your scripts in any +way, simply installing SQL::Statement will give you the more robust SQL +capabilities without breaking scripts written for DBI::SQL::Nano. See +L<SQL::Statement> for a description of the SQL it supports. + +To find out which SQL module is working in a given script, you can use the +dbm_versions() method or, if you don't need the full output and version +numbers, just do this: + + print $dbh->{sql_handler}, "\n"; + +That will print out either "SQL::Statement" or "DBI::SQL::Nano". + +Baring the section about optimized access to the DBM storage in mind, +comparing the benefits of both engines: + + # DBI::SQL::Nano is faster + $sth = $dbh->prepare( "update foo set value='new' where key=15" ); + $sth->execute(); + $sth = $dbh->prepare( "delete from foo where key=27" ); + $sth->execute(); + $sth = $dbh->prepare( "select * from foo where key='abc'" ); + + # SQL::Statement might faster (depending on DB size) + $sth = $dbh->prepare( "update foo set value='new' where key=?" ); + $sth->execute(15); + $sth = $dbh->prepare( "update foo set value=? where key=15" ); + $sth->execute('new'); + $sth = $dbh->prepare( "delete from foo where key=?" ); + $sth->execute(27); + + # SQL::Statement is faster + $sth = $dbh->prepare( "update foo set value='new' where value='old'" ); + $sth->execute(); + # must be expressed using "where key = 15 or key = 27 or key = 42 or key = 'abc'" + # in DBI::SQL::Nano + $sth = $dbh->prepare( "delete from foo where key in (15,27,42,'abc')" ); + $sth->execute(); + # must be expressed using "where key > 10 and key < 90" in DBI::SQL::Nano + $sth = $dbh->prepare( "select * from foo where key between (10,90)" ); + $sth->execute(); + + # only SQL::Statement can handle + $sth->prepare( "select * from foo,bar where foo.name = bar.name" ); + $sth->execute(); + $sth->prepare( "insert into foo values ( 1, 'foo' ), ( 2, 'bar' )" ); + $sth->execute(); + +=head2 Specifying Column Names + +DBM files don't have a standard way to store column names. DBD::DBM gets +around this issue with a DBD::DBM specific way of storing the column names. +B<If you are working only with DBD::DBM and not using files created by or +accessed with other DBM programs, you can ignore this section.> + +DBD::DBM stores column names as a row in the file with the key I<_metadata +\0>. So this code + + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->do("CREATE TABLE baz (foo CHAR(10), bar INTEGER)"); + $dbh->do("INSERT INTO baz (foo,bar) VALUES ('zippy',1)"); + +Will create a file that has a structure something like this: + + _metadata \0 | <dbd_metadata><schema></schema><col_names>foo,bar</col_names></dbd_metadata> + zippy | 1 + +The next time you access this table with DBD::DBM, it will treat the +I<_metadata \0> row as a header rather than as data and will pull the column +names from there. However, if you access the file with something other +than DBD::DBM, the row will be treated as a regular data row. + +If you do not want the column names stored as a data row in the table you +can set the I<dbm_store_metadata> attribute to 0. + + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_store_metadata => 0 }); + + # or + $dbh->{dbm_store_metadata} = 0; + + # or for per-table setting + $dbh->{f_meta}->{qux}->{dbm_store_metadata} = 0; + +By default, DBD::DBM assumes that you have two columns named "k" and "v" +(short for "key" and "value"). So if you have I<dbm_store_metadata> set to +1 and you want to use alternate column names, you need to specify the +column names like this: + + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_store_metadata => 0, + dbm_cols => [ qw(foo bar) ], + }); + + # or + $dbh->{dbm_store_metadata} = 0; + $dbh->{dbm_cols} = 'foo,bar'; + + # or to set the column names on per-table basis, do this: + # sets the column names only for table "qux" + $dbh->{f_meta}->{qux}->{dbm_store_metadata} = 0; + $dbh->{f_meta}->{qux}->{col_names} = [qw(foo bar)]; + +If you have a file that was created by another DBM program or created with +I<dbm_store_metadata> set to zero and you want to convert it to using +DBD::DBM's column name storage, just use one of the methods above to name +the columns but *without* specifying I<dbm_store_metadata> as zero. You +only have to do that once - thereafter you can get by without setting +either I<dbm_store_metadata> or setting I<dbm_cols> because the names will +be stored in the file. + +=head1 DBI database handle attributes + +=head2 Metadata + +=head3 Statement handle ($sth) attributes and methods + +Most statement handle attributes such as NAME, NUM_OF_FIELDS, etc. are +available only after an execute. The same is true of $sth->rows which is +available after the execute but does I<not> require a fetch. + +=head3 Driver handle ($dbh) attributes + +It is not supported anymore to use dbm-attributes without the dbm_-prefix. +Currently, if an DBD::DBM private attribute is accessed without an +underscore in it's name, dbm_ is prepended to that attribute and it's +processed further. If the resulting attribute name is invalid, an error is +thrown. + +=head4 dbm_cols + +Contains a comma separated list of column names or an array reference to +the column names. + +=head4 dbm_type + +Contains the DBM storage type. Currently known supported type are +C<< ODBM_File >>, C<< NDBM_File >>, C<< SDBM_File >>, C<< GDBM_File >>, +C<< DB_File >> and C<< BerkeleyDB >>. It is not recommended to use one +of the first three types - even if C<< SDBM_File >> is the most commonly +available I<dbm_type>. + +=head4 dbm_mldbm + +Contains the serializer for DBM storage (value column). Requires the +CPAN module L<MLDBM> installed. Currently known supported serializers +are: + +=over 8 + +=item Data::Dumper + +Default serializer. Deployed with Perl core. + +=item Storable + +Faster serializer. Deployed with Perl core. + +=item FreezeThaw + +Pure Perl serializer, requires L<FreezeThaw> to be installed. + +=item YAML + +Portable serializer (between languages but not architectures). +Requires L<YAML::MLDBM> installation. + +=item JSON + +Portable, fast serializer (between languages but not architectures). +Requires L<MLDBM::Serializer::JSON> installation. + +=back + +=head4 dbm_store_metadata + +Boolean value which determines if the metadata in DBM is stored or not. + +=head4 dbm_berkeley_flags + +Hash reference with additional flags for BerkeleyDB::Hash instantiation. + +=head4 dbm_version + +Readonly attribute containing the version of DBD::DBM. + +=head4 f_meta + +In addition to the attributes L<DBD::File> recognizes, DBD::DBM knows +about the (public) attributes C<col_names> (B<Note> not I<dbm_cols> +here!), C<dbm_type>, C<dbm_mldbm>, C<dbm_store_metadata> and +C<dbm_berkeley_flags>. As in DBD::File, there are undocumented, +internal attributes in DBD::DBM. Be very careful when modifying +attributes you do not know; the consequence might a destroyed or +corrupted table. + +=head4 dbm_tables + +This attribute provides restricted access to the table meta data. See +L<f_meta> and L<DBD::File/f_meta> for attribute details. + +dbm_tables is a tied hash providing the internal table names as keys +(accessing unknown tables might create an entry) and their meta +data as another tied hash. The table meta storage is obtained via +the C<get_table_meta> method from the table implementation (see +L<DBD::File::Developers>). Attribute setting and getting within the +table meta data is handled via the methods C<set_table_meta_attr> and +C<get_table_meta_attr>. + +=head3 Following attributes are no longer handled by DBD::DBM: + +=head4 dbm_ext + +This attribute is silently mapped to DBD::File's attribute I<f_ext>. +Later versions of DBI might show a depreciated warning when this attribute +is used and eventually it will be removed. + +=head4 dbm_lockfile + +This attribute is silently mapped to DBD::File's attribute I<f_lockfile>. +Later versions of DBI might show a depreciated warning when this attribute +is used and eventually it will be removed. + +=head1 DBI database handle methods + +=head2 The $dbh->dbm_versions() method + +The private method dbm_versions() returns a summary of what other modules +are being used at any given time. DBD::DBM can work with or without many +other modules - it can use either SQL::Statement or DBI::SQL::Nano as its +SQL engine, it can be run with DBI or DBI::PurePerl, it can use many kinds +of DBM modules, and many kinds of serializers when run with MLDBM. The +dbm_versions() method reports all of that and more. + + print $dbh->dbm_versions; # displays global settings + print $dbh->dbm_versions($table_name); # displays per table settings + +An important thing to note about this method is that when it called +with no arguments, it displays the *global* settings. If you override +these by setting per-table attributes, these will I<not> be shown +unless you specify a table name as an argument to the method call. + +=head2 Storing Objects + +If you are using MLDBM, you can use DBD::DBM to take advantage of its +serializing abilities to serialize any Perl object that MLDBM can handle. +To store objects in columns, you should (but don't absolutely need to) +declare it as a column of type BLOB (the type is *currently* ignored by +the SQL engine, but it's good form). + +=head1 EXTENSIBILITY + +=over 8 + +=item C<SQL::Statement> + +Improved SQL engine compared to the built-in DBI::SQL::Nano - see +L<Supported SQL syntax>. + +=item C<DB_File> + +Berkeley DB version 1. This database library is available on many +systems without additional installation and most systems are +supported. + +=item C<GDBM_File> + +Simple dbm type (comparable to C<DB_File>) under the GNU license. +Typically not available (or requires extra installation) on non-GNU +operating systems. + +=item C<BerkeleyDB> + +Berkeley DB version up to v4 (and maybe higher) - requires additional +installation but is easier than GDBM_File on non-GNU systems. + +db4 comes with a many tools which allow repairing and migrating +databases. This is the B<recommended> dbm type for production use. + +=item C<MLDBM> + +Serializer wrapper to support more than one column for the files. +Comes with serializers using C<Data::Dumper>, C<FreezeThaw> and +C<Storable>. + +=item C<YAML::MLDBM> + +Additional serializer for MLDBM. YAML is very portable between languanges. + +=item C<MLDBM::Serializer::JSON> + +Additional serializer for MLDBM. JSON is very portable between languanges, +probably more than YAML. + +=back + +=head1 GOTCHAS AND WARNINGS + +Using the SQL DROP command will remove any file that has the name specified +in the command with either '.pag' and '.dir', '.db' or your {f_ext} appended +to it. So this be dangerous if you aren't sure what file it refers to: + + $dbh->do(qq{DROP TABLE "/path/to/any/file"}); + +Each DBM type has limitations. SDBM_File, for example, can only store +values of less than 1,000 characters. *You* as the script author must +ensure that you don't exceed those bounds. If you try to insert a value +that is larger than DBM can store, the results will be unpredictable. +See the documentation for whatever DBM you are using for details. + +Different DBM implementations return records in different orders. +That means that you I<should not> rely on the order of records unless +you use an ORDER BY statement. + +DBM data files are platform-specific. To move them from one platform to +another, you'll need to do something along the lines of dumping your data +to CSV on platform #1 and then dumping from CSV to DBM on platform #2. +DBD::AnyData and DBD::CSV can help with that. There may also be DBM +conversion tools for your platforms which would probably be quicker. + +When using MLDBM, there is a very powerful serializer - it will allow +you to store Perl code or objects in database columns. When these get +de-serialized, they may be eval'ed - in other words MLDBM (or actually +Data::Dumper when used by MLDBM) may take the values and try to +execute them in Perl. Obviously, this can present dangers, so if you +do not know what is in a file, be careful before you access it with +MLDBM turned on! + +See the entire section on L<Table locking and flock()> for gotchas and +warnings about the use of flock(). + +=head1 BUGS AND LIMITATIONS + +This module uses hash interfaces of two column file databases. While +none of supported SQL engines have support for indices, the following +statements really do the same (even if they mean something completely +different) for each dbm type which lacks C<EXISTS> support: + + $sth->do( "insert into foo values (1, 'hello')" ); + + # this statement does ... + $sth->do( "update foo set v='world' where k=1" ); + # ... the same as this statement + $sth->do( "insert into foo values (1, 'world')" ); + +This is considered to be a bug and might change in a future release. + +Known affected dbm types are C<ODBM_File> and C<NDBM_File>. We highly +recommended you use a more modern dbm type such as C<DB_File>. + +=head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS + +If you need help installing or using DBD::DBM, please write to the DBI +users mailing list at dbi-users@perl.org or to the +comp.lang.perl.modules newsgroup on usenet. I cannot always answer +every question quickly but there are many on the mailing list or in +the newsgroup who can. + +DBD developers for DBD's which rely on DBD::File or DBD::DBM or use +one of them as an example are suggested to join the DBI developers +mailing list at dbi-dev@perl.org and strongly encouraged to join our +IRC channel at L<irc://irc.perl.org/dbi>. + +If you have suggestions, ideas for improvements, or bugs to report, please +report a bug as described in DBI. Do not mail any of the authors directly, +you might not get an answer. + +When reporting bugs, please send the output of $dbh->dbm_versions($table) +for a table that exhibits the bug and as small a sample as you can make of +the code that produces the bug. And of course, patches are welcome, too +:-). + +If you need enhancements quickly, you can get commercial support as +described at L<http://dbi.perl.org/support/> or you can contact Jens Rehsack +at rehsack@cpan.org for commercial support in Germany. + +Please don't bother Jochen Wiedmann or Jeff Zucker for support - they +handed over further maintenance to H.Merijn Brand and Jens Rehsack. + +=head1 ACKNOWLEDGEMENTS + +Many, many thanks to Tim Bunce for prodding me to write this, and for +copious, wise, and patient suggestions all along the way. (Jeff Zucker) + +I send my thanks and acknowledgements to H.Merijn Brand for his +initial refactoring of DBD::File and his strong and ongoing support of +SQL::Statement. Without him, the current progress would never have +been made. And I have to name Martin J. Evans for each laugh (and +correction) of all those funny word creations I (as non-native +speaker) made to the documentation. And - of course - I have to thank +all those unnamed contributors and testers from the Perl +community. (Jens Rehsack) + +=head1 AUTHOR AND COPYRIGHT + +This module is written by Jeff Zucker < jzucker AT cpan.org >, who also +maintained it till 2007. After that, in 2010, Jens Rehsack & H.Merijn Brand +took over maintenance. + + Copyright (c) 2004 by Jeff Zucker, all rights reserved. + Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand, all rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=head1 SEE ALSO + +L<DBI>, +L<SQL::Statement>, L<DBI::SQL::Nano>, +L<AnyDBM_File>, L<DB_File>, L<BerkeleyDB>, +L<MLDBM>, L<YAML::MLDBM>, L<MLDBM::Serializer::JSON> + +=cut diff --git a/lib/DBD/ExampleP.pm b/lib/DBD/ExampleP.pm new file mode 100644 index 0000000..0bbace0 --- /dev/null +++ b/lib/DBD/ExampleP.pm @@ -0,0 +1,428 @@ +{ + package DBD::ExampleP; + + use Symbol; + + use DBI qw(:sql_types); + + require File::Spec; + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = sprintf("12.%06d", q$Revision: 14310 $ =~ /(\d+)/o); + + +# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z REHSACK $ +# +# Copyright (c) 1994,1997,1998 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + @statnames = qw(dev ino mode nlink + uid gid rdev size + atime mtime ctime + blksize blocks name); + @statnames{@statnames} = (0 .. @statnames-1); + + @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); + @stattypes{@statnames} = @stattypes; + @statprec = ((10) x (@statnames-1), 1024); + @statprec{@statnames} = @statprec; + die unless @statnames == @stattypes; + die unless @statprec == @stattypes; + + $drh = undef; # holds driver handle once initialised + #$gensym = "SYM000"; # used by st::execute() for filehandles + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'ExampleP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Perl stub by Tim Bunce', + }, ['example implementors private data '.__PACKAGE__]); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::ExampleP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my($drh, $dbname, $user, $auth)= @_; + my ($outer, $dbh) = DBI::_new_dbh($drh, { + Name => $dbname, + examplep_private_dbh_attrib => 42, # an example, for testing + }); + $dbh->{examplep_get_info} = { + 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR + 41 => '.', # SQL_CATALOG_NAME_SEPARATOR + 114 => 1, # SQL_CATALOG_LOCATION + }; + #$dbh->{Name} = $dbname; + $dbh->STORE('Active', 1); + return $outer; + } + + sub data_sources { + return ("dbi:ExampleP:dir=."); # possibly usefully meaningless + } + +} + + +{ package DBD::ExampleP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement)= @_; + my @fields; + my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; + + if (defined $fields and defined $dir) { + @fields = ($fields eq '*') + ? keys %DBD::ExampleP::statnames + : split(/\s*,\s*/, $fields); + } + else { + return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") + unless $statement =~ m/^\s*set\s+/; + # the SET syntax is just a hack so the ExampleP driver can + # be used to test non-select statements. + # Now we have DBI::DBM etc., ExampleP should be deprecated + } + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + examplep_private_sth_attrib => 24, # an example, for testing + }, ['example implementors private data '.__PACKAGE__]); + + my @bad = map { + defined $DBD::ExampleP::statnames{$_} ? () : $_ + } @fields; + return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") + if @bad; + + $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); + + $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; + $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); + + if (@fields) { + $outer->STORE('NAME' => \@fields); + $outer->STORE('NULLABLE' => [ (0) x @fields ]); + $outer->STORE('SCALE' => [ (0) x @fields ]); + } + + $outer; + } + + + sub table_info { + my $dbh = shift; + my ($catalog, $schema, $table, $type) = @_; + + my @types = split(/["']*,["']/, $type || 'TABLE'); + my %types = map { $_=>$_ } @types; + + # Return a list of all subdirectories + my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + my $dir = $catalog || File::Spec->curdir(); + my @list; + if ($types{VIEW}) { # for use by test harness + push @list, [ undef, "schema", "table", 'VIEW', undef ]; + push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; + push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; + } + if ($types{TABLE}) { + no strict 'refs'; + opendir($dh, $dir) + or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); + while (defined(my $item = readdir($dh))) { + if ($^O eq 'VMS') { + # if on VMS then avoid warnings from catdir if you use a file + # (not a dir) as the item below + next if $item !~ /\.dir$/oi; + } + my $file = File::Spec->catdir($dir,$item); + next unless -d $file; + my($dev, $ino, $mode, $nlink, $uid) = lstat($file); + my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; + push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; + } + close($dh); + } + # We would like to simply do a DBI->connect() here. However, + # this is wrong if we are in a subclass like DBI::ProxyServer. + $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') + or return $dbh->set_err($DBI::err, + "Failed to connect to DBI::Sponge: $DBI::errstr"); + + my $attr = { + 'rows' => \@list, + 'NUM_OF_FIELDS' => 5, + 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', + 'TABLE_TYPE', 'REMARKS'], + 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), + DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], + 'NULLABLE' => [1, 1, 1, 1, 1] + }; + my $sdbh = $dbh->{'dbd_sponge_dbh'}; + my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) + or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); + $sth; + } + + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE=> 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + + sub ping { + (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t + } + + + sub disconnect { + shift->STORE(Active => 0); + return 1; + } + + + sub get_info { + my ($dbh, $info_type) = @_; + return $dbh->{examplep_get_info}->{$info_type}; + } + + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + # else pass up to DBI to handle + return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; + return $dbh->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; + return $dbh->SUPER::STORE($attrib, $value); + } + + sub DESTROY { + my $dbh = shift; + $dbh->disconnect if $dbh->FETCH('Active'); + undef + } + + + # This is an example to demonstrate the use of driver-specific + # methods via $dbh->func(). + # Use it as follows: + # my @tables = $dbh->func($re, 'examplep_tables'); + # + # Returns all the tables that match the regular expression $re. + sub examplep_tables { + my $dbh = shift; my $re = shift; + grep { $_ =~ /$re/ } $dbh->tables(); + } + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + + sub private_attribute_info { + return { example_driver_path => undef }; + } +} + + +{ package DBD::ExampleP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; no strict 'refs'; # cause problems with filehandles + + sub bind_param { + my($sth, $param, $value, $attribs) = @_; + $sth->{'dbd_param'}->[$param-1] = $value; + return 1; + } + + + sub execute { + my($sth, @dir) = @_; + my $dir; + + if (@dir) { + $sth->bind_param($_, $dir[$_-1]) or return + foreach (1..@dir); + } + + my $dbd_param = $sth->{'dbd_param'} || []; + return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") + unless @$dbd_param == $sth->{NUM_OF_PARAMS}; + + return 0 unless $sth->{NUM_OF_FIELDS}; # not a select + + $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; + return $sth->set_err(2, "No bind parameter supplied") + unless defined $dir; + + $sth->finish; + + # + # If the users asks for directory "long_list_4532", then we fake a + # directory with files "file4351", "file4350", ..., "file0". + # This is a special case used for testing, especially DBD::Proxy. + # + if ($dir =~ /^long_list_(\d+)$/) { + $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode + $sth->{dbd_datahandle} = undef; + } + else { + $sth->{dbd_dir} = $dir; + my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + opendir($sym, $dir) + or return $sth->set_err(2, "opendir($dir): $!"); + $sth->{dbd_datahandle} = $sym; + } + $sth->STORE(Active => 1); + return 1; + } + + + sub fetch { + my $sth = shift; + my $dir = $sth->{dbd_dir}; + my %s; + + if (ref $dir) { # special fake-data test mode + my $num = $dir->[0]--; + unless ($num > 0) { + $sth->finish(); + return; + } + my $time = time; + @s{@DBD::ExampleP::statnames} = + ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, + $time, $time, $time, 512, 2, "file$num") + } + else { # normal mode + my $dh = $sth->{dbd_datahandle} + or return $sth->set_err($DBI::stderr, "fetch without successful execute"); + my $f = readdir($dh); + unless ($f) { + $sth->finish; + return; + } + # untaint $f so that we can use this for DBI taint tests + ($f) = ($f =~ m/^(.*)$/); + my $file = File::Spec->catfile($dir, $f); + # put in all the data fields + @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); + } + + # return just what fields the query asks for + my @new = @s{ @{$sth->{NAME}} }; + + return $sth->_set_fbav(\@new); + } + *fetchrow_arrayref = \&fetch; + + + sub finish { + my $sth = shift; + closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; + $sth->{dbd_datahandle} = undef; + $sth->{dbd_dir} = undef; + $sth->SUPER::finish(); + return 1; + } + + + sub FETCH { + my ($sth, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + if ($attrib eq 'TYPE'){ + return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'PRECISION'){ + return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'ParamValues') { + my $dbd_param = $sth->{dbd_param} || []; + my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; + return \%pv; + } + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->{$attrib} = $value + if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; + return $sth->SUPER::STORE($attrib, $value); + } + + *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; +} + +1; +# vim: sw=4:ts=8 diff --git a/lib/DBD/File.pm b/lib/DBD/File.pm new file mode 100644 index 0000000..d4d57ae --- /dev/null +++ b/lib/DBD/File.pm @@ -0,0 +1,1637 @@ +# -*- perl -*- +# +# DBD::File - A base class for implementing DBI drivers that +# act on plain files +# +# This module is currently maintained by +# +# H.Merijn Brand & Jens Rehsack +# +# The original author is Jochen Wiedmann. +# +# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack +# Copyright (C) 2004 by Jeff Zucker +# Copyright (C) 1998 by Jochen Wiedmann +# +# All rights reserved. +# +# You may distribute this module under the terms of either the GNU +# General Public License or the Artistic License, as specified in +# the Perl README file. + +require 5.008; + +use strict; +use warnings; + +use DBI (); + +package DBD::File; + +use strict; +use warnings; + +use base qw(DBI::DBD::SqlEngine); +use Carp; +use vars qw(@ISA $VERSION $drh); + +$VERSION = "0.40"; + +$drh = undef; # holds driver handle(s) once initialized + +my %accessors = ( + get_meta => "get_file_meta", + set_meta => "set_file_meta", + clear_meta => "clear_file_meta", + ); + +sub driver ($;$) +{ + my ($class, $attr) = @_; + + # Drivers typically use a singleton object for the $drh + # We use a hash here to have one singleton per subclass. + # (Otherwise DBD::CSV and DBD::DBM, for example, would + # share the same driver object which would cause problems.) + # An alternative would be not not cache the $drh here at all + # and require that subclasses do that. Subclasses should do + # their own caching, so caching here just provides extra safety. + $drh->{$class} and return $drh->{$class}; + + $attr ||= {}; + { no strict "refs"; + unless ($attr->{Attribution}) { + $class eq "DBD::File" and + $attr->{Attribution} = "$class by Jeff Zucker"; + $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} || + "oops the author of $class forgot to define this"; + } + $attr->{Version} ||= ${$class . "::VERSION"}; + $attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://; + } + + $drh->{$class} = $class->SUPER::driver ($attr); + + my $prefix = DBI->driver_prefix ($class); + if ($prefix) { + my $dbclass = $class . "::db"; + while (my ($accessor, $funcname) = each %accessors) { + my $method = $prefix . $accessor; + $dbclass->can ($method) and next; + my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname; +sub %s::%s +{ + my $func = %s->can (q{%s}); + goto &$func; + } +EOI + eval $inject; + $dbclass->install_method ($method); + } + } + + # XXX inject DBD::XXX::Statement unless exists + + return $drh->{$class}; + } # driver + +sub CLONE +{ + undef $drh; + } # CLONE + +# ====== DRIVER ================================================================ + +package DBD::File::dr; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +@DBD::File::dr::ISA = qw(DBI::DBD::SqlEngine::dr); +$DBD::File::dr::imp_data_size = 0; + +sub dsn_quote +{ + my $str = shift; + ref $str and return ""; + defined $str or return ""; + $str =~ s/([;:\\])/\\$1/g; + return $str; + } # dsn_quote + +sub data_sources ($;$) +{ + my ($drh, $attr) = @_; + my $dir = $attr && exists $attr->{f_dir} + ? $attr->{f_dir} + : File::Spec->curdir (); + my %attrs; + $attr and %attrs = %$attr; + delete $attrs{f_dir}; + my $dsnextra = join ";", map { $_ . "=" . dsn_quote ($attrs{$_}) } keys %attrs; + my ($dirh) = Symbol::gensym (); + unless (opendir $dirh, $dir) { + $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return; + } + + my ($file, @dsns, %names, $driver); + $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File"; + + while (defined ($file = readdir ($dirh))) { + my $d = File::Spec->catdir ($dir, $file); + # allow current dir ... it can be a data_source too + $file ne File::Spec->updir () && -d $d and + push @dsns, "DBI:$driver:f_dir=" . dsn_quote ($d) . ($dsnextra ? ";$dsnextra" : ""); + } + return @dsns; + } # data_sources + +sub disconnect_all +{ + } # disconnect_all + +sub DESTROY +{ + undef; + } # DESTROY + +# ====== DATABASE ============================================================== + +package DBD::File::db; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +use Carp; +require File::Spec; +require Cwd; +use Scalar::Util qw(refaddr); # in CORE since 5.7.3 + +@DBD::File::db::ISA = qw(DBI::DBD::SqlEngine::db); +$DBD::File::db::imp_data_size = 0; + +sub set_versions +{ + my $dbh = shift; + $dbh->{f_version} = $DBD::File::VERSION; + + return $dbh->SUPER::set_versions (); + } # set_versions + +sub init_valid_attributes +{ + my $dbh = shift; + + $dbh->{f_valid_attrs} = { + f_version => 1, # DBD::File version + f_dir => 1, # base directory + f_ext => 1, # file extension + f_schema => 1, # schema name + f_meta => 1, # meta data for tables + f_meta_map => 1, # mapping table for identifier case + f_lock => 1, # Table locking mode + f_lockfile => 1, # Table lockfile extension + f_encoding => 1, # Encoding of the file + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + $dbh->{f_readonly_attrs} = { + f_version => 1, # DBD::File version + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + + return $dbh->SUPER::init_valid_attributes (); + } # init_valid_attributes + +sub init_default_attributes +{ + my ($dbh, $phase) = @_; + + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->SUPER::init_default_attributes ($phase); + + # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and + # don't call twice + unless (defined $phase) { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if (0 == $phase) { + # check whether we're running in a Gofer server or not (see + # validate_FETCH_attr for details) + $dbh->{f_in_gofer} = (defined $INC{"DBD/Gofer.pm"} && (caller(5))[0] eq "DBI::Gofer::Execute"); + # f_ext should not be initialized + # f_map is deprecated (but might return) + $dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ()); + $dbh->{f_meta} = {}; + $dbh->{f_meta_map} = {}; # choose new name because it contains other keys + + # complete derived attributes, if required + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + my $valid_attrs = $drv_prefix . "valid_attrs"; + my $ro_attrs = $drv_prefix . "readonly_attrs"; + + my @comp_attrs = (); + if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{f_in_gofer}) { + my $attr = $dbh->{$drv_prefix . "meta"}; + defined $attr and defined $dbh->{$valid_attrs} and + !defined $dbh->{$valid_attrs}{$attr} and + $dbh->{$valid_attrs}{$attr} = 1; + + my %h; + tie %h, "DBD::File::TieTables", $dbh; + $dbh->{$attr} = \%h; + + push @comp_attrs, "meta"; + } + + foreach my $comp_attr (@comp_attrs) { + my $attr = $drv_prefix . $comp_attr; + defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and + $dbh->{$valid_attrs}{$attr} = 1; + defined $dbh->{$ro_attrs} and !defined $dbh->{$ro_attrs}{$attr} and + $dbh->{$ro_attrs}{$attr} = 1; + } + } + + return $dbh; + } # init_default_attributes + +sub disconnect ($) +{ + %{$_[0]->{f_meta}} = (); + return $_[0]->SUPER::disconnect (); + } # disconnect + +sub validate_FETCH_attr +{ + my ($dbh, $attrib) = @_; + + # If running in a Gofer server, access to our tied compatibility hash + # would force Gofer to serialize the tieing object including it's + # private $dbh reference used to do the driver function calls. + # This will result in nasty exceptions. So return a copy of the + # f_meta structure instead, which is the source of for the compatibility + # tie-hash. It's not as good as liked, but the best we can do in this + # situation. + if ($dbh->{f_in_gofer}) { + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + exists $dbh->{$drv_prefix . "meta"} && $attrib eq $dbh->{$drv_prefix . "meta"} and + $attrib = "f_meta"; + } + + return $attrib; + } # validate_FETCH_attr + +sub validate_STORE_attr +{ + my ($dbh, $attrib, $value) = @_; + + if ($attrib eq "f_dir") { + -d $value or + return $dbh->set_err ($DBI::stderr, "No such directory '$value'"); + File::Spec->file_name_is_absolute ($value) or + $value = Cwd::abs_path ($value); + } + + if ($attrib eq "f_ext") { + $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or + carp "'$value' doesn't look like a valid file extension attribute\n"; + } + + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + + if (exists $dbh->{$drv_prefix . "meta"}) { + my $attr = $dbh->{$drv_prefix . "meta"}; + if ($attrib eq $attr) { + while (my ($k, $v) = each %$value) { + $dbh->{$attrib}{$k} = $v; + } + } + } + + return $dbh->SUPER::validate_STORE_attr ($attrib, $value); + } # validate_STORE_attr + +sub get_f_versions +{ + my ($dbh, $table) = @_; + + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + my (undef, $meta); + $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + unless ($meta) { + $meta = {}; + $class->bootstrap_table_meta ($dbh, $meta, $table); + } + + my $dver; + my $dtype = "IO::File"; + eval { + $dver = IO::File->VERSION (); + + # when we're still alive here, everthing went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + + $meta->{f_encoding} and $dtype .= " + " . $meta->{f_encoding} . " encoding"; + + return sprintf "%s using %s", $dbh->{f_version}, $dtype; + } # get_f_versions + +sub get_single_table_meta +{ + my ($dbh, $table, $attr) = @_; + my $meta; + + $table eq "." and + return $dbh->FETCH ($attr); + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta or croak "No such table '$table'"; + + # prevent creation of undef attributes + return $class->get_table_meta_attr ($meta, $attr); + } # get_single_table_meta + +sub get_file_meta +{ + my ($dbh, $table, $attr) = @_; + + my $gstm = $dbh->{ImplementorClass}->can ("get_single_table_meta"); + + $table eq "*" and + $table = [ ".", keys %{$dbh->{f_meta}} ]; + $table eq "+" and + $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ]; + ref $table eq "Regexp" and + $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ]; + + ref $table || ref $attr or + return &$gstm ($dbh, $table, $attr); + + ref $table or $table = [ $table ]; + ref $attr or $attr = [ $attr ]; + "ARRAY" eq ref $table or + croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table; + "ARRAY" eq ref $attr or + croak "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr; + + my %results; + foreach my $tname (@{$table}) { + my %tattrs; + foreach my $aname (@{$attr}) { + $tattrs{$aname} = &$gstm ($dbh, $tname, $aname); + } + $results{$tname} = \%tattrs; + } + + return \%results; + } # get_file_meta + +sub set_single_table_meta +{ + my ($dbh, $table, $attr, $value) = @_; + my $meta; + + $table eq "." and + return $dbh->STORE ($attr, $value); + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta or croak "No such table '$table'"; + $class->set_table_meta_attr ($meta, $attr, $value); + + return $dbh; + } # set_single_table_meta + +sub set_file_meta +{ + my ($dbh, $table, $attr, $value) = @_; + + my $sstm = $dbh->{ImplementorClass}->can ("set_single_table_meta"); + + $table eq "*" and + $table = [ ".", keys %{$dbh->{f_meta}} ]; + $table eq "+" and + $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ]; + ref ($table) eq "Regexp" and + $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ]; + + ref $table || ref $attr or + return &$sstm ($dbh, $table, $attr, $value); + + ref $table or $table = [ $table ]; + ref $attr or $attr = { $attr => $value }; + "ARRAY" eq ref $table or + croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table; + "HASH" eq ref $attr or + croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr; + + foreach my $tname (@{$table}) { + my %tattrs; + while (my ($aname, $aval) = each %$attr) { + &$sstm ($dbh, $tname, $aname, $aval); + } + } + + return $dbh; + } # set_file_meta + +sub clear_file_meta +{ + my ($dbh, $table) = @_; + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + my (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta and %{$meta} = (); + + return; + } # clear_file_meta + +sub get_avail_tables +{ + my $dbh = shift; + + my @tables = $dbh->SUPER::get_avail_tables (); + my $dir = $dbh->{f_dir}; + my $dirh = Symbol::gensym (); + + unless (opendir $dirh, $dir) { + $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return @tables; + } + + my $class = $dbh->FETCH ("ImplementorClass"); + $class =~ s/::db$/::Table/; + my ($file, %names); + my $schema = exists $dbh->{f_schema} + ? defined $dbh->{f_schema} && $dbh->{f_schema} ne "" + ? $dbh->{f_schema} : undef + : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent + my %seen; + while (defined ($file = readdir ($dirh))) { + my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX + # $tbl && $meta && -f $meta->{f_fqfn} or next; + $seen{defined $schema ? $schema : "\0"}{$tbl}++ or + push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ]; + } + closedir $dirh or + $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!"); + + return @tables; + } # get_avail_tables + +# ====== Tie-Meta ============================================================== + +package DBD::File::TieMeta; + +use Carp qw(croak); +require Tie::Hash; +@DBD::File::TieMeta::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ($class, $tblClass, $tblMeta) = @_; + + my $self = bless ({ tblClass => $tblClass, tblMeta => $tblMeta, }, $class); + return $self; + } # new + +sub STORE +{ + my ($self, $meta_attr, $meta_val) = @_; + + $self->{tblClass}->set_table_meta_attr ($self->{tblMeta}, $meta_attr, $meta_val); + + return; + } # STORE + +sub FETCH +{ + my ($self, $meta_attr) = @_; + + return $self->{tblClass}->get_table_meta_attr ($self->{tblMeta}, $meta_attr); + } # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]->{tblMeta}}; + each %{$_[0]->{tblMeta}}; + } # FIRSTKEY + +sub NEXTKEY +{ + each %{$_[0]->{tblMeta}}; + } # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{tblMeta}{$_[1]}; + } # EXISTS + +sub DELETE +{ + croak "Can't delete single attributes from table meta structure"; + } # DELETE + +sub CLEAR +{ + %{$_[0]->{tblMeta}} = () + } # CLEAR + +sub SCALAR +{ + scalar %{$_[0]->{tblMeta}} + } # SCALAR + +# ====== Tie-Tables ============================================================ + +package DBD::File::TieTables; + +use Carp qw(croak); +require Tie::Hash; +@DBD::File::TieTables::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ($class, $dbh) = @_; + + (my $tbl_class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + my $self = bless ({ dbh => $dbh, tblClass => $tbl_class, }, $class); + return $self; + } # new + +sub STORE +{ + my ($self, $table, $tbl_meta) = @_; + + "HASH" eq ref $tbl_meta or + croak "Invalid data for storing as table meta data (must be hash)"; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + while (my ($meta_attr, $meta_val) = each %$tbl_meta) { + $self->{tblClass}->set_table_meta_attr ($meta, $meta_attr, $meta_val); + } + + return; + } # STORE + +sub FETCH +{ + my ($self, $table) = @_; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + my %h; + tie %h, "DBD::File::TieMeta", $self->{tblClass}, $meta; + + return \%h; + } # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]->{dbh}->{f_meta}}; + each %{$_[0]->{dbh}->{f_meta}}; + } # FIRSTKEY + +sub NEXTKEY +{ + each %{$_[0]->{dbh}->{f_meta}}; + } # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{dbh}->{f_meta}->{$_[1]} or + exists $_[0]->{dbh}->{f_meta_map}->{$_[1]}; + } # EXISTS + +sub DELETE +{ + my ($self, $table) = @_; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + delete $_[0]->{dbh}->{f_meta}->{$meta->{table_name}}; + } # DELETE + +sub CLEAR +{ + %{$_[0]->{dbh}->{f_meta}} = (); + %{$_[0]->{dbh}->{f_meta_map}} = (); + } # CLEAR + +sub SCALAR +{ + scalar %{$_[0]->{dbh}->{f_meta}} + } # SCALAR + +# ====== STATEMENT ============================================================= + +package DBD::File::st; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +@DBD::File::st::ISA = qw(DBI::DBD::SqlEngine::st); +$DBD::File::st::imp_data_size = 0; + +my %supported_attrs = ( + TYPE => 1, + PRECISION => 1, + NULLABLE => 1, + ); + +sub FETCH +{ + my ($sth, $attr) = @_; + + if ($supported_attrs{$attr}) { + my $stmt = $sth->{sql_stmt}; + + if (exists $sth->{ImplementorClass} && + exists $sth->{sql_stmt} && + $sth->{sql_stmt}->isa ("SQL::Statement")) { + + # fill overall_defs unless we know + unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) { + my $all_meta = + $sth->{Database}->func ("*", "table_defs", "get_file_meta"); + while (my ($tbl, $meta) = each %$all_meta) { + exists $meta->{table_defs} && ref $meta->{table_defs} or next; + foreach (keys %{$meta->{table_defs}{columns}}) { + $sth->{f_overall_defs}{$_} = $meta->{table_defs}{columns}{$_}; + } + } + } + + my @colnames = $sth->sql_get_colnames (); + + $attr eq "TYPE" and + return [ map { $sth->{f_overall_defs}{$_}{data_type} || "CHAR" } + @colnames ]; + + $attr eq "PRECISION" and + return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 } + @colnames ]; + + $attr eq "NULLABLE" and + return [ map { ( grep m/^NOT NULL$/ => + @{ $sth->{f_overall_defs}{$_}{constraints} || [] }) + ? 0 : 1 } + @colnames ]; + } + } + + return $sth->SUPER::FETCH ($attr); + } # FETCH + +# ====== SQL::STATEMENT ======================================================== + +package DBD::File::Statement; + +use strict; +use warnings; + +@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement ); + +sub open_table ($$$$$) +{ + my ($self, $data, $table, $createMode, $lockMode) = @_; + + my $class = ref $self; + $class =~ s/::Statement/::Table/; + + my $flags = { + createMode => $createMode, + lockMode => $lockMode, + }; + $self->{command} eq "DROP" and $flags->{dropMode} = 1; + + return $class->new ($data, { table => $table }, $flags); + } # open_table + +# ====== SQL::TABLE ============================================================ + +package DBD::File::Table; + +use strict; +use warnings; + +use Carp; +require IO::File; +require File::Basename; +require File::Spec; +require Cwd; + +# We may have a working flock () built-in but that doesn't mean that locking +# will work on NFS (flock () may hang hard) +my $locking = eval { flock STDOUT, 0; 1 }; + +@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table ); + +# ====== FLYWEIGHT SUPPORT ===================================================== + +my $fn_any_ext_regex = qr/\.[^.]*/; + +# Flyweight support for table_info +# The functions file2table, init_table_meta, default_table_meta and +# get_table_meta are using $self arguments for polymorphism only. The +# must not rely on an instantiated DBD::File::Table +sub file2table +{ + my ($self, $meta, $file, $file_is_table, $respect_case) = @_; + + $file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir + + my ($ext, $req) = ("", 0); + if ($meta->{f_ext}) { + ($ext, my $opt) = split m/\//, $meta->{f_ext}; + if ($ext && $opt) { + $opt =~ m/r/i and $req = 1; + } + } + + # (my $tbl = $file) =~ s/$ext$//i; + my ($tbl, $basename, $dir, $fn_ext, $user_spec_file); + if ($file_is_table and defined $meta->{f_file}) { + $tbl = $file; + ($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex); + $file = $basename . $fn_ext; + $user_spec_file = 1; + } + else { + ($basename, $dir, undef) = File::Basename::fileparse ($file, $ext); + $file = $tbl = $basename; + $user_spec_file = 0; + } + + if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER + $basename = uc $basename; + $tbl = uc $tbl; + } + if( !$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER + $basename = lc $basename; + $tbl = lc $tbl; + } + + my $searchdir = File::Spec->file_name_is_absolute ($dir) + ? ($dir =~ s|/$||, $dir) + : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir)); + -d $searchdir or + croak "-d $searchdir: $!"; + + $searchdir eq $meta->{f_dir} and + $dir = ""; + + unless ($user_spec_file) { + $file_is_table and $file = "$basename$ext"; + + # Fully Qualified File Name + my $cmpsub; + if ($respect_case) { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot + $fn eq $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + else { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot + lc $fn eq lc $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + + opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!"; + my @f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } readdir $dh; + @f > 0 && @f <= 2 and $file = $f[0]; + !$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED + ($tbl = $file) =~ s/$ext$//i; + closedir $dh or croak "Can't close '$searchdir': $!"; + + my $tmpfn = $file; + if ($ext && $req) { + # File extension required + $tmpfn =~ s/$ext$//i or return; + } + } + + my $fqfn = File::Spec->catfile ($searchdir, $file); + my $fqbn = File::Spec->catfile ($searchdir, $basename); + + $meta->{f_fqfn} = $fqfn; + $meta->{f_fqbn} = $fqbn; + defined $meta->{f_lockfile} && $meta->{f_lockfile} and + $meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile}; + + $dir && !$user_spec_file and $tbl = File::Spec->catfile ($dir, $tbl); + $meta->{table_name} = $tbl; + + return $tbl; + } # file2table + +sub bootstrap_table_meta +{ + my ($self, $dbh, $meta, $table) = @_; + + exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir}; + defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext}; + defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding}; + exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock}; + exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile}; + defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema}; + defined $meta->{sql_identifier_case} or + $meta->{sql_identifier_case} = $dbh->{sql_identifier_case}; + } # bootstrap_table_meta + +sub init_table_meta +{ + my ($self, $dbh, $meta, $table) = @_; + + return; + } # init_table_meta + +sub get_table_meta ($$$$;$) +{ + my ($self, $dbh, $table, $file_is_table, $respect_case) = @_; + unless (defined $respect_case) { + $respect_case = 0; + $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers + $table =~ s/\"$//; + } + + unless ($respect_case) { + defined $dbh->{f_meta_map}{$table} and $table = $dbh->{f_meta_map}{$table}; + } + + my $meta = {}; + defined $dbh->{f_meta}{$table} and $meta = $dbh->{f_meta}{$table}; + + unless ($meta->{initialized}) { + $self->bootstrap_table_meta ($dbh, $meta, $table); + + unless (defined $meta->{f_fqfn}) { + $self->file2table ($meta, $table, $file_is_table, $respect_case) or return; + } + + if (defined $meta->{table_name} and $table ne $meta->{table_name}) { + $dbh->{f_meta_map}{$table} = $meta->{table_name}; + $table = $meta->{table_name}; + } + + # now we know a bit more - let's check if user can't use consequent spelling + # XXX add know issue about reset sql_identifier_case here ... + if (defined $dbh->{f_meta}{$table} && defined $dbh->{f_meta}{$table}{initialized}) { + $meta = $dbh->{f_meta}{$table}; + $self->file2table ($meta, $table, $file_is_table, $respect_case) or + return unless $dbh->{f_meta}{$table}{initialized}; + } + unless ($dbh->{f_meta}{$table}{initialized}) { + $self->init_table_meta ($dbh, $meta, $table); + $meta->{initialized} = 1; + $dbh->{f_meta}{$table} = $meta; + } + } + + return ($table, $meta); + } # get_table_meta + +my %reset_on_modify = ( + f_file => "f_fqfn", + f_dir => "f_fqfn", + f_ext => "f_fqfn", + f_lockfile => "f_fqfn", # forces new file2table call + ); + +my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile ); + +sub register_reset_on_modify +{ + my ($proto, $extra_resets) = @_; + %reset_on_modify = (%reset_on_modify, %$extra_resets); + return; + } # register_reset_on_modify + +sub register_compat_map +{ + my ($proto, $extra_compat_map) = @_; + %compat_map = (%compat_map, %$extra_compat_map); + return; + } # register_compat_map + +sub get_table_meta_attr +{ + my ($class, $meta, $attrib) = @_; + exists $compat_map{$attrib} and + $attrib = $compat_map{$attrib}; + exists $meta->{$attrib} and + return $meta->{$attrib}; + return; + } # get_table_meta_attr + +sub set_table_meta_attr +{ + my ($class, $meta, $attrib, $value) = @_; + exists $compat_map{$attrib} and + $attrib = $compat_map{$attrib}; + $class->table_meta_attr_changed ($meta, $attrib, $value); + $meta->{$attrib} = $value; + } # set_table_meta_attr + +sub table_meta_attr_changed +{ + my ($class, $meta, $attrib, $value) = @_; + defined $reset_on_modify{$attrib} and + delete $meta->{$reset_on_modify{$attrib}} and + $meta->{initialized} = 0; + } # table_meta_attr_changed + +# ====== FILE OPEN ============================================================= + +sub open_file ($$$) +{ + my ($self, $meta, $attrs, $flags) = @_; + + defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename given"; + + my ($fh, $fn); + unless ($meta->{f_dontopen}) { + $fn = $meta->{f_fqfn}; + if ($flags->{createMode}) { + -f $meta->{f_fqfn} and + croak "Cannot create table $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + if ($fh) { + $fh->seek (0, 0) or + croak "Error while seeking back: $!"; + if (my $enc = $meta->{f_encoding}) { + binmode $fh, ":encoding($enc)" or + croak "Failed to set encoding layer '$enc' on $fn: $!"; + } + else { + binmode $fh or croak "Failed to set binary mode on $fn: $!"; + } + } + + $meta->{fh} = $fh; + } + if ($meta->{f_fqln}) { + $fn = $meta->{f_fqln}; + if ($flags->{createMode}) { + -f $fn and + croak "Cannot create table lock for $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + $meta->{lockfh} = $fh; + } + + if ($locking && $fh) { + my $lm = defined $flags->{f_lock} + && $flags->{f_lock} =~ m/^[012]$/ + ? $flags->{f_lock} + : $flags->{lockMode} ? 2 : 1; + if ($lm == 2) { + flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; + } + elsif ($lm == 1) { + flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!"; + } + # $lm = 0 is forced no locking at all + } + } # open_file + +# ====== SQL::Eval API ========================================================= + +sub new +{ + my ($className, $data, $attrs, $flags) = @_; + my $dbh = $data->{Database}; + + my ($tblnm, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1) or + croak "Cannot find appropriate file for table '$attrs->{table}'"; + $attrs->{table} = $tblnm; + + # Being a bit dirty here, as SQL::Statement::Structure does not offer + # me an interface to the data I want + $flags->{createMode} && $data->{sql_stmt}{table_defs} and + $meta->{table_defs} = $data->{sql_stmt}{table_defs}; + + $className->open_file ($meta, $attrs, $flags); + + my $columns = {}; + my $array = []; + my $tbl = { + %{$attrs}, + meta => $meta, + col_names => $meta->{col_names} || [], + }; + return $className->SUPER::new ($tbl); + } # new + +sub drop ($) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + # We have to close the file before unlinking it: Some OS'es will + # refuse the unlink otherwise. + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + $meta->{f_fqfn} and unlink $meta->{f_fqfn}; + $meta->{f_fqln} and unlink $meta->{f_fqln}; + delete $data->{Database}{f_meta}{$self->{table}}; + return 1; + } # drop + +sub seek ($$$$) +{ + my ($self, $data, $pos, $whence) = @_; + my $meta = $self->{meta}; + if ($whence == 0 && $pos == 0) { + $pos = defined $meta->{first_row_pos} ? $meta->{first_row_pos} : 0; + } + elsif ($whence != 2 || $pos != 0) { + croak "Illegal seek position: pos = $pos, whence = $whence"; + } + + $meta->{fh}->seek ($pos, $whence) or + croak "Error while seeking in " . $meta->{f_fqfn} . ": $!"; + } # seek + +sub truncate ($$) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + $meta->{fh}->truncate ($meta->{fh}->tell ()) or + croak "Error while truncating " . $meta->{f_fqfn} . ": $!"; + return 1; + } # truncate + +sub DESTROY +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + } # DESTROY + +1; + +__END__ + +=head1 NAME + +DBD::File - Base class for writing file based DBI drivers + +=head1 SYNOPSIS + +This module is a base class for writing other L<DBD|DBI::DBD>s. +It is not intended to function as a DBD itself (though it is possible). +If you want to access flat files, use L<DBD::AnyData|DBD::AnyData>, or +L<DBD::CSV|DBD::CSV> (both of which are subclasses of DBD::File). + +=head1 DESCRIPTION + +The DBD::File module is not a true L<DBI|DBI> driver, but an abstract +base class for deriving concrete DBI drivers from it. The implication +is, that these drivers work with plain files, for example CSV files or +INI files. The module is based on the L<SQL::Statement|SQL::Statement> +module, a simple SQL engine. + +See L<DBI|DBI> for details on DBI, L<SQL::Statement|SQL::Statement> for +details on SQL::Statement and L<DBD::CSV|DBD::CSV>, L<DBD::DBM|DBD::DBM> +or L<DBD::AnyData|DBD::AnyData> for example drivers. + +=head2 Metadata + +The following attributes are handled by DBI itself and not by DBD::File, +thus they all work as expected: + + Active + ActiveKids + CachedKids + CompatMode (Not used) + InactiveDestroy + AutoInactiveDestroy + Kids + PrintError + RaiseError + Warn (Not used) + +=head3 The following DBI attributes are handled by DBD::File: + +=head4 AutoCommit + +Always on. + +=head4 ChopBlanks + +Works. + +=head4 NUM_OF_FIELDS + +Valid after C<< $sth->execute >>. + +=head4 NUM_OF_PARAMS + +Valid after C<< $sth->prepare >>. + +=head4 NAME + +Valid after C<< $sth->execute >>; undef for Non-Select statements. + +=head4 NULLABLE + +Not really working, always returns an array ref of ones, except the +affected table has been created in this session. Valid after +C<< $sth->execute >>; undef for non-select statements. + +=head3 The following DBI attributes and methods are not supported: + +=over 4 + +=item bind_param_inout + +=item CursorName + +=item LongReadLen + +=item LongTruncOk + +=back + +=head3 DBD::File specific attributes + +In addition to the DBI attributes, you can use the following dbh +attributes: + +=head4 f_dir + +This attribute is used for setting the directory where the files are +opened and it defaults to the current directory (F<.>). Usually you set +it on the dbh but it may be overridden per table (see L<f_meta>). + +When the value for C<f_dir> is a relative path, it is converted into +the appropriate absolute path name (based on the current working +directory) when the dbh attribute is set. + +See L<KNOWN BUGS AND LIMITATIONS>. + +=head4 f_ext + +This attribute is used for setting the file extension. The format is: + + extension{/flag} + +where the /flag is optional and the extension is case-insensitive. +C<f_ext> allows you to specify an extension which: + +=over + +=item * + +makes DBD::File prefer F<table.extension> over F<table>. + +=item * + +makes the table name the filename minus the extension. + +=back + + DBI:CSV:f_dir=data;f_ext=.csv + +In the above example and when C<f_dir> contains both F<table.csv> and +F<table>, DBD::File will open F<table.csv> and the table will be +named "table". If F<table.csv> does not exist but F<table> does +that file is opened and the table is also called "table". + +If C<f_ext> is not specified and F<table.csv> exists it will be opened +and the table will be called "table.csv" which is probably not what +you want. + +NOTE: even though extensions are case-insensitive, table names are +not. + + DBI:CSV:f_dir=data;f_ext=.csv/r + +The C<r> flag means the file extension is required and any filename +that does not match the extension is ignored. + +Usually you set it on the dbh but it may be overridden per table +(see L<f_meta>). + +=head4 f_schema + +This will set the schema name and defaults to the owner of the +directory in which the table file resides. You can set C<f_schema> to +C<undef>. + + my $dbh = DBI->connect ("dbi:CSV:", "", "", { + f_schema => undef, + f_dir => "data", + f_ext => ".csv/r", + }) or die $DBI::errstr; + +By setting the schema you affect the results from the tables call: + + my @tables = $dbh->tables (); + + # no f_schema + "merijn".foo + "merijn".bar + + # f_schema => "dbi" + "dbi".foo + "dbi".bar + + # f_schema => undef + foo + bar + +Defining C<f_schema> to the empty string is equal to setting it to C<undef> +so the DSN can be C<"dbi:CSV:f_schema=;f_dir=.">. + +=head4 f_lock + +The C<f_lock> attribute is used to set the locking mode on the opened +table files. Note that not all platforms support locking. By default, +tables are opened with a shared lock for reading, and with an +exclusive lock for writing. The supported modes are: + + 0: No locking at all. + + 1: Shared locks will be used. + + 2: Exclusive locks will be used. + +But see L<KNOWN BUGS|/"KNOWN BUGS AND LIMITATIONS"> below. + +=head4 f_lockfile + +If you wish to use a lockfile extension other than C<.lck>, simply specify +the C<f_lockfile> attribute: + + $dbh = DBI->connect ("dbi:DBM:f_lockfile=.foo"); + $dbh->{f_lockfile} = ".foo"; + $dbh->{f_meta}{qux}{f_lockfile} = ".foo"; + +If you wish to disable locking, set the C<f_lockfile> to C<0>. + + $dbh = DBI->connect ("dbi:DBM:f_lockfile=0"); + $dbh->{f_lockfile} = 0; + $dbh->{f_meta}{qux}{f_lockfile} = 0; + +=head4 f_encoding + +With this attribute, you can set the encoding in which the file is opened. +This is implemented using C<< binmode $fh, ":encoding(<f_encoding>)" >>. + +=head4 f_meta + +Private data area which contains information about the tables this +module handles. Table meta data might not be available until the +table has been accessed for the first time e.g., by issuing a select +on it however it is possible to pre-initialize attributes for each table +you use. + +DBD::File recognizes the (public) attributes C<f_ext>, C<f_dir>, +C<f_file>, C<f_encoding>, C<f_lock>, C<f_lockfile>, C<f_schema>, +C<col_names>, C<table_name> and C<sql_identifier_case>. Be very careful +when modifying attributes you do not know, the consequence might be a +destroyed or corrupted table. + +C<f_file> is an attribute applicable to table meta data only and you +will not find a corresponding attribute in the dbh. Whilst it may be +reasonable to have several tables with the same column names, it is +not for the same file name. If you need access to the same file using +different table names, use C<SQL::Statement> as the SQL engine and the +C<AS> keyword: + + SELECT * FROM tbl AS t1, tbl AS t2 WHERE t1.id = t2.id + +C<f_file> can be an absolute path name or a relative path name but if +it is relative, it is interpreted as being relative to the C<f_dir> +attribute of the table meta data. When C<f_file> is set DBD::File will +use C<f_file> as specified and will not attempt to work out an +alternative for C<f_file> using the C<table name> and C<f_ext> +attribute. + +While C<f_meta> is a private and readonly attribute (which means, you +cannot modify it's values), derived drivers might provide restricted +write access through another attribute. Well known accessors are +C<csv_tables> for L<DBD::CSV>, C<ad_tables> for L<DBD::AnyData> and +C<dbm_tables> for L<DBD::DBM>. + +=head3 Internally private attributes to deal with SQL backends: + +Do not modify any of these private attributes unless you understand +the implications of doing so. The behavior of DBD::File and derived +DBDs might be unpredictable when one or more of those attributes are +modified. + +=head4 sql_nano_version + +Contains the version of loaded DBI::SQL::Nano. + +=head4 sql_statement_version + +Contains the version of loaded SQL::Statement. + +=head4 sql_handler + +Contains either the text 'SQL::Statement' or 'DBI::SQL::Nano'. + +=head4 sql_ram_tables + +Contains optionally temporary tables. + +=head4 sql_flags + +Contains optional flags to instantiate the SQL::Parser parsing engine +when SQL::Statement is used as SQL engine. See L<SQL::Parser> for valid +flags. + +=head2 Driver private methods + +=head3 Default DBI methods + +=head4 data_sources + +The C<data_sources> method returns a list of subdirectories of the current +directory in the form "dbi:CSV:f_dir=$dirname". + +If you want to read the subdirectories of another directory, use + + my ($drh) = DBI->install_driver ("CSV"); + my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data"); + +=head4 list_tables + +This method returns a list of file names inside $dbh->{f_dir}. +Example: + + my ($dbh) = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data"); + my (@list) = $dbh->func ("list_tables"); + +Note that the list includes all files contained in the directory, even +those that have non-valid table names, from the view of SQL. + +=head3 Additional methods + +The following methods are only available via their documented name when +DBD::File is used directly. Because this is only reasonable for testing +purposes, the real names must be used instead. Those names can be computed +by replacing the C<f_> in the method name with the driver prefix. + +=head4 f_versions + +Signature: + + sub f_versions (;$) + { + my ($table_name) = @_; + $table_name ||= "."; + ... + } + +Returns the versions of the driver, including the DBI version, the Perl +version, DBI::PurePerl version (if DBI::PurePerl is active) and the version +of the SQL engine in use. + + my $dbh = DBI->connect ("dbi:File:"); + my $f_versions = $dbh->f_versions (); + print "$f_versions\n"; + __END__ + # DBD::File 0.39 using SQL::Statement 1.28 + # DBI 1.612 + # OS netbsd (5.99.24) + # Perl 5.010001 (x86_64-netbsd-thread-multi) + +Called in list context, f_versions will return an array containing each +line as single entry. + +Some drivers might use the optional (table name) argument and modify +version information related to the table (e.g. DBD::DBM provides storage +backend information for the requested table, when it has a table name). + +=head4 f_get_meta + +Signature: + + sub f_get_meta ($$) + { + my ($table_name, $attrib) = @_; + ... + } + +Returns the value of a meta attribute set for a specific table, if any. +See L<f_meta> for the possible attributes. + +A table name of C<"."> (single dot) is interpreted as the default table. +This will retrieve the appropriate attribute globally from the dbh. +This has the same restrictions as C<< $dbh->{$attrib} >>. + +=head4 f_set_meta + +Signature: + + sub f_set_meta ($$$) + { + my ($table_name, $attrib, $value) = @_; + ... + } + +Sets the value of a meta attribute set for a specific table. +See L<f_meta> for the possible attributes. + +A table name of C<"."> (single dot) is interpreted as the default table +which will set the specified attribute globally for the dbh. +This has the same restrictions as C<< $dbh->{$attrib} = $value >>. + +=head4 f_clear_meta + +Signature: + + sub f_clear_meta ($) + { + my ($table_name) = @_; + ... + } + +Clears the table specific meta information in the private storage of the +dbh. + +=head1 SQL ENGINES + +DBD::File currently supports two SQL engines: L<SQL::Statement|SQL::Statement> +and L<DBI::SQL::Nano::Statement_|DBI::SQL::Nano>. DBI::SQL::Nano supports a +I<very> limited subset of SQL statements, but it might be faster for some +very simple tasks. SQL::Statement in contrast supports a much larger subset +of ANSI SQL. + +To use SQL::Statement, you need at least version 1.28 of +SQL::Statement and the environment variable C<DBI_SQL_NANO> must not +be set to a true value. + +=head1 KNOWN BUGS AND LIMITATIONS + +=over 4 + +=item * + +This module uses flock () internally but flock is not available on all +platforms. On MacOS and Windows 95 there is no locking at all (perhaps +not so important on MacOS and Windows 95, as there is only a single +user). + +=item * + +The module stores details about the handled tables in a private area +of the driver handle (C<$drh>). This data area is not shared between +different driver instances, so several C<< DBI->connect () >> calls will +cause different table instances and private data areas. + +This data area is filled for the first time when a table is accessed, +either via an SQL statement or via C<table_info> and is not +destroyed until the table is dropped or the driver handle is released. +Manual destruction is possible via L<f_clear_meta>. + +The following attributes are preserved in the data area and will +evaluated instead of driver globals: + +=over 8 + +=item f_ext + +=item f_dir + +=item f_lock + +=item f_lockfile + +=item f_encoding + +=item f_schema + +=item col_names + +=item sql_identifier_case + +=back + +The following attributes are preserved in the data area only and +cannot be set globally. + +=over 8 + +=item f_file + +=back + +The following attributes are preserved in the data area only and are +computed when initializing the data area: + +=over 8 + +=item f_fqfn + +=item f_fqbn + +=item f_fqln + +=item table_name + +=back + +For DBD::CSV tables this means, once opened "foo.csv" as table named "foo", +another table named "foo" accessing the file "foo.txt" cannot be opened. +Accessing "foo" will always access the file "foo.csv" in memorized +C<f_dir>, locking C<f_lockfile> via memorized C<f_lock>. + +You can use L<f_clear_meta> or the C<f_file> attribute for a specific table +to work around this. + +=item * + +When used with SQL::Statement and temporary tables e.g., + + CREATE TEMP TABLE ... + +the table data processing bypasses DBD::File::Table. No file system +calls will be made and there are no clashes with existing (file based) +tables with the same name. Temporary tables are chosen over file +tables, but they will not covered by C<table_info>. + +=back + +=head1 AUTHOR + +This module is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original author is Jochen Wiedmann. + +=head1 COPYRIGHT AND LICENSE + + Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack + Copyright (C) 2004-2009 by Jeff Zucker + Copyright (C) 1998-2004 by Jochen Wiedmann + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=head1 SEE ALSO + +L<DBI|DBI>, L<DBD::DBM|DBD::DBM>, L<DBD::CSV|DBD::CSV>, L<Text::CSV|Text::CSV>, +L<Text::CSV_XS|Text::CSV_XS>, L<SQL::Statement|SQL::Statement>, and +L<DBI::SQL::Nano|DBI::SQL::Nano> + +=cut diff --git a/lib/DBD/File/Developers.pod b/lib/DBD/File/Developers.pod new file mode 100644 index 0000000..a9bef85 --- /dev/null +++ b/lib/DBD/File/Developers.pod @@ -0,0 +1,556 @@ +=head1 NAME + +DBD::File::Developers - Developers documentation for DBD::File + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBD::File); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + sub CLONE { ... } + + package DBD::myDriver::dr; + + @ISA = qw(DBD::File::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBD::File::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBD::File::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBD::File::Statement); + + package DBD::myDriver::Table; + + @ISA = qw(DBD::File::Table); + + my %reset_on_modify = ( + myd_abc => "myd_foo", + myd_mno => "myd_bar", + ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + my %compat_map = ( + abc => 'foo_abc', + xyz => 'foo_xyz', + ); + __PACKAGE__->register_compat_map( \%compat_map ); + + sub bootstrap_table_meta { ... } + sub init_table_meta { ... } + sub table_meta_attr_changed { ... } + sub open_file { ... } + + sub fetch_row { ... } + sub push_row { ... } + sub push_names { ... } + + # optimize the SQL engine by add one or more of + sub update_current_row { ... } + # or + sub update_specific_row { ... } + # or + sub update_one_row { ... } + # or + sub insert_new_row { ... } + # or + sub delete_current_row { ... } + # or + sub delete_one_row { ... } + +=head1 DESCRIPTION + +This document describes how DBD developers can write DBD::File based DBI +drivers. It supplements L<DBI::DBD> and L<DBI::DBD::SqlEngine::Developers>, +which you should read first. + +=head1 CLASSES + +Each DBI driver must provide a package global C<driver> method and three +DBI related classes: + +=over 4 + +=item DBD::File::dr + +Driver package, contains the methods DBI calls indirectly via DBI +interface: + + DBI->connect ('DBI:DBM:', undef, undef, {}) + + # invokes + package DBD::DBM::dr; + @DBD::DBM::dr::ISA = qw(DBD::File::dr); + + sub connect ($$;$$$) + { + ... + } + +Similar for C<< data_sources () >> and C<< disconnect_all() >>. + +Pure Perl DBI drivers derived from DBD::File do not usually need to +override any of the methods provided through the DBD::XXX::dr package +however if you need additional initialization in the connect method +you may need to. + +=item DBD::File::db + +Contains the methods which are called through DBI database handles +(C<< $dbh >>). e.g., + + $sth = $dbh->prepare ("select * from foo"); + # returns the f_encoding setting for table foo + $dbh->csv_get_meta ("foo", "f_encoding"); + +DBD::File provides the typical methods required here. Developers who +write DBI drivers based on DBD::File need to override the methods C<< +set_versions >> and C<< init_valid_attributes >>. + +=item DBD::File::st + +Contains the methods to deal with prepared statement handles. e.g., + + $sth->execute () or die $sth->errstr; + +=back + +=head2 DBD::File + +This is the main package containing the routines to initialize +DBD::File based DBI drivers. Primarily the C<< DBD::File::driver >> +method is invoked, either directly from DBI when the driver is +initialized or from the derived class. + + package DBD::DBM; + + use base qw( DBD::File ); + + sub driver + { + my ( $class, $attr ) = @_; + ... + my $drh = $class->SUPER::driver( $attr ); + ... + return $drh; + } + +It is not necessary to implement your own driver method as long as +additional initialization (e.g. installing more private driver +methods) is not required. You do not need to call C<< setup_driver >> +as DBD::File takes care of it. + +=head2 DBD::File::dr + +The driver package contains the methods DBI calls indirectly via the DBI +interface (see L<DBI/DBI Class Methods>). + +DBD::File based DBI drivers usually do not need to implement anything here, +it is enough to do the basic initialization: + + package DBD:XXX::dr; + + @DBD::XXX::dr::ISA = qw (DBD::File::dr); + $DBD::XXX::dr::imp_data_size = 0; + $DBD::XXX::dr::data_sources_attr = undef; + $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; + +=head2 DBD::File::db + +This package defines the database methods, which are called via the DBI +database handle C<< $dbh >>. + +Methods provided by DBD::File: + +=over 4 + +=item ping + +Simply returns the content of the C<< Active >> attribute. Override +when your driver needs more complicated actions here. + +=item prepare + +Prepares a new SQL statement to execute. Returns a statement handle, +C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor +recommended to override this method. + +=item FETCH + +Fetches an attribute of a DBI database object. Private handle attributes +must have a prefix (this is mandatory). If a requested attribute is +detected as a private attribute without a valid prefix, the driver prefix +(written as C<$drv_prefix>) is added. + +The driver prefix is extracted from the attribute name and verified against +C<< $dbh->{ $drv_prefix . "valid_attrs" } >> (when it exists). If the +requested attribute value is not listed as a valid attribute, this method +croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ +$drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the +attribute value is returned. So it's not possible to modify +C<f_valid_attrs> from outside of DBD::File::db or a derived class. + +=item STORE + +Stores a database private attribute. Private handle attributes must have a +prefix (this is mandatory). If a requested attribute is detected as a private +attribute without a valid prefix, the driver prefix (written as +C<$drv_prefix>) is added. If the database handle has an attribute +C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in +that hash, this method croaks. If the database handle has an attribute +C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there +can be stored (once they are initialized). Trying to overwrite such an +immutable attribute forces this method to croak. + +An example of a valid attributes list can be found in +C<< DBD::File::db::init_valid_attributes >>. + +=item set_versions + +This method sets the attribute C<f_version> with the version of DBD::File. + +This method is called at the begin of the C<connect ()> phase. + +When overriding this method, do not forget to invoke the superior one. + +=item init_valid_attributes + +This method is called after the database handle is instantiated as the +first attribute initialization. + +C<< DBD::File::db::init_valid_attributes >> initializes the attributes +C<f_valid_attrs> and C<f_readonly_attrs>. + +When overriding this method, do not forget to invoke the superior one, +preferably before doing anything else. Compatibility table attribute +access must be initialized here to allow DBD::File to instantiate the +map tie: + + # for DBD::CSV + $dbh->{csv_meta} = "csv_tables"; + # for DBD::DBM + $dbh->{dbm_meta} = "dbm_tables"; + # for DBD::AnyData + $dbh->{ad_meta} = "ad_tables"; + +=item init_default_attributes + +This method is called after the database handle is instantiated to +initialize the default attributes. + +C<< DBD::File::db::init_default_attributes >> initializes the attributes +C<f_dir>, C<f_meta>, C<f_meta_map>, C<f_version>. + +When the derived implementor class provides the attribute to validate +attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute +containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} += {...}; >>), the attributes C<drv_valid_attrs>, C<drv_readonly_attrs>, +C<drv_version> and C<drv_meta> are added (when available) to the list of +valid and immutable attributes (where C<drv_> is interpreted as the driver +prefix). + +If C<drv_meta> is set, an attribute with the name in C<drv_meta> is +initialized providing restricted read/write access to the meta data of the +tables using C<DBD::File::TieTables> in the first (table) level and +C<DBD::File::TieMeta> for the meta attribute level. C<DBD::File::TieTables> +uses C<DBD::DRV::Table::get_table_meta> to initialize the second level +tied hash on FETCH/STORE. The C<DBD::File::TieMeta> class uses +C<DBD::DRV::Table::get_table_meta_attr> to FETCH attribute values and +C<DBD::DRV::Table::set_table_meta_attr> to STORE attribute values. This +allows it to map meta attributes for compatibility reasons. + +=item get_single_table_meta + +=item get_file_meta + +Retrieve an attribute from a table's meta information. The method +signature is C<< get_file_meta ($dbh, $table, $attr) >>. This method +is called by the injected db handle method C<< ${drv_prefix}get_meta +>>. + +While get_file_meta allows C<$table> or C<$attr> to be a list of tables or +attributes to retrieve, get_single_table_meta allows only one table name +and only one attribute name. A table name of C<'.'> (single dot) is +interpreted as the default table and this will retrieve the appropriate +attribute globally from the dbh. This has the same restrictions as +C<< $dbh->{$attrib} >>. + +get_file_meta allows C<'+'> and C<'*'> as wildcards for table names and +C<$table> being a regular expression matching against the table names +(evaluated without the default table). The table name C<'*'> is +I<all currently known tables, including the default one>. The table +name C<'+'> is I<all table names which conform to +ANSI file name restrictions> (/^[_A-Za-z0-9]+$/). + +The table meta information is retrieved using the get_table_meta and +get_table_meta_attr methods of the table class of the implementation. + +=item set_single_table_meta + +=item set_file_meta + +Sets an attribute in a table's meta information. The method signature is +C<< set_file_meta ($dbh, $table, $attr, $value) >>. This method is called +by the injected db handle method C<< ${drv_prefix}set_meta >>. + +While set_file_meta allows C<$table> to be a list of tables and C<$attr> +to be a hash of several attributes to set, set_single_table_meta allows +only one table name and only one attribute name/value pair. + +The wildcard characters for the table name are the same as for +get_file_meta. + +The table meta information is updated using the get_table_meta and +set_table_meta_attr methods of the table class of the implementation. + +=item clear_file_meta + +Clears all meta information cached about a table. The method signature is +C<< clear_file_meta ($dbh, $table) >>. This method is called +by the injected db handle method C<< ${drv_prefix}clear_meta >>. + +=back + +=head2 DBD::File::st + +Contains the methods to deal with prepared statement handles: + +=over 4 + +=item FETCH + +Fetches statement handle attributes. Supported attributes (for full overview +see L<DBI/Statement Handle Attributes>) are C<NAME>, C<TYPE>, C<PRECISION> +and C<NULLABLE> in case that SQL::Statement is used as SQL execution engine +and a statement is successful prepared. When SQL::Statement has additional +information about a table, those information are returned. Otherwise, the +same defaults as in L<DBI::DBD::SqlEngine> are used. + +This method usually requires extending in a derived implementation. +See L<DBD::CSV> or L<DBD::DBM> for some example. + +=back + +=head2 DBD::File::Statement + +Derives from DBI::SQL::Nano::Statement to provide following method: + +=over 4 + +=item open_table + +Implements the open_table method required by L<SQL::Statement> and +L<DBI::SQL::Nano>. All the work for opening the file(s) belonging to the +table is handled and parameterized in DBD::File::Table. Unless you intend +to add anything to the following implementation, an empty DBD::XXX::Statement +package satisfies DBD::File. + + sub open_table ($$$$$) + { + my ($self, $data, $table, $createMode, $lockMode) = @_; + + my $class = ref $self; + $class =~ s/::Statement/::Table/; + + my $flags = { + createMode => $createMode, + lockMode => $lockMode, + }; + $self->{command} eq "DROP" and $flags->{dropMode} = 1; + + return $class->new ($data, { table => $table }, $flags); + } # open_table + +=back + +=head2 DBD::File::Table + +Derives from DBI::SQL::Nano::Table and provides physical file access for +the table data which are stored in the files. + +=over 4 + +=item file2table + +This method tries to map a filename to the associated table +name. It is called with a partially filled meta structure for the +resulting table containing at least the following attributes: +C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>. + +If a file/table map can be found then this method sets the C<< f_fqfn +>>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in +the meta structure. If a map cannot be found the table name will be +undef. + +=item bootstrap_table_meta + +Initializes a table meta structure. Can be safely overridden in a +derived class, as long as the C<< SUPER >> method is called at the end +of the overridden method. + +It copies the following attributes from the database into the table meta data +C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >>, +C<< f_lockfile >> and C<< sql_identifier_case >> and makes them sticky to the +table. + +This method should be called before you attempt to map between file +name and table name to ensure the correct directory, extension etc. are +used. + +=item init_table_meta + +Initializes more attributes of the table meta data - usually more +expensive ones (e.g. those which require class instantiations) - when +the file name and the table name could mapped. + +=item get_table_meta + +Returns the table meta data. If there are none for the required +table, a new one is initialized. When it fails, nothing is +returned. On success, the name of the table and the meta data +structure is returned. + +=item get_table_meta_attr + +Returns a single attribute from the table meta data. If the attribute +name appears in C<%compat_map>, the attribute name is updated from +there. + +=item set_table_meta_attr + +Sets a single attribute in the table meta data. If the attribute +name appears in C<%compat_map>, the attribute name is updated from +there. + +=item table_meta_attr_changed + +Called when an attribute of the meta data is modified. + +If the modified attribute requires to reset a calculated attribute, the +calculated attribute is reset (deleted from meta data structure) and +the I<initialized> flag is removed, too. The decision is made based on +C<%register_reset_on_modify>. + +=item register_reset_on_modify + +Allows C<set_table_meta_attr> to reset meta attributes when special +attributes are modified. For DBD::File, modifying one of C<f_file>, C<f_dir>, +C<f_ext> or C<f_lockfile> will reset C<f_fqfn>. DBD::DBM extends the +list for C<dbm_type> and C<dbm_mldbm> to reset the value of C<dbm_tietype>. + +If your DBD has calculated values in the meta data area, then call +C<register_reset_on_modify>: + + my %reset_on_modify = ( "xxx_foo" => "xxx_bar" ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +=item register_compat_map + +Allows C<get_table_meta_attr> and C<set_table_meta_attr> to update the +attribute name to the current favored one: + + # from DBD::DBM + my %compat_map = ( "dbm_ext" => "f_ext" ); + __PACKAGE__->register_compat_map( \%compat_map ); + +=item open_file + +Called to open the table's data file. + +Depending on the attributes set in the table's meta data, the +following steps are performed. Unless C<< f_dontopen >> is set to a +true value, C<< f_fqfn >> must contain the full qualified file name +for the table to work on (file2table ensures this). The encoding in +C<< f_encoding >> is applied if set and the file is opened. If +C<<f_fqln >> (full qualified lock name) is set, this file is opened, +too. Depending on the value in C<< f_lock >>, the appropriate lock is +set on the opened data file or lock file. + +After this is done, a derived class might add more steps in an overridden +C<< open_file >> method. + +=item new + +Instantiates the table. This is done in 3 steps: + + 1. get the table meta data + 2. open the data file + 3. bless the table data structure using inherited constructor new + +It is not recommended to override the constructor of the table class. +Find a reasonable place to add you extensions in one of the above four +methods. + +=item drop + +Implements the abstract table method for the C<< DROP >> +command. Discards table meta data after all files belonging to the +table are closed and unlinked. + +Overriding this method might be reasonable in very rare cases. + +=item seek + +Implements the abstract table method used when accessing the table from the +engine. C<< seek >> is called every time the engine uses dumb algorithms +for iterating over the table content. + +=item truncate + +Implements the abstract table method used when dumb table algorithms +for C<< UPDATE >> or C<< DELETE >> need to truncate the table storage +after the last written row. + +=back + +You should consult the documentation of C<< SQL::Eval::Table >> (see +L<SQL::Eval>) to get more information about the abstract methods of the +table's base class you have to override and a description of the table +meta information expected by the SQL engines. + +=head1 AUTHOR + +The module DBD::File is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original author is Jochen Wiedmann. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=cut diff --git a/lib/DBD/File/HowTo.pod b/lib/DBD/File/HowTo.pod new file mode 100644 index 0000000..3d45257 --- /dev/null +++ b/lib/DBD/File/HowTo.pod @@ -0,0 +1,270 @@ +=head1 NAME + +DBD::File::HowTo - Guide to create DBD::File based driver + +=head1 SYNOPSIS + + perldoc DBD::File::HowTo + perldoc DBI + perldoc DBI::DBD + perldoc DBD::File::Developers + perldoc DBI::DBD::SqlEngine::Developers + perldoc DBI::DBD::SqlEngine + perldoc SQL::Eval + perldoc DBI::DBD::SqlEngine::HowTo + perldoc SQL::Statement::Embed + perldoc DBD::File + perldoc DBD::File::HowTo + perldoc DBD::File::Developers + +=head1 DESCRIPTION + +This document provides a step-by-step guide, how to create a new +C<DBD::File> based DBD. It expects that you carefully read the L<DBI> +documentation and that you're familiar with L<DBI::DBD> and had read and +understood L<DBD::ExampleP>. + +This document addresses experienced developers who are really sure that +they need to invest time when writing a new DBI Driver. Writing a DBI +Driver is neither a weekend project nor an easy job for hobby coders +after work. Expect one or two man-month of time for the first start. + +Those who are still reading, should be able to sing the rules of +L<DBI::DBD/CREATING A NEW DRIVER>. + +Of course, DBD::File is a DBI::DBD::SqlEngine and you surely read +L<DBI::DBD::SqlEngine::HowTo> before continuing here. + +=head1 CREATING DRIVER CLASSES + +Do you have an entry in DBI's DBD registry? For this guide, a prefix of +C<foo_> is assumed. + +=head2 Sample Skeleton + + package DBD::Foo; + + use strict; + use warnings; + use vars qw(@ISA $VERSION); + use base qw(DBD::File); + + use DBI (); + + $VERSION = "0.001"; + + package DBD::Foo::dr; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::dr); + $imp_data_size = 0; + + package DBD::Foo::db; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::db); + $imp_data_size = 0; + + package DBD::Foo::st; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::st); + $imp_data_size = 0; + + package DBD::Foo::Statement; + + use vars qw(@ISA); + + @ISA = qw(DBD::File::Statement); + + package DBD::Foo::Table; + + use vars qw(@ISA); + + @ISA = qw(DBD::File::Table); + + 1; + +Tiny, eh? And all you have now is a DBD named foo which will is able to +deal with temporary tables, as long as you use L<SQL::Statement>. In +L<DBI::SQL::Nano> environments, this DBD can do nothing. + +=head2 Start over + +Based on L<DBI::DBD::SqlEngine::HowTo>, we're now having a driver which +could do basic things. Of course, it should now derive from DBD::File +instead of DBI::DBD::SqlEngine, shouldn't it? + +DBD::File extends DBI::DBD::SqlEngine to deal with any kind of files. +In principle, the only extensions required are to the table class: + + package DBD::Foo::Table; + + sub bootstrap_table_meta + { + my ( $self, $dbh, $meta, $table ) = @_; + + # initialize all $meta attributes which might be relevant for + # file2table + + return $self->SUPER::bootstrap_table_meta($dbh, $meta, $table); + } + + sub init_table_meta + { + my ( $self, $dbh, $meta, $table ) = @_; + + # called after $meta contains the results from file2table + # initialize all missing $meta attributes + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); + } + +In case C<DBD::File::Table::open_file> doesn't open the files as the driver +needs that, override it! + + sub open_file + { + my ( $self, $meta, $attrs, $flags ) = @_; + # ensure that $meta->{f_dontopen} is set + $self->SUPER::open_file( $meta, $attrs, $flags ); + # now do what ever needs to be done + } + +Combined with the methods implemented using the L<SQL::Statement::Embed> +guide, the table is full working and you could try a start over. + +=head2 User comfort + +C<DBD::File> since C<0.39> consolidates all persistent meta data of a table +into a single structure stored in C<< $dbh->{f_meta} >>. While DBD::File +provides only readonly access to this structure, modifications are still +allowed. + +Primarily DBD::File provides access via setters C<get_file_meta>, +C<set_file_meta> and C<clear_file_meta>. Those methods are easily +accessible by the users via the C<< $dbh->func () >> interface provided +by DBI. Well, many users don't feel comfortize when calling + + # don't require extension for tables cars + $dbh->func ("cars", "f_ext", ".csv", "set_file_meta"); + +DBD::File will inject a method into your driver to increase the user +comfort to allow: + + # don't require extension for tables cars + $dbh->foo_set_meta ("cars", "f_ext", ".csv"); + +Better, but here and there users likes to do: + + # don't require extension for tables cars + $dbh->{foo_tables}->{cars}->{f_ext} = ".csv"; + +This interface is provided when derived DBD's define following in +C<init_valid_attributes> (please compare carefully with the example in +DBI::DBD::SqlEngine::HowTo): + + sub init_valid_attributes + { + my $dbh = $_[0]; + + $dbh->SUPER::init_valid_attributes (); + + $dbh->{foo_valid_attrs} = { + foo_version => 1, # contains version of this driver + foo_valid_attrs => 1, # contains the valid attributes of foo drivers + foo_readonly_attrs => 1, # contains immutable attributes of foo drivers + foo_bar => 1, # contains the bar attribute + foo_baz => 1, # contains the baz attribute + foo_manager => 1, # contains the manager of the driver instance + foo_manager_type => 1, # contains the manager class of the driver instance + foo_meta => 1, # contains the public interface to modify table meta attributes + }; + $dbh->{foo_readonly_attrs} = { + foo_version => 1, # ensure no-one modifies the driver version + foo_valid_attrs => 1, # do not permit to add more valid attributes ... + foo_readonly_attrs => 1, # ... or make the immutable mutable + foo_manager => 1, # manager is set internally only + foo_meta => 1, # ensure public interface to modify table meta attributes are immutable + }; + + $dbh->{foo_meta} = "foo_tables"; + + return $dbh; + } + +This provides a tied hash in C<< $dbh->{foo_tables} >> and a tied hash for +each table's meta data in C<< $dbh->{foo_tables}->{$table_name} >>. +Modifications on the table meta attributes are done using the table +methods: + + sub get_table_meta_attr { ... } + sub set_table_meta_attr { ... } + +Both methods can adjust the attribute name for compatibility reasons, e.g. +when former versions of the DBD allowed different names to be used for the +same flag: + + my %compat_map = ( + abc => 'foo_abc', + xyz => 'foo_xyz', + ); + __PACKAGE__->register_compat_map( \%compat_map ); + +If any user modification on a meta attribute needs reinitialization of +the meta structure (in case of C<DBD::File> these are the attributes +C<f_file>, C<f_dir>, C<f_ext> and C<f_lockfile>), inform DBD::File by +doing + + my %reset_on_modify = ( + foo_xyz => "foo_bar", + foo_abc => "foo_bar", + ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +The next access to the table meta data will force DBD::File to re-do the +entire meta initialization process. + +Any further action which needs to be taken can handled in +C<table_meta_attr_changed>: + + sub table_meta_attr_changed + { + my ($class, $meta, $attrib, $value) = @_; + ... + $class->SUPER::table_meta_attr_changed ($meta, $attrib, $value); + } + +This is done before the new value is set in C<$meta>, so the attribute +changed handler can act depending on the old value. + +=head2 Testing + +Now you should have your own DBD::File based driver. Was easy, wasn't it? +But does it work well? Prove it by writing tests and remember to use +dbd_edit_mm_attribs from L<DBI::DBD> to ensure testing even rare cases. + +=head1 AUTHOR + +This guide is written by Jens Rehsack. DBD::File is written by Jochen +Wiedmann and Jeff Zucker. + +The module DBD::File is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +All rights reserved. + +You may freely distribute and/or modify this module under the terms of +either the GNU General Public License (GPL) or the Artistic License, as +specified in the Perl README file. + +=cut diff --git a/lib/DBD/File/Roadmap.pod b/lib/DBD/File/Roadmap.pod new file mode 100644 index 0000000..804d759 --- /dev/null +++ b/lib/DBD/File/Roadmap.pod @@ -0,0 +1,176 @@ +=head1 NAME + +DBD::File::Roadmap - Planned Enhancements for DBD::File and pure Perl DBD's + +Jens Rehsack - May 2010 + +=head1 SYNOPSIS + +This document gives a high level overview of the future of the DBD::File DBI +driver and groundwork for pure Perl DBI drivers. + +The planned enhancements cover features, testing, performance, reliability, +extensibility and more. + +=head1 CHANGES AND ENHANCEMENTS + +=head2 Features + +There are some features missing we would like to add, but there is +no time plan: + +=over 4 + +=item LOCK TABLE + +The newly implemented internal common table meta storage area would allow +us to implement LOCK TABLE support based on file system C<flock ()> +support. + +=item Transaction support + +While DBD::AnyData recommends explicitly committing by importing and +exporting tables, DBD::File might be enhanced in a future version to allow +transparent transactions using the temporary tables of SQL::Statement as +shadow (dirty) tables. + +Transaction support will heavily rely on lock table support. + +=item Data Dictionary Persistence + +SQL::Statement provides dictionary information when a "CREATE TABLE ..." +statement is executed. This dictionary is preserved for some statement +handle attribute fetches (as C<NULLABLE> or C<PRECISION>). + +It is planned to extend DBD::File to support data dictionaries to work +on the tables in it. It is not planned to support one table in different +dictionaries, but you can have several dictionaries in one directory. + +=item SQL Engine selecting on connect + +Currently the SQL engine selected is chosen during the loading of the module +L<DBI::SQL::Nano>. Ideally end users should be able to select the engine +used in C<< DBI->connect () >> with a special DBD::File attribute. + +=back + +Other points of view to the planned features (and more features for the +SQL::Statement engine) are shown in L<SQL::Statement::Roadmap>. + +=head2 Testing + +DBD::File and the dependent DBD::DBM requires a lot more automated tests +covering API stability and compatibility with optional modules +like SQL::Statement. + +=head2 Performance + +Several arguments for support of features like indexes on columns +and cursors are made for DBD::CSV (which is a DBD::File based driver, +too). Similar arguments could be made for DBD::DBM, DBD::AnyData, +DBD::RAM or DBD::PO etc. + +To improve the performance of the underlying SQL engines, a clean +reimplementation seems to be required. Currently both engines are +prematurely optimized and therefore it is not trivial to provide +further optimization without the risk of breaking existing features. + +Join the DBI developers IRC channel at L<irc://irc.perl.org/dbi> to +participate or post to the DBI Developers Mailing List. + +=head2 Reliability + +DBD::File currently lacks the following points: + +=over 4 + +=item duplicate table names + +It is currently possible to access a table quoted with a relative path +(a) and additionally using an absolute path (b). If (a) and (b) are +the same file that is not recognized (except for +flock protection handled by the Operating System) and two independent +tables are handled. + +=item invalid table names + +The current implementation does not prevent someone choosing a +directory name as a physical file name for the table to open. + +=back + +=head2 Extensibility + +I (Jens Rehsack) have some (partially for example only) DBD's in mind: + +=over 4 + +=item DBD::Sys + +Derive DBD::Sys from a common code base shared with DBD::File which handles +all the emulation DBI needs (as getinfo, SQL engine handling, ...) + +=item DBD::Dir + +Provide a DBD::File derived to work with fixed table definitions through the +file system to demonstrate how DBI / Pure Perl DBDs could handle databases +with hierarchical structures. + +=item DBD::Join + +Provide a DBI driver which is able to manage multiple connections to other +Databases (as DBD::Multiplex), but allow them to point to different data +sources and allow joins between the tables of them: + + # Example + # Let table 'lsof' being a table in DBD::Sys giving a list of open files using lsof utility + # Let table 'dir' being a atable from DBD::Dir + $sth = $dbh->prepare( "select * from dir,lsof where path='/documents' and dir.entry = lsof.filename" ) + $sth->execute(); # gives all open files in '/documents' + ... + + # Let table 'filesys' a DBD::Sys table of known file systems on current host + # Let table 'applications' a table of your Configuration Management Database + # where current applications (relocatable, with mountpoints for filesystems) + # are stored + $sth = dbh->prepare( "select * from applications,filesys where " . + "application.mountpoint = filesys.mountpoint and ". + "filesys.mounted is true" ); + $sth->execute(); # gives all currently mounted applications on this host + +=back + +=head1 PRIORITIES + +Our priorities are focussed on current issues. Initially many new test +cases for DBD::File and DBD::DBM should be added to the DBI test +suite. After that some additional documentation on how to use the +DBD::File API will be provided. + +Any additional priorities will come later and can be modified by (paying) +users. + +=head1 RESOURCES AND CONTRIBUTIONS + +See L<http://dbi.perl.org/contributing> for I<how you can help>. + +If your company has benefited from DBI, please consider if +it could make a donation to The Perl Foundation "DBI Development" +fund at L<http://dbi.perl.org/donate> to secure future development. + +Alternatively, if your company would benefit from a specific new +DBI feature, please consider sponsoring it's development through +the options listed in the section "Commercial Support from the Author" +on L<http://dbi.perl.org/support/>. + +Using such targeted financing allows you to contribute to DBI +development and rapidly get something specific and directly valuable +to you in return. + +My company also offers annual support contracts for the DBI, which +provide another way to support the DBI and get something specific +in return. Contact me for details. + +Thank you. + +=cut diff --git a/lib/DBD/Gofer.pm b/lib/DBD/Gofer.pm new file mode 100644 index 0000000..afd8201 --- /dev/null +++ b/lib/DBD/Gofer.pm @@ -0,0 +1,1292 @@ +{ + package DBD::Gofer; + + use strict; + + require DBI; + require DBI::Gofer::Request; + require DBI::Gofer::Response; + require Carp; + + our $VERSION = sprintf("0.%06d", q$Revision: 15326 $ =~ /(\d+)/o); + +# $Id: Gofer.pm 15326 2012-06-06 16:32:38Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + + + # attributes we'll allow local STORE + our %xxh_local_store_attrib = map { $_=>1 } qw( + Active + CachedKids + Callbacks + DbTypeSubclass + ErrCount Executed + FetchHashKeyName + HandleError HandleSetErr + InactiveDestroy + AutoInactiveDestroy + PrintError PrintWarn + Profile + RaiseError + RootClass + ShowErrorStatement + Taint TaintIn TaintOut + TraceLevel + Warn + dbi_quote_identifier_cache + dbi_connect_closure + dbi_go_execute_unique + ); + our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw( + Username + dbi_connect_method + ); + + our $drh = undef; # holds driver handle once initialized + our $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBI->setup_driver('DBD::Gofer'); + + unless ($methods_already_installed++) { + my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR + DBD::Gofer::db->install_method('go_dbh_method', $opts); + DBD::Gofer::st->install_method('go_sth_method', $opts); + DBD::Gofer::st->install_method('go_clone_sth', $opts); + DBD::Gofer::db->install_method('go_cache', $opts); + DBD::Gofer::st->install_method('go_cache', $opts); + } + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Gofer', + 'Version' => $VERSION, + 'Attribution' => 'DBD Gofer by Tim Bunce', + }); + + $drh; + } + + + sub CLONE { + undef $drh; + } + + + sub go_cache { + my $h = shift; + $h->{go_cache} = shift if @_; + # return handle's override go_cache, if it has one + return $h->{go_cache} if defined $h->{go_cache}; + # or else the transports default go_cache + return $h->{go_transport}->{go_cache}; + } + + + sub set_err_from_response { # set error/warn/info and propagate warnings + my $h = shift; + my $response = shift; + if (my $warnings = $response->warnings) { + warn $_ for @$warnings; + } + my ($err, $errstr, $state) = $response->err_errstr_state; + # Only set_err() if there's an error else leave the current values + # (The current values will normally be set undef by the DBI dispatcher + # except for methods marked KEEPERR such as ping.) + $h->set_err($err, $errstr, $state) if defined $err; + return undef; + } + + + sub install_methods_proxy { + my ($installed_methods) = @_; + while ( my ($full_method, $attr) = each %$installed_methods ) { + # need to install both a DBI dispatch stub and a proxy stub + # (the dispatch stub may be already here due to local driver use) + + DBI->_install_method($full_method, "", $attr||{}) + unless defined &{$full_method}; + + # now install proxy stubs on the driver side + $full_method =~ m/^DBI::(\w\w)::(\w+)$/ + or die "Invalid method name '$full_method' for install_method"; + my ($type, $method) = ($1, $2); + my $driver_method = "DBD::Gofer::${type}::${method}"; + next if defined &{$driver_method}; + my $sub; + if ($type eq 'db') { + $sub = sub { return shift->go_dbh_method(undef, $method, @_) }; + } + else { + $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; }; + } + no strict 'refs'; + *$driver_method = $sub; + } + } +} + + +{ package DBD::Gofer::dr; # ====== DRIVER ====== + + $imp_data_size = 0; + use strict; + + sub connect_cached { + my ($drh, $dsn, $user, $auth, $attr)= @_; + $attr ||= {}; + return $drh->SUPER::connect_cached($dsn, $user, $auth, { + (%$attr), + go_connect_method => $attr->{go_connect_method} || 'connect_cached', + }); + } + + + sub connect { + my($drh, $dsn, $user, $auth, $attr)= @_; + my $orig_dsn = $dsn; + + # first remove dsn= and everything after it + my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1) + or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'"); + + if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection + # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t + return DBI->connect($remote_dsn, $user, $auth, $attr); + } + + my %go_attr; + # extract any go_ attributes from the connect() attr arg + for my $k (grep { /^go_/ } keys %$attr) { + $go_attr{$k} = delete $attr->{$k}; + } + # then override those with any attributes embedded in our dsn (not remote_dsn) + for my $kv (grep /=/, split /;/, $dsn, -1) { + my ($k, $v) = split /=/, $kv, 2; + $go_attr{ "go_$k" } = $v; + } + + if (not ref $go_attr{go_policy}) { # if not a policy object already + my $policy_class = $go_attr{go_policy} || 'classic'; + $policy_class = "DBD::Gofer::Policy::$policy_class" + unless $policy_class =~ /::/; + _load_class($policy_class) + or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@"); + # replace policy name in %go_attr with policy object + $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@"); + } + # policy object is left in $go_attr{go_policy} so transport can see it + my $go_policy = $go_attr{go_policy}; + + if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already + my $cache_class = $go_attr{go_cache}; + $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1'; + _load_class($cache_class) + or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@"); + $go_attr{go_cache} = eval { $cache_class->new() } + or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning + } + + # delete any other attributes that don't apply to transport + my $go_connect_method = delete $go_attr{go_connect_method}; + + my $transport_class = delete $go_attr{go_transport} + or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'"); + $transport_class = "DBD::Gofer::Transport::$transport_class" + unless $transport_class =~ /::/; + _load_class($transport_class) + or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@"); + my $go_transport = eval { $transport_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@"); + + my $request_class = "DBI::Gofer::Request"; + my $go_request = eval { + my $go_attr = { %$attr }; + # XXX user/pass of fwd server vs db server ? also impact of autoproxy + if ($user) { + $go_attr->{Username} = $user; + $go_attr->{Password} = $auth; + } + # delete any attributes we can't serialize (or don't want to) + delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)}; + # delete any attributes that should only apply to the client-side + delete @{$go_attr}{qw(RootClass DbTypeSubclass)}; + + $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect'; + $request_class->new({ + dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ], + }) + } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@"); + + my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + 'USER' => $user, + go_transport => $go_transport, + go_request => $go_request, + go_policy => $go_policy, + }); + + # mark as inactive temporarily for STORE. Active not set until connected() called. + $dbh->STORE(Active => 0); + + # should we ping to check the connection + # and fetch dbh attributes + my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh); + if (not $skip_connect_check) { + if (not $dbh->go_dbh_method(undef, 'ping')) { + return undef if $dbh->err; # error already recorded, typically + return $dbh->set_err($DBI::stderr, "ping failed"); + } + } + + return $dbh; + } + + sub _load_class { # return true or false+$@ + my $class = shift; + (my $pm = $class) =~ s{::}{/}g; + $pm .= ".pm"; + return 1 if eval { require $pm }; + delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough + undef; # error in $@ + } + +} + + +{ package DBD::Gofer::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + use Carp qw(carp croak); + + my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib; + + sub connected { + shift->STORE(Active => 1); + } + + sub go_dbh_method { + my $dbh = shift; + my $meta = shift; + # @_ now contains ($method_name, @args) + + my $request = $dbh->{go_request}; + $request->init_request([ wantarray, @_ ], $dbh); + ++$dbh->{go_request_count}; + + my $go_policy = $dbh->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $transport = $dbh->{go_transport} + or return $dbh->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $dbh->{go_cache} + if defined $dbh->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $dbh->{go_response} = $response + or die "No response object returned by $transport"; + + die "response '$response' returned by $transport is not a response object" + unless UNIVERSAL::isa($response,"DBI::Gofer::Response"); + + if (my $dbh_attributes = $response->dbh_attributes) { + + # XXX installed_methods piggybacks on dbh_attributes for now + if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) { + DBD::Gofer::install_methods_proxy($installed_methods) + if $dbh->{go_request_count}==1; + } + + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + } + + my $rv = $response->rv; + if (my $resultset_list = $response->sth_resultsets) { + # dbh method call returned one or more resultsets + # (was probably a metadata method like table_info) + # + # setup an sth but don't execute/forward it + my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 }); + # set the sth response to our dbh response + (tied %$sth)->{go_response} = $response; + # setup the sth with the results in our response + $sth->more_results; + # and return that new sth as if it came from original request + $rv = [ $sth ]; + } + elsif (!$rv) { # should only occur for major transport-level error + #carp("no rv in response { @{[ %$response ]} }"); + $rv = [ ]; + } + + DBD::Gofer::set_err_from_response($dbh, $response); + + return (wantarray) ? @$rv : $rv->[0]; + } + + + # Methods that should be forwarded but can be cached + for my $method (qw( + tables table_info column_info primary_key_info foreign_key_info statistics_info + data_sources type_info_all get_info + parse_trace_flags parse_trace_flag + func + )) { + my $policy_name = "cache_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + my $rv; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + my $cache; + my $cache_key; + if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) { + $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache + $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0, + join(",\t", map { # XXX basic but sufficient for now + !ref($_) ? DBI::neat($_,1e6) + : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001") + : ref($_) eq 'HASH' ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") } + : do { warn "unhandled argument type ($_)"; $_ } + } @_); + if ($rv = $cache->{$cache_key}) { + $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + return (wantarray) ? @cache_rv : $cache_rv[0]; + } + } + + $rv = [ (wantarray) + ? ($dbh->go_dbh_method(undef, $method, @_)) + : scalar $dbh->go_dbh_method(undef, $method, @_) + ]; + + if ($cache) { + $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + #$cache_rv[0] = $cache_rv[0]->go_clone_sth + # if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + $cache->{$cache_key} = \@cache_rv + unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done + } + + return (wantarray) ? @$rv : $rv->[0]; + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that can use the DBI defaults for some situations/drivers + for my $method (qw( + quote quote_identifier + )) { # XXX keep DBD::Gofer::Policy::Base in sync + my $policy_name = "locally_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + # false: use remote gofer + # 1: use local DBI default method + # code ref: use the code ref + my $locally = $dbh->{go_policy}->$policy_name($dbh, @_); + if ($locally) { + return $locally->($dbh, @_) if ref $locally eq 'CODE'; + return $dbh->$super_name(@_); + } + return $dbh->go_dbh_method(undef, $method, @_); # propagate context + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that should always fail + for my $method (qw( + begin_work commit rollback + )) { + no strict 'refs'; + *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") } + } + + + sub do { + my ($dbh, $sql, $attr, @args) = @_; + delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted" + $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement + my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} }; + return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args); + } + + sub ping { + my $dbh = shift; + return $dbh->set_err(0, "can't ping while not connected") # warning + unless $dbh->SUPER::FETCH('Active'); + my $skip_ping = $dbh->{go_policy}->skip_ping(); + return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_); + } + + sub last_insert_id { + my $dbh = shift; + my $response = $dbh->{go_response} or return undef; + return $response->last_insert_id; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + + # FETCH is effectively already cached because the DBI checks the + # attribute cache in the handle before calling FETCH + # and this FETCH copies the value into the attribute cache + + # forward driver-private attributes (except ours) + if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) { + my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib); + $dbh->{$attrib} = $value; # XXX forces caching by DBI + return $dbh->{$attrib} = $value; + } + + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + if ($attrib eq 'AutoCommit') { + croak "Can't enable transactions when using DBD::Gofer" if !$value; + return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900); + } + return $dbh->SUPER::STORE($attrib => $value) + # we handle this attribute locally + if $dbh_local_store_attrib{$attrib} + # or it's a private_ (application) attribute + or $attrib =~ /^private_/ + # or not yet connected (ie being called by DBI->connect) + or not $dbh->FETCH('Active'); + + return $dbh->SUPER::STORE($attrib => $value) + if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib} + && do { # values are the same + my $crnt = $dbh->FETCH($attrib); + local $^W; + (defined($value) ^ defined($crnt)) + ? 0 # definedness differs + : $value eq $crnt; + }; + + # dbh attributes are set at connect-time - see connect() + carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn'); + return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer"); + } + + sub disconnect { + my $dbh = shift; + $dbh->{go_transport} = undef; + $dbh->STORE(Active => 0); + } + + sub prepare { + my ($dbh, $statement, $attr)= @_; + + return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected") + unless $dbh->FETCH('Active'); + + $attr = { %$attr } if $attr; # copy so we can edit + + my $policy = delete($attr->{go_policy}) || $dbh->{go_policy}; + my $lii_args = delete $attr->{go_last_insert_id_args}; + my $go_prepare = delete($attr->{go_prepare_method}) + || $dbh->{go_prepare_method} + || $policy->prepare_method($dbh, $statement, $attr) + || 'prepare'; # e.g. for code not using placeholders + my $go_cache = delete $attr->{go_cache}; + # set to undef if there are no attributes left for the actual prepare call + $attr = undef if $attr and not %$attr; + + my ($sth, $sth_inner) = DBI::_new_sth($dbh, { + Statement => $statement, + go_prepare_call => [ 0, $go_prepare, $statement, $attr ], + # go_method_calls => [], # autovivs if needed + go_request => $dbh->{go_request}, + go_transport => $dbh->{go_transport}, + go_policy => $policy, + go_last_insert_id_args => $lii_args, + go_cache => $go_cache, + }); + $sth->STORE(Active => 0); + + my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth); + if (not $skip_prepare_check) { + $sth->go_sth_method() or return undef; + } + + return $sth; + } + + sub prepare_cached { + my ($dbh, $sql, $attr, $if_active)= @_; + $attr ||= {}; + return $dbh->SUPER::prepare_cached($sql, { + %$attr, + go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached', + }, $if_active); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + + +{ package DBD::Gofer::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1); + + sub go_sth_method { + my ($sth, $meta) = @_; + + if (my $ParamValues = $sth->{ParamValues}) { + my $ParamAttr = $sth->{ParamAttr}; + # XXX the sort here is a hack to work around a DBD::Sybase bug + # but only works properly for params 1..9 + # (reverse because of the unshift) + my @params = reverse sort keys %$ParamValues; + if (@params > 9 && ($sth->{Database}{go_dsn}||'') =~ /dbi:Sybase/) { + # if more than 9 then we need to do a proper numeric sort + # also warn to alert user of this issue + warn "Sybase param binding order hack in use"; + @params = sort { $b <=> $a } @params; + } + for my $p (@params) { + # unshift to put binds before execute call + unshift @{ $sth->{go_method_calls} }, + [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ]; + } + } + + my $dbh = $sth->{Database} or die "panic"; + ++$dbh->{go_request_count}; + + my $request = $sth->{go_request}; + $request->init_request($sth->{go_prepare_call}, $sth); + $request->sth_method_calls(delete $sth->{go_method_calls}) + if $sth->{go_method_calls}; + $request->sth_result_attr({}); # (currently) also indicates this is an sth request + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $go_policy = $sth->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + my $transport = $sth->{go_transport} + or return $sth->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $sth->{go_cache} + if defined $sth->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $sth->{go_response} = $response + or die "No response object returned by $transport"; + $dbh->{go_response} = $response; # mainly for last_insert_id + + if (my $dbh_attributes = $response->dbh_attributes) { + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + # record the values returned, so we know that we have fetched + # values are which we have fetched (see dbh->FETCH method) + $dbh->{go_dbh_attributes_fetched} = $dbh_attributes; + } + + my $rv = $response->rv; # may be undef on error + if ($response->sth_resultsets) { + # setup first resultset - including sth attributes + $sth->more_results; + } + else { + $sth->STORE(Active => 0); + $sth->{go_rows} = $rv; + } + # set error/warn/info (after more_results as that'll clear err) + DBD::Gofer::set_err_from_response($sth, $response); + + return $rv; + } + + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute' ]; + my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args} }; + return $sth->go_sth_method($meta); + } + + + sub more_results { + my $sth = shift; + + $sth->finish; + + my $response = $sth->{go_response} or do { + # e.g., we haven't sent a request yet (ie prepare then more_results) + $sth->trace_msg(" No response object present", 3); + return; + }; + + my $resultset_list = $response->sth_resultsets + or return $sth->set_err($DBI::stderr, "No sth_resultsets"); + + my $meta = shift @$resultset_list + or return undef; # no more result sets + #warn "more_results: ".Data::Dumper::Dumper($meta); + + # pull out the special non-atributes first + my ($rowset, $err, $errstr, $state) + = delete @{$meta}{qw(rowset err errstr state)}; + + # copy meta attributes into attribute cache + my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS}; + $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS); + # XXX need to use STORE for some? + $sth->{$_} = $meta->{$_} for keys %$meta; + + if (($NUM_OF_FIELDS||0) > 0) { + $sth->{go_rows} = ($rowset) ? @$rowset : -1; + $sth->{go_current_rowset} = $rowset; + $sth->{go_current_rowset_err} = [ $err, $errstr, $state ] + if defined $err; + $sth->STORE(Active => 1) if $rowset; + } + + return $sth; + } + + + sub go_clone_sth { + my ($sth1) = @_; + # clone an (un-fetched-from) sth - effectively undoes the initial more_results + # not 100% so just for use in caching returned sth e.g. table_info + my $sth2 = $sth1->{Database}->prepare($sth1->{Statement}, { go_skip_prepare_check => 1 }); + $sth2->STORE($_, $sth1->{$_}) for qw(NUM_OF_FIELDS Active); + my $sth2_inner = tied %$sth2; + $sth2_inner->{$_} = $sth1->{$_} for qw(NUM_OF_PARAMS FetchHashKeyName); + die "not fully implemented yet"; + return $sth2; + } + + + sub fetchrow_arrayref { + my ($sth) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + return $sth->_set_fbav(shift @$resultset) if @$resultset; + $sth->finish; # no more data so finish + return undef; + } + *fetch = \&fetchrow_arrayref; # alias + + + sub fetchall_arrayref { + my ($sth, $slice, $max_rows) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + my $mode = ref($slice) || 'ARRAY'; + return $sth->SUPER::fetchall_arrayref($slice, $max_rows) + if ref($slice) or defined $max_rows; + $sth->finish; # no more data after this so finish + return $resultset; + } + + + sub rows { + return shift->{go_rows}; + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + + return $sth->SUPER::STORE($attrib => $value) + if $sth_local_store_attrib{$attrib} # handle locally + # or it's a private_ (application) attribute + or $attrib =~ /^private_/; + + # otherwise warn but do it anyway + # this will probably need refining later + my $msg = "Altering \$sth->{$attrib} won't affect proxied handle"; + Carp::carp($msg) if $sth->FETCH('Warn'); + + # XXX could perhaps do + # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ] + # if not $sth->FETCH('Executed'); + # but how to handle repeat executions? How to we know when an + # attribute is being set to affect the current resultset or the + # next execution? + # Could just always use go_method_calls I guess. + + # do the store locally anyway, just in case + $sth->SUPER::STORE($attrib => $value); + + return $sth->set_err($DBI::stderr, $msg); + } + + # sub bind_param_array + # we use DBI's default, which sets $sth->{ParamArrays}{$param} = $value + # and calls bind_param($param, undef, $attr) if $attr. + + sub execute_array { + my $sth = shift; + my $attr = shift; + $sth->bind_param_array($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute_array', $attr ]; + return $sth->go_sth_method($attr); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer - A stateless-proxy driver for communicating with a remote DBI + +=head1 SYNOPSIS + + use DBI; + + $original_dsn = "dbi:..."; # your original DBI Data Source Name + + $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$original_dsn", + $user, $passwd, \%attributes); + + ... use $dbh as if it was connected to $original_dsn ... + + +The C<transport=$transport> part specifies the name of the module to use to +transport the requests to the remote DBI. If $transport doesn't contain any +double colons then it's prefixed with C<DBD::Gofer::Transport::>. + +The C<dsn=$original_dsn> part I<must be the last element> of the DSN because +everything after C<dsn=> is assumed to be the DSN that the remote DBI should +use. + +The C<...> represents attributes that influence the operation of the Gofer +driver or transport. These are described below or in the documentation of the +transport module being used. + +=encoding ISO8859-1 + +=head1 DESCRIPTION + +DBD::Gofer is a DBI database driver that forwards requests to another DBI +driver, usually in a separate process, often on a separate machine. It tries to +be as transparent as possible so it appears that you are using the remote +driver directly. + +DBD::Gofer is very similar to DBD::Proxy. The major difference is that with +DBD::Gofer no state is maintained on the remote end. That means every +request contains all the information needed to create the required state. (So, +for example, every request includes the DSN to connect to.) Each request can be +sent to any available server. The server executes the request and returns a +single response that includes all the data. + +This is very similar to the way http works as a stateless protocol for the web. +Each request from your web browser can be handled by a different web server process. + +=head2 Use Cases + +This may seem like pointless overhead but there are situations where this is a +very good thing. Let's consider a specific case. + +Imagine using DBD::Gofer with an http transport. Your application calls +connect(), prepare("select * from table where foo=?"), bind_param(), and execute(). +At this point DBD::Gofer builds a request containing all the information +about the method calls. It then uses the httpd transport to send that request +to an apache web server. + +This 'dbi execute' web server executes the request (using DBI::Gofer::Execute +and related modules) and builds a response that contains all the rows of data, +if the statement returned any, along with all the attributes that describe the +results, such as $sth->{NAME}. This response is sent back to DBD::Gofer which +unpacks it and presents it to the application as if it had executed the +statement itself. + +=head2 Advantages + +Okay, but you still don't see the point? Well let's consider what we've gained: + +=head3 Connection Pooling and Throttling + +The 'dbi execute' web server leverages all the functionality of web +infrastructure in terms of load balancing, high-availability, firewalls, access +management, proxying, caching. + +At its most basic level you get a configurable pool of persistent database connections. + +=head3 Simple Scaling + +Got thousands of processes all trying to connect to the database? You can use +DBD::Gofer to connect them to your smaller pool of 'dbi execute' web servers instead. + +=head3 Caching + +Client-side caching is as simple as adding "C<cache=1>" to the DSN. +This feature alone can be worth using DBD::Gofer for. + +=head3 Fewer Network Round-trips + +DBD::Gofer sends as few requests as possible (dependent on the policy being used). + +=head3 Thin Clients / Unsupported Platforms + +You no longer need drivers for your database on every system. DBD::Gofer is pure perl. + +=head1 CONSTRAINTS + +There are some natural constraints imposed by the DBD::Gofer 'stateless' approach. +But not many: + +=head2 You can't change database handle attributes after connect() + +You can't change database handle attributes after you've connected. +Use the connect() call to specify all the attribute settings you want. + +This is because it's critical that when a request is complete the database +handle is left in the same state it was when first connected. + +An exception is made for attributes with names starting "C<private_>": +They can be set after connect() but the change is only applied locally. + +=head2 You can't change statement handle attributes after prepare() + +You can't change statement handle attributes after prepare. + +An exception is made for attributes with names starting "C<private_>": +They can be set after prepare() but the change is only applied locally. + +=head2 You can't use transactions + +AutoCommit only. Transactions aren't supported. + +(In theory transactions could be supported when using a transport that +maintains a connection, like C<stream> does. If you're interested in this +please get in touch via dbi-dev@perl.org) + +=head2 You can't call driver-private sth methods + +But that's rarely needed anyway. + +=head1 GENERAL CAVEATS + +A few important things to keep in mind when using DBD::Gofer: + +=head2 Temporary tables, locks, and other per-connection persistent state + +You shouldn't expect any per-session state to persist between requests. +This includes locks and temporary tables. + +Because the server-side may execute your requests via a different +database connections, you can't rely on any per-connection persistent state, +such as temporary tables, being available from one request to the next. + +This is an easy trap to fall into. A good way to check for this is to test your +code with a Gofer policy package that sets the C<connect_method> policy to +'connect' to force a new connection for each request. The C<pedantic> policy does this. + +=head2 Driver-private Database Handle Attributes + +Some driver-private dbh attributes may not be available if the driver has not +implemented the private_attribute_info() method (added in DBI 1.54). + +=head2 Driver-private Statement Handle Attributes + +Driver-private sth attributes can be set in the prepare() call. TODO + +Some driver-private sth attributes may not be available if the driver has not +implemented the private_attribute_info() method (added in DBI 1.54). + +=head2 Multiple Resultsets + +Multiple resultsets are supported only if the driver supports the more_results() method +(an exception is made for DBD::Sybase). + +=head2 Statement activity that also updates dbh attributes + +Some drivers may update one or more dbh attributes after performing activity on +a child sth. For example, DBD::mysql provides $dbh->{mysql_insertid} in addition to +$sth->{mysql_insertid}. Currently mysql_insertid is supported via a hack but a +more general mechanism is needed for other drivers to use. + +=head2 Methods that report an error always return undef + +With DBD::Gofer, a method that sets an error always return an undef or empty list. +That shouldn't be a problem in practice because the DBI doesn't define any +methods that return meaningful values while also reporting an error. + +=head2 Subclassing only applies to client-side + +The RootClass and DbTypeSubclass attributes are not passed to the Gofer server. + +=head1 CAVEATS FOR SPECIFIC METHODS + +=head2 last_insert_id + +To enable use of last_insert_id you need to indicate to DBD::Gofer that you'd +like to use it. You do that my adding a C<go_last_insert_id_args> attribute to +the do() or prepare() method calls. For example: + + $dbh->do($sql, { go_last_insert_id_args => [...] }); + +or + + $sth = $dbh->prepare($sql, { go_last_insert_id_args => [...] }); + +The array reference should contains the args that you want passed to the +last_insert_id() method. + +=head2 execute_for_fetch + +The array methods bind_param_array() and execute_array() are supported. +When execute_array() is called the data is serialized and executed in a single +round-trip to the Gofer server. This makes it very fast, but requires enough +memory to store all the serialized data. + +The execute_for_fetch() method currently isn't optimised, it uses the DBI +fallback behaviour of executing each tuple individually. +(It could be implemented as a wrapper for execute_array() - patches welcome.) + +=head1 TRANSPORTS + +DBD::Gofer doesn't concern itself with transporting requests and responses to and fro. +For that it uses special Gofer transport modules. + +Gofer transport modules usually come in pairs: one for the 'client' DBD::Gofer +driver to use and one for the remote 'server' end. They have very similar names: + + DBD::Gofer::Transport::<foo> + DBI::Gofer::Transport::<foo> + +Sometimes the transports on the DBD and DBI sides may have different names. For +example DBD::Gofer::Transport::http is typically used with DBI::Gofer::Transport::mod_perl +(DBD::Gofer::Transport::http and DBI::Gofer::Transport::mod_perl modules are +part of the GoferTransport-http distribution). + +=head2 Bundled Transports + +Several transport modules are provided with DBD::Gofer: + +=head3 null + +The null transport is the simplest of them all. It doesn't actually transport the request anywhere. +It just serializes (freezes) the request into a string, then thaws it back into +a data structure before passing it to DBI::Gofer::Execute to execute. The same +freeze and thaw is applied to the results. + +The null transport is the best way to test if your application will work with Gofer. +Just set the DBI_AUTOPROXY environment variable to "C<dbi:Gofer:transport=null;policy=pedantic>" +(see L</Using DBI_AUTOPROXY> below) and run your application, or ideally its test suite, as usual. + +It doesn't take any parameters. + +=head3 pipeone + +The pipeone transport launches a subprocess for each request. It passes in the +request and reads the response. + +The fact that a new subprocess is started for each request ensures that the +server side is truly stateless. While this does make the transport I<very> slow, +it is useful as a way to test that your application doesn't depend on +per-connection state, such as temporary tables, persisting between requests. + +It's also useful both as a proof of concept and as a base class for the stream +driver. + +=head3 stream + +The stream driver also launches a subprocess and writes requests and reads +responses, like the pipeone transport. In this case, however, the subprocess +is expected to handle more that one request. (Though it will be automatically +restarted if it exits.) + +This is the first transport that is truly useful because it can launch the +subprocess on a remote machine using C<ssh>. This means you can now use DBD::Gofer +to easily access any databases that's accessible from any system you can login to. +You also get all the benefits of ssh, including encryption and optional compression. + +See L</Using DBI_AUTOPROXY> below for an example. + +=head2 Other Transports + +Implementing a Gofer transport is I<very> simple, and more transports are very welcome. +Just take a look at any existing transports that are similar to your needs. + +=head3 http + +See the GoferTransport-http distribution on CPAN: http://search.cpan.org/dist/GoferTransport-http/ + +=head3 Gearman + +I know Ask Bjørn Hansen has implemented a transport for the C<gearman> distributed +job system, though it's not on CPAN at the time of writing this. + +=head1 CONNECTING + +Simply prefix your existing DSN with "C<dbi:Gofer:transport=$transport;dsn=>" +where $transport is the name of the Gofer transport you want to use (see L</TRANSPORTS>). +The C<transport> and C<dsn> attributes must be specified and the C<dsn> attributes must be last. + +Other attributes can be specified in the DSN to configure DBD::Gofer and/or the +Gofer transport module being used. The main attributes after C<transport>, are +C<url> and C<policy>. These and other attributes are described below. + +=head2 Using DBI_AUTOPROXY + +The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment variable. +In this case you don't include the C<dsn=> part. For example: + + export DBI_AUTOPROXY="dbi:Gofer:transport=null" + +or, for a more useful example, try: + + export DBI_AUTOPROXY="dbi:Gofer:transport=stream;url=ssh:user@example.com" + +=head2 Connection Attributes + +These attributes can be specified in the DSN. They can also be passed in the +\%attr parameter of the DBI connect method by adding a "C<go_>" prefix to the name. + +=head3 transport + +Specifies the Gofer transport class to use. Required. See L</TRANSPORTS> above. + +If the value does not include C<::> then "C<DBD::Gofer::Transport::>" is prefixed. + +The transport object can be accessed via $h->{go_transport}. + +=head3 dsn + +Specifies the DSN for the remote side to connect to. Required, and must be last. + +=head3 url + +Used to tell the transport where to connect to. The exact form of the value depends on the transport used. + +=head3 policy + +Specifies the policy to use. See L</CONFIGURING BEHAVIOUR POLICY>. + +If the value does not include C<::> then "C<DBD::Gofer::Policy>" is prefixed. + +The policy object can be accessed via $h->{go_policy}. + +=head3 timeout + +Specifies a timeout, in seconds, to use when waiting for responses from the server side. + +=head3 retry_limit + +Specifies the number of times a failed request will be retried. Default is 0. + +=head3 retry_hook + +Specifies a code reference to be called to decide if a failed request should be retried. +The code reference is called like this: + + $transport = $h->{go_transport}; + $retry = $transport->go_retry_hook->($request, $response, $transport); + +If it returns true then the request will be retried, upto the C<retry_limit>. +If it returns a false but defined value then the request will not be retried. +If it returns undef then the default behaviour will be used, as if C<retry_hook> +had not been specified. + +The default behaviour is to retry requests where $request->is_idempotent is true, +or the error message matches C</induced by DBI_GOFER_RANDOM/>. + +=head3 cache + +Specifies that client-side caching should be performed. The value is the name +of a cache class to use. + +Any class implementing get($key) and set($key, $value) methods can be used. +That includes a great many powerful caching classes on CPAN, including the +Cache and Cache::Cache distributions. + +You can use "C<cache=1>" is a shortcut for "C<cache=DBI::Util::CacheMemory>". +See L<DBI::Util::CacheMemory> for a description of this simple fast default cache. + +The cache object can be accessed via $h->go_cache. For example: + + $dbh->go_cache->clear; # free up memory being used by the cache + +The cache keys are the frozen (serialized) requests, and the values are the +frozen responses. + +The default behaviour is to only use the cache for requests where +$request->is_idempotent is true (i.e., the dbh has the ReadOnly attribute set +or the SQL statement is obviously a SELECT without a FOR UPDATE clause.) + +For even more control you can use the C<go_cache> attribute to pass in an +instantiated cache object. Individual methods, including prepare(), can also +specify alternative caches via the C<go_cache> attribute. For example, to +specify no caching for a particular query, you could use + + $sth = $dbh->prepare( $sql, { go_cache => 0 } ); + +This can be used to implement different caching policies for different statements. + +It's interesting to note that DBD::Gofer can be used to add client-side caching +to any (gofer compatible) application, with no code changes and no need for a +gofer server. Just set the DBI_AUTOPROXY environment variable like this: + + DBI_AUTOPROXY='dbi:Gofer:transport=null;cache=1' + +=head1 CONFIGURING BEHAVIOUR POLICY + +DBD::Gofer supports a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. +The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. + +The L<DBD::Gofer::Policy::Base> class is the base class for all the policy +packages and describes all the available policies. + +Three policy packages are supplied with DBD::Gofer: + +L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it +makes more round-trips to the Gofer server. + +L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy. + +L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications. + +Generally the default C<classic> policy is fine. When first testing an existing +application with Gofer it is a good idea to start with the C<pedantic> policy +first and then switch to C<classic> or a custom policy, for final testing. + + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 ACKNOWLEDGEMENTS + +The development of DBD::Gofer and related modules was sponsored by +Shopzilla.com (L<http://Shopzilla.com>), where I currently work. + +=head1 SEE ALSO + +L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>. + +L<DBI::Gofer::Transport::Base>, L<DBD::Gofer::Policy::Base>. + +L<DBI> + +=head1 Caveats for specific drivers + +This section aims to record issues to be aware of when using Gofer with specific drivers. +It usually only documents issues that are not natural consequences of the limitations +of the Gofer approach - as documented above. + +=head1 TODO + +This is just a random brain dump... (There's more in the source of the Changes file, not the pod) + +Document policy mechanism + +Add mechanism for transports to list config params and for Gofer to apply any that match (and warn if any left over?) + +Driver-private sth attributes - set via prepare() - change DBI spec + +add hooks into transport base class for checking & updating a result set cache + ie via a standard cache interface such as: + http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm + http://search.cpan.org/~bradfitz/Cache-Memcached/lib/Cache/Memcached.pm + http://search.cpan.org/~dclinton/Cache-Cache/ + http://search.cpan.org/~cleishman/Cache/ +Also caching instructions could be passed through the httpd transport layer +in such a way that appropriate http cache headers are added to the results +so that web caches (squid etc) could be used to implement the caching. +(MUST require the use of GET rather than POST requests.) + +Rework handling of installed_methods to not piggyback on dbh_attributes? + +Perhaps support transactions for transports where it's possible (ie null and stream)? +Would make stream transport (ie ssh) more useful to more people. + +Make sth_result_attr more like dbh_attributes (using '*' etc) + +Add @val = FETCH_many(@names) to DBI in C and use in Gofer/Execute? + +Implement _new_sth in C. + +=cut diff --git a/lib/DBD/Gofer/Policy/Base.pm b/lib/DBD/Gofer/Policy/Base.pm new file mode 100644 index 0000000..1725b03 --- /dev/null +++ b/lib/DBD/Gofer/Policy/Base.pm @@ -0,0 +1,162 @@ +package DBD::Gofer::Policy::Base; + +# $Id: Base.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; +use Carp; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); +our $AUTOLOAD; + +my %policy_defaults = ( + # force connect method (unless overridden by go_connect_method=>'...' attribute) + # if false: call same method on client as on server + connect_method => 'connect', + # force prepare method (unless overridden by go_prepare_method=>'...' attribute) + # if false: call same method on client as on server + prepare_method => 'prepare', + skip_connect_check => 0, + skip_default_methods => 0, + skip_prepare_check => 0, + skip_ping => 0, + dbh_attribute_update => 'every', + dbh_attribute_list => ['*'], + locally_quote => 0, + locally_quote_identifier => 0, + cache_parse_trace_flags => 1, + cache_parse_trace_flag => 1, + cache_data_sources => 1, + cache_type_info_all => 1, + cache_tables => 0, + cache_table_info => 0, + cache_column_info => 0, + cache_primary_key_info => 0, + cache_foreign_key_info => 0, + cache_statistics_info => 0, + cache_get_info => 0, + cache_func => 0, +); + +my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; + +__PACKAGE__->create_policy_subs(\%policy_defaults); + +sub create_policy_subs { + my ($class, $policy_defaults) = @_; + + while ( my ($policy_name, $policy_default) = each %$policy_defaults) { + my $policy_attr_name = "go_$policy_name"; + my $sub = sub { + # $policy->foo($attr, ...) + #carp "$policy_name($_[1],...)"; + # return the policy default value unless an attribute overrides it + return (ref $_[1] && exists $_[1]->{$policy_attr_name}) + ? $_[1]->{$policy_attr_name} + : $policy_default; + }; + no strict 'refs'; + *{$class . '::' . $policy_name} = $sub; + } +} + +sub AUTOLOAD { + carp "Unknown policy name $AUTOLOAD used"; + # only warn once + no strict 'refs'; + *$AUTOLOAD = sub { undef }; + return undef; +} + +sub new { + my ($class, $args) = @_; + my $policy = {}; + bless $policy, $class; +} + +sub DESTROY { }; + +1; + +=head1 NAME + +DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...) + +=head1 DESCRIPTION + +DBD::Gofer can be configured via a 'policy' mechanism that allows you to +fine-tune the number of round-trips to the Gofer server. The policies are +grouped into classes (which may be subclassed) and referenced by the name of +the class. + +The L<DBD::Gofer::Policy::Base> class is the base class for all the policy +classes and describes all the individual policy items. + +The Base policy is not used directly. You should use a policy class derived from it. + +=head1 POLICY CLASSES + +Three policy classes are supplied with DBD::Gofer: + +L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it +makes more round-trips to the Gofer server. + +L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy. + +L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications. + +Generally the default C<classic> policy is fine. When first testing an existing +application with Gofer it is a good idea to start with the C<pedantic> policy +first and then switch to C<classic> or a custom policy, for final testing. + +=head1 POLICY ITEMS + +These are temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +See the source code to this module for more details. + +=head1 POLICY CUSTOMIZATION + +XXX This area of DBD::Gofer is subject to change. + +There are three ways to customize policies: + +Policy classes are designed to influence the overall behaviour of DBD::Gofer +with existing, unaltered programs, so they work in a reasonably optimal way +without requiring code changes. You can implement new policy classes as +subclasses of existing policies. + +In many cases individual policy items can be overridden on a case-by-case basis +within your application code. You do this by passing a corresponding +C<<go_<policy_name>>> attribute into DBI methods by your application code. +This let's you fine-tune the behaviour for special cases. + +The policy items are implemented as methods. In many cases the methods are +passed parameters relating to the DBD::Gofer code being executed. This means +the policy can implement dynamic behaviour that varies depending on the +particular circumstances, such as the particular statement being executed. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/classic.pm b/lib/DBD/Gofer/Policy/classic.pm new file mode 100644 index 0000000..8f828f0 --- /dev/null +++ b/lib/DBD/Gofer/Policy/classic.pm @@ -0,0 +1,79 @@ +package DBD::Gofer::Policy::classic; + +# $Id: classic.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + prepare_method => '', + + # don't skip the connect check since that also sets dbh attributes + # although this makes connect more expensive, that's partly offset + # by skip_ping=>1 below, which makes connect_cached very fast. + skip_connect_check => 0, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is not important for DBD::Gofer and most transports + skip_ping => 1, + + # only update dbh attributes on first contact with server + dbh_attribute_update => 'first', + + # we'd like to set locally_* but can't because drivers differ + + # get_info results usually don't change + cache_get_info => 1, +}); + + +1; + +=head1 NAME + +DBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...) + +The C<classic> policy is the default DBD::Gofer policy, so need not be included in the DSN. + +=head1 DESCRIPTION + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/pedantic.pm b/lib/DBD/Gofer/Policy/pedantic.pm new file mode 100644 index 0000000..6829bea --- /dev/null +++ b/lib/DBD/Gofer/Policy/pedantic.pm @@ -0,0 +1,53 @@ +package DBD::Gofer::Policy::pedantic; + +# $Id: pedantic.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +# the 'pedantic' policy is the same as the Base policy + +1; + +=head1 NAME + +DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...) + +=head1 DESCRIPTION + +The C<pedantic> policy tries to be as transparent as possible. To do this it +makes round-trips to the server for almost every DBI method call. + +This is the best policy to use when first testing existing code with Gofer. +Once it's working well you should consider moving to the C<classic> policy or defining your own policy class. + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/rush.pm b/lib/DBD/Gofer/Policy/rush.pm new file mode 100644 index 0000000..9cfd582 --- /dev/null +++ b/lib/DBD/Gofer/Policy/rush.pm @@ -0,0 +1,90 @@ +package DBD::Gofer::Policy::rush; + +# $Id: rush.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + # (because code not using placeholders would bloat the sth cache) + prepare_method => '', + + # Skipping the connect check is fast, but it also skips + # fetching the remote dbh attributes! + # Make sure that your application doesn't need access to dbh attributes. + skip_connect_check => 1, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is almost meaningless for DBD::Gofer and most transports anyway + skip_ping => 1, + + # don't update dbh attributes at all + # XXX actually we currently need dbh_attribute_update for skip_default_methods to work + # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update + dbh_attribute_update => 'none', # actually means 'first' currently + #dbh_attribute_list => undef, + + # we'd like to set locally_* but can't because drivers differ + + # in a rush assume metadata doesn't change + cache_tables => 1, + cache_table_info => 1, + cache_column_info => 1, + cache_primary_key_info => 1, + cache_foreign_key_info => 1, + cache_statistics_info => 1, + cache_get_info => 1, +}); + + +1; + +=head1 NAME + +DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...) + +=head1 DESCRIPTION + +The C<rush> policy tries to make as few round-trips as possible. +It's the opposite end of the policy spectrum to the C<pedantic> policy. + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Transport/Base.pm b/lib/DBD/Gofer/Transport/Base.pm new file mode 100644 index 0000000..fe0d078 --- /dev/null +++ b/lib/DBD/Gofer/Transport/Base.pm @@ -0,0 +1,410 @@ +package DBD::Gofer::Transport::Base; + +# $Id: Base.pm 14120 2010-06-07 19:52:19Z hmbrand $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use base qw(DBI::Gofer::Transport::Base); + +our $VERSION = sprintf("0.%06d", q$Revision: 14120 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + trace + go_dsn + go_url + go_policy + go_timeout + go_retry_hook + go_retry_limit + go_cache + cache_hit + cache_miss + cache_store +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($class, $args) = @_; + $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); + $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; + #warn "args @{[ %$args ]}\n"; + return $class->SUPER::new($args); +} + + +sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } + + +sub new_response { + my $self = shift; + return DBI::Gofer::Response->new(@_); +} + + +sub transmit_request { + my ($self, $request) = @_; + my $trace = $self->trace; + my $response; + + my ($go_cache, $request_cache_key); + if ($go_cache = $self->{go_cache}) { + $request_cache_key + = $request->{meta}{request_cache_key} + = $self->get_cache_key_for_request($request); + if ($request_cache_key) { + my $frozen_response = eval { $go_cache->get($request_cache_key) }; + if ($frozen_response) { + $self->_dump("cached response found for ".ref($request), $request) + if $trace; + $response = $self->thaw_response($frozen_response); + $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") + if $trace; + ++$self->{cache_hit}; + return $response; + } + warn $@ if $@; + ++$self->{cache_miss}; + $self->trace_msg("transmit_request cache miss\n") + if $trace; + } + } + + my $to = $self->go_timeout; + my $transmit_sub = sub { + $self->trace_msg("transmit_request\n") if $trace; + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + local $SIG{PIPE} = sub { + my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; + die "Unable to send request: Broken pipe$extra\n"; + }; + alarm($to) if $to; + $self->transmit_request_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("transmit_request", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + + return $response; + }; + + $response = $self->_transmit_request_with_retries($request, $transmit_sub); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key; + } + + $self->trace_msg("transmit_request is returning a response itself\n") + if $trace && $response; + + return $response unless wantarray; + return ($response, $transmit_sub); +} + + +sub _transmit_request_with_retries { + my ($self, $request, $transmit_sub) = @_; + my $response; + do { + $response = $transmit_sub->(); + } while ( $response && $self->response_needs_retransmit($request, $response) ); + return $response; +} + + +sub receive_response { + my ($self, $request, $retransmit_sub) = @_; + my $to = $self->go_timeout; + + my $receive_sub = sub { + $self->trace_msg("receive_response\n"); + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + alarm($to) if $to; + $self->receive_response_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("receive_response", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + return $response; + }; + + my $response; + do { + $response = $receive_sub->(); + if ($self->response_needs_retransmit($request, $response)) { + $response = $self->_transmit_request_with_retries($request, $retransmit_sub); + $response ||= $receive_sub->(); + } + } while ( $self->response_needs_retransmit($request, $response) ); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + my $request_cache_key = $request->{meta}{request_cache_key}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key && $self->{go_cache}; + } + + return $response; +} + + +sub response_retry_preference { + my ($self, $request, $response) = @_; + + # give the user a chance to express a preference (or undef for default) + if (my $go_retry_hook = $self->go_retry_hook) { + my $retry = $go_retry_hook->($request, $response, $self); + $self->trace_msg(sprintf "go_retry_hook returned %s\n", + (defined $retry) ? $retry : 'undef'); + return $retry if defined $retry; + } + + # This is the main decision point. We don't retry requests that got + # as far as executing because the error is probably from the database + # (not transport) so retrying is unlikely to help. But note that any + # severe transport error occuring after execute is likely to return + # a new response object that doesn't have the execute flag set. Beware! + return 0 if $response->executed_flag_set; + + return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; + + return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set + + return undef; # we couldn't make up our mind +} + + +sub response_needs_retransmit { + my ($self, $request, $response) = @_; + + my $err = $response->err + or return 0; # nothing went wrong + + my $retry = $self->response_retry_preference($request, $response); + + if (!$retry) { # false or undef + $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); + return 0; + } + + # we'd like to retry but have we retried too much already? + + my $retry_limit = $self->go_retry_limit; + if (!$retry_limit) { + $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); + return 0; + } + + my $request_meta = $request->meta; + my $retry_count = $request_meta->{retry_count} || 0; + if ($retry_count >= $retry_limit) { + $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); + # XXX should be possible to disable altering the err + $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); + return 0; + } + + # will retry now, do the admin + ++$retry_count; + $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); + + # hook so response_retry_preference can defer some code execution + # until we've checked retry_count and retry_limit. + if (ref $retry eq 'CODE') { + $retry->($retry_count, $retry_limit) + and warn "should return false"; # protect future use + } + + ++$request_meta->{retry_count}; # update count for this request object + ++$self->meta->{request_retry_count}; # update cumulative transport stats + + return 1; +} + + +sub transport_timedout { + my ($self, $method, $timeout) = @_; + $timeout ||= $self->go_timeout; + return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); +} + + +# return undef if we don't want to cache this request +# subclasses may use more specialized rules +sub get_cache_key_for_request { + my ($self, $request) = @_; + + # we only want to cache idempotent requests + # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set + return undef if not $request->is_idempotent; + + # XXX would be nice to avoid the extra freeze here + my $key = $self->freeze_request($request, undef, 1); + + #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; + + return $key; +} + + +sub _store_response_in_cache { + my ($self, $frozen_response, $request_cache_key) = @_; + my $go_cache = $self->{go_cache} + or return; + + # new() ensures that enabling go_cache also enables keep_meta_frozen + warn "No meta frozen in response" if !$frozen_response; + warn "No request_cache_key" if !$request_cache_key; + + if ($frozen_response && $request_cache_key) { + $self->trace_msg("receive_response added response to cache $go_cache\n"); + eval { $go_cache->set($request_cache_key, $frozen_response) }; + warn $@ if $@; + ++$self->{cache_store}; + } +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports + +=head1 SYNOPSIS + + my $remote_dsn = "..." + DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...' + +which will force I<all> DBI connections to be made via that Gofer server. + +=head1 DESCRIPTION + +This is the base class for all DBD::Gofer client transports. + +=head1 ATTRIBUTES + +Gofer transport attributes can be specified either in the attributes parameter +of the connect() method call, or in the DSN string. When used in the DSN +string, attribute names don't have the C<go_> prefix. + +=head2 go_dsn + +The full DBI DSN that the Gofer server should connect to on your behalf. + +When used in the DSN it must be the last element in the DSN string. + +=head2 go_timeout + +A time limit for sending a request and receiving a response. Some drivers may +implement sending and receiving as separate steps, in which case (currently) +the timeout applies to each separately. + +If a request needs to be resent then the timeout is restarted for each sending +of a request and receiving of a response. + +=head2 go_retry_limit + +The maximum number of times an request may be retried. The default is 2. + +=head2 go_retry_hook + +This subroutine reference is called, if defined, for each response received where $response->err is true. + +The subroutine is pass three parameters: the request object, the response object, and the transport object. + +If it returns an undefined value then the default retry behaviour is used. See L</RETRY ON ERROR> below. + +If it returns a defined but false value then the request is not resent. + +If it returns true value then the request is resent, so long as the number of retries does not exceed C<go_retry_limit>. + +=head1 RETRY ON ERROR + +The default retry on error behaviour is: + + - Retry if the error was due to DBI_GOFER_RANDOM. See L<DBI::Gofer::Execute>. + + - Retry if $request->is_idempotent returns true. See L<DBI::Gofer::Request>. + +A retry won't be allowed if the number of previous retries has reached C<go_retry_limit>. + +=head1 TRACING + +Tracing of gofer requests and responses can be enabled by setting the +C<DBD_GOFER_TRACE> environment variable. A value of 1 gives a reasonably +compact summary of each request and response. A value of 2 or more gives a +detailed, and voluminous, dump. + +The trace is written using DBI->trace_msg() and so is written to the default +DBI trace output, which is usually STDERR. + +=head1 METHODS + +I<This section is currently far from complete.> + +=head2 response_retry_preference + + $retry = $transport->response_retry_preference($request, $response); + +The response_retry_preference is called by DBD::Gofer when considering if a +request should be retried after an error. + +Returns true (would like to retry), false (must not retry), undef (no preference). + +If a true value is returned in the form of a CODE ref then, if DBD::Gofer does +decide to retry the request, it calls the code ref passing $retry_count, $retry_limit. +Can be used for logging and/or to implement exponential backoff behaviour. +Currently the called code must return using C<return;> to allow for future extensions. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer>, L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>. + +and some example transports: + +L<DBD::Gofer::Transport::stream> + +L<DBD::Gofer::Transport::http> + +L<DBI::Gofer::Transport::mod_perl> + +=cut diff --git a/lib/DBD/Gofer/Transport/corostream.pm b/lib/DBD/Gofer/Transport/corostream.pm new file mode 100644 index 0000000..6e79278 --- /dev/null +++ b/lib/DBD/Gofer/Transport/corostream.pm @@ -0,0 +1,144 @@ +package DBD::Gofer::Transport::corostream; + +use strict; +use warnings; + +use Carp; + +use Coro::Select; # a slow but coro-aware replacement for CORE::select (global effect!) + +use Coro; +use Coro::Handle; + +use base qw(DBD::Gofer::Transport::stream); + +# XXX ensure DBI_PUREPERL for parent doesn't pass to child +sub start_pipe_command { + local $ENV{DBI_PUREPERL} = $ENV{DBI_PUREPERL_COROCHILD}; # typically undef + my $connection = shift->SUPER::start_pipe_command(@_); + return $connection; +} + + + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::corostream - Async DBD::Gofer stream transport using Coro and AnyEvent + +=head1 SYNOPSIS + + DBI_AUTOPROXY="dbi:Gofer:transport=corostream" perl some-perl-script-using-dbi.pl + +or + + $dsn = ...; # the DSN for the driver and database you want to use + $dbh = DBI->connect("dbi:Gofer:transport=corostream;dsn=$dsn", ...); + +=head1 DESCRIPTION + +The I<BIG WIN> from using L<Coro> is that it enables the use of existing +DBI frameworks like L<DBIx::Class>. + +=head1 KNOWN ISSUES AND LIMITATIONS + + - Uses Coro::Select so alters CORE::select globally + Parent class probably needs refactoring to enable a more encapsulated approach. + + - Doesn't prevent multiple concurrent requests + Probably just needs a per-connection semaphore + + - Coro has many caveats. Caveat emptor. + +=head1 STATUS + +THIS IS CURRENTLY JUST A PROOF-OF-CONCEPT IMPLEMENTATION FOR EXPERIMENTATION. + +Please note that I have no plans to develop this code further myself. +I'd very much welcome contributions. Interested? Let me know! + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2010, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::stream> + +L<DBD::Gofer> + +=head1 APPENDIX + +Example code: + + #!perl + + use strict; + use warnings; + use Time::HiRes qw(time); + + BEGIN { $ENV{PERL_ANYEVENT_STRICT} = 1; $ENV{PERL_ANYEVENT_VERBOSE} = 1; } + + use AnyEvent; + + BEGIN { $ENV{DBI_TRACE} = 0; $ENV{DBI_GOFER_TRACE} = 0; $ENV{DBD_GOFER_TRACE} = 0; }; + + use DBI; + + $ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=corostream'; + + my $ticker = AnyEvent->timer( after => 0, interval => 0.1, cb => sub { + warn sprintf "-tick- %.2f\n", time + } ); + + warn "connecting...\n"; + my $dbh = DBI->connect("dbi:NullP:"); + warn "...connected\n"; + + for (1..3) { + warn "entering DBI...\n"; + $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver + warn "...returned\n"; + } + + warn "done."; + +Example output: + + $ perl corogofer.pl + connecting... + -tick- 1293631437.14 + -tick- 1293631437.14 + ...connected + entering DBI... + -tick- 1293631437.25 + -tick- 1293631437.35 + -tick- 1293631437.45 + -tick- 1293631437.55 + ...returned + entering DBI... + -tick- 1293631437.66 + -tick- 1293631437.76 + -tick- 1293631437.86 + ...returned + entering DBI... + -tick- 1293631437.96 + -tick- 1293631438.06 + -tick- 1293631438.16 + ...returned + done. at corogofer.pl line 39. + +You can see that the timer callback is firing while the code 'waits' inside the +do() method for the response from the database. Normally that would block. + +=cut diff --git a/lib/DBD/Gofer/Transport/null.pm b/lib/DBD/Gofer/Transport/null.pm new file mode 100644 index 0000000..4b8d86c --- /dev/null +++ b/lib/DBD/Gofer/Transport/null.pm @@ -0,0 +1,111 @@ +package DBD::Gofer::Transport::null; + +# $Id: null.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use base qw(DBD::Gofer::Transport::Base); + +use DBI::Gofer::Execute; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + pending_response + transmit_count +)); + +my $executor = DBI::Gofer::Execute->new(); + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests + + my $frozen_request = $self->freeze_request($request); + + # ... + # the request is magically transported over to ... ourselves + # ... + + my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) ); + + # put response 'on the shelf' ready for receive_response() + $self->pending_response( $response ); + + return undef; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $response = $self->pending_response; + + my $frozen_response = $self->freeze_response($response, undef, 1); + + # ... + # the response is magically transported back to ... ourselves + # ... + + return $self->thaw_response($frozen_response); +} + + +1; +__END__ + +=head1 NAME + +DBD::Gofer::Transport::null - DBD::Gofer client transport for testing + +=head1 SYNOPSIS + + my $original_dsn = "..." + DBI->connect("dbi:Gofer:transport=null;dsn=$original_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY="dbi:Gofer:transport=null" + +=head1 DESCRIPTION + +Connect via DBD::Gofer but execute the requests within the same process. + +This is a quick and simple way to test applications for compatibility with the +(few) restrictions that DBD::Gofer imposes. + +It also provides a simple, portable way for the DBI test suite to be used to +test DBD::Gofer on all platforms with no setup. + +Also, by measuring the difference in performance between normal connections and +connections via C<dbi:Gofer:transport=null> the basic cost of using DBD::Gofer +can be measured. Furthermore, the additional cost of more advanced transports can be +isolated by comparing their performance with the null transport. + +The C<t/85gofer.t> script in the DBI distribution includes a comparative benchmark. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/Gofer/Transport/pipeone.pm b/lib/DBD/Gofer/Transport/pipeone.pm new file mode 100644 index 0000000..3df2bf3 --- /dev/null +++ b/lib/DBD/Gofer/Transport/pipeone.pm @@ -0,0 +1,253 @@ +package DBD::Gofer::Transport::pipeone; + +# $Id: pipeone.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use Carp; +use Fcntl; +use IO::Select; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +use base qw(DBD::Gofer::Transport::Base); + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + connection_info + go_perl +)); + + +sub new { + my ($self, $args) = @_; + $args->{go_perl} ||= do { + ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ]; + }; + if (not ref $args->{go_perl}) { + # user can override the perl to be used, either with an array ref + # containing the command name and args to use, or with a string + # (ie via the DSN) in which case, to enable args to be passed, + # we split on two or more consecutive spaces (otherwise the path + # to perl couldn't contain a space itself). + $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ]; + } + return $self->SUPER::new($args); +} + + +# nonblock($fh) puts filehandle into nonblocking mode +sub nonblock { + my $fh = shift; + my $flags = fcntl($fh, F_GETFL, 0) + or croak "Can't get flags for filehandle $fh: $!"; + fcntl($fh, F_SETFL, $flags | O_NONBLOCK) + or croak "Can't make filehandle $fh nonblocking: $!"; +} + + +sub start_pipe_command { + my ($self, $cmd) = @_; + $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY'; + + # if it's important that the subprocess uses the same + # (versions of) modules as us then the caller should + # set PERL5LIB itself. + + # limit various forms of insanity, for now + local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead + local $ENV{DBI_AUTOPROXY}; + local $ENV{DBI_PROFILE}; + + my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); + my $pid = open3($wfh, $rfh, $efh, @$cmd) + or die "error starting @$cmd: $!\n"; + if ($self->trace) { + $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0); + } + nonblock($rfh); + nonblock($efh); + my $ios = IO::Select->new($rfh, $efh); + + return { + cmd=>$cmd, + pid=>$pid, + wfh=>$wfh, rfh=>$rfh, efh=>$efh, + ios=>$ios, + }; +} + + +sub cmd_as_string { + my $self = shift; + # XXX meant to return a properly shell-escaped string suitable for system + # but its only for debugging so that can wait + my $connection_info = $self->connection_info; + return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}}; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + + my $frozen_request = $self->freeze_request($request); + + my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)]; + my $info = $self->start_pipe_command($cmd); + + my $wfh = delete $info->{wfh}; + # send frozen request + local $\; + print $wfh $frozen_request + or warn "error writing to @$cmd: $!\n"; + # indicate that there's no more + close $wfh + or die "error closing pipe to @$cmd: $!\n"; + + $self->connection_info( $info ); + return; +} + + +sub read_response_from_fh { + my ($self, $fh_actions) = @_; + my $trace = $self->trace; + + my $info = $self->connection_info || die; + my ($ios) = @{$info}{qw(ios)}; + my $errors = 0; + my $complete; + + die "No handles to read response from" unless $ios->count; + + while ($ios->count) { + my @readable = $ios->can_read(); + for my $fh (@readable) { + local $_; + my $actions = $fh_actions->{$fh} || die "panic: no action for $fh"; + my $rv = sysread($fh, $_='', 1024*31); # to fit in 32KB slab + unless ($rv) { # error (undef) or end of file (0) + my $action; + unless (defined $rv) { # was an error + $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4; + $action = $actions->{error} || $actions->{eof}; + ++$errors; + # XXX an error may be a permenent condition of the handle + # if so we'll loop here - not good + } + else { + $action = $actions->{eof}; + $self->trace_msg("eof on handle $fh\n") if $trace >= 4; + } + if ($action->($fh)) { + $self->trace_msg("removing $fh from handle set\n") if $trace >= 4; + $ios->remove($fh); + } + next; + } + # action returns true if the response is now complete + # (we finish all handles + $actions->{read}->($fh) && ++$complete; + } + last if $complete; + } + return $errors; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $info = $self->connection_info || die; + my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)}; + + my $frozen_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; 1 }, + eof => sub { warn "eof on stderr" if 0; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; 1 }, + eof => sub { warn "eof on stdout" if 0; 1 }, + read => sub { $frozen_response .= $_; 0 }, + }, + }); + + waitpid $info->{pid}, 0 + or warn "waitpid: $!"; # XXX do something more useful? + + die ref($self)." command (@$cmd) failed: $stderr_msg" + if not $frozen_response; # no output on stdout at all + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $self->trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing + +=head1 SYNOPSIS + + $original_dsn = "..."; + DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone" + +=head1 DESCRIPTION + +Connect via DBD::Gofer and execute each request by starting executing a subprocess. + +This is, as you might imagine, spectacularly inefficient! + +It's only intended for testing. Specifically it demonstrates that the server +side is completely stateless. + +It also provides a base class for the much more useful L<DBD::Gofer::Transport::stream> +transport. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/Gofer/Transport/stream.pm b/lib/DBD/Gofer/Transport/stream.pm new file mode 100644 index 0000000..61e211c --- /dev/null +++ b/lib/DBD/Gofer/Transport/stream.pm @@ -0,0 +1,292 @@ +package DBD::Gofer::Transport::stream; + +# $Id: stream.pm 14598 2010-12-21 22:53:25Z timbo $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use Carp; + +use base qw(DBD::Gofer::Transport::pipeone); + +our $VERSION = sprintf("0.%06d", q$Revision: 14598 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + go_persist +)); + +my $persist_all = 5; +my %persist; + + +sub _connection_key { + my ($self) = @_; + return join "~", $self->go_url||"", @{ $self->go_perl || [] }; +} + + +sub _connection_get { + my ($self) = @_; + + my $persist = $self->go_persist; # = 0 can force non-caching + $persist = $persist_all if not defined $persist; + my $key = ($persist) ? $self->_connection_key : ''; + if ($persist{$key} && $self->_connection_check($persist{$key})) { + $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1; + return $persist{$key}; + } + + my $connection = $self->_make_connection; + + if ($key) { + %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses + $persist{$key} = $connection; + } + + return $connection; +} + + +sub _connection_check { + my ($self, $connection) = @_; + $connection ||= $self->connection_info; + my $pid = $connection->{pid}; + my $ok = (kill 0, $pid); + $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace; + return $ok; +} + + +sub _connection_kill { + my ($self) = @_; + my $connection = $self->connection_info; + my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)}; + $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace; + # closing the write file handle should be enough, generally + close $wfh; + # in future we may want to be more aggressive + #close $rfh; close $efh; kill 15, $pid + # but deleting from the persist cache... + delete $persist{ $self->_connection_key }; + # ... and removing the connection_info should suffice + $self->connection_info( undef ); + return; +} + + +sub _make_connection { + my ($self) = @_; + + my $go_perl = $self->go_perl; + my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)]; + + #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c"; + if (my $url = $self->go_url) { + die "Only 'ssh:user\@host' style url supported by this transport" + unless $url =~ s/^ssh://; + my $ssh = $url; + my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile); + my $setup = $setup_env.q{; exec "$@"}; + # don't use $^X on remote system by default as it's possibly wrong + $cmd->[0] = 'perl' if "@$go_perl" eq $^X; + # -x not only 'Disables X11 forwarding' but also makes connections *much* faster + unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup; + } + + $self->trace_msg("new connection: @$cmd\n",0) if $self->trace; + + # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's + # sent as soon as it starts that we can wait for to report success - and soak up + # and report useful warnings etc from ssh before we get it? Increases latency though. + my $connection = $self->start_pipe_command($cmd); + return $connection; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + my $trace = $self->trace; + + my $connection = $self->connection_info || do { + my $con = $self->_connection_get; + $self->connection_info( $con ); + $con; + }; + + my $encoded_request = unpack("H*", $self->freeze_request($request)); + $encoded_request .= "\015\012"; + + my $wfh = $connection->{wfh}; + $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0) + if $trace >= 4; + + # send frozen request + local $\; + $wfh->print($encoded_request) # autoflush enabled + or do { + my $err = $!; + # XXX could/should make new connection and retry + $self->_connection_kill; + die "Error sending request: $err"; + }; + $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4; + + return undef; # indicate no response yet (so caller calls receive_response_by_transport) +} + + +sub receive_response_by_transport { + my $self = shift; + my $trace = $self->trace; + + $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4; + my $connection = $self->connection_info || die; + my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)}; + + my $errno = 0; + my $encoded_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading efh" if $trace >= 4; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading rfh" if $trace >= 4; 1 }, + read => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 }, + }, + }); + + # if we got no output on stdout at all then the command has + # probably exited, possibly with an error to stderr. + # Turn this situation into a reasonably useful DBI error. + if (not $encoded_response) { + my @msg; + push @msg, "error while reading response: $errno" if $errno; + if ($stderr_msg) { + chomp $stderr_msg; + push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s", + $self->cmd_as_string, + $pid, ((kill 0, $pid) ? "" : ", exited"), + $stderr_msg; + } + die join(", ", "No response received", @msg)."\n"; + } + + $self->trace_msg("Response received: $encoded_response\n",0) + if $trace >= 4; + + $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0) + if $stderr_msg && $trace; + + my $frozen_response = pack("H*", $encoded_response); + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + +sub transport_timedout { + my $self = shift; + $self->_connection_kill; + return $self->SUPER::transport_timedout(@_); +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::stream - DBD::Gofer transport for stdio streaming + +=head1 SYNOPSIS + + DBI->connect('dbi:Gofer:transport=stream;url=ssh:username@host.example.com;dsn=dbi:...',...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY='dbi:Gofer:transport=stream;url=ssh:username@host.example.com' + +=head1 DESCRIPTION + +Without the C<url=> parameter it launches a subprocess as + + perl -MDBI::Gofer::Transport::stream -e run_stdio_hex + +and feeds requests into it and reads responses from it. But that's not very useful. + +With a C<url=ssh:username@host.example.com> parameter it uses ssh to launch the subprocess +on a remote system. That's much more useful! + +It gives you secure remote access to DBI databases on any system you can login to. +Using ssh also gives you optional compression and many other features (see the +ssh manual for how to configure that and many other options via ~/.ssh/config file). + +The actual command invoked is something like: + + ssh -xq ssh:username@host.example.com bash -c $setup $run + +where $run is the command shown above, and $command is + + . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile 2>/dev/null; exec "$@" + +which is trying (in a limited and fairly unportable way) to setup the environment +(PATH, PERL5LIB etc) as it would be if you had logged in to that system. + +The "C<perl>" used in the command will default to the value of $^X when not using ssh. +On most systems that's the full path to the perl that's currently executing. + + +=head1 PERSISTENCE + +Currently gofer stream connections persist (remain connected) after all +database handles have been disconnected. This makes later connections in the +same process very fast. + +Currently up to 5 different gofer stream connections (based on url) can +persist. If more than 5 are in the cache when a new connection is made then +the cache is cleared before adding the new connection. Simple but effective. + +=head1 TO DO + +Document go_perl attribute + +Automatically reconnect (within reason) if there's a transport error. + +Decide on default for persistent connection - on or off? limits? ttl? + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/NullP.pm b/lib/DBD/NullP.pm new file mode 100644 index 0000000..b1f8a71 --- /dev/null +++ b/lib/DBD/NullP.pm @@ -0,0 +1,166 @@ +{ + package DBD::NullP; + + require DBI; + require Carp; + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = sprintf("12.%06d", q$Revision: 14714 $ =~ /(\d+)/o); + +# $Id: NullP.pm 14714 2011-02-22 17:27:07Z timbo $ +# +# Copyright (c) 1994-2007 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + $drh = undef; # holds driver handle once initialised + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'NullP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Null Perl stub by Tim Bunce', + }, [ qw'example implementors private data']); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::NullP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my $dbh = shift->SUPER::connect(@_) + or return; + $dbh->STORE(Active => 1); + $dbh; + } + + + sub DESTROY { undef } +} + + +{ package DBD::NullP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + use Carp qw(croak); + + sub prepare { + my ($dbh, $statement)= @_; + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }); + + return $outer; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + Carp::croak("Can't disable AutoCommit") unless $value; + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub ping { 1 } + + sub disconnect { + shift->STORE(Active => 0); + } + +} + + +{ package DBD::NullP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) { + $sth->STORE(NUM_OF_FIELDS => 1); + $sth->{NAME} = [ "fieldname" ]; + # just for the sake of returning something, we return the params + my $params = $sth->{ParamValues} || {}; + $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ]; + $sth->STORE(Active => 1); + } + # force a sleep - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) { + my $secs = $1; + if (eval { require Time::HiRes; defined &Time::HiRes::sleep }) { + Time::HiRes::sleep($secs); + } + else { + sleep $secs; + } + } + # force an error - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) { + return $sth->set_err($1, $2); + } + # anything else is silently ignored, sucessfully + 1; + } + + sub fetchrow_arrayref { + my $sth = shift; + my $data = $sth->{dbd_nullp_data}; + if (!$data || !@$data) { + $sth->finish; # no more data so finish + return undef; + } + return $sth->_set_fbav(shift @$data); + } + *fetch = \&fetchrow_arrayref; # alias + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } + +} + +1; diff --git a/lib/DBD/Proxy.pm b/lib/DBD/Proxy.pm new file mode 100644 index 0000000..6c9e14d --- /dev/null +++ b/lib/DBD/Proxy.pm @@ -0,0 +1,997 @@ +# -*- perl -*- +# +# +# DBD::Proxy - DBI Proxy driver +# +# +# Copyright (c) 1997,1998 Jochen Wiedmann +# +# The DBD::Proxy module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. In particular permission +# is granted to Tim Bunce for distributing this as a part of the DBI. +# +# +# Author: Jochen Wiedmann +# Am Eisteich 9 +# 72555 Metzingen +# Germany +# +# Email: joe@ispsoft.de +# Phone: +49 7123 14881 +# + +use strict; +use Carp; + +require DBI; +DBI->require_version(1.0201); + +use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released + +{ package DBD::Proxy::RPC::PlClient; + @DBD::Proxy::RPC::PlClient::ISA = qw(RPC::PlClient); + sub Call { + my $self = shift; + if ($self->{debug}) { + my ($rpcmeth, $obj, $method, @args) = @_; + local $^W; # silence undefs + Carp::carp("Server $rpcmeth $method(@args)"); + } + return $self->SUPER::Call(@_); + } +} + + +package DBD::Proxy; + +use vars qw($VERSION $drh %ATTR); + +$VERSION = "0.2004"; + +$drh = undef; # holds driver handle once initialised + +%ATTR = ( # common to db & st, see also %ATTR in DBD::Proxy::db & ::st + 'Warn' => 'local', + 'Active' => 'local', + 'Kids' => 'local', + 'CachedKids' => 'local', + 'PrintError' => 'local', + 'RaiseError' => 'local', + 'HandleError' => 'local', + 'TraceLevel' => 'cached', + 'CompatMode' => 'local', +); + +sub driver ($$) { + if (!$drh) { + my($class, $attr) = @_; + + $class .= "::dr"; + + $drh = DBI::_new_drh($class, { + 'Name' => 'Proxy', + 'Version' => $VERSION, + 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', + }); + $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) + } + $drh; +} + +sub CLONE { + undef $drh; +} + +sub proxy_set_err { + my ($h,$errmsg) = @_; + my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//) + ? ($1, $2) : (1, ' ' x 5); + return $h->set_err($err, $errmsg, $state); +} + +package DBD::Proxy::dr; # ====== DRIVER ====== + +$DBD::Proxy::dr::imp_data_size = 0; + +sub connect ($$;$$) { + my($drh, $dsn, $user, $auth, $attr)= @_; + my($dsnOrig) = $dsn; + + my %attr = %$attr; + my ($var, $val); + while (length($dsn)) { + if ($dsn =~ /^dsn=(.*)/) { + $attr{'dsn'} = $1; + last; + } + if ($dsn =~ /^(.*?);(.*)/) { + $var = $1; + $dsn = $2; + } else { + $var = $dsn; + $dsn = ''; + } + if ($var =~ /^(.*?)=(.*)/) { + $var = $1; + $val = $2; + $attr{$var} = $val; + } + } + + my $err = ''; + if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } + if (!defined($attr{'port'})) { $err .= " Missing port."; } + if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } + + # Create a cipher object, if requested + my $cipherRef = undef; + if ($attr{'cipher'}) { + $cipherRef = eval { $attr{'cipher'}->new(pack('H*', + $attr{'key'})) }; + if ($@) { $err .= " Cannot create cipher object: $@."; } + } + my $userCipherRef = undef; + if ($attr{'userkey'}) { + my $cipher = $attr{'usercipher'} || $attr{'cipher'}; + $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; + if ($@) { $err .= " Cannot create usercipher object: $@."; } + } + + return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef + + my %client_opts = ( + 'peeraddr' => $attr{'hostname'}, + 'peerport' => $attr{'port'}, + 'socket_proto' => 'tcp', + 'application' => $attr{dsn}, + 'user' => $user || '', + 'password' => $auth || '', + 'version' => $DBD::Proxy::VERSION, + 'cipher' => $cipherRef, + 'debug' => $attr{debug} || 0, + 'timeout' => $attr{timeout} || undef, + 'logfile' => $attr{logfile} || undef + ); + # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after + # stripping the prefix. + while (my($var,$val) = each %attr) { + if ($var =~ s/^proxy_rpc_//) { + $client_opts{$var} = $val; + } + } + # Create an RPC::PlClient object. + my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) }; + + return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@") + if $@; # Returns undef + return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg") + unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef + + $msg = RPC::PlClient::Object->new($1, $client, $msg); + + my $max_proto_ver; + my ($server_ver_str) = eval { $client->Call('Version') }; + if ( $@ ) { + # Server denies call, assume legacy protocol. + $max_proto_ver = 1; + } else { + # Parse proxy server version. + my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/; + $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1; + } + my $req_proto_ver; + if ( exists $attr{proxy_lazy_prepare} ) { + $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1; + return DBD::Proxy::proxy_set_err($drh, + "DBI::ProxyServer does not support synchronous statement preparation.") + if $max_proto_ver < $req_proto_ver; + } + + # Switch to user specific encryption mode, if desired + if ($userCipherRef) { + $client->{'cipher'} = $userCipherRef; + } + + # create a 'blank' dbh + my $this = DBI::_new_dbh($drh, { + 'Name' => $dsnOrig, + 'proxy_dbh' => $msg, + 'proxy_client' => $client, + 'RowCacheSize' => $attr{'RowCacheSize'} || 20, + 'proxy_proto_ver' => $req_proto_ver || 1 + }); + + foreach $var (keys %attr) { + if ($var =~ /proxy_/) { + $this->{$var} = $attr{$var}; + } + } + $this->SUPER::STORE('Active' => 1); + + $this; +} + + +sub DESTROY { undef } + + +package DBD::Proxy::db; # ====== DATABASE ====== + +$DBD::Proxy::db::imp_data_size = 0; + +# XXX probably many more methods need to be added here +# in order to trigger our AUTOLOAD to redirect them to the server. +# (Unless the sub is declared it's bypassed by perl method lookup.) +# See notes in ToDo about method metadata +# The question is whether to add all the methods in %DBI::DBI_methods +# to the corresponding classes (::db, ::st etc) +# Also need to consider methods that, if proxied, would change the server state +# in a way that might not be visible on the client, ie begin_work -> AutoCommit. + +sub commit; +sub connected; +sub rollback; +sub ping; + + +use vars qw(%ATTR $AUTOLOAD); + +# inherited: STORE / FETCH against this class. +# local: STORE / FETCH against parent class. +# cached: STORE to remote and local objects, FETCH from local. +# remote: STORE / FETCH against remote object only (default). +# +# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. +# +%ATTR = ( # see also %ATTR in DBD::Proxy::st + %DBD::Proxy::ATTR, + RowCacheSize => 'inherited', + #AutoCommit => 'cached', + 'FetchHashKeyName' => 'cached', + Statement => 'local', + Driver => 'local', + dbi_connect_closure => 'local', + Username => 'local', +); + +sub AUTOLOAD { + my $method = $AUTOLOAD; + $method =~ s/(.*::(.*)):://; + my $class = $1; + my $type = $2; + #warn "AUTOLOAD of $method (class=$class, type=$type)"; + my %expand = ( + 'method' => $method, + 'class' => $class, + 'type' => $type, + 'call' => "$method(\@_)", + # XXX was trying to be smart but was tripping up over the DBI's own + # smartness. Disabled, but left here in case there are issues. + # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')", + ); + + my $method_code = q{ + package ~class~; + sub ~method~ { + my $h = shift; + local $@; + my @result = wantarray + ? eval { $h->{'proxy_~type~h'}->~call~ } + : eval { scalar $h->{'proxy_~type~h'}->~call~ }; + return DBD::Proxy::proxy_set_err($h, $@) if $@; + return wantarray ? @result : $result[0]; + } + }; + $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; + local $SIG{__DIE__} = 'DEFAULT'; + my $err = do { local $@; eval $method_code.2; $@ }; + die $err if $err; + goto &$AUTOLOAD; +} + +sub DESTROY { + my $dbh = shift; + local $@ if $@; # protect $@ + $dbh->disconnect if $dbh->SUPER::FETCH('Active'); +} + +sub disconnect ($) { + my ($dbh) = @_; + + # Sadly the Proxy too-often disagrees with the backend database + # on the subject of 'Active'. In the short term, I'd like the + # Proxy to ease up and let me decide when it's proper to go over + # the wire. This ultimately applies to finish() as well. + #return unless $dbh->SUPER::FETCH('Active'); + + # Drop database connection at remote end + my $rdbh = $dbh->{'proxy_dbh'}; + if ( $rdbh ) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + eval { $rdbh->disconnect() } ; + DBD::Proxy::proxy_set_err($dbh, $@) if $@; + } + + # Close TCP connect to remote + # XXX possibly best left till DESTROY? Add a config attribute to choose? + #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module + $dbh->{proxy_client}->{socket} = undef; # hack + + $dbh->SUPER::STORE('Active' => 0); + 1; +} + + +sub STORE ($$$) { + my($dbh, $attr, $val) = @_; + my $type = $ATTR{$attr} || 'remote'; + + if ($attr eq 'TraceLevel') { + warn("TraceLevel $val"); + my $pc = $dbh->{proxy_client} || die; + $pc->{logfile} ||= 1; # XXX hack + $pc->{debug} = ($val && $val >= 4); + $pc->Debug("$pc debug enabled") if $pc->{debug}; + } + + if ($attr =~ /^proxy_/ || $type eq 'inherited') { + $dbh->{$attr} = $val; + return 1; + } + + if ($type eq 'remote' || $type eq 'cached') { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef + $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; + return $result; + } + return $dbh->SUPER::STORE($attr => $val); +} + +sub FETCH ($$) { + my($dbh, $attr) = @_; + # we only get here for cached attribute values if the handle is in CompatMode + # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache. + my $type = $ATTR{$attr} || 'remote'; + + if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { + return $dbh->{$attr}; + } + + return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; + + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + +sub prepare ($$;$) { + my($dbh, $stmt, $attr) = @_; + my $sth = DBI::_new_sth($dbh, { + 'Statement' => $stmt, + 'proxy_attr' => $attr, + 'proxy_cache_only' => 0, + 'proxy_params' => [], + } + ); + my $proto_ver = $dbh->{'proxy_proto_ver'}; + if ( $proto_ver > 1 ) { + $sth->{'proxy_attr_cache'} = {cache_filled => 0}; + my $rdbh = $dbh->{'proxy_dbh'}; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") + unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); + + my $client = $dbh->{'proxy_client'}; + $rsth = RPC::PlClient::Object->new($1, $client, $rsth); + + $sth->{'proxy_sth'} = $rsth; + # If statement is a positioned update we do not want any readahead. + $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i; + # Since resources are used by prepared remote handle, mark us active. + $sth->SUPER::STORE(Active => 1); + } + $sth; +} + +sub quote { + my $dbh = shift; + my $proxy_quote = $dbh->{proxy_quote} || 'remote'; + + return $dbh->SUPER::quote(@_) + if $proxy_quote eq 'local' && @_ == 1; + + # For the common case of only a single argument + # (no $data_type) we could learn and cache the behaviour. + # Or we could probe the driver with a few test cases. + # Or we could add a way to ask the DBI::ProxyServer + # if $dbh->can('quote') == \&DBI::_::db::quote. + # Tim + # + # Sounds all *very* smart to me. I'd rather suggest to + # implement some of the typical quote possibilities + # and let the user set + # $dbh->{'proxy_quote'} = 'backslash_escaped'; + # for example. + # Jochen + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + +sub table_info { + my $dbh = shift; + my $rdbh = $dbh->{'proxy_dbh'}; + #warn "table_info(@_)"; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + my ($sth, $inner) = DBI::_new_sth($dbh, { + 'Statement' => "SHOW TABLES", + 'proxy_params' => [], + 'proxy_data' => \@rows, + 'proxy_attr_cache' => { + 'NUM_OF_PARAMS' => 0, + 'NUM_OF_FIELDS' => $numFields, + 'NAME' => $names, + 'TYPE' => $types, + 'cache_filled' => 1 + }, + 'proxy_cache_only' => 1, + }); + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $inner->{NAME} = $names; + $inner->{TYPE} = $types; + $sth->SUPER::STORE('Active' => 1); # already execute()'d + $sth->{'proxy_rows'} = @rows; + return $sth; +} + +sub tables { + my $dbh = shift; + #warn "tables(@_)"; + return $dbh->SUPER::tables(@_); +} + + +sub type_info_all { + my $dbh = shift; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + + +package DBD::Proxy::st; # ====== STATEMENT ====== + +$DBD::Proxy::st::imp_data_size = 0; + +use vars qw(%ATTR); + +# inherited: STORE to current object. FETCH from current if exists, else call up +# to the (proxy) database object. +# local: STORE / FETCH against parent class. +# cache_only: STORE noop (read-only). FETCH from private_* if exists, else call +# remote and cache the result. +# remote: STORE / FETCH against remote object only (default). +# +# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. +# +%ATTR = ( # see also %ATTR in DBD::Proxy::db + %DBD::Proxy::ATTR, + 'Database' => 'local', + 'RowsInCache' => 'local', + 'RowCacheSize' => 'inherited', + 'NULLABLE' => 'cache_only', + 'NAME' => 'cache_only', + 'TYPE' => 'cache_only', + 'PRECISION' => 'cache_only', + 'SCALE' => 'cache_only', + 'NUM_OF_FIELDS' => 'cache_only', + 'NUM_OF_PARAMS' => 'cache_only' +); + +*AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; + +sub execute ($@) { + my $sth = shift; + my $params = @_ ? \@_ : $sth->{'proxy_params'}; + + # new execute, so delete any cached rows from previous execute + undef $sth->{'proxy_data'}; + undef $sth->{'proxy_rows'}; + + my $rsth = $sth->{proxy_sth}; + my $dbh = $sth->FETCH('Database'); + my $proto_ver = $dbh->{proxy_proto_ver}; + + my ($numRows, @outData); + + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + if ( $proto_ver > 1 ) { + ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + + # Attributes passed back only on the first execute() of a statement. + unless ($sth->{proxy_attr_cache}->{cache_filled}) { + my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); + $sth->{'proxy_attr_cache'} = { + 'NUM_OF_FIELDS' => $numFields, + 'NUM_OF_PARAMS' => $numParams, + 'NAME' => $names, + 'cache_filled' => 1 + }; + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); + } + + } + else { + if ($rsth) { + ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + + } + else { + my $rdbh = $dbh->{'proxy_dbh'}; + + # Legacy prepare is actually prepare + first execute on the server. + ($rsth, @outData) = + eval { $rdbh->prepare($sth->{'Statement'}, + $sth->{'proxy_attr'}, $params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") + unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); + + my $client = $dbh->{'proxy_client'}; + $rsth = RPC::PlClient::Object->new($1, $client, $rsth); + + my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); + $sth->{'proxy_sth'} = $rsth; + $sth->{'proxy_attr_cache'} = { + 'NUM_OF_FIELDS' => $numFields, + 'NUM_OF_PARAMS' => $numParams, + 'NAME' => $names + }; + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); + $numRows = shift @outData; + } + } + # Always condition active flag. + $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT + $sth->{'proxy_rows'} = $numRows; + # Any remaining items are output params. + if (@outData) { + foreach my $p (@$params) { + if (ref($p->[0])) { + my $ref = shift @outData; + ${$p->[0]} = $$ref; + } + } + } + + $sth->{'proxy_rows'} || '0E0'; +} + +sub fetch ($) { + my $sth = shift; + + my $data = $sth->{'proxy_data'}; + + $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'}; + + if(!$data || !@$data) { + return undef unless $sth->SUPER::FETCH('Active'); + + my $rsth = $sth->{'proxy_sth'}; + if (!$rsth) { + die "Attempt to fetch row without execute"; + } + my $num_rows = $sth->FETCH('RowCacheSize') || 20; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my @rows = eval { $rsth->fetch($num_rows) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + unless (@rows == $num_rows) { + undef $sth->{'proxy_data'}; + # server side has already called finish + $sth->SUPER::STORE(Active => 0); + } + return undef unless @rows; + $sth->{'proxy_data'} = $data = [@rows]; + } + my $row = shift @$data; + + $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); + $sth->{'proxy_rows'}++; + return $sth->_set_fbav($row); +} +*fetchrow_arrayref = \&fetch; + +sub rows ($) { + my $rows = shift->{'proxy_rows'}; + return (defined $rows) ? $rows : -1; +} + +sub finish ($) { + my($sth) = @_; + return 1 unless $sth->SUPER::FETCH('Active'); + my $rsth = $sth->{'proxy_sth'}; + $sth->SUPER::STORE('Active' => 0); + return 0 unless $rsth; # Something's out of sync + my $no_finish = exists($sth->{'proxy_no_finish'}) + ? $sth->{'proxy_no_finish'} + : $sth->FETCH('Database')->{'proxy_no_finish'}; + unless ($no_finish) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->finish() }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return $result; + } + 1; +} + +sub STORE ($$$) { + my($sth, $attr, $val) = @_; + my $type = $ATTR{$attr} || 'remote'; + + if ($attr =~ /^proxy_/ || $type eq 'inherited') { + $sth->{$attr} = $val; + return 1; + } + + if ($type eq 'cache_only') { + return 0; + } + + if ($type eq 'remote' || $type eq 'cached') { + my $rsth = $sth->{'proxy_sth'} or return undef; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->STORE($attr => $val) }; + return DBD::Proxy::proxy_set_err($sth, $@) if ($@); + return $result if $type eq 'remote'; # else fall through to cache locally + } + return $sth->SUPER::STORE($attr => $val); +} + +sub FETCH ($$) { + my($sth, $attr) = @_; + + if ($attr =~ /^proxy_/) { + return $sth->{$attr}; + } + + my $type = $ATTR{$attr} || 'remote'; + if ($type eq 'inherited') { + if (exists($sth->{$attr})) { + return $sth->{$attr}; + } + return $sth->FETCH('Database')->{$attr}; + } + + if ($type eq 'cache_only' && + exists($sth->{'proxy_attr_cache'}->{$attr})) { + return $sth->{'proxy_attr_cache'}->{$attr}; + } + + if ($type ne 'local') { + my $rsth = $sth->{'proxy_sth'} or return undef; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->FETCH($attr) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return $result; + } + elsif ($attr eq 'RowsInCache') { + my $data = $sth->{'proxy_data'}; + $data ? @$data : 0; + } + else { + $sth->SUPER::FETCH($attr); + } +} + +sub bind_param ($$$@) { + my $sth = shift; my $param = shift; + $sth->{'proxy_params'}->[$param-1] = [@_]; +} +*bind_param_inout = \&bind_param; + +sub DESTROY { + my $sth = shift; + $sth->finish if $sth->SUPER::FETCH('Active'); +} + + +1; + + +__END__ + +=head1 NAME + +DBD::Proxy - A proxy driver for the DBI + +=head1 SYNOPSIS + + use DBI; + + $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", + $user, $passwd); + + # See the DBI module documentation for full details + +=head1 DESCRIPTION + +DBD::Proxy is a Perl module for connecting to a database via a remote +DBI driver. See L<DBD::Gofer> for an alternative with different trade-offs. + +This is of course not needed for DBI drivers which already +support connecting to a remote database, but there are engines which +don't offer network connectivity. + +Another application is offering database access through a firewall, as +the driver offers query based restrictions. For example you can +restrict queries to exactly those that are used in a given CGI +application. + +Speaking of CGI, another application is (or rather, will be) to reduce +the database connect/disconnect overhead from CGI scripts by using +proxying the connect_cached method. The proxy server will hold the +database connections open in a cache. The CGI script then trades the +database connect/disconnect overhead for the DBD::Proxy +connect/disconnect overhead which is typically much less. +I<Note that the connect_cached method is new and still experimental.> + + +=head1 CONNECTING TO THE DATABASE + +Before connecting to a remote database, you must ensure, that a Proxy +server is running on the remote machine. There's no default port, so +you have to ask your system administrator for the port number. See +L<DBI::ProxyServer> for details. + +Say, your Proxy server is running on machine "alpha", port 3334, and +you'd like to connect to an ODBC database called "mydb" as user "joe" +with password "hello". When using DBD::ODBC directly, you'd do a + + $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); + +With DBD::Proxy this becomes + + $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; + $dbh = DBI->connect($dsn, "joe", "hello"); + +You see, this is mainly the same. The DBD::Proxy module will create a +connection to the Proxy server on "alpha" which in turn will connect +to the ODBC database. + +Refer to the L<DBI> documentation on the C<connect> method for a way +to automatically use DBD::Proxy without having to change your code. + +DBD::Proxy's DSN string has the format + + $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; + +In other words, it is a collection of key/value pairs. The following +keys are recognized: + +=over 4 + +=item hostname + +=item port + +Hostname and port of the Proxy server; these keys must be present, +no defaults. Example: + + hostname=alpha;port=3334 + +=item dsn + +The value of this attribute will be used as a dsn name by the Proxy +server. Thus it must have the format C<DBI:driver:...>, in particular +it will contain colons. The I<dsn> value may contain semicolons, hence +this key *must* be the last and it's value will be the complete +remaining part of the dsn. Example: + + dsn=DBI:ODBC:mydb + +=item cipher + +=item key + +=item usercipher + +=item userkey + +By using these fields you can enable encryption. If you set, +for example, + + cipher=$class;key=$key + +(note the semicolon) then DBD::Proxy will create a new cipher object +by executing + + $cipherRef = $class->new(pack("H*", $key)); + +and pass this object to the RPC::PlClient module when creating a +client. See L<RPC::PlClient>. Example: + + cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 + +The usercipher/userkey attributes allow you to use two phase encryption: +The cipher/key encryption will be used in the login and authorisation +phase. Once the client is authorised, he will change to usercipher/userkey +encryption. Thus the cipher/key pair is a B<host> based secret, typically +less secure than the usercipher/userkey secret and readable by anyone. +The usercipher/userkey secret is B<your> private secret. + +Of course encryption requires an appropriately configured server. See +<DBD::ProxyServer/CONFIGURATION FILE>. + +=item debug + +Turn on debugging mode + +=item stderr + +This attribute will set the corresponding attribute of the RPC::PlClient +object, thus logging will not use syslog(), but redirected to stderr. +This is the default under Windows. + + stderr=1 + +=item logfile + +Similar to the stderr attribute, but output will be redirected to the +given file. + + logfile=/dev/null + +=item RowCacheSize + +The DBD::Proxy driver supports this attribute (which is DBI standard, +as of DBI 1.02). It's used to reduce network round-trips by fetching +multiple rows in one go. The current default value is 20, but this may +change. + + +=item proxy_no_finish + +This attribute can be used to reduce network traffic: If the +application is calling $sth->finish() then the proxy tells the server +to finish the remote statement handle. Of course this slows down things +quite a lot, but is perfectly good for reducing memory usage with +persistent connections. + +However, if you set the I<proxy_no_finish> attribute to a TRUE value, +either in the database handle or in the statement handle, then finish() +calls will be supressed. This is what you want, for example, in small +and fast CGI applications. + +=item proxy_quote + +This attribute can be used to reduce network traffic: By default calls +to $dbh->quote() are passed to the remote driver. Of course this slows +down things quite a lot, but is the safest default behaviour. + +However, if you set the I<proxy_quote> attribute to the value 'C<local>' +either in the database handle or in the statement handle, and the call +to quote has only one parameter, then the local default DBI quote +method will be used (which will be faster but may be wrong). + +=back + +=head1 KNOWN ISSUES + +=head2 Unproxied method calls + +If a method isn't being proxied, try declaring a stub sub in the appropriate +package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method). +For example: + + sub DBD::Proxy::db::selectall_arrayref; + +That will enable selectall_arrayref to be proxied. + +Currently many methods aren't explicitly proxied and so you get the DBI's +default methods executed on the client. + +Some of those methods, like selectall_arrayref, may then call other methods +that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch +which is proxied). So things may appear to work but operate more slowly than +the could. + +This may all change in a later version. + +=head2 Complex handle attributes + +Sometimes handles are having complex attributes like hash refs or +array refs and not simple strings or integers. For example, with +DBD::CSV, you would like to write something like + + $dbh->{"csv_tables"}->{"passwd"} = + { "sep_char" => ":", "eol" => "\n"; + +The above example would advice the CSV driver to assume the file +"passwd" to be in the format of the /etc/passwd file: Colons as +separators and a line feed without carriage return as line +terminator. + +Surprisingly this example doesn't work with the proxy driver. To understand +the reasons, you should consider the following: The Perl compiler is +executing the above example in two steps: + +=over + +=item 1 + +The first step is fetching the value of the key "csv_tables" in the +handle $dbh. The value returned is complex, a hash ref. + +=item 2 + +The second step is storing some value (the right hand side of the +assignment) as the key "passwd" in the hash ref from step 1. + +=back + +This becomes a little bit clearer, if we rewrite the above code: + + $tables = $dbh->{"csv_tables"}; + $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; + +While the examples work fine without the proxy, the fail due to a +subtle difference in step 1: By DBI magic, the hash ref +$dbh->{'csv_tables'} is returned from the server to the client. +The client creates a local copy. This local copy is the result of +step 1. In other words, step 2 modifies a local copy of the hash ref, +but not the server's hash ref. + +The workaround is storing the modified local copy back to the server: + + $tables = $dbh->{"csv_tables"}; + $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; + $dbh->{"csv_tables"} = $tables; + + +=head1 AUTHOR AND COPYRIGHT + +This module is Copyright (c) 1997, 1998 + + Jochen Wiedmann + Am Eisteich 9 + 72555 Metzingen + Germany + + Email: joe@ispsoft.de + Phone: +49 7123 14887 + +The DBD::Proxy module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. In particular permission +is granted to Tim Bunce for distributing this as a part of the DBI. + + +=head1 SEE ALSO + +L<DBI>, L<RPC::PlClient>, L<Storable> + +=cut diff --git a/lib/DBD/Sponge.pm b/lib/DBD/Sponge.pm new file mode 100644 index 0000000..2413bc0 --- /dev/null +++ b/lib/DBD/Sponge.pm @@ -0,0 +1,305 @@ +{ + package DBD::Sponge; + + require DBI; + require Carp; + + our @EXPORT = qw(); # Do NOT @EXPORT anything. + our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o); + + +# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z timbo $ +# +# Copyright (c) 1994-2003 Tim Bunce Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + $drh = undef; # holds driver handle once initialised + my $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBD::Sponge::db->install_method("sponge_test_installed_method") + unless $methods_already_installed++; + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Sponge', + 'Version' => $VERSION, + 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", + }); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::Sponge::dr; # ====== DRIVER ====== + $imp_data_size = 0; + # we use default (dummy) connect method +} + + +{ package DBD::Sponge::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement, $attribs) = @_; + my $rows = delete $attribs->{'rows'} + or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare"); + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + 'rows' => $rows, + (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } + qw(execute_hook) + ), + }); + if (my $behave_like = $attribs->{behave_like}) { + $outer->{$_} = $behave_like->{$_} + foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); + } + + if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() + $sth->{is_insert} = 1; + my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} + or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); + $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); + } + else { #assume select + + # we need to set NUM_OF_FIELDS + my $numFields; + if ($attribs->{'NUM_OF_FIELDS'}) { + $numFields = $attribs->{'NUM_OF_FIELDS'}; + } elsif ($attribs->{'NAME'}) { + $numFields = @{$attribs->{NAME}}; + } elsif ($attribs->{'TYPE'}) { + $numFields = @{$attribs->{TYPE}}; + } elsif (my $firstrow = $rows->[0]) { + $numFields = scalar @$firstrow; + } else { + return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); + } + $sth->STORE('NUM_OF_FIELDS' => $numFields); + $sth->{NAME} = $attribs->{NAME} + || [ map { "col$_" } 1..$numFields ]; + $sth->{TYPE} = $attribs->{TYPE} + || [ (DBI::SQL_VARCHAR()) x $numFields ]; + $sth->{PRECISION} = $attribs->{PRECISION} + || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; + $sth->{SCALE} = $attribs->{SCALE} + || [ (0) x $numFields ]; + $sth->{NULLABLE} = $attribs->{NULLABLE} + || [ (2) x $numFields ]; + } + + $outer; + } + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return 1 if $attrib eq 'AutoCommit'; + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + return 1 if $value; # is already set + Carp::croak("Can't disable AutoCommit"); + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub sponge_test_installed_method { + my ($dbh, @args) = @_; + return $dbh->set_err(42, "not enough parameters") unless @args >= 2; + return \@args; + } +} + + +{ package DBD::Sponge::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + sub execute { + my $sth = shift; + + # hack to support ParamValues (when not using bind_param) + $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; + + if (my $hook = $sth->{execute_hook}) { + &$hook($sth, @_) or return; + } + + if ($sth->{is_insert}) { + my $row; + $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; + my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; + return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") + if @$row != $NUM_OF_PARAMS; + { local $^W; $sth->trace_msg("inserting (@$row)\n"); } + push @{ $sth->{rows} }, $row; + } + else { # mark select sth as Active + $sth->STORE(Active => 1); + } + # else do nothing for select as data is already in $sth->{rows} + return 1; + } + + sub fetch { + my ($sth) = @_; + my $row = shift @{$sth->{'rows'}}; + unless ($row) { + $sth->STORE(Active => 0); + return undef; + } + return $sth->_set_fbav($row); + } + *fetchrow_arrayref = \&fetch; + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +DBD::Sponge - Create a DBI statement handle from Perl data + +=head1 SYNOPSIS + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=head1 DESCRIPTION + +DBD::Sponge is useful for making a Perl data structure accessible through a +standard DBI statement handle. This may be useful to DBD module authors who +need to transform data in this way. + +=head1 METHODS + +=head2 connect() + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + +Here's a sample syntax for creating a database handle for the Sponge driver. +No username and password are needed. + +=head2 prepare() + + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=over 4 + +=item * + +The C<$statement> here is an arbitrary statement or name you want +to provide as identity of your data. If you're using DBI::Profile +it will appear in the profile data. + +Generally it's expected that you are preparing a statement handle +as if a C<select> statement happened. + +=item * + +C<$data> is a reference to the data you are providing, given as an array of arrays. + +=item * + +C<$names> is a reference an array of column names for the C<$data> you are providing. +The number and order should match the number and ordering of the C<$data> columns. + +=item * + +C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement. + +Currently only NAME, TYPE, and PRECISION are supported. + +=back + +=head1 BUGS + +Using this module to prepare INSERT-like statements is not currently documented. + +=head1 AUTHOR AND COPYRIGHT + +This module is Copyright (c) 2003 Tim Bunce + +Documentation initially written by Mark Stosberg + +The DBD::Sponge module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. In particular permission +is granted to Tim Bunce for distributing this as a part of the DBI. + +=head1 SEE ALSO + +L<DBI> + +=cut |