| Current File : /home/mmdealscpanel/yummmdeals.com/DBD.tar |
File.pm 0000644 00000117471 15053110135 0005766 0 ustar 00 # -*- 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-2013 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.44";
$drh = undef; # holds driver handle(s) once initialized
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 to 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);
# 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 );
use Carp;
@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
# XXX rewrite using TableConfig ...
sub default_table_source { "DBD::File::TableSource::FileSystem" }
sub connect
{
my ($drh, $dbname, $user, $auth, $attr) = @_;
# We do not (yet) care about conflicting attributes here
# my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" });
# will test here that both test and text should exist
if (my $attr_hash = (DBI->parse_dsn ($dbname))[3]) {
if (defined $attr_hash->{f_dir} && ! -d $attr_hash->{f_dir}) {
my $msg = "No such directory '$attr_hash->{f_dir}";
$drh->set_err (2, $msg);
$attr_hash->{RaiseError} and croak $msg;
return;
}
}
if ($attr and defined $attr->{f_dir} && ! -d $attr->{f_dir}) {
my $msg = "No such directory '$attr->{f_dir}";
$drh->set_err (2, $msg);
$attr->{RaiseError} and croak $msg;
return;
}
return $drh->SUPER::connect ($dbname, $user, $auth, $attr);
} # connect
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 data_sources
{
my ($dbh, $attr, @other) = @_;
ref ($attr) eq "HASH" or $attr = {};
exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir};
exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search};
return $dbh->SUPER::data_sources ($attr, @other);
} # data_source
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_dir_search => 1, # extended search directories
f_ext => 1, # file extension
f_schema => 1, # schema name
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) {
# f_ext should not be initialized
# f_map is deprecated (but might return)
$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());
push @{$dbh->{sql_init_order}{90}}, "f_meta";
# complete derived attributes, if required
(my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
my $drv_prefix = DBI->driver_prefix ($drv_class);
if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) {
my $attr = $dbh->{$drv_prefix . "meta"};
defined $dbh->{f_valid_attrs}{f_meta}
and $dbh->{f_valid_attrs}{f_meta} = 1;
$dbh->{f_meta} = $dbh->{$attr};
}
}
return $dbh;
} # init_default_attributes
sub validate_FETCH_attr
{
my ($dbh, $attrib) = @_;
$attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
return $dbh->SUPER::validate_FETCH_attr ($attrib);
} # validate_FETCH_attr
sub validate_STORE_attr
{
my ($dbh, $attrib, $value) = @_;
if ($attrib eq "f_dir" && defined $value) {
-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";
}
$attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";
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 $dver;
my $dtype = "IO::File";
eval {
$dver = IO::File->VERSION ();
# when we're still alive here, everything went ok - no need to check for $@
$dtype .= " ($dver)";
};
my $f_encoding;
if ($table) {
my $meta;
$table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
$meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding};
} # if ($table)
$f_encoding ||= $dbh->{f_encoding};
$f_encoding and $dtype .= " + " . $f_encoding . " encoding";
return sprintf "%s using %s", $dbh->{f_version}, $dtype;
} # get_f_versions
# ====== 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 $types = $sth->{Database}{Types};
unless ($types) { # Fetch types only once per database
if (my $t = $sth->{Database}->type_info_all ()) {
foreach my $i (1 .. $#$t) {
$types->{uc $t->[$i][0]} = $t->[$i][1];
$types->{$t->[$i][1]} ||= uc $t->[$i][0];
}
}
# sane defaults
for ([ 0, "" ],
[ 1, "CHAR" ],
[ 4, "INTEGER" ],
[ 12, "VARCHAR" ],
) {
$types->{$_->[0]} ||= $_->[1];
$types->{$_->[1]} ||= $_->[0];
}
$sth->{Database}{Types} = $types;
}
my $all_meta =
$sth->{Database}->func ("*", "table_defs", "get_sql_engine_meta");
foreach my $tbl (keys %$all_meta) {
my $meta = $all_meta->{$tbl};
exists $meta->{table_defs} && ref $meta->{table_defs} or next;
foreach (keys %{$meta->{table_defs}{columns}}) {
my $field_info = $meta->{table_defs}{columns}{$_};
if (defined $field_info->{data_type} &&
$field_info->{data_type} !~ m/^[0-9]+$/) {
$field_info->{type_name} = uc $field_info->{data_type};
$field_info->{data_type} = $types->{$field_info->{type_name}} || 0;
}
$field_info->{type_name} ||= $types->{$field_info->{data_type}} || "CHAR";
$sth->{f_overall_defs}{$_} = $field_info;
}
}
}
my @colnames = $sth->sql_get_colnames ();
$attr eq "TYPE" and
return [ map { $sth->{f_overall_defs}{$_}{data_type} || 12 }
@colnames ];
$attr eq "TYPE_NAME" and
return [ map { $sth->{f_overall_defs}{$_}{type_name} || "VARCHAR" }
@colnames ];
$attr eq "PRECISION" and
return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 }
@colnames ];
$attr eq "NULLABLE" and
return [ map { ( grep { $_ eq "NOT NULL" }
@{ $sth->{f_overall_defs}{$_}{constraints} || [] })
? 0 : 1 }
@colnames ];
}
}
return $sth->SUPER::FETCH ($attr);
} # FETCH
# ====== TableSource ===========================================================
package DBD::File::TableSource::FileSystem;
use strict;
use warnings;
use IO::Dir;
@DBD::File::TableSource::FileSystem::ISA = "DBI::DBD::SqlEngine::TableSource";
sub data_sources
{
my ($class, $drh, $attr) = @_;
my $dir = $attr && exists $attr->{f_dir}
? $attr->{f_dir}
: File::Spec->curdir ();
defined $dir or return; # Stream-based databases do not have f_dir
unless (-d $dir && -r $dir && -x $dir) {
$drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir");
return;
}
my %attrs;
$attr and %attrs = %$attr;
delete $attrs{f_dir};
my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote");
my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs;
my @dir = ($dir);
$attr->{f_dir_search} && ref $attr->{f_dir_search} eq "ARRAY" and
push @dir, grep { -d $_ } @{$attr->{f_dir_search}};
my @dsns;
foreach $dir (@dir) {
my $dirh = IO::Dir->new ($dir);
unless (defined $dirh) {
$drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
return;
}
my ($file, %names, $driver);
$driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File";
while (defined ($file = $dirh->read ())) {
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 avail_tables
{
my ($self, $dbh) = @_;
my $dir = $dbh->{f_dir};
defined $dir or return; # Stream based db's cannot be queried for tables
my %seen;
my @tables;
my @dir = ($dir);
$dbh->{f_dir_search} && ref $dbh->{f_dir_search} eq "ARRAY" and
push @dir, grep { -d $_ } @{$dbh->{f_dir_search}};
foreach $dir (@dir) {
my $dirh = IO::Dir->new ($dir);
unless (defined $dirh) {
$dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!");
return;
}
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
while (defined ($file = $dirh->read ())) {
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"}{$dir}{$tbl}++ or
push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ];
}
$dirh->close () or
$dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!");
}
return @tables;
} # avail_tables
# ====== DataSource ============================================================
package DBD::File::DataSource::Stream;
use strict;
use warnings;
use Carp;
@DBD::File::DataSource::Stream::ISA = "DBI::DBD::SqlEngine::DataSource";
# 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 {
my $fh;
my $nulldevice = File::Spec->devnull ();
open $fh, ">", $nulldevice or croak "Can't open $nulldevice: $!";
flock $fh, 0;
close $fh;
1;
};
sub complete_table_name
{
my ($self, $meta, $file, $respect_case) = @_;
my $tbl = $file;
if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
$tbl = uc $tbl;
}
elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
$tbl = lc $tbl;
}
$meta->{f_fqfn} = undef;
$meta->{f_fqbn} = undef;
$meta->{f_fqln} = undef;
$meta->{table_name} = $tbl;
return $tbl;
} # complete_table_name
sub apply_encoding
{
my ($self, $meta, $fn) = @_;
defined $fn or $fn = "file handle " . fileno ($meta->{fh});
if (my $enc = $meta->{f_encoding}) {
binmode $meta->{fh}, ":encoding($enc)" or
croak "Failed to set encoding layer '$enc' on $fn: $!";
}
else {
binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!";
}
} # apply_encoding
sub open_data
{
my ($self, $meta, $attrs, $flags) = @_;
$flags->{dropMode} and croak "Can't drop a table in stream";
my $fn = "file handle " . fileno ($meta->{f_file});
if ($flags->{createMode} || $flags->{lockMode}) {
$meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or
croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
}
else {
$meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or
croak "Cannot open $fn for reading: $! (" . ($!+0) . ")";
}
if ($meta->{fh}) {
$self->apply_encoding ($meta, $fn);
} # have $meta->{$fh}
if ($self->can_flock && $meta->{fh}) {
my $lm = defined $flags->{f_lock}
&& $flags->{f_lock} =~ m/^[012]$/
? $flags->{f_lock}
: $flags->{lockMode} ? 2 : 1;
if ($lm == 2) {
flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
}
elsif ($lm == 1) {
flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!";
}
# $lm = 0 is forced no locking at all
}
} # open_data
sub can_flock { $locking }
package DBD::File::DataSource::File;
use strict;
use warnings;
@DBD::File::DataSource::File::ISA = "DBD::File::DataSource::Stream";
use Carp;
my $fn_any_ext_regex = qr/\.[^.]*/;
sub complete_table_name
{
my ($self, $meta, $file, $respect_case, $file_is_table) = @_;
$file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir
# XXX now called without proving f_fqfn first ...
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/\Q$ext\E$//i;
my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir);
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, qr{\Q$ext\E});
# $dir is returned with trailing (back)slash. We just need to check
# if it is ".", "./", or ".\" or "[]" (VMS)
if ($dir =~ m{^(?:[.][/\\]?|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") {
foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) {
my $f = File::Spec->catdir ($d, $file);
-f $f or next;
$searchdir = Cwd::abs_path ($d);
$dir = "";
last;
}
}
$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;
}
elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
$basename = lc $basename;
$tbl = lc $tbl;
}
unless (defined $searchdir) {
$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);
$^O eq "VMS" && $sfx eq "." and
$sfx = ""; # 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);
$^O eq "VMS" && $sfx eq "." and
$sfx = ""; # no extension turns up as a dot
lc $fn eq lc $basename and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
}
}
my @f;
{ my $dh = IO::Dir->new ($searchdir) or croak "Can't open '$searchdir': $!";
@f = sort { length $b <=> length $a }
grep { &$cmpsub ($_) }
$dh->read ();
$dh->close () or croak "Can't close '$searchdir': $!";
}
@f > 0 && @f <= 2 and $file = $f[0];
!$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED
($tbl = $file) =~ s/\Q$ext\E$//i;
my $tmpfn = $file;
if ($ext && $req) {
# File extension required
$tmpfn =~ s/\Q$ext\E$//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;
} # complete_table_name
sub open_data
{
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) . ")";
}
}
$meta->{fh} = $fh;
if ($fh) {
$fh->seek (0, 0) or
croak "Error while seeking back: $!";
$self->apply_encoding ($meta);
}
}
if ($meta->{f_fqln}) {
$fn = $meta->{f_fqln};
if ($flags->{createMode}) {
-f $fn and
croak "Cannot create table lock at '$fn' 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 ($self->can_flock && $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_data
# ====== SQL::STATEMENT ========================================================
package DBD::File::Statement;
use strict;
use warnings;
@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement );
# ====== SQL::TABLE ============================================================
package DBD::File::Table;
use strict;
use warnings;
use Carp;
require IO::File;
require File::Basename;
require File::Spec;
require Cwd;
require Scalar::Util;
@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table );
# ====== UTILITIES ============================================================
if (eval { require Params::Util; }) {
Params::Util->import ("_HANDLE");
}
else {
# taken but modified from Params::Util ...
*_HANDLE = sub {
# It has to be defined, of course
defined $_[0] or return;
# Normal globs are considered to be file handles
ref $_[0] eq "GLOB" and return $_[0];
# Check for a normal tied filehandle
# Side Note: 5.5.4's tied () and can () doesn't like getting undef
tied ($_[0]) and tied ($_[0])->can ("TIEHANDLE") and return $_[0];
# There are no other non-object handles that we support
Scalar::Util::blessed ($_[0]) or return;
# Check for a common base classes for conventional IO::Handle object
$_[0]->isa ("IO::Handle") and return $_[0];
# Check for tied file handles using Tie::Handle
$_[0]->isa ("Tie::Handle") and return $_[0];
# IO::Scalar is not a proper seekable, but it is valid is a
# regular file handle
$_[0]->isa ("IO::Scalar") and return $_[0];
# Yet another special case for IO::String, which refuses (for now
# anyway) to become a subclass of IO::Handle.
$_[0]->isa ("IO::String") and return $_[0];
# This is not any sort of object we know about
return;
};
}
# ====== FLYWEIGHT SUPPORT =====================================================
# 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) = @_;
return $meta->{sql_data_source}->complete_table_name ($meta, $file, $respect_case, $file_is_table);
} # file2table
sub bootstrap_table_meta
{
my ($self, $dbh, $meta, $table, @other) = @_;
$self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other);
exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir};
exists $meta->{f_dir_search} or $meta->{f_dir_search} = $dbh->{f_dir_search};
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->{f_open_file_needed} or
$meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file");
defined ($meta->{sql_data_source}) or
$meta->{sql_data_source} = _HANDLE ($meta->{f_file})
? "DBD::File::DataSource::Stream"
: "DBD::File::DataSource::File";
} # bootstrap_table_meta
sub get_table_meta ($$$$;$)
{
my ($self, $dbh, $table, $file_is_table, $respect_case) = @_;
my $meta = $self->SUPER::get_table_meta ($dbh, $table, $respect_case, $file_is_table);
$table = $meta->{table_name};
return unless $table;
return ($table, $meta);
} # get_table_meta
my %reset_on_modify = (
f_file => [ "f_fqfn", "sql_data_source" ],
f_dir => "f_fqfn",
f_dir_search => [],
f_ext => "f_fqfn",
f_lockfile => "f_fqfn", # forces new file2table call
);
__PACKAGE__->register_reset_on_modify (\%reset_on_modify);
my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile );
__PACKAGE__->register_compat_map (\%compat_map);
# ====== DBD::File <= 0.40 compat stuff ========================================
# compat to 0.38 .. 0.40 API
sub open_file
{
my ($className, $meta, $attrs, $flags) = @_;
return $className->SUPER::open_data ($meta, $attrs, $flags);
} # open_file
sub open_data
{
my ($className, $meta, $attrs, $flags) = @_;
# compat to 0.38 .. 0.40 API
$meta->{f_open_file_needed}
? $className->open_file ($meta, $attrs, $flags)
: $className->SUPER::open_data ($meta, $attrs, $flags);
return;
} # open_data
# ====== SQL::Eval API =========================================================
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}; # XXX ==> sql_data_source
$meta->{f_fqln} and unlink $meta->{f_fqln}; # XXX ==> sql_data_source
delete $data->{Database}{sql_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};
$self->SUPER::DESTROY();
} # 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 Unsupported DBI attributes and methods
=head4 bind_param_inout
=head4 CursorName
=head4 LongReadLen
=head4 LongTruncOk
=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.
f_dir => "/data/foo/csv",
See L<KNOWN BUGS AND LIMITATIONS>.
=head4 f_dir_search
This optional attribute can be set to pass a list of folders to also
find existing tables. It will B<not> be used to create new files.
f_dir_search => [ "/data/bar/csv", "/dump/blargh/data" ],
=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:
f_ext => ".csv/r",
=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->{dbm_tables}{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->{dbm_tables}{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 aliasing L<DBI::DBD::SqlEngine/sql_meta> 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>,
in addition to the attributes L<DBI::DBD::SqlEngine/sql_meta> already
supports. 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 New opportunities for attributes from DBI::DBD::SqlEngine
=head4 sql_table_source
C<< $dbh->{sql_table_source} >> can be set to
I<DBD::File::TableSource::FileSystem> (and is the default setting
of DBD::File). This provides usual behaviour of previous DBD::File
releases on
@ary = DBI->data_sources ($driver);
@ary = DBI->data_sources ($driver, \%attr);
@ary = $dbh->data_sources ();
@ary = $dbh->data_sources (\%attr);
@names = $dbh->tables ($catalog, $schema, $table, $type);
$sth = $dbh->table_info ($catalog, $schema, $table, $type);
$sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr);
$dbh->func ("list_tables");
=head4 sql_data_source
C<< $dbh->{sql_data_source} >> can be set to either
I<DBD::File::DataSource::File>, which is default and provides the
well known behavior of DBD::File releases prior to 0.41, or
I<DBD::File::DataSource::Stream>, which reuses already opened
file-handle for operations.
=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");
=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->func ("f_versions");
print "$f_versions\n";
__END__
# DBD::File 0.41 using IO::File (1.16)
# DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.406
# DBI 1.623
# OS darwin (12.2.1)
# Perl 5.017006 (darwin-thread-multi-ld-2level)
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).
=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_dir_search
=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-2013 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
mysql/GetInfo.pm 0000644 00000037362 15053110135 0007607 0 ustar 00 package DBD::mysql::GetInfo;
########################################
# DBD::mysql::GetInfo
#
#
# Generated by DBI::DBD::Metadata
# $Author$ <-- the person to blame
# $Revision$
# $Date$
use strict;
use warnings;
use DBD::mysql;
# Beware: not officially documented interfaces...
# use DBI::Const::GetInfoType qw(%GetInfoType);
# use DBI::Const::GetInfoReturn qw(%GetInfoReturnTypes %GetInfoReturnValues);
my $sql_driver = 'mysql';
# SQL_DRIVER_VER should be formatted as dd.dd.dddd
my $dbdversion = $DBD::mysql::VERSION;
$dbdversion .= '_00' if $dbdversion =~ /^\d+\.\d+$/;
my $sql_driver_ver = sprintf("%02d.%02d.%04d", split(/[\._]/,$dbdversion));
my @Keywords = qw(
BIGINT
BLOB
DEFAULT
KEYS
LIMIT
LONGBLOB
MEDIMUMBLOB
MEDIUMINT
MEDIUMTEXT
PROCEDURE
REGEXP
RLIKE
SHOW
TABLES
TINYBLOB
TINYTEXT
UNIQUE
UNSIGNED
ZEROFILL
);
sub sql_keywords {
return join ',', @Keywords;
}
sub sql_data_source_name {
my $dbh = shift;
return "dbi:$sql_driver:" . $dbh->{Name};
}
sub sql_user_name {
my $dbh = shift;
# Non-standard attribute
return $dbh->{CURRENT_USER};
}
####################
# makefunc()
# returns a ref to a sub that calls into XS to get
# values for info types that must needs be coded in C
sub makefunk ($) {
my $type = shift;
return sub {dbd_mysql_get_info(shift, $type)}
}
our %info = (
20 => 'N', # SQL_ACCESSIBLE_PROCEDURES
19 => 'Y', # SQL_ACCESSIBLE_TABLES
0 => 0, # SQL_ACTIVE_CONNECTIONS
116 => 0, # SQL_ACTIVE_ENVIRONMENTS
1 => 0, # SQL_ACTIVE_STATEMENTS
169 => 127, # SQL_AGGREGATE_FUNCTIONS
117 => 0, # SQL_ALTER_DOMAIN
86 => 3, # SQL_ALTER_TABLE
10021 => makefunk 10021, # SQL_ASYNC_MODE
120 => 2, # SQL_BATCH_ROW_COUNT
121 => 2, # SQL_BATCH_SUPPORT
82 => 0, # SQL_BOOKMARK_PERSISTENCE
114 => 1, # SQL_CATALOG_LOCATION
10003 => 'Y', # SQL_CATALOG_NAME
41 => makefunk 41, # SQL_CATALOG_NAME_SEPARATOR
42 => makefunk 42, # SQL_CATALOG_TERM
92 => 29, # SQL_CATALOG_USAGE
10004 => '', # SQL_COLLATING_SEQUENCE
10004 => '', # SQL_COLLATION_SEQ
87 => 'Y', # SQL_COLUMN_ALIAS
22 => 0, # SQL_CONCAT_NULL_BEHAVIOR
53 => 259071, # SQL_CONVERT_BIGINT
54 => 0, # SQL_CONVERT_BINARY
55 => 259071, # SQL_CONVERT_BIT
56 => 259071, # SQL_CONVERT_CHAR
57 => 259071, # SQL_CONVERT_DATE
58 => 259071, # SQL_CONVERT_DECIMAL
59 => 259071, # SQL_CONVERT_DOUBLE
60 => 259071, # SQL_CONVERT_FLOAT
48 => 0, # SQL_CONVERT_FUNCTIONS
# 173 => undef, # SQL_CONVERT_GUID
61 => 259071, # SQL_CONVERT_INTEGER
123 => 0, # SQL_CONVERT_INTERVAL_DAY_TIME
124 => 0, # SQL_CONVERT_INTERVAL_YEAR_MONTH
71 => 0, # SQL_CONVERT_LONGVARBINARY
62 => 259071, # SQL_CONVERT_LONGVARCHAR
63 => 259071, # SQL_CONVERT_NUMERIC
64 => 259071, # SQL_CONVERT_REAL
65 => 259071, # SQL_CONVERT_SMALLINT
66 => 259071, # SQL_CONVERT_TIME
67 => 259071, # SQL_CONVERT_TIMESTAMP
68 => 259071, # SQL_CONVERT_TINYINT
69 => 0, # SQL_CONVERT_VARBINARY
70 => 259071, # SQL_CONVERT_VARCHAR
122 => 0, # SQL_CONVERT_WCHAR
125 => 0, # SQL_CONVERT_WLONGVARCHAR
126 => 0, # SQL_CONVERT_WVARCHAR
74 => 1, # SQL_CORRELATION_NAME
127 => 0, # SQL_CREATE_ASSERTION
128 => 0, # SQL_CREATE_CHARACTER_SET
129 => 0, # SQL_CREATE_COLLATION
130 => 0, # SQL_CREATE_DOMAIN
131 => 0, # SQL_CREATE_SCHEMA
132 => 1045, # SQL_CREATE_TABLE
133 => 0, # SQL_CREATE_TRANSLATION
134 => 0, # SQL_CREATE_VIEW
23 => 2, # SQL_CURSOR_COMMIT_BEHAVIOR
24 => 2, # SQL_CURSOR_ROLLBACK_BEHAVIOR
10001 => 0, # SQL_CURSOR_SENSITIVITY
2 => \&sql_data_source_name, # SQL_DATA_SOURCE_NAME
25 => 'N', # SQL_DATA_SOURCE_READ_ONLY
119 => 7, # SQL_DATETIME_LITERALS
17 => 'MySQL', # SQL_DBMS_NAME
18 => makefunk 18, # SQL_DBMS_VER
170 => 3, # SQL_DDL_INDEX
26 => 2, # SQL_DEFAULT_TRANSACTION_ISOLATION
26 => 2, # SQL_DEFAULT_TXN_ISOLATION
10002 => 'N', # SQL_DESCRIBE_PARAMETER
# 171 => undef, # SQL_DM_VER
3 => 137076632, # SQL_DRIVER_HDBC
# 135 => undef, # SQL_DRIVER_HDESC
4 => 137076088, # SQL_DRIVER_HENV
# 76 => undef, # SQL_DRIVER_HLIB
# 5 => undef, # SQL_DRIVER_HSTMT
6 => 'libmyodbc3.so', # SQL_DRIVER_NAME
77 => '03.51', # SQL_DRIVER_ODBC_VER
7 => $sql_driver_ver, # SQL_DRIVER_VER
136 => 0, # SQL_DROP_ASSERTION
137 => 0, # SQL_DROP_CHARACTER_SET
138 => 0, # SQL_DROP_COLLATION
139 => 0, # SQL_DROP_DOMAIN
140 => 0, # SQL_DROP_SCHEMA
141 => 7, # SQL_DROP_TABLE
142 => 0, # SQL_DROP_TRANSLATION
143 => 0, # SQL_DROP_VIEW
144 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES1
145 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES2
27 => 'Y', # SQL_EXPRESSIONS_IN_ORDERBY
8 => 63, # SQL_FETCH_DIRECTION
84 => 0, # SQL_FILE_USAGE
146 => 97863, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1
147 => 6016, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2
81 => 11, # SQL_GETDATA_EXTENSIONS
88 => 3, # SQL_GROUP_BY
28 => 4, # SQL_IDENTIFIER_CASE
#29 => sub {dbd_mysql_get_info(shift,$GetInfoType {SQL_IDENTIFIER_QUOTE_CHAR})},
29 => makefunk 29, # SQL_IDENTIFIER_QUOTE_CHAR
148 => 0, # SQL_INDEX_KEYWORDS
149 => 0, # SQL_INFO_SCHEMA_VIEWS
172 => 7, # SQL_INSERT_STATEMENT
73 => 'N', # SQL_INTEGRITY
150 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES1
151 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES2
89 => \&sql_keywords, # SQL_KEYWORDS
113 => 'Y', # SQL_LIKE_ESCAPE_CLAUSE
78 => 0, # SQL_LOCK_TYPES
34 => 64, # SQL_MAXIMUM_CATALOG_NAME_LENGTH
97 => 0, # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY
98 => 32, # SQL_MAXIMUM_COLUMNS_IN_INDEX
99 => 0, # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY
100 => 0, # SQL_MAXIMUM_COLUMNS_IN_SELECT
101 => 0, # SQL_MAXIMUM_COLUMNS_IN_TABLE
30 => 64, # SQL_MAXIMUM_COLUMN_NAME_LENGTH
1 => 0, # SQL_MAXIMUM_CONCURRENT_ACTIVITIES
31 => 18, # SQL_MAXIMUM_CURSOR_NAME_LENGTH
0 => 0, # SQL_MAXIMUM_DRIVER_CONNECTIONS
10005 => 64, # SQL_MAXIMUM_IDENTIFIER_LENGTH
102 => 500, # SQL_MAXIMUM_INDEX_SIZE
104 => 0, # SQL_MAXIMUM_ROW_SIZE
32 => 0, # SQL_MAXIMUM_SCHEMA_NAME_LENGTH
105 => makefunk 105, # SQL_MAXIMUM_STATEMENT_LENGTH
# 20000 => undef, # SQL_MAXIMUM_STMT_OCTETS
# 20001 => undef, # SQL_MAXIMUM_STMT_OCTETS_DATA
# 20002 => undef, # SQL_MAXIMUM_STMT_OCTETS_SCHEMA
106 => makefunk 106, # SQL_MAXIMUM_TABLES_IN_SELECT
35 => 64, # SQL_MAXIMUM_TABLE_NAME_LENGTH
107 => 16, # SQL_MAXIMUM_USER_NAME_LENGTH
10022 => makefunk 10022, # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS
112 => 0, # SQL_MAX_BINARY_LITERAL_LEN
34 => 64, # SQL_MAX_CATALOG_NAME_LEN
108 => 0, # SQL_MAX_CHAR_LITERAL_LEN
97 => 0, # SQL_MAX_COLUMNS_IN_GROUP_BY
98 => 32, # SQL_MAX_COLUMNS_IN_INDEX
99 => 0, # SQL_MAX_COLUMNS_IN_ORDER_BY
100 => 0, # SQL_MAX_COLUMNS_IN_SELECT
101 => 0, # SQL_MAX_COLUMNS_IN_TABLE
30 => 64, # SQL_MAX_COLUMN_NAME_LEN
1 => 0, # SQL_MAX_CONCURRENT_ACTIVITIES
31 => 18, # SQL_MAX_CURSOR_NAME_LEN
0 => 0, # SQL_MAX_DRIVER_CONNECTIONS
10005 => 64, # SQL_MAX_IDENTIFIER_LEN
102 => 500, # SQL_MAX_INDEX_SIZE
32 => 0, # SQL_MAX_OWNER_NAME_LEN
33 => 0, # SQL_MAX_PROCEDURE_NAME_LEN
34 => 64, # SQL_MAX_QUALIFIER_NAME_LEN
104 => 0, # SQL_MAX_ROW_SIZE
103 => 'Y', # SQL_MAX_ROW_SIZE_INCLUDES_LONG
32 => 0, # SQL_MAX_SCHEMA_NAME_LEN
105 => 8192, # SQL_MAX_STATEMENT_LEN
106 => 31, # SQL_MAX_TABLES_IN_SELECT
35 => makefunk 35, # SQL_MAX_TABLE_NAME_LEN
107 => 16, # SQL_MAX_USER_NAME_LEN
37 => 'Y', # SQL_MULTIPLE_ACTIVE_TXN
36 => 'Y', # SQL_MULT_RESULT_SETS
111 => 'N', # SQL_NEED_LONG_DATA_LEN
75 => 1, # SQL_NON_NULLABLE_COLUMNS
85 => 2, # SQL_NULL_COLLATION
49 => 16777215, # SQL_NUMERIC_FUNCTIONS
9 => 1, # SQL_ODBC_API_CONFORMANCE
152 => 2, # SQL_ODBC_INTERFACE_CONFORMANCE
12 => 1, # SQL_ODBC_SAG_CLI_CONFORMANCE
15 => 1, # SQL_ODBC_SQL_CONFORMANCE
73 => 'N', # SQL_ODBC_SQL_OPT_IEF
10 => '03.80', # SQL_ODBC_VER
115 => 123, # SQL_OJ_CAPABILITIES
90 => 'Y', # SQL_ORDER_BY_COLUMNS_IN_SELECT
38 => 'Y', # SQL_OUTER_JOINS
115 => 123, # SQL_OUTER_JOIN_CAPABILITIES
39 => '', # SQL_OWNER_TERM
91 => 0, # SQL_OWNER_USAGE
153 => 2, # SQL_PARAM_ARRAY_ROW_COUNTS
154 => 3, # SQL_PARAM_ARRAY_SELECTS
80 => 3, # SQL_POSITIONED_STATEMENTS
79 => 31, # SQL_POS_OPERATIONS
21 => 'N', # SQL_PROCEDURES
40 => '', # SQL_PROCEDURE_TERM
114 => 1, # SQL_QUALIFIER_LOCATION
41 => '.', # SQL_QUALIFIER_NAME_SEPARATOR
42 => 'database', # SQL_QUALIFIER_TERM
92 => 29, # SQL_QUALIFIER_USAGE
93 => 3, # SQL_QUOTED_IDENTIFIER_CASE
11 => 'N', # SQL_ROW_UPDATES
39 => '', # SQL_SCHEMA_TERM
91 => 0, # SQL_SCHEMA_USAGE
43 => 7, # SQL_SCROLL_CONCURRENCY
44 => 17, # SQL_SCROLL_OPTIONS
14 => '\\', # SQL_SEARCH_PATTERN_ESCAPE
13 => makefunk 13, # SQL_SERVER_NAME
94 => 'ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜáíóúñÑ', # SQL_SPECIAL_CHARACTERS
155 => 7, # SQL_SQL92_DATETIME_FUNCTIONS
156 => 0, # SQL_SQL92_FOREIGN_KEY_DELETE_RULE
157 => 0, # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE
158 => 8160, # SQL_SQL92_GRANT
159 => 0, # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS
160 => 0, # SQL_SQL92_PREDICATES
161 => 466, # SQL_SQL92_RELATIONAL_JOIN_OPERATORS
162 => 32640, # SQL_SQL92_REVOKE
163 => 7, # SQL_SQL92_ROW_VALUE_CONSTRUCTOR
164 => 255, # SQL_SQL92_STRING_FUNCTIONS
165 => 0, # SQL_SQL92_VALUE_EXPRESSIONS
118 => 4, # SQL_SQL_CONFORMANCE
166 => 2, # SQL_STANDARD_CLI_CONFORMANCE
167 => 97863, # SQL_STATIC_CURSOR_ATTRIBUTES1
168 => 6016, # SQL_STATIC_CURSOR_ATTRIBUTES2
83 => 7, # SQL_STATIC_SENSITIVITY
50 => 491519, # SQL_STRING_FUNCTIONS
95 => 0, # SQL_SUBQUERIES
51 => 7, # SQL_SYSTEM_FUNCTIONS
45 => 'table', # SQL_TABLE_TERM
109 => 0, # SQL_TIMEDATE_ADD_INTERVALS
110 => 0, # SQL_TIMEDATE_DIFF_INTERVALS
52 => 106495, # SQL_TIMEDATE_FUNCTIONS
46 => 3, # SQL_TRANSACTION_CAPABLE
72 => 15, # SQL_TRANSACTION_ISOLATION_OPTION
46 => 3, # SQL_TXN_CAPABLE
72 => 15, # SQL_TXN_ISOLATION_OPTION
96 => 0, # SQL_UNION
96 => 0, # SQL_UNION_STATEMENT
47 => \&sql_user_name, # SQL_USER_NAME
10000 => 1992, # SQL_XOPEN_CLI_YEAR
);
1;
__END__
mysql/INSTALL.pod 0000644 00000057715 15053110135 0007534 0 ustar 00 =encoding utf8
=head1 NAME
DBD::mysql::INSTALL - How to install and configure DBD::mysql
=head1 SYNOPSIS
perl Makefile.PL [options]
make
make test
make install
=head1 DESCRIPTION
This document describes the installation and configuration of
DBD::mysql, the Perl DBI driver for the MySQL database. Before
reading on, make sure that you have the prerequisites available:
Perl, MySQL and DBI. For details see the separate section
L</PREREQUISITES>.
Depending on your version of Perl, it might be possible to
use a binary distribution of DBD::mysql. If possible, this is
recommended. Otherwise you need to install from the sources.
If so, you will definitely need a C compiler. Installation
from binaries and sources are both described in separate
sections. L</BINARY INSTALLATION>. L</SOURCE INSTALLATION>.
Finally, if you encounter any problems, do not forget to
read the section on known problems L</KNOWN PROBLEMS>. If
that doesn't help, you should check the section on L</SUPPORT>.
=head1 PREREQUISITES
=over
=item Perl
Preferably a version of Perl, that comes preconfigured with
your system. For example, all Linux and FreeBSD distributions
come with Perl. For Windows, using ActivePerl or Strawberry Perl
is recommended, see L<http://www.activestate.com> and
L<http://www.strawberryperl.com> for details.
=item MySQL
You need not install the actual MySQL database server, the
client files and the development files are sufficient. For
example, Fedora Linux distribution comes with RPM files
(using YUM) B<mysql> and B<mysql-server> (use "yum search"
to find exact package names). These are sufficient, if the MySQL
server is located on a foreign machine. You may also create client
files by compiling from the MySQL source distribution and using
configure --without-server
If you are using Windows and need to compile from sources
(which is only the case if you are not using ActivePerl or
Strawberry Perl),
then you must ensure that the header and library files are
installed. This may require choosing a "Custom installation"
and selecting the appropriate option when running the
MySQL setup program.
=item DBI
DBD::mysql is a DBI driver, hence you need DBI. It is available
from the same source where you got the DBD::mysql distribution
from.
=item C compiler
A C compiler is only required if you install from source. In
most cases there are binary distributions of DBD::mysql
available. However, if you need a C compiler, make sure, that
it is the same C compiler that was used for compiling Perl and
MySQL! Otherwise you will almost definitely encounter problems
because of differences in the underlying C runtime libraries.
In the worst case, this might mean to compile Perl and MySQL
yourself. But believe me, experience shows that a lot of problems
are fixed this way.
=item Gzip libraries
Late versions of MySQL come with support for compression. Thus
it B<may> be required that you have install an RPM package like
libz-devel, libgz-devel or something similar.
=back
=head1 BINARY INSTALLATION
Binary installation is possible in the most cases, depending
on your system.
=head2 Windows
=head3 Strawberry Perl
Strawberry Perl comes bundled with DBD::mysql and the needed
client libraries.
=head3 ActiveState Perl
ActivePerl offers a PPM archive of DBD::mysql. All you need to
do is typing in a cmd.exe window:
ppm install DBD-mysql
This will fetch the module via HTTP and install them. If you
need to use a WWW proxy server, the environment variable
HTTP_proxy must be set:
set HTTP_proxy=http://myproxy.example.com:8080/
ppm install DBD-mysql
Of course you need to replace the host name C<myproxy.example.com>
and the port number C<8080> with your local values.
If the above procedure doesn't work, please upgrade to the latest
version of ActivePerl. ActiveState has a policy where it only
provides access free-of-charge for the PPM mirrors of the last
few stable Perl releases. If you have an older perl, you'd either
need to upgrade your perl or contact ActiveState about a subscription.
=head2 Red Hat Enterprise Linux (RHEL), CentOS and Fedora
Red Hat Enterprise Linux, its community derivatives such as
CentOS, and Fedora come with MySQL and DBD::mysql.
Use the following command to install DBD::mysql:
yum install "perl(DBD::mysql)"
=head2 Debian and Ubuntu
On Debian, Ubuntu and derivatives you can install DBD::mysql from
the repositories with the following command:
sudo apt-get install libdbd-mysql-perl
=head2 SLES and openSUSE
On SUSE Linux Enterprise and the community version openSUSE, you
can install DBD::mysql from the repositories with the following
command:
zypper install perl-DBD-mysql
=head2 Other systems
In the case of other Linux or FreeBSD distributions it is very likely
that all you need comes with your distribution.
I just cannot give you names, as I am not using
these systems.
Please let me know if you find the files in your favorite
Linux or FreeBSD distribution so that I can extend the above list.
=head1 SOURCE INSTALLATION
So you need to install from sources. If you are lucky, the Perl
module C<CPAN> will do all for you, thanks to the excellent work
of Andreas König. Otherwise you will need to do a manual
installation.
All of these installation types have their own section:
L</CPAN installation>, L</Manual installation> and L</Configuration>.
The DBD::mysql Makefile.PL needs to know where to find your MySQL
installation. This may be achieved using command line switches
(see L</Configuration>) or automatically using the mysql_config binary
which comes with most MySQL distributions. If your MySQL distribution
contains mysql_config the easiest method is to ensure this binary
is on your path.
Typically, this is the case if you've installed the mysql library
from your systems' package manager.
e.g.
PATH=$PATH:/usr/local/mysql/bin
export PATH
As stated, to compile DBD::mysql you'll need a C compiler. This should
be the same compiler as the one used to build perl AND the mysql client
libraries. If you're on linux, this is most typically the case and you
need not worry. If you're on UNIX systems, you might want to pay
attention.
Also you'll need to get the MySQL client and development headers on
your system. The easiest is to get these from your package manager.
To run the tests that ship with the module, you'll need access to a
running MySQL server. This can be running on localhost, but it can also
be on a remote machine.
On Fedora the process is as follows. Please note that Fedora actually
ships with MariaDB but not with MySQL. This is not a problem, it
will work just as well.
In this example we install and start a local server for running the
tests against.
yum -y install make gcc mariadb-devel mariadb-libs mariadb-server
yum -y install "perl(Test::Deep)" "perl(Test::More)"
systemctl start mariadb.service
=head2 Environment Variables
For ease of use, you can set environment variables for
DBD::mysql installation. You can set any or all of the options, and
export them by putting them in your .bashrc or the like:
export DBD_MYSQL_CFLAGS=-I/usr/local/mysql/include/mysql
export DBD_MYSQL_LIBS="-L/usr/local/mysql/lib/mysql -lmysqlclient"
export DBD_MYSQL_EMBEDDED=
export DBD_MYSQL_CONFIG=mysql_config
export DBD_MYSQL_NOCATCHSTDERR=0
export DBD_MYSQL_NOFOUNDROWS=0
export DBD_MYSQL_NOSSL=
export DBD_MYSQL_TESTDB=test
export DBD_MYSQL_TESTHOST=localhost
export DBD_MYSQL_TESTPASSWORD=s3kr1+
export DBD_MYSQL_TESTPORT=3306
export DBD_MYSQL_TESTUSER=me
The most useful may be the host, database, port, socket, user, and password.
Installation will first look to your mysql_config, and then your
environment variables, and then it will guess with intelligent defaults.
=head2 CPAN installation
Installation of DBD::mysql can be incredibly easy:
cpan DBD::mysql
Please note that this will only work if the prerequisites are
fulfilled, which means you have a C-compiler installed, and you
have the development headers and mysql client libraries available
on your system.
If you are using the CPAN module for the first time, just answer
the questions by accepting the defaults which are fine in most
cases.
If you cannot get the CPAN module working, you might try manual
installation. If installation with CPAN fails because the your local
settings have been guessed wrong, you need to ensure MySQL's
mysql_config is on your path (see L</SOURCE INSTALLATION>) or
alternatively create a script called C<mysql_config>. This is
described in more details later. L</Configuration>.
=head2 Manual installation
For a manual installation you need to fetch the DBD::mysql
source distribution. The latest version is always available
from
https://metacpan.org/module/DBD::mysql
The name is typically something like
DBD-mysql-4.025.tar.gz
The archive needs to be extracted. On Windows you may use a tool
like 7-zip, on *nix you type
tar xf DBD-mysql-4.025.tar.gz
This will create a subdirectory DBD-mysql-4.025. Enter this
subdirectory and type
perl Makefile.PL
make
make test
(On Windows you may need to replace "make" with "dmake" or
"nmake".) If the tests seem to look fine, you may continue with
make install
If the compilation (make) or tests fail, you might need to
configure some settings.
For example you might choose a different database, the C
compiler or the linker might need some flags. L</Configuration>.
L</Compiler flags>. L</Linker flags>.
For Cygwin there is a special section below.
L</Cygwin>.
=head2 Configuration
The install script "Makefile.PL" can be configured via a lot of
switches. All switches can be used on the command line. For
example, the test database:
perl Makefile.PL --testdb=<db>
If you do not like configuring these switches on the command
line, you may alternatively create a script called C<mysql_config>.
This is described later on.
Available switches are:
=over
=item testdb
Name of the test database, defaults to B<test>.
=item testuser
Name of the test user, defaults to empty. If the name is empty,
then the currently logged in users name will be used.
=item testpassword
Password of the test user, defaults to empty.
=item testhost
Host name or IP number of the test database; defaults to localhost.
=item testport
Port number of the test database
=item ps-protcol=1 or 0
Whether to run the test suite using server prepared statements or driver
emulated prepared statements. ps-protocol=1 means use server prepare,
ps-protocol=0 means driver emulated.
=item cflags
This is a list of flags that you want to give to the C compiler.
The most important flag is the location of the MySQL header files.
For example, on Red Hat Linux the header files are in /usr/include/mysql
and you might try
-I/usr/include/mysql
On Windows the header files may be in C:\mysql\include and you might try
-IC:\mysql\include
The default flags are determined by running
mysql_config --cflags
More details on the C compiler flags can be found in the following
section. L</Compiler flags>.
=item libs
This is a list of flags that you want to give to the linker
or loader. The most important flags are the locations and names
of additional libraries. For example, on Red Hat Linux your
MySQL client libraries are in /usr/lib/mysql and you might try
-L/usr/lib/mysql -lmysqlclient -lz
On Windows the libraries may be in C:\mysql\lib and
-LC:\mysql\lib -lmysqlclient
might be a good choice. The default flags are determined by running
mysql_config --libs
More details on the linker flags can be found in a separate section.
L<Linker flags>.
=back
If a switch is not present on the command line, then the
script C<mysql_config> will be executed. This script comes
as part of the MySQL distribution. For example, to determine
the C compiler flags, we are executing
mysql_config --cflags
mysql_config --libs
If you want to configure your own settings for database name,
database user and so on, then you have to create a script with
the same name, that replies
=head2 Compiler flags
Note: the following info about compiler and linker flags, you shouldn't have
to use these options because Makefile.PL is pretty good at utilizing
mysql_config to get the flags that you need for a successful compile.
It is typically not so difficult to determine the appropriate
flags for the C compiler. The linker flags, which you find in
the next section, are another story.
The determination of the C compiler flags is usually left to
a configuration script called F<mysql_config>, which can be
invoked with
mysql_config --cflags
When doing so, it will emit a line with suggested C compiler
flags, for example like this:
-L/usr/include/mysql
The C compiler must find some header files. Header files have
the extension C<.h>. MySQL header files are, for example,
F<mysql.h> and F<mysql_version.h>. In most cases the header
files are not installed by default. For example, on Windows
it is an installation option of the MySQL setup program
(Custom installation), whether the header files are installed
or not. On Red Hat Linux, you need to install an RPM archive
F<mysql-devel> or F<MySQL-devel>.
If you know the location of the header files, then you will
need to add an option
-L<header directory>
to the C compiler flags, for example C<-L/usr/include/mysql>.
=head2 Linker flags
Appropriate linker flags are the most common source of problems
while installing DBD::mysql. I will only give a rough overview,
you'll find more details in the troubleshooting section.
L</KNOWN PROBLEMS>
The determination of the C compiler flags is usually left to
a configuration script called F<mysql_config>, which can be
invoked with
mysql_config --libs
When doing so, it will emit a line with suggested C compiler
flags, for example like this:
-L'/usr/lib/mysql' -lmysqlclient -lnsl -lm -lz -lcrypt
The following items typically need to be configured for the
linker:
=over
=item The mysqlclient library
The MySQL client library comes as part of the MySQL distribution.
Depending on your system it may be a file called
F<libmysqlclient.a> statically linked library, Unix
F<libmysqlclient.so> dynamically linked library, Unix
F<mysqlclient.lib> statically linked library, Windows
F<mysqlclient.dll> dynamically linked library, Windows
or something similar.
As in the case of the header files, the client library is typically
not installed by default. On Windows you will need to select them
while running the MySQL setup program (Custom installation). On
Red Hat Linux an RPM archive F<mysql-devel> or F<MySQL-devel> must
be installed.
The linker needs to know the location and name of the mysqlclient
library. This can be done by adding the flags
-L<lib directory> -lmysqlclient
or by adding the complete path name. Examples:
-L/usr/lib/mysql -lmysqlclient
-LC:\mysql\lib -lmysqlclient
If you would like to use the static libraries (and there are
excellent reasons to do so), you need to create a separate
directory, copy the static libraries to that place and use
the -L switch above to point to your new directory. For example:
mkdir /tmp/mysql-static
cp /usr/lib/mysql/*.a /tmp/mysql-static
perl Makefile.PL --libs="-L/tmp/mysql-static -lmysqlclient"
make
make test
make install
rm -rf /tmp/mysql-static
=item The gzip library
The MySQL client can use compression when talking to the MySQL
server, a nice feature when sending or receiving large texts over
a slow network.
On Unix you typically find the appropriate file name by running
ldconfig -p | grep libz
ldconfig -p | grep libgz
Once you know the name (libz.a or libgz.a is best), just add it
to the list of linker flags. If this seems to be causing problem
you may also try to link without gzip libraries.
=back
=head1 ENCRYPTED CONNECTIONS via SSL
Connecting to your servers over an encrypted connection (SSL) is only possible
if you enabled this setting at build time. Since version 4.034, this is the
default.
Attempting to connect to a server that requires an encrypted connection without
first having L<DBD::mysql> compiled with the C<--ssl> option will result in
an error that makes things appear as if your password is incorrect.
If you want to compile L<DBD::mysql> without SSL support, which you might
probably only want if you for some reason can't install libssl headers, you
can do this by passing the C<--nossl> option to Makefile.PL or by setting the
DBD_MYSQL_NOSSL environment variable to '1'.
=head1 MARIADB NATIVE CLIENT INSTALLATION
The MariaDB native client is another option for connecting to a MySQL·
database licensed LGPL 2.1. To build DBD::mysql against this client, you
will first need to build the client. Generally, this is done with
the following:
cd path/to/src/mariadb-native-client
cmake -G "Unix Makefiles'
make
sudo make install
Once the client is built and installed, you can build DBD::mysql against
it:
perl Makefile.PL --testuser=xxx --testpassword=xxx --testsocket=/path/to//mysqld.sock --mysql_config=/usr/local/bin/mariadb_config·
make
make test
make install
=head1 SPECIAL SYSTEMS
Below you find information on particular systems:
=head2 Mac OS X
Please see the the post at
L<https://discussions.apple.com/thread/3932531>
(Thanks to Kris Davey for pointing this out to me). I plan to see if I can get the build process
to be more intelligent about using build flags that work. It is very difficult as it's
not a driver problem per se but a problem in how one builds DBD::mysql with a binary client lib
built on a different compiler than the one the user is using.
Quite simply, using the binary MySQL installation from Oracle, you will need to first run:
perl Makefile.PL --mysql_config=/usr/local/mysql-5.6.16-osx10.7-x86_64/bin/mysql_config
There are some runtime issues you may encounter with OS X. Upon
running make test, you might encounter the error:
Error: Can't load '/Users/username/DBD-mysql/blib/arch/auto/DBD/mysql/mysql.bundle' for module DBD::mysql: dlopen(/Users/username/DBD-mysql/blib/arch/auto/DBD/mysql/mysql.bundle, 2): Library not loaded: libmysqlclient.18.dylib
To solve this issue, you need to set the library path, similar to LD_LIBRARY_PATH on other Unix variants, but on OS X you need to do the following (this is for a binary install of MySQL from Oracle)
export DYLD_LIBRARY_PATH=$DYLD_LIBRARY_PATH:/usr/local/mysql-5.6.16-osx10.7-x86_64/lib/
=head2 Cygwin
If you are a user of Cygwin you already
know, it contains a nicely running perl 5.6.1, installation of
additional modules usually works like a charm via the standard
procedure of
perl makefile.PL
make
make test
make install
The Windows binary distribution of MySQL runs smoothly under Cygwin.
You can start/stop the server and use all Windows clients without problem.
But to install DBD::mysql you have to take a little special action.
Don't attempt to build DBD::mysql against either the MySQL Windows or
Linux/Unix BINARY distributions: neither will work!
You MUST compile the MySQL clients yourself under Cygwin, to get a
'libmysqlclient.a' compiled under Cygwin. Really! You'll only need
that library and the header files, you don't need any other client parts.
Continue to use the Windows binaries. And don't attempt (currently) to
build the MySQL Server part, it is unnecessary, as MySQL AB does an
excellent job to deliver optimized binaries for the mainstream
operating systems, and it is told, that the server compiled under Cygwin is
unstable.
Install a MySQL server for testing against. You can install the regular
Windows MySQL server package on your Windows machine, or you can also
test against a MySQL server on a remote host.
=head3 Build MySQL clients under Cygwin:
download the MySQL LINUX source from
L<https://www.mysql.com/downloads>,
unpack mysql-<version>.tar.gz into some tmp location and from this directory
run configure:
./configure --prefix=/usr/local/mysql --without-server
This prepares the Makefile with the installed Cygwin features. It
takes some time, but should finish without error. The 'prefix', as
given, installs the whole Cygwin/MySQL thingy into a location not
normally in your PATH, so that you continue to use already installed
Windows binaries. The --without-server parameter tells configure to
only build the clients.
make
This builds all MySQL client parts ... be patient. It should finish
finally without any error.
make install
This installs the compiled client files under /usr/local/mysql/.
Remember, you don't need anything except the library under
/usr/local/mysql/lib and the headers under /usr/local/mysql/include!
Essentially you are now done with this part. If you want, you may try
your compiled binaries shortly; for that, do:
cd /usr/local/mysql/bin
./mysql -h 127.0.0.1
The host (-h) parameter 127.0.0.1 targets the local host, but forces
the mysql client to use a TCP/IP connection. The default would be a
pipe/socket connection (even if you say '-h localhost') and this
doesn't work between Cygwin and Windows (as far as I know).
If you have your MySQL server running on some other box, then please
substitute '127.0.0.1' with the name or IP-number of that box.
Please note, in my environment the 'mysql' client did not accept a
simple RETURN, I had to use CTRL-RETURN to send commands
... strange,
but I didn't attempt to fix that, as we are only interested in the
built lib and headers.
At the 'mysql>' prompt do a quick check:
mysql> use mysql
mysql> show tables;
mysql> select * from db;
mysql> exit
You are now ready to build DBD::mysql!
=head3 compile DBD::mysql
download and extract DBD-mysql-<version>.tar.gz from CPAN
cd into unpacked dir DBD-mysql-<version>
you probably did that already, if you are reading this!
cp /usr/local/mysql/bin/mysql_config .
This copies the executable script mentioned in the DBD::mysql docs
from your just built Cywin/MySQL client directory; it knows about
your Cygwin installation, especially about the right libraries to link
with.
perl Makefile.PL --testhost=127.0.0.1
The --testhost=127.0.0.1 parameter again forces a TCP/IP connection
to the MySQL server on the local host instead of a pipe/socket
connection for the 'make test' phase.
make
This should run without error
make test
make install
This installs DBD::mysql into the Perl hierarchy.
=head1 KNOWN PROBLEMS
=head2 no gzip on your system
Some Linux distributions don't come with a gzip library by default.
Running "make" terminates with an error message like
LD_RUN_PATH="/usr/lib/mysql:/lib:/usr/lib" gcc
-o blib/arch/auto/DBD/mysql/mysql.so -shared
-L/usr/local/lib dbdimp.o mysql.o -L/usr/lib/mysql
-lmysqlclient -lm -L/usr/lib/gcc-lib/i386-redhat-linux/2.96
-lgcc -lz
/usr/bin/ld: cannot find -lz
collect2: ld returned 1 exit status
make: *** [blib/arch/auto/DBD/mysql/mysql.so] Error 1
If this is the case for you, install an RPM archive like
libz-devel, libgz-devel, zlib-devel or gzlib-devel or something
similar.
=head2 different compiler for mysql and perl
If Perl was compiled with gcc or egcs, but MySQL was compiled
with another compiler or on another system, an error message like
this is very likely when running "Make test":
t/00base............install_driver(mysql) failed: Can't load
'../blib/arch/auto/DBD/mysql/mysql.so' for module DBD::mysql:
../blib/arch/auto/DBD/mysql/mysql.so: undefined symbol: _umoddi3
at /usr/local/perl-5.005/lib/5.005/i586-linux-thread/DynaLoader.pm
line 168.
This means, that your linker doesn't include libgcc.a. You have
the following options:
The solution is telling the linker to use libgcc. Run
gcc --print-libgcc-file
to determine the exact location of libgcc.a or for older versions
of gcc
gcc -v
to determine the directory. If you know the directory, add a
-L<directory> -lgcc
to the list of C compiler flags. L</Configuration>. L</Linker flags>.
=head1 SUPPORT
Finally, if everything else fails, you are not alone. First of
all, for an immediate answer, you should look into the archives
of the dbi-users mailing list, which is available at
L<http://groups.google.com/group/perl.dbi.users?hl=en&lr=>
To subscribe to this list, send and email to
dbi-users-subscribe@perl.org
If you don't find an appropriate posting and reply in the
mailing list, please post a question. Typically a reply will
be seen within one or two days.
NullP.pm 0000644 00000013650 15053110135 0006133 0 ustar 00 use strict;
{
package DBD::NullP;
require DBI;
require Carp;
our @EXPORT = qw(); # Do NOT @EXPORT anything.
our $VERSION = "12.014715";
# $Id: NullP.pm 14714 2011-02-22 17:27:07Z Tim $
#
# 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.
our $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 ======
our $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 ======
our $imp_data_size = 0;
use strict;
use Carp qw(croak);
# Added get_info to support tests in 10examp.t
sub get_info {
my ($dbh, $type) = @_;
if ($type == 29) { # identifier quote
return '"';
}
return;
}
# Added table_info to support tests in 10examp.t
sub table_info {
my ($dbh, $catalog, $schema, $table, $type) = @_;
my ($outer, $sth) = DBI::_new_sth($dbh, {
'Statement' => 'tables',
});
if (defined($type) && $type eq '%' && # special case for tables('','','','%')
grep {defined($_) && $_ eq ''} ($catalog, $schema, $table)) {
$outer->{dbd_nullp_data} = [[undef, undef, undef, 'TABLE', undef],
[undef, undef, undef, 'VIEW', undef],
[undef, undef, undef, 'ALIAS', undef]];
} elsif (defined($catalog) && $catalog eq '%' && # special case for tables('%','','')
grep {defined($_) && $_ eq ''} ($schema, $table)) {
$outer->{dbd_nullp_data} = [['catalog1', undef, undef, undef, undef],
['catalog2', undef, undef, undef, undef]];
} else {
$outer->{dbd_nullp_data} = [['catalog', 'schema', 'table1', 'TABLE']];
$outer->{dbd_nullp_data} = [['catalog', 'schema', 'table2', 'TABLE']];
$outer->{dbd_nullp_data} = [['catalog', 'schema', 'table3', 'TABLE']];
}
$outer->STORE(NUM_OF_FIELDS => 5);
$sth->STORE(Active => 1);
return $outer;
}
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;
} elsif ($attrib eq 'nullp_set_err') {
# a fake attribute to produce a test case where STORE issues a warning
$dbh->set_err($value, $value);
}
return $dbh->SUPER::STORE($attrib, $value);
}
sub ping { 1 }
sub disconnect {
shift->STORE(Active => 0);
}
}
{ package DBD::NullP::st; # ====== STATEMENT ======
our $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, successfully
1;
}
sub fetchrow_arrayref {
my $sth = shift;
my $data = shift @{$sth->{dbd_nullp_data}};
if (!$data || !@$data) {
$sth->finish; # no more data so finish
return undef;
}
return $sth->_set_fbav($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;
File/Developers.pod 0000644 00000050166 15053110135 0010241 0 ustar 00 =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_data { ... }
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::TableSource::FileSystem
Provides data sources and table information on database driver and database
handle level.
package DBD::File::TableSource::FileSystem;
sub data_sources ($;$)
{
my ($class, $drh, $attrs) = @_;
...
}
sub avail_tables
{
my ($class, $drh) = @_;
...
}
The C<data_sources> method is called when the user invokes any of the
following:
@ary = DBI->data_sources ($driver);
@ary = DBI->data_sources ($driver, \%attr);
@ary = $dbh->data_sources ();
@ary = $dbh->data_sources (\%attr);
The C<avail_tables> method is called when the user invokes any of the
following:
@names = $dbh->tables ($catalog, $schema, $table, $type);
$sth = $dbh->table_info ($catalog, $schema, $table, $type);
$sth = $dbh->table_info ($catalog, $schema, $table, $type, \%attr);
$dbh->func ("list_tables");
Every time where an C<\%attr> argument can be specified, this C<\%attr>
object's C<sql_table_source> attribute is preferred over the C<$dbh>
attribute or the driver default.
=head2 DBD::File::DataSource::Stream
package DBD::File::DataSource::Stream;
@DBD::File::DataSource::Stream::ISA = 'DBI::DBD::SqlEngine::DataSource';
sub complete_table_name
{
my ($self, $meta, $file, $respect_case) = @_;
...
}
Clears all meta attributes identifying a file: C<f_fqfn>, C<f_fqbn> and
C<f_fqln>. The table name is set according to C<$respect_case> and
C<< $meta->{sql_identifier_case} >> (SQL_IC_LOWER, SQL_IC_UPPER).
package DBD::File::DataSource::Stream;
sub apply_encoding
{
my ($self, $meta, $fn) = @_;
...
}
Applies the encoding from I<meta information> (C<< $meta->{f_encoding} >>)
to the file handled opened in C<open_data>.
package DBD::File::DataSource::Stream;
sub open_data
{
my ($self, $meta, $attrs, $flags) = @_;
...
}
Opens (C<dup (2)>) the file handle provided in C<< $meta->{f_file} >>.
package DBD::File::DataSource::Stream;
sub can_flock { ... }
Returns whether C<flock (2)> is available or not (avoids retesting in
subclasses).
=head2 DBD::File::DataSource::File
package DBD::File::DataSource::File;
sub complete_table_name ($$;$)
{
my ($self, $meta, $table, $respect_case) = @_;
...
}
The method C<complete_table_name> 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.
package DBD::File::DataSource::File;
sub open_data ($)
{
my ($self, $meta, $attrs, $flags) = @_;
...
}
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.
=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 parametrized 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 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 >>
and C<< f_lockfile >> 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-2013 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
File/Roadmap.pod 0000644 00000013473 15053110135 0007514 0 ustar 00 =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
re-implementation 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 focused 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
File/HowTo.pod 0000644 00000011624 15053110135 0007165 0 ustar 00 =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} >>. With C<DBD::File>
version C<0.41> and C<DBI::DBD::SqlEngine> version C<0.05>, this
consolidation moves to L<DBI::DBD::SqlEngine>. It's still the
C<< $dbh->{$drv_prefix . "_meta"} >> attribute which cares, so what you
learned at this place before, is still valid.
sub init_valid_attributes
{
my $dbh = $_[0];
$dbh->SUPER::init_valid_attributes ();
$dbh->{foo_valid_attrs} = { ... };
$dbh->{foo_readonly_attrs} = { ... };
$dbh->{foo_meta} = "foo_tables";
return $dbh;
}
See updates at L<DBI::DBD::SqlEngine::HowTo/User comfort>.
=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
mysql.pm 0000644 00000175106 15053110135 0006253 0 ustar 00 #!/usr/bin/perl
use strict;
use warnings;
require 5.008_001; # just as DBI
package DBD::mysql;
use DBI;
use DynaLoader();
use Carp;
our @ISA = qw(DynaLoader);
# please make sure the sub-version does not increase above '099'
# SQL_DRIVER_VER is formatted as dd.dd.dddd
# for version 5.x please switch to 5.00(_00) version numbering
# keep $VERSION in Bundle/DBD/mysql.pm in sync
our $VERSION = '4.046';
bootstrap DBD::mysql $VERSION;
our $err = 0; # holds error code for DBI::err
our $errstr = ""; # holds error string for DBI::errstr
our $drh = undef; # holds driver handle once initialised
my $methods_are_installed = 0;
sub driver{
return $drh if $drh;
my($class, $attr) = @_;
$class .= "::dr";
# not a 'my' since we use it above to prevent multiple drivers
$drh = DBI::_new_drh($class, { 'Name' => 'mysql',
'Version' => $VERSION,
'Err' => \$DBD::mysql::err,
'Errstr' => \$DBD::mysql::errstr,
'Attribution' => 'DBD::mysql by Patrick Galbraith'
});
if (!$methods_are_installed) {
DBD::mysql::db->install_method('mysql_fd');
DBD::mysql::db->install_method('mysql_async_result');
DBD::mysql::db->install_method('mysql_async_ready');
DBD::mysql::st->install_method('mysql_async_result');
DBD::mysql::st->install_method('mysql_async_ready');
$methods_are_installed++;
}
$drh;
}
sub CLONE {
undef $drh;
}
sub _OdbcParse($$$) {
my($class, $dsn, $hash, $args) = @_;
my($var, $val);
if (!defined($dsn)) {
return;
}
while (length($dsn)) {
if ($dsn =~ /([^:;]*\[.*]|[^:;]*)[:;](.*)/) {
$val = $1;
$dsn = $2;
$val =~ s/\[|]//g; # Remove [] if present, the rest of the code prefers plain IPv6 addresses
} else {
$val = $dsn;
$dsn = '';
}
if ($val =~ /([^=]*)=(.*)/) {
$var = $1;
$val = $2;
if ($var eq 'hostname' || $var eq 'host') {
$hash->{'host'} = $val;
} elsif ($var eq 'db' || $var eq 'dbname') {
$hash->{'database'} = $val;
} else {
$hash->{$var} = $val;
}
} else {
foreach $var (@$args) {
if (!defined($hash->{$var})) {
$hash->{$var} = $val;
last;
}
}
}
}
}
sub _OdbcParseHost ($$) {
my($class, $dsn) = @_;
my($hash) = {};
$class->_OdbcParse($dsn, $hash, ['host', 'port']);
($hash->{'host'}, $hash->{'port'});
}
sub AUTOLOAD {
my ($meth) = $DBD::mysql::AUTOLOAD;
my ($smeth) = $meth;
$smeth =~ s/(.*)\:\://;
my $val = constant($smeth, @_ ? $_[0] : 0);
if ($! == 0) { eval "sub $meth { $val }"; return $val; }
Carp::croak "$meth: Not defined";
}
1;
package DBD::mysql::dr; # ====== DRIVER ======
use strict;
use DBI qw(:sql_types);
use DBI::Const::GetInfoType;
sub connect {
my($drh, $dsn, $username, $password, $attrhash) = @_;
my($port);
my($cWarn);
my $connect_ref= { 'Name' => $dsn };
my $dbi_imp_data;
# Avoid warnings for undefined values
$username ||= '';
$password ||= '';
$attrhash ||= {};
$attrhash->{mysql_conn_attrs} ||= {};
$attrhash->{mysql_conn_attrs}->{'program_name'} ||= $0;
# create a 'blank' dbh
my($this, $privateAttrHash) = (undef, $attrhash);
$privateAttrHash = { %$privateAttrHash,
'Name' => $dsn,
'user' => $username,
'password' => $password
};
DBD::mysql->_OdbcParse($dsn, $privateAttrHash,
['database', 'host', 'port']);
if ($DBI::VERSION >= 1.49)
{
$dbi_imp_data = delete $attrhash->{dbi_imp_data};
$connect_ref->{'dbi_imp_data'} = $dbi_imp_data;
}
if (!defined($this = DBI::_new_dbh($drh,
$connect_ref,
$privateAttrHash)))
{
return undef;
}
DBD::mysql::db::_login($this, $dsn, $username, $password)
or $this = undef;
if ($this && ($ENV{MOD_PERL} || $ENV{GATEWAY_INTERFACE})) {
$this->{mysql_auto_reconnect} = 1;
}
$this;
}
sub data_sources {
my($self) = shift;
my($attributes) = shift;
my($host, $port, $user, $password) = ('', '', '', '');
if ($attributes) {
$host = $attributes->{host} || '';
$port = $attributes->{port} || '';
$user = $attributes->{user} || '';
$password = $attributes->{password} || '';
}
my(@dsn) = $self->func($host, $port, $user, $password, '_ListDBs');
my($i);
for ($i = 0; $i < @dsn; $i++) {
$dsn[$i] = "DBI:mysql:$dsn[$i]";
}
@dsn;
}
sub admin {
my($drh) = shift;
my($command) = shift;
my($dbname) = ($command eq 'createdb' || $command eq 'dropdb') ?
shift : '';
my($host, $port) = DBD::mysql->_OdbcParseHost(shift(@_) || '');
my($user) = shift || '';
my($password) = shift || '';
$drh->func(undef, $command,
$dbname || '',
$host || '',
$port || '',
$user, $password, '_admin_internal');
}
package DBD::mysql::db; # ====== DATABASE ======
use strict;
use DBI qw(:sql_types);
%DBD::mysql::db::db2ANSI = (
"INT" => "INTEGER",
"CHAR" => "CHAR",
"REAL" => "REAL",
"IDENT" => "DECIMAL"
);
### ANSI datatype mapping to MySQL datatypes
%DBD::mysql::db::ANSI2db = (
"CHAR" => "CHAR",
"VARCHAR" => "CHAR",
"LONGVARCHAR" => "CHAR",
"NUMERIC" => "INTEGER",
"DECIMAL" => "INTEGER",
"BIT" => "INTEGER",
"TINYINT" => "INTEGER",
"SMALLINT" => "INTEGER",
"INTEGER" => "INTEGER",
"BIGINT" => "INTEGER",
"REAL" => "REAL",
"FLOAT" => "REAL",
"DOUBLE" => "REAL",
"BINARY" => "CHAR",
"VARBINARY" => "CHAR",
"LONGVARBINARY" => "CHAR",
"DATE" => "CHAR",
"TIME" => "CHAR",
"TIMESTAMP" => "CHAR"
);
sub prepare {
my($dbh, $statement, $attribs)= @_;
return unless $dbh->func('_async_check');
# create a 'blank' dbh
my $sth = DBI::_new_sth($dbh, {'Statement' => $statement});
# Populate internal handle data.
if (!DBD::mysql::st::_prepare($sth, $statement, $attribs)) {
$sth = undef;
}
$sth;
}
sub db2ANSI {
my $self = shift;
my $type = shift;
return $DBD::mysql::db::db2ANSI{"$type"};
}
sub ANSI2db {
my $self = shift;
my $type = shift;
return $DBD::mysql::db::ANSI2db{"$type"};
}
sub admin {
my($dbh) = shift;
my($command) = shift;
my($dbname) = ($command eq 'createdb' || $command eq 'dropdb') ?
shift : '';
$dbh->{'Driver'}->func($dbh, $command, $dbname, '', '', '',
'_admin_internal');
}
sub _SelectDB ($$) {
die "_SelectDB is removed from this module; use DBI->connect instead.";
}
sub table_info ($) {
my ($dbh, $catalog, $schema, $table, $type, $attr) = @_;
$dbh->{mysql_server_prepare}||= 0;
my $mysql_server_prepare_save= $dbh->{mysql_server_prepare};
$dbh->{mysql_server_prepare}= 0;
my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS);
my @rows;
my $sponge = DBI->connect("DBI:Sponge:", '','')
or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");
# Return the list of catalogs
if (defined $catalog && $catalog eq "%" &&
(!defined($schema) || $schema eq "") &&
(!defined($table) || $table eq ""))
{
@rows = (); # Empty, because MySQL doesn't support catalogs (yet)
}
# Return the list of schemas
elsif (defined $schema && $schema eq "%" &&
(!defined($catalog) || $catalog eq "") &&
(!defined($table) || $table eq ""))
{
my $sth = $dbh->prepare("SHOW DATABASES")
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return undef);
$sth->execute()
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return DBI::set_err($dbh, $sth->err(), $sth->errstr()));
while (my $ref = $sth->fetchrow_arrayref())
{
push(@rows, [ undef, $ref->[0], undef, undef, undef ]);
}
}
# Return the list of table types
elsif (defined $type && $type eq "%" &&
(!defined($catalog) || $catalog eq "") &&
(!defined($schema) || $schema eq "") &&
(!defined($table) || $table eq ""))
{
@rows = (
[ undef, undef, undef, "TABLE", undef ],
[ undef, undef, undef, "VIEW", undef ],
);
}
# Special case: a catalog other than undef, "", or "%"
elsif (defined $catalog && $catalog ne "" && $catalog ne "%")
{
@rows = (); # Nothing, because MySQL doesn't support catalogs yet.
}
# Uh oh, we actually have a meaty table_info call. Work is required!
else
{
my @schemas;
# If no table was specified, we want them all
$table ||= "%";
# If something was given for the schema, we need to expand it to
# a list of schemas, since it may be a wildcard.
if (defined $schema && $schema ne "")
{
my $sth = $dbh->prepare("SHOW DATABASES LIKE " .
$dbh->quote($schema))
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return undef);
$sth->execute()
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return DBI::set_err($dbh, $sth->err(), $sth->errstr()));
while (my $ref = $sth->fetchrow_arrayref())
{
push @schemas, $ref->[0];
}
}
# Otherwise we want the current database
else
{
push @schemas, $dbh->selectrow_array("SELECT DATABASE()");
}
# Figure out which table types are desired
my ($want_tables, $want_views);
if (defined $type && $type ne "")
{
$want_tables = ($type =~ m/table/i);
$want_views = ($type =~ m/view/i);
}
else
{
$want_tables = $want_views = 1;
}
for my $database (@schemas)
{
my $sth = $dbh->prepare("SHOW /*!50002 FULL*/ TABLES FROM " .
$dbh->quote_identifier($database) .
" LIKE " . $dbh->quote($table))
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return undef);
$sth->execute() or
($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return DBI::set_err($dbh, $sth->err(), $sth->errstr()));
while (my $ref = $sth->fetchrow_arrayref())
{
my $type = (defined $ref->[1] &&
$ref->[1] =~ /view/i) ? 'VIEW' : 'TABLE';
next if $type eq 'TABLE' && not $want_tables;
next if $type eq 'VIEW' && not $want_views;
push @rows, [ undef, $database, $ref->[0], $type, undef ];
}
}
}
my $sth = $sponge->prepare("table_info",
{
rows => \@rows,
NUM_OF_FIELDS => scalar @names,
NAME => \@names,
})
or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()));
$dbh->{mysql_server_prepare}= $mysql_server_prepare_save;
return $sth;
}
sub _ListTables {
my $dbh = shift;
if (!$DBD::mysql::QUIET) {
warn "_ListTables is deprecated, use \$dbh->tables()";
}
return map { $_ =~ s/.*\.//; $_ } $dbh->tables();
}
sub column_info {
my ($dbh, $catalog, $schema, $table, $column) = @_;
return unless $dbh->func('_async_check');
$dbh->{mysql_server_prepare}||= 0;
my $mysql_server_prepare_save= $dbh->{mysql_server_prepare};
$dbh->{mysql_server_prepare}= 0;
# ODBC allows a NULL to mean all columns, so we'll accept undef
$column = '%' unless defined $column;
my $ER_NO_SUCH_TABLE= 1146;
my $table_id = $dbh->quote_identifier($catalog, $schema, $table);
my @names = qw(
TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME
DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS
NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF
SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH
ORDINAL_POSITION IS_NULLABLE CHAR_SET_CAT
CHAR_SET_SCHEM CHAR_SET_NAME COLLATION_CAT COLLATION_SCHEM COLLATION_NAME
UDT_CAT UDT_SCHEM UDT_NAME DOMAIN_CAT DOMAIN_SCHEM DOMAIN_NAME
SCOPE_CAT SCOPE_SCHEM SCOPE_NAME MAX_CARDINALITY
DTD_IDENTIFIER IS_SELF_REF
mysql_is_pri_key mysql_type_name mysql_values
mysql_is_auto_increment
);
my %col_info;
local $dbh->{FetchHashKeyName} = 'NAME_lc';
# only ignore ER_NO_SUCH_TABLE in internal_execute if issued from here
my $desc_sth = $dbh->prepare("DESCRIBE $table_id " . $dbh->quote($column));
my $desc = $dbh->selectall_arrayref($desc_sth, { Columns=>{} });
#return $desc_sth if $desc_sth->err();
if (my $err = $desc_sth->err())
{
# return the error, unless it is due to the table not
# existing per DBI spec
if ($err != $ER_NO_SUCH_TABLE)
{
$dbh->{mysql_server_prepare}= $mysql_server_prepare_save;
return undef;
}
$dbh->set_err(undef,undef);
$desc = [];
}
my $ordinal_pos = 0;
my @fields;
for my $row (@$desc)
{
my $type = $row->{type};
$type =~ m/^(\w+)(\((.+)\))?\s?(.*)?$/;
my $basetype = lc($1);
my $typemod = $3;
my $attr = $4;
push @fields, $row->{field};
my $info = $col_info{ $row->{field} }= {
TABLE_CAT => $catalog,
TABLE_SCHEM => $schema,
TABLE_NAME => $table,
COLUMN_NAME => $row->{field},
NULLABLE => ($row->{null} eq 'YES') ? 1 : 0,
IS_NULLABLE => ($row->{null} eq 'YES') ? "YES" : "NO",
TYPE_NAME => uc($basetype),
COLUMN_DEF => $row->{default},
ORDINAL_POSITION => ++$ordinal_pos,
mysql_is_pri_key => ($row->{key} eq 'PRI'),
mysql_type_name => $row->{type},
mysql_is_auto_increment => ($row->{extra} =~ /auto_increment/i ? 1 : 0),
};
#
# This code won't deal with a pathological case where a value
# contains a single quote followed by a comma, and doesn't unescape
# any escaped values. But who would use those in an enum or set?
#
my @type_params= ($typemod && index($typemod,"'")>=0) ?
("$typemod," =~ /'(.*?)',/g) # assume all are quoted
: split /,/, $typemod||''; # no quotes, plain list
s/''/'/g for @type_params; # undo doubling of quotes
my @type_attr= split / /, $attr||'';
$info->{DATA_TYPE}= SQL_VARCHAR();
if ($basetype =~ /^(char|varchar|\w*text|\w*blob)/)
{
$info->{DATA_TYPE}= SQL_CHAR() if $basetype eq 'char';
if ($type_params[0])
{
$info->{COLUMN_SIZE} = $type_params[0];
}
else
{
$info->{COLUMN_SIZE} = 65535;
$info->{COLUMN_SIZE} = 255 if $basetype =~ /^tiny/;
$info->{COLUMN_SIZE} = 16777215 if $basetype =~ /^medium/;
$info->{COLUMN_SIZE} = 4294967295 if $basetype =~ /^long/;
}
}
elsif ($basetype =~ /^(binary|varbinary)/)
{
$info->{COLUMN_SIZE} = $type_params[0];
# SQL_BINARY & SQL_VARBINARY are tempting here but don't match the
# semantics for mysql (not hex). SQL_CHAR & SQL_VARCHAR are correct here.
$info->{DATA_TYPE} = ($basetype eq 'binary') ? SQL_CHAR() : SQL_VARCHAR();
}
elsif ($basetype =~ /^(enum|set)/)
{
if ($basetype eq 'set')
{
$info->{COLUMN_SIZE} = length(join ",", @type_params);
}
else
{
my $max_len = 0;
length($_) > $max_len and $max_len = length($_) for @type_params;
$info->{COLUMN_SIZE} = $max_len;
}
$info->{"mysql_values"} = \@type_params;
}
elsif ($basetype =~ /int/ || $basetype eq 'bit' )
{
# big/medium/small/tiny etc + unsigned?
$info->{DATA_TYPE} = SQL_INTEGER();
$info->{NUM_PREC_RADIX} = 10;
$info->{COLUMN_SIZE} = $type_params[0];
}
elsif ($basetype =~ /^decimal/)
{
$info->{DATA_TYPE} = SQL_DECIMAL();
$info->{NUM_PREC_RADIX} = 10;
$info->{COLUMN_SIZE} = $type_params[0];
$info->{DECIMAL_DIGITS} = $type_params[1];
}
elsif ($basetype =~ /^(float|double)/)
{
$info->{DATA_TYPE} = ($basetype eq 'float') ? SQL_FLOAT() : SQL_DOUBLE();
$info->{NUM_PREC_RADIX} = 2;
$info->{COLUMN_SIZE} = ($basetype eq 'float') ? 32 : 64;
}
elsif ($basetype =~ /date|time/)
{
# date/datetime/time/timestamp
if ($basetype eq 'time' or $basetype eq 'date')
{
#$info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TYPE_TIME() : SQL_TYPE_DATE();
$info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TIME() : SQL_DATE();
$info->{COLUMN_SIZE} = ($basetype eq 'time') ? 8 : 10;
}
else
{
# datetime/timestamp
#$info->{DATA_TYPE} = SQL_TYPE_TIMESTAMP();
$info->{DATA_TYPE} = SQL_TIMESTAMP();
$info->{SQL_DATA_TYPE} = SQL_DATETIME();
$info->{SQL_DATETIME_SUB} = $info->{DATA_TYPE} - ($info->{SQL_DATA_TYPE} * 10);
$info->{COLUMN_SIZE} = ($basetype eq 'datetime') ? 19 : $type_params[0] || 14;
}
$info->{DECIMAL_DIGITS}= 0; # no fractional seconds
}
elsif ($basetype eq 'year')
{
# no close standard so treat as int
$info->{DATA_TYPE} = SQL_INTEGER();
$info->{NUM_PREC_RADIX} = 10;
$info->{COLUMN_SIZE} = 4;
}
else
{
Carp::carp("column_info: unrecognized column type '$basetype' of $table_id.$row->{field} treated as varchar");
}
$info->{SQL_DATA_TYPE} ||= $info->{DATA_TYPE};
#warn Dumper($info);
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or ( $dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"));
my $sth = $sponge->prepare("column_info $table", {
rows => [ map { [ @{$_}{@names} ] } map { $col_info{$_} } @fields ],
NUM_OF_FIELDS => scalar @names,
NAME => \@names,
}) or
return ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
$dbh->DBI::set_err($sponge->err(), $sponge->errstr()));
$dbh->{mysql_server_prepare}= $mysql_server_prepare_save;
return $sth;
}
sub primary_key_info {
my ($dbh, $catalog, $schema, $table) = @_;
return unless $dbh->func('_async_check');
$dbh->{mysql_server_prepare}||= 0;
my $mysql_server_prepare_save= $dbh->{mysql_server_prepare};
my $table_id = $dbh->quote_identifier($catalog, $schema, $table);
my @names = qw(
TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME
);
my %col_info;
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $desc_sth = $dbh->prepare("SHOW KEYS FROM $table_id");
my $desc= $dbh->selectall_arrayref($desc_sth, { Columns=>{} });
my $ordinal_pos = 0;
for my $row (grep { $_->{key_name} eq 'PRIMARY'} @$desc)
{
$col_info{ $row->{column_name} }= {
TABLE_CAT => $catalog,
TABLE_SCHEM => $schema,
TABLE_NAME => $table,
COLUMN_NAME => $row->{column_name},
KEY_SEQ => $row->{seq_in_index},
PK_NAME => $row->{key_name},
};
}
my $sponge = DBI->connect("DBI:Sponge:", '','')
or
($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"));
my $sth= $sponge->prepare("primary_key_info $table", {
rows => [
map { [ @{$_}{@names} ] }
sort { $a->{KEY_SEQ} <=> $b->{KEY_SEQ} }
values %col_info
],
NUM_OF_FIELDS => scalar @names,
NAME => \@names,
}) or
($dbh->{mysql_server_prepare}= $mysql_server_prepare_save &&
return $dbh->DBI::set_err($sponge->err(), $sponge->errstr()));
$dbh->{mysql_server_prepare}= $mysql_server_prepare_save;
return $sth;
}
sub foreign_key_info {
my ($dbh,
$pk_catalog, $pk_schema, $pk_table,
$fk_catalog, $fk_schema, $fk_table,
) = @_;
return unless $dbh->func('_async_check');
# INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6
# no one is going to be running 5.0.6, taking out the check for $point > .6
my ($maj, $min, $point) = _version($dbh);
return if $maj < 5 ;
my $sql = <<'EOF';
SELECT NULL AS PKTABLE_CAT,
A.REFERENCED_TABLE_SCHEMA AS PKTABLE_SCHEM,
A.REFERENCED_TABLE_NAME AS PKTABLE_NAME,
A.REFERENCED_COLUMN_NAME AS PKCOLUMN_NAME,
A.TABLE_CATALOG AS FKTABLE_CAT,
A.TABLE_SCHEMA AS FKTABLE_SCHEM,
A.TABLE_NAME AS FKTABLE_NAME,
A.COLUMN_NAME AS FKCOLUMN_NAME,
A.ORDINAL_POSITION AS KEY_SEQ,
NULL AS UPDATE_RULE,
NULL AS DELETE_RULE,
A.CONSTRAINT_NAME AS FK_NAME,
NULL AS PK_NAME,
NULL AS DEFERABILITY,
NULL AS UNIQUE_OR_PRIMARY
FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE A,
INFORMATION_SCHEMA.TABLE_CONSTRAINTS B
WHERE A.TABLE_SCHEMA = B.TABLE_SCHEMA AND A.TABLE_NAME = B.TABLE_NAME
AND A.CONSTRAINT_NAME = B.CONSTRAINT_NAME AND B.CONSTRAINT_TYPE IS NOT NULL
EOF
my @where;
my @bind;
# catalogs are not yet supported by MySQL
# if (defined $pk_catalog) {
# push @where, 'A.REFERENCED_TABLE_CATALOG = ?';
# push @bind, $pk_catalog;
# }
if (defined $pk_schema) {
push @where, 'A.REFERENCED_TABLE_SCHEMA = ?';
push @bind, $pk_schema;
}
if (defined $pk_table) {
push @where, 'A.REFERENCED_TABLE_NAME = ?';
push @bind, $pk_table;
}
# if (defined $fk_catalog) {
# push @where, 'A.TABLE_CATALOG = ?';
# push @bind, $fk_schema;
# }
if (defined $fk_schema) {
push @where, 'A.TABLE_SCHEMA = ?';
push @bind, $fk_schema;
}
if (defined $fk_table) {
push @where, 'A.TABLE_NAME = ?';
push @bind, $fk_table;
}
if (@where) {
$sql .= ' AND ';
$sql .= join ' AND ', @where;
}
$sql .= " ORDER BY A.TABLE_SCHEMA, A.TABLE_NAME, A.ORDINAL_POSITION";
local $dbh->{FetchHashKeyName} = 'NAME_uc';
my $sth = $dbh->prepare($sql);
$sth->execute(@bind);
return $sth;
}
# #86030: PATCH: adding statistics_info support
# Thank you to David Dick http://search.cpan.org/~ddick/
sub statistics_info {
my ($dbh,
$catalog, $schema, $table,
$unique_only, $quick,
) = @_;
return unless $dbh->func('_async_check');
# INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6
# no one is going to be running 5.0.6, taking out the check for $point > .6
my ($maj, $min, $point) = _version($dbh);
return if $maj < 5 ;
my $sql = <<'EOF';
SELECT TABLE_CATALOG AS TABLE_CAT,
TABLE_SCHEMA AS TABLE_SCHEM,
TABLE_NAME AS TABLE_NAME,
NON_UNIQUE AS NON_UNIQUE,
NULL AS INDEX_QUALIFIER,
INDEX_NAME AS INDEX_NAME,
LCASE(INDEX_TYPE) AS TYPE,
SEQ_IN_INDEX AS ORDINAL_POSITION,
COLUMN_NAME AS COLUMN_NAME,
COLLATION AS ASC_OR_DESC,
CARDINALITY AS CARDINALITY,
NULL AS PAGES,
NULL AS FILTER_CONDITION
FROM INFORMATION_SCHEMA.STATISTICS
EOF
my @where;
my @bind;
# catalogs are not yet supported by MySQL
# if (defined $catalog) {
# push @where, 'TABLE_CATALOG = ?';
# push @bind, $catalog;
# }
if (defined $schema) {
push @where, 'TABLE_SCHEMA = ?';
push @bind, $schema;
}
if (defined $table) {
push @where, 'TABLE_NAME = ?';
push @bind, $table;
}
if (@where) {
$sql .= ' WHERE ';
$sql .= join ' AND ', @where;
}
$sql .= " ORDER BY TABLE_SCHEMA, TABLE_NAME, ORDINAL_POSITION";
local $dbh->{FetchHashKeyName} = 'NAME_uc';
my $sth = $dbh->prepare($sql);
$sth->execute(@bind);
return $sth;
}
sub _version {
my $dbh = shift;
return
$dbh->get_info($DBI::Const::GetInfoType::GetInfoType{SQL_DBMS_VER})
=~ /(\d+)\.(\d+)\.(\d+)/;
}
####################
# get_info()
# Generated by DBI::DBD::Metadata
sub get_info {
my($dbh, $info_type) = @_;
return unless $dbh->func('_async_check');
require DBD::mysql::GetInfo;
my $v = $DBD::mysql::GetInfo::info{int($info_type)};
$v = $v->($dbh) if ref $v eq 'CODE';
return $v;
}
BEGIN {
my @needs_async_check = qw/data_sources quote_identifier begin_work/;
foreach my $method (@needs_async_check) {
no strict 'refs';
my $super = "SUPER::$method";
*$method = sub {
my $h = shift;
return unless $h->func('_async_check');
return $h->$super(@_);
};
}
}
package DBD::mysql::st; # ====== STATEMENT ======
use strict;
BEGIN {
my @needs_async_result = qw/fetchrow_hashref fetchall_hashref/;
my @needs_async_check = qw/bind_param_array bind_col bind_columns execute_for_fetch/;
foreach my $method (@needs_async_result) {
no strict 'refs';
my $super = "SUPER::$method";
*$method = sub {
my $sth = shift;
if(defined $sth->mysql_async_ready) {
return unless $sth->mysql_async_result;
}
return $sth->$super(@_);
};
}
foreach my $method (@needs_async_check) {
no strict 'refs';
my $super = "SUPER::$method";
*$method = sub {
my $h = shift;
return unless $h->func('_async_check');
return $h->$super(@_);
};
}
}
1;
__END__
=pod
=encoding utf8
=head1 NAME
DBD::mysql - MySQL driver for the Perl5 Database Interface (DBI)
=head1 SYNOPSIS
use DBI;
my $dsn = "DBI:mysql:database=$database;host=$hostname;port=$port";
my $dbh = DBI->connect($dsn, $user, $password);
my $sth = $dbh->prepare(
'SELECT id, first_name, last_name FROM authors WHERE last_name = ?')
or die "prepare statement failed: $dbh->errstr()";
$sth->execute('Eggers') or die "execution failed: $dbh->errstr()";
print $sth->rows . " rows found.\n";
while (my $ref = $sth->fetchrow_hashref()) {
print "Found a row: id = $ref->{'id'}, fn = $ref->{'first_name'}\n";
}
$sth->finish;
=head1 EXAMPLE
#!/usr/bin/perl
use strict;
use warnings;
use DBI;
# Connect to the database.
my $dbh = DBI->connect("DBI:mysql:database=test;host=localhost",
"joe", "joe's password",
{'RaiseError' => 1});
# Drop table 'foo'. This may fail, if 'foo' doesn't exist
# Thus we put an eval around it.
eval { $dbh->do("DROP TABLE foo") };
print "Dropping foo failed: $@\n" if $@;
# Create a new table 'foo'. This must not fail, thus we don't
# catch errors.
$dbh->do("CREATE TABLE foo (id INTEGER, name VARCHAR(20))");
# INSERT some data into 'foo'. We are using $dbh->quote() for
# quoting the name.
$dbh->do("INSERT INTO foo VALUES (1, " . $dbh->quote("Tim") . ")");
# same thing, but using placeholders (recommended!)
$dbh->do("INSERT INTO foo VALUES (?, ?)", undef, 2, "Jochen");
# now retrieve data from the table.
my $sth = $dbh->prepare("SELECT * FROM foo");
$sth->execute();
while (my $ref = $sth->fetchrow_hashref()) {
print "Found a row: id = $ref->{'id'}, name = $ref->{'name'}\n";
}
$sth->finish();
# Disconnect from the database.
$dbh->disconnect();
=head1 DESCRIPTION
B<DBD::mysql> is the Perl5 Database Interface driver for the MySQL
database. In other words: DBD::mysql is an interface between the Perl
programming language and the MySQL programming API that comes with
the MySQL relational database management system. Most functions
provided by this programming API are supported. Some rarely used
functions are missing, mainly because no-one ever requested
them. :-)
In what follows we first discuss the use of DBD::mysql,
because this is what you will need the most. For installation, see the
separate document L<DBD::mysql::INSTALL>.
See L</"EXAMPLE"> for a simple example above.
From perl you activate the interface with the statement
use DBI;
After that you can connect to multiple MySQL database servers
and send multiple queries to any of them via a simple object oriented
interface. Two types of objects are available: database handles and
statement handles. Perl returns a database handle to the connect
method like so:
$dbh = DBI->connect("DBI:mysql:database=$db;host=$host",
$user, $password, {RaiseError => 1});
Once you have connected to a database, you can execute SQL
statements with:
my $query = sprintf("INSERT INTO foo VALUES (%d, %s)",
$number, $dbh->quote("name"));
$dbh->do($query);
See L<DBI> for details on the quote and do methods. An alternative
approach is
$dbh->do("INSERT INTO foo VALUES (?, ?)", undef,
$number, $name);
in which case the quote method is executed automatically. See also
the bind_param method in L<DBI>. See L</"DATABASE HANDLES"> below
for more details on database handles.
If you want to retrieve results, you need to create a so-called
statement handle with:
$sth = $dbh->prepare("SELECT * FROM $table");
$sth->execute();
This statement handle can be used for multiple things. First of all
you can retrieve a row of data:
my $row = $sth->fetchrow_hashref();
If your table has columns ID and NAME, then $row will be hash ref with
keys ID and NAME. See L</"STATEMENT HANDLES"> below for more details on
statement handles.
But now for a more formal approach:
=head2 Class Methods
=over
=item B<connect>
use DBI;
$dsn = "DBI:mysql:$database";
$dsn = "DBI:mysql:database=$database;host=$hostname";
$dsn = "DBI:mysql:database=$database;host=$hostname;port=$port";
$dbh = DBI->connect($dsn, $user, $password);
The C<database> is not a required attribute, but please note that MySQL
has no such thing as a default database. If you don't specify the database
at connection time your active database will be null and you'd need to prefix
your tables with the database name; i.e. 'SELECT * FROM mydb.mytable'.
This is similar to the behavior of the mysql command line client. Also,
'SELECT DATABASE()' will return the current database active for the handle.
=over
=item host
=item port
The hostname, if not specified or specified as '' or 'localhost', will
default to a MySQL server running on the local machine using the default for
the UNIX socket. To connect to a MySQL server on the local machine via TCP,
you must specify the loopback IP address (127.0.0.1) as the host.
Should the MySQL server be running on a non-standard port number,
you may explicitly state the port number to connect to in the C<hostname>
argument, by concatenating the I<hostname> and I<port number> together
separated by a colon ( C<:> ) character or by using the C<port> argument.
To connect to a MySQL server on localhost using TCP/IP, you must specify the
hostname as 127.0.0.1 (with the optional port).
When connecting to a MySQL Server with IPv6, a bracketed IPv6 address should be used.
Example DSN:
my $dsn = "DBI:mysql:;host=[1a12:2800:6f2:85::f20:8cf];port=3306";
=item mysql_client_found_rows
Enables (TRUE value) or disables (FALSE value) the flag CLIENT_FOUND_ROWS
while connecting to the MySQL server. This has a somewhat funny effect:
Without mysql_client_found_rows, if you perform a query like
UPDATE $table SET id = 1 WHERE id = 1;
then the MySQL engine will always return 0, because no rows have changed.
With mysql_client_found_rows however, it will return the number of rows
that have an id 1, as some people are expecting. (At least for compatibility
to other engines.)
=item mysql_compression
If your DSN contains the option "mysql_compression=1", then the communication
between client and server will be compressed.
=item mysql_connect_timeout
If your DSN contains the option "mysql_connect_timeout=##", the connect
request to the server will timeout if it has not been successful after
the given number of seconds.
=item mysql_write_timeout
If your DSN contains the option "mysql_write_timeout=##", the write
operation to the server will timeout if it has not been successful after
the given number of seconds.
=item mysql_read_timeout
If your DSN contains the option "mysql_read_timeout=##", the read
operation to the server will timeout if it has not been successful after
the given number of seconds.
=item mysql_init_command
If your DSN contains the option "mysql_init_command=##", then
this SQL statement is executed when connecting to the MySQL server.
It is automatically re-executed if reconnection occurs.
=item mysql_skip_secure_auth
This option is for older mysql databases that don't have secure auth set.
=item mysql_read_default_file
=item mysql_read_default_group
These options can be used to read a config file like /etc/my.cnf or
~/.my.cnf. By default MySQL's C client library doesn't use any config
files unlike the client programs (mysql, mysqladmin, ...) that do, but
outside of the C client library. Thus you need to explicitly request
reading a config file, as in
$dsn = "DBI:mysql:test;mysql_read_default_file=/home/joe/my.cnf";
$dbh = DBI->connect($dsn, $user, $password)
The option mysql_read_default_group can be used to specify the default
group in the config file: Usually this is the I<client> group, but
see the following example:
[client]
host=localhost
[perl]
host=perlhost
(Note the order of the entries! The example won't work, if you reverse
the [client] and [perl] sections!)
If you read this config file, then you'll be typically connected to
I<localhost>. However, by using
$dsn = "DBI:mysql:test;mysql_read_default_group=perl;"
. "mysql_read_default_file=/home/joe/my.cnf";
$dbh = DBI->connect($dsn, $user, $password);
you'll be connected to I<perlhost>. Note that if you specify a
default group and do not specify a file, then the default config
files will all be read. See the documentation of
the C function mysql_options() for details.
=item mysql_socket
It is possible to choose the Unix socket that is
used for connecting to the server. This is done, for example, with
mysql_socket=/dev/mysql
Usually there's no need for this option, unless you are using another
location for the socket than that built into the client.
=item mysql_ssl
A true value turns on the CLIENT_SSL flag when connecting to the MySQL
server and enforce SSL encryption. A false value (which is default)
disable SSL encryption with the MySQL server.
When enabling SSL encryption you should set also other SSL options,
at least mysql_ssl_ca_file or mysql_ssl_ca_path.
mysql_ssl=1 mysql_ssl_verify_server_cert=1 mysql_ssl_ca_file=/path/to/ca_cert.pem
This means that your communication with the server will be encrypted.
Please note that this can only work if you enabled SSL when compiling
DBD::mysql; this is the default starting version 4.034.
See L<DBD::mysql::INSTALL> for more details.
=item mysql_ssl_ca_file
The path to a file in PEM format that contains a list of trusted SSL
certificate authorities.
When set MySQL server certificate is checked that it is signed by some
CA certificate in the list. Common Name value is not verified unless
C<mysql_ssl_verify_server_cert> is enabled.
=item mysql_ssl_ca_path
The path to a directory that contains trusted SSL certificate authority
certificates in PEM format.
When set MySQL server certificate is checked that it is signed by some
CA certificate in the list. Common Name value is not verified unless
C<mysql_ssl_verify_server_cert> is enabled.
Please note that this option is supported only if your MySQL client was
compiled with OpenSSL library, and not with default yaSSL library.
=item mysql_ssl_verify_server_cert
Checks the server's Common Name value in the certificate that the server
sends to the client. The client verifies that name against the host name
the client uses for connecting to the server, and the connection fails if
there is a mismatch. For encrypted connections, this option helps prevent
man-in-the-middle attacks.
Verification of the host name is disabled by default.
=item mysql_ssl_client_key
The name of the SSL key file in PEM format to use for establishing
a secure connection.
=item mysql_ssl_client_cert
The name of the SSL certificate file in PEM format to use for
establishing a secure connection.
=item mysql_ssl_cipher
A list of permissible ciphers to use for connection encryption. If no
cipher in the list is supported, encrypted connections will not work.
mysql_ssl_cipher=AES128-SHA
mysql_ssl_cipher=DHE-RSA-AES256-SHA:AES128-SHA
=item mysql_ssl_optional
Setting C<mysql_ssl_optional> to true disables strict SSL enforcement
and makes SSL connection optional. This option opens security hole
for man-in-the-middle attacks. Default value is false which means
that C<mysql_ssl> set to true enforce SSL encryption.
This option was introduced in 4.043 version of DBD::mysql. Due to
L<The BACKRONYM|http://backronym.fail/> and L<The Riddle|http://riddle.link/>
vulnerabilities in libmysqlclient library, enforcement of SSL
encryption was not possbile and therefore C<mysql_ssl_optional=1>
was effectively set for all DBD::mysql versions prior to 4.043.
Starting with 4.043, DBD::mysql with C<mysql_ssl=1> could refuse
connection to MySQL server if underlaying libmysqlclient library is
vulnerable. Option C<mysql_ssl_optional> can be used to make SSL
connection vulnerable.
=item mysql_local_infile
The LOCAL capability for LOAD DATA may be disabled
in the MySQL client library by default. If your DSN contains the option
"mysql_local_infile=1", LOAD DATA LOCAL will be enabled. (However,
this option is *ineffective* if the server has also been configured to
disallow LOCAL.)
=item mysql_multi_statements
Support for multiple statements separated by a semicolon
(;) may be enabled by using this option. Enabling this option may cause
problems if server-side prepared statements are also enabled.
=item mysql_server_prepare
This option is used to enable server side prepared statements.
To use server side prepared statements, all you need to do is set the variable
mysql_server_prepare in the connect:
$dbh = DBI->connect(
"DBI:mysql:database=test;host=localhost;mysql_server_prepare=1",
"",
"",
{ RaiseError => 1, AutoCommit => 1 }
);
or:
$dbh = DBI->connect(
"DBI:mysql:database=test;host=localhost",
"",
"",
{ RaiseError => 1, AutoCommit => 1, mysql_server_prepare => 1 }
);
There are many benefits to using server side prepare statements, mostly if you are
performing many inserts because of that fact that a single statement is prepared
to accept multiple insert values.
To make sure that the 'make test' step tests whether server prepare works, you just
need to export the env variable MYSQL_SERVER_PREPARE:
export MYSQL_SERVER_PREPARE=1
Please note that mysql server cannot prepare or execute some prepared statements.
In this case DBD::mysql fallbacks to normal non-prepared statement and tries again.
=item mysql_server_prepare_disable_fallback
This option disable fallback to normal non-prepared statement when mysql server
does not support execution of current statement as prepared.
Useful when you want to be sure that statement is going to be executed as
server side prepared. Error message and code in case of failure is propagated
back to DBI.
=item mysql_embedded_options
The option <mysql_embedded_options> can be used to pass 'command-line'
options to embedded server.
Example:
use DBI;
$testdsn="DBI:mysqlEmb:database=test;mysql_embedded_options=--help,--verbose";
$dbh = DBI->connect($testdsn,"a","b");
This would cause the command line help to the embedded MySQL server library
to be printed.
=item mysql_embedded_groups
The option <mysql_embedded_groups> can be used to specify the groups in the
config file(I<my.cnf>) which will be used to get options for embedded server.
If not specified [server] and [embedded] groups will be used.
Example:
$testdsn="DBI:mysqlEmb:database=test;mysql_embedded_groups=embedded_server,common";
=item mysql_conn_attrs
The option <mysql_conn_attrs> is a hash of attribute names and values which can be
used to send custom connection attributes to the server. Some attributes like
'_os', '_platform', '_client_name' and '_client_version' are added by libmysqlclient
and 'program_name' is added by DBD::mysql.
You can then later read these attributes from the performance schema tables which
can be quite helpful for profiling your database or creating statistics.
You'll have to use a MySQL 5.6 server and libmysqlclient or newer to leverage this
feature.
my $dbh= DBI->connect($dsn, $user, $password,
{ AutoCommit => 0,
mysql_conn_attrs => {
foo => 'bar',
wiz => 'bang'
},
});
Now you can select the results from the performance schema tables. You can do this
in the same session, but also afterwards. It can be very useful to answer questions
like 'which script sent this query?'.
my $results = $dbh->selectall_hashref(
'SELECT * FROM performance_schema.session_connect_attrs',
'ATTR_NAME'
);
This returns:
$result = {
'foo' => {
'ATTR_VALUE' => 'bar',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => 'foo',
'ORDINAL_POSITION' => '6'
},
'wiz' => {
'ATTR_VALUE' => 'bang',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => 'wiz',
'ORDINAL_POSITION' => '3'
},
'program_name' => {
'ATTR_VALUE' => './foo.pl',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => 'program_name',
'ORDINAL_POSITION' => '5'
},
'_client_name' => {
'ATTR_VALUE' => 'libmysql',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => '_client_name',
'ORDINAL_POSITION' => '1'
},
'_client_version' => {
'ATTR_VALUE' => '5.6.24',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => '_client_version',
'ORDINAL_POSITION' => '7'
},
'_os' => {
'ATTR_VALUE' => 'osx10.8',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => '_os',
'ORDINAL_POSITION' => '0'
},
'_pid' => {
'ATTR_VALUE' => '59860',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => '_pid',
'ORDINAL_POSITION' => '2'
},
'_platform' => {
'ATTR_VALUE' => 'x86_64',
'PROCESSLIST_ID' => '3',
'ATTR_NAME' => '_platform',
'ORDINAL_POSITION' => '4'
}
};
=back
=back
=head2 Private MetaData Methods
=over
=item B<ListDBs>
my $drh = DBI->install_driver("mysql");
@dbs = $drh->func("$hostname:$port", '_ListDBs');
@dbs = $drh->func($hostname, $port, '_ListDBs');
@dbs = $dbh->func('_ListDBs');
Returns a list of all databases managed by the MySQL server
running on C<$hostname>, port C<$port>. This is a legacy
method. Instead, you should use the portable method
@dbs = DBI->data_sources("mysql");
=back
=head1 DATABASE HANDLES
The DBD::mysql driver supports the following attributes of database
handles (read only):
$errno = $dbh->{'mysql_errno'};
$error = $dbh->{'mysql_error'};
$info = $dbh->{'mysql_hostinfo'};
$info = $dbh->{'mysql_info'};
$insertid = $dbh->{'mysql_insertid'};
$info = $dbh->{'mysql_protoinfo'};
$info = $dbh->{'mysql_serverinfo'};
$info = $dbh->{'mysql_stat'};
$threadId = $dbh->{'mysql_thread_id'};
These correspond to mysql_errno(), mysql_error(), mysql_get_host_info(),
mysql_info(), mysql_insert_id(), mysql_get_proto_info(),
mysql_get_server_info(), mysql_stat() and mysql_thread_id(),
respectively.
=over 2
=item mysql_clientinfo
List information of the MySQL client library that DBD::mysql was built
against:
print "$dbh->{mysql_clientinfo}\n";
5.2.0-MariaDB
=item mysql_clientversion
print "$dbh->{mysql_clientversion}\n";
50200
=item mysql_serverversion
print "$dbh->{mysql_serverversion}\n";
50200
=item mysql_dbd_stats
$info_hashref = $dhb->{mysql_dbd_stats};
DBD::mysql keeps track of some statistics in the mysql_dbd_stats attribute.
The following stats are being maintained:
=over 8
=item auto_reconnects_ok
The number of times that DBD::mysql successfully reconnected to the mysql
server.
=item auto_reconnects_failed
The number of times that DBD::mysql tried to reconnect to mysql but failed.
=back
=back
The DBD::mysql driver also supports the following attributes of database
handles (read/write):
=over
=item mysql_auto_reconnect
This attribute determines whether DBD::mysql will automatically reconnect
to mysql if the connection be lost. This feature defaults to off; however,
if either the GATEWAY_INTERFACE or MOD_PERL environment variable is set,
DBD::mysql will turn mysql_auto_reconnect on. Setting mysql_auto_reconnect
to on is not advised if 'lock tables' is used because if DBD::mysql reconnect
to mysql all table locks will be lost. This attribute is ignored when
AutoCommit is turned off, and when AutoCommit is turned off, DBD::mysql will
not automatically reconnect to the server.
It is also possible to set the default value of the C<mysql_auto_reconnect>
attribute for the $dbh by passing it in the C<\%attr> hash for C<DBI->connect>.
$dbh->{mysql_auto_reconnect} = 1;
or
my $dbh = DBI->connect($dsn, $user, $password, {
mysql_auto_reconnect => 1,
});
Note that if you are using a module or framework that performs reconnections
for you (for example L<DBIx::Connector> in fixup mode), this value must be set
to 0.
=item mysql_use_result
This attribute forces the driver to use mysql_use_result rather than
mysql_store_result. The former is faster and less memory consuming, but
tends to block other processes. mysql_store_result is the default due to that
fact storing the result is expected behavior with most applications.
It is possible to set the default value of the C<mysql_use_result> attribute
for the $dbh via the DSN:
$dbh = DBI->connect("DBI:mysql:test;mysql_use_result=1", "root", "");
You can also set it after creation of the database handle:
$dbh->{mysql_use_result} = 0; # disable
$dbh->{mysql_use_result} = 1; # enable
You can also set or unset the C<mysql_use_result> setting on your statement
handle, when creating the statement handle or after it has been created.
See L</"STATEMENT HANDLES">.
=item mysql_enable_utf8
This attribute determines whether DBD::mysql should assume strings
stored in the database are utf8. This feature defaults to off.
When set, a data retrieved from a textual column type (char, varchar,
etc) will have the UTF-8 flag turned on if necessary. This enables
character semantics on that string. You will also need to ensure that
your database / table / column is configured to use UTF8. See for more
information the chapter on character set support in the MySQL manual:
L<http://dev.mysql.com/doc/refman/5.7/en/charset.html>
Additionally, turning on this flag tells MySQL that incoming data should
be treated as UTF-8. This will only take effect if used as part of the
call to connect(). If you turn the flag on after connecting, you will
need to issue the command C<SET NAMES utf8> to get the same effect.
=item mysql_enable_utf8mb4
This is similar to mysql_enable_utf8, but is capable of handling 4-byte
UTF-8 characters.
=item mysql_bind_type_guessing
This attribute causes the driver (emulated prepare statements)
to attempt to guess if a value being bound is a numeric value,
and if so, doesn't quote the value. This was created by
Dragonchild and is one way to deal with the performance issue
of using quotes in a statement that is inserting or updating a
large numeric value. This was previously called
C<unsafe_bind_type_guessing> because it is experimental. I have
successfully run the full test suite with this option turned on,
the name can now be simply C<mysql_bind_type_guessing>.
CAVEAT: Even though you can insert an integer value into a
character column, if this column is indexed, if you query that
column with the integer value not being quoted, it will not
use the index:
MariaDB [test]> explain select * from test where value0 = '3' \G
*************************** 1. row ***************************
id: 1
select_type: SIMPLE
table: test
type: ref
possible_keys: value0
key: value0
key_len: 13
ref: const
rows: 1
Extra: Using index condition
1 row in set (0.00 sec)
MariaDB [test]> explain select * from test where value0 = 3
-> \G
*************************** 1. row ***************************
id: 1
select_type: SIMPLE
table: test
type: ALL
possible_keys: value0
key: NULL
key_len: NULL
ref: NULL
rows: 6
Extra: Using where
1 row in set (0.00 sec)
See bug: https://rt.cpan.org/Ticket/Display.html?id=43822
C<mysql_bind_type_guessing> can be turned on via
- through DSN
my $dbh= DBI->connect('DBI:mysql:test', 'username', 'pass',
{ mysql_bind_type_guessing => 1})
- OR after handle creation
$dbh->{mysql_bind_type_guessing} = 1;
=item mysql_bind_comment_placeholders
This attribute causes the driver (emulated prepare statements)
will cause any placeholders in comments to be bound. This is
not correct prepared statement behavior, but some developers
have come to depend on this behavior, so I have made it available
in 4.015
=item mysql_no_autocommit_cmd
This attribute causes the driver to not issue 'set autocommit'
either through explicit or using mysql_autocommit(). This is
particularly useful in the case of using MySQL Proxy.
See the bug report:
https://rt.cpan.org/Public/Bug/Display.html?id=46308
C<mysql_no_autocommit_cmd> can be turned on when creating the database
handle:
my $dbh = DBI->connect('DBI:mysql:test', 'username', 'pass',
{ mysql_no_autocommit_cmd => 1});
or using an existing database handle:
$dbh->{mysql_no_autocommit_cmd} = 1;
=item ping
This can be used to send a ping to the server.
$rc = $dbh->ping();
=back
=head1 STATEMENT HANDLES
The statement handles of DBD::mysql support a number
of attributes. You access these by using, for example,
my $numFields = $sth->{NUM_OF_FIELDS};
Note, that most attributes are valid only after a successful I<execute>.
An C<undef> value will returned otherwise. The most important exception
is the C<mysql_use_result> attribute, which forces the driver to use
mysql_use_result rather than mysql_store_result. The former is faster
and less memory consuming, but tends to block other processes. (That's why
mysql_store_result is the default.)
To set the C<mysql_use_result> attribute, use either of the following:
my $sth = $dbh->prepare("QUERY", { mysql_use_result => 1});
or
my $sth = $dbh->prepare($sql);
$sth->{mysql_use_result} = 1;
Column dependent attributes, for example I<NAME>, the column names,
are returned as a reference to an array. The array indices are
corresponding to the indices of the arrays returned by I<fetchrow>
and similar methods. For example the following code will print a
header of table names together with all rows:
my $sth = $dbh->prepare("SELECT * FROM $table") ||
die "Error:" . $dbh->errstr . "\n";
$sth->execute || die "Error:" . $sth->errstr . "\n";
my $names = $sth->{NAME};
my $numFields = $sth->{'NUM_OF_FIELDS'} - 1;
for my $i ( 0..$numFields ) {
printf("%s%s", $i ? "," : "", $$names[$i]);
}
print "\n";
while (my $ref = $sth->fetchrow_arrayref) {
for my $i ( 0..$numFields ) {
printf("%s%s", $i ? "," : "", $$ref[$i]);
}
print "\n";
}
For portable applications you should restrict yourself to attributes with
capitalized or mixed case names. Lower case attribute names are private
to DBD::mysql. The attribute list includes:
=over
=item ChopBlanks
this attribute determines whether a I<fetchrow> will chop preceding
and trailing blanks off the column values. Chopping blanks does not
have impact on the I<max_length> attribute.
=item mysql_insertid
If the statement you executed performs an INSERT, and there is an AUTO_INCREMENT
column in the table you inserted in, this attribute holds the value stored into
the AUTO_INCREMENT column, if that value is automatically generated, by
storing NULL or 0 or was specified as an explicit value.
Typically, you'd access the value via $sth->{mysql_insertid}. The value can
also be accessed via $dbh->{mysql_insertid} but this can easily
produce incorrect results in case one database handle is shared.
=item mysql_is_blob
Reference to an array of boolean values; TRUE indicates, that the
respective column is a blob. This attribute is valid for MySQL only.
=item mysql_is_key
Reference to an array of boolean values; TRUE indicates, that the
respective column is a key. This is valid for MySQL only.
=item mysql_is_num
Reference to an array of boolean values; TRUE indicates, that the
respective column contains numeric values.
=item mysql_is_pri_key
Reference to an array of boolean values; TRUE indicates, that the
respective column is a primary key.
=item mysql_is_auto_increment
Reference to an array of boolean values; TRUE indicates that the
respective column is an AUTO_INCREMENT column. This is only valid
for MySQL.
=item mysql_length
=item mysql_max_length
A reference to an array of maximum column sizes. The I<max_length> is
the maximum physically present in the result table, I<length> gives
the theoretically possible maximum. I<max_length> is valid for MySQL
only.
=item NAME
A reference to an array of column names.
=item NULLABLE
A reference to an array of boolean values; TRUE indicates that this column
may contain NULL's.
=item NUM_OF_FIELDS
Number of fields returned by a I<SELECT> or I<LISTFIELDS> statement.
You may use this for checking whether a statement returned a result:
A zero value indicates a non-SELECT statement like I<INSERT>,
I<DELETE> or I<UPDATE>.
=item mysql_table
A reference to an array of table names, useful in a I<JOIN> result.
=item TYPE
A reference to an array of column types. The engine's native column
types are mapped to portable types like DBI::SQL_INTEGER() or
DBI::SQL_VARCHAR(), as good as possible. Not all native types have
a meaningful equivalent, for example DBD::mysql::FIELD_TYPE_INTERVAL
is mapped to DBI::SQL_VARCHAR().
If you need the native column types, use I<mysql_type>. See below.
=item mysql_type
A reference to an array of MySQL's native column types, for example
DBD::mysql::FIELD_TYPE_SHORT() or DBD::mysql::FIELD_TYPE_STRING().
Use the I<TYPE> attribute, if you want portable types like
DBI::SQL_SMALLINT() or DBI::SQL_VARCHAR().
=item mysql_type_name
Similar to mysql, but type names and not numbers are returned.
Whenever possible, the ANSI SQL name is preferred.
=item mysql_warning_count
The number of warnings generated during execution of the SQL statement.
This attribute is available on both statement handles and database handles.
=back
=head1 TRANSACTION SUPPORT
The transaction support works as follows:
=over
=item *
By default AutoCommit mode is on, following the DBI specifications.
=item *
If you execute
$dbh->{AutoCommit} = 0;
or
$dbh->{AutoCommit} = 1;
then the driver will set the MySQL server variable autocommit to 0 or
1, respectively. Switching from 0 to 1 will also issue a COMMIT,
following the DBI specifications.
=item *
The methods
$dbh->rollback();
$dbh->commit();
will issue the commands ROLLBACK and COMMIT, respectively. A
ROLLBACK will also be issued if AutoCommit mode is off and the
database handles DESTROY method is called. Again, this is following
the DBI specifications.
=back
Given the above, you should note the following:
=over
=item *
You should never change the server variable autocommit manually,
unless you are ignoring DBI's transaction support.
=item *
Switching AutoCommit mode from on to off or vice versa may fail.
You should always check for errors when changing AutoCommit mode.
The suggested way of doing so is using the DBI flag RaiseError.
If you don't like RaiseError, you have to use code like the
following:
$dbh->{AutoCommit} = 0;
if ($dbh->{AutoCommit}) {
# An error occurred!
}
=item *
If you detect an error while changing the AutoCommit mode, you
should no longer use the database handle. In other words, you
should disconnect and reconnect again, because the transaction
mode is unpredictable. Alternatively you may verify the transaction
mode by checking the value of the server variable autocommit.
However, such behaviour isn't portable.
=item *
DBD::mysql has a "reconnect" feature that handles the so-called
MySQL "morning bug": If the server has disconnected, most probably
due to a timeout, then by default the driver will reconnect and
attempt to execute the same SQL statement again. However, this
behaviour is disabled when AutoCommit is off: Otherwise the
transaction state would be completely unpredictable after a
reconnect.
=item *
The "reconnect" feature of DBD::mysql can be toggled by using the
L<mysql_auto_reconnect> attribute. This behaviour should be turned off
in code that uses LOCK TABLE because if the database server time out
and DBD::mysql reconnect, table locks will be lost without any
indication of such loss.
=back
=head1 MULTIPLE RESULT SETS
DBD::mysql supports multiple result sets, thanks to Guy Harrison!
The basic usage of multiple result sets is
do
{
while (@row = $sth->fetchrow_array())
{
do stuff;
}
} while ($sth->more_results)
An example would be:
$dbh->do("drop procedure if exists someproc") or print $DBI::errstr;
$dbh->do("create procedure someproc() deterministic
begin
declare a,b,c,d int;
set a=1;
set b=2;
set c=3;
set d=4;
select a, b, c, d;
select d, c, b, a;
select b, a, c, d;
select c, b, d, a;
end") or print $DBI::errstr;
$sth=$dbh->prepare('call someproc()') ||
die $DBI::err.": ".$DBI::errstr;
$sth->execute || die DBI::err.": ".$DBI::errstr; $rowset=0;
do {
print "\nRowset ".++$i."\n---------------------------------------\n\n";
foreach $colno (0..$sth->{NUM_OF_FIELDS}-1) {
print $sth->{NAME}->[$colno]."\t";
}
print "\n";
while (@row= $sth->fetchrow_array()) {
foreach $field (0..$#row) {
print $row[$field]."\t";
}
print "\n";
}
} until (!$sth->more_results)
=head2 Issues with multiple result sets
Please be aware there could be issues if your result sets are "jagged",
meaning the number of columns of your results vary. Varying numbers of
columns could result in your script crashing.
=head1 MULTITHREADING
The multithreading capabilities of DBD::mysql depend completely
on the underlying C libraries. The modules are working with handle data
only, no global variables are accessed or (to the best of my knowledge)
thread unsafe functions are called. Thus DBD::mysql is believed
to be completely thread safe, if the C libraries are thread safe
and you don't share handles among threads.
The obvious question is: Are the C libraries thread safe?
In the case of MySQL the answer is "mostly" and, in theory, you should
be able to get a "yes", if the C library is compiled for being thread
safe (By default it isn't.) by passing the option -with-thread-safe-client
to configure. See the section on I<How to make a threadsafe client> in
the manual.
=head1 ASYNCHRONOUS QUERIES
You can make a single asynchronous query per MySQL connection; this allows
you to submit a long-running query to the server and have an event loop
inform you when it's ready. An asynchronous query is started by either
setting the 'async' attribute to a true value in the L<DBI/do> method,
or in the L<DBI/prepare> method. Statements created with 'async' set to
true in prepare always run their queries asynchronously when L<DBI/execute>
is called. The driver also offers three additional methods:
C<mysql_async_result>, C<mysql_async_ready>, and C<mysql_fd>.
C<mysql_async_result> returns what do or execute would have; that is, the
number of rows affected. C<mysql_async_ready> returns true if
C<mysql_async_result> will not block, and zero otherwise. They both return
C<undef> if that handle is not currently running an asynchronous query.
C<mysql_fd> returns the file descriptor number for the MySQL connection; you
can use this in an event loop.
Here's an example of how to use the asynchronous query interface:
use feature 'say';
$dbh->do('SELECT SLEEP(10)', { async => 1 });
until($dbh->mysql_async_ready) {
say 'not ready yet!';
sleep 1;
}
my $rows = $dbh->mysql_async_result;
=head1 INSTALLATION
See L<DBD::mysql::INSTALL>.
=head1 AUTHORS
Originally, there was a non-DBI driver, Mysql, which was much like
PHP drivers such as mysql and mysqli. The B<Mysql> module was
originally written by Andreas König <koenig@kulturbox.de> who still, to this
day, contributes patches to DBD::mysql. An emulated version of Mysql was
provided to DBD::mysql from Jochen Wiedmann, but eventually deprecated as it
was another bundle of code to maintain.
The first incarnation of DBD::mysql was developed by Alligator Descartes,
who was also aided and abetted by Gary Shea, Andreas König and
Tim Bunce.
The current incarnation of B<DBD::mysql> was written by Jochen Wiedmann,
then numerous changes and bug-fixes were added by Rudy Lippan. Next,
prepared statement support was added by Patrick Galbraith and
Alexy Stroganov (who also solely added embedded server
support).
For the past nine years DBD::mysql has been maintained by
Patrick Galbraith (I<patg@patg.net>), and recently with the great help of
Michiel Beijen (I<michiel.beijen@gmail.com>), along with the entire community
of Perl developers who keep sending patches to help continue improving DBD::mysql
=head1 CONTRIBUTIONS
Anyone who desires to contribute to this project is encouraged to do so.
Currently, the source code for this project can be found at Github:
L<https://github.com/perl5-dbi/DBD-mysql/>
Either fork this repository and produce a branch with your changeset that
the maintainer can merge to his tree, or create a diff with git. The maintainer
is more than glad to take contributions from the community as
many features and fixes from DBD::mysql have come from the community.
=head1 COPYRIGHT
This module is
=over
=item *
Large Portions Copyright (c) 2004-2013 Patrick Galbraith
=item *
Large Portions Copyright (c) 2004-2006 Alexey Stroganov
=item *
Large Portions Copyright (c) 2003-2005 Rudolf Lippan
=item *
Large Portions Copyright (c) 1997-2003 Jochen Wiedmann, with code portions
=item *
Copyright (c)1994-1997 their original authors
=back
=head1 LICENSE
This module is released under the same license as Perl itself. See
L<http://www.perl.com/perl/misc/Artistic.html> for details.
=head1 MAILING LIST SUPPORT
This module is maintained and supported on a mailing list, dbi-users.
To subscribe to this list, send an email to
dbi-users-subscribe@perl.org
Mailing list archives are at
L<http://groups.google.com/group/perl.dbi.users?hl=en&lr=>
=head1 ADDITIONAL DBI INFORMATION
Additional information on the DBI project can be found on the World
Wide Web at the following URL:
L<http://dbi.perl.org>
where documentation, pointers to the mailing lists and mailing list
archives and pointers to the most current versions of the modules can
be used.
Information on the DBI interface itself can be gained by typing:
perldoc DBI
Information on DBD::mysql specifically can be gained by typing:
perldoc DBD::mysql
(this will display the document you're currently reading)
=head1 BUG REPORTING, ENHANCEMENT/FEATURE REQUESTS
Please report bugs, including all the information needed
such as DBD::mysql version, MySQL version, OS type/version, etc
to this link:
L<https://rt.cpan.org/Dist/Display.html?Name=DBD-mysql>
Note: until recently, MySQL/Sun/Oracle responded to bugs and assisted in
fixing bugs which many thanks should be given for their help!
This driver is outside the realm of the numerous components they support, and the
maintainer and community solely support DBD::mysql
=cut
Mem.pm 0000644 00000023615 15053110135 0005621 0 ustar 00 # -*- perl -*-
#
# DBD::Mem - A DBI driver for in-memory tables
#
# This module is currently maintained by
#
# Jens Rehsack
#
# Copyright (C) 2016,2017 by Jens Rehsack
#
# 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;
#################
package DBD::Mem;
#################
use base qw( DBI::DBD::SqlEngine );
use vars qw($VERSION $ATTRIBUTION $drh);
$VERSION = '0.001';
$ATTRIBUTION = 'DBD::Mem 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 DBI::DBD::SqlEngine
#
$attr->{Attribution} = 'DBD::Mem by Jens Rehsack';
$drh = $class->SUPER::driver($attr);
return $drh;
}
sub CLONE
{
undef $drh;
}
#####################
package DBD::Mem::dr;
#####################
$DBD::Mem::dr::imp_data_size = 0;
@DBD::Mem::dr::ISA = qw(DBI::DBD::SqlEngine::dr);
# you could put some :dr private methods here
# you may need to over-ride some DBI::DBD::SqlEngine::dr methods here
# but you can probably get away with just letting it do the work
# in most cases
#####################
package DBD::Mem::db;
#####################
$DBD::Mem::db::imp_data_size = 0;
@DBD::Mem::db::ISA = qw(DBI::DBD::SqlEngine::db);
use Carp qw/carp/;
sub set_versions
{
my $this = $_[0];
$this->{mem_version} = $DBD::Mem::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 mem_ or foo_
#
# see the STORE methods below for how to check these attrs
#
$dbh->{mem_valid_attrs} = {
mem_version => 1, # verbose DBD::Mem version
mem_valid_attrs => 1, # DBD::Mem::db valid attrs
mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs
mem_meta => 1, # DBD::Mem public access for f_meta
mem_tables => 1, # DBD::Mem public access for f_meta
};
$dbh->{mem_readonly_attrs} = {
mem_version => 1, # verbose DBD::Mem version
mem_valid_attrs => 1, # DBD::Mem::db valid attrs
mem_readonly_attrs => 1, # DBD::Mem::db r/o attrs
mem_meta => 1, # DBD::Mem public access for f_meta
};
$dbh->{mem_meta} = "mem_tables";
return $dbh->SUPER::init_valid_attributes();
}
sub get_mem_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 ) );
return sprintf( "%s using %s", $dbh->{mem_version}, $AnyData2::VERSION );
}
package DBD::Mem::st;
use strict;
use warnings;
our $imp_data_size = 0;
our @ISA = qw(DBI::DBD::SqlEngine::st);
############################
package DBD::Mem::Statement;
############################
@DBD::Mem::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,
};
if( defined( $data->{Database}->{mem_table_data}->{$table} ) && $data->{Database}->{mem_table_data}->{$table})
{
my $t = $data->{Database}->{mem_tables}->{$table};
$t->seek( $data, 0, 0 );
return $t;
}
return $self->SUPER::open_table($data, $table, $createMode, $lockMode);
}
# ====== DataSource ============================================================
package DBD::Mem::DataSource;
use strict;
use warnings;
use Carp;
@DBD::Mem::DataSource::ISA = "DBI::DBD::SqlEngine::DataSource";
sub complete_table_name ($$;$)
{
my ( $self, $meta, $table, $respect_case ) = @_;
$table;
}
sub open_data ($)
{
my ( $self, $meta, $attrs, $flags ) = @_;
defined $meta->{data_tbl} or $meta->{data_tbl} = [];
}
########################
package DBD::Mem::Table;
########################
# shamelessly stolen from SQL::Statement::RAM
use Carp qw/croak/;
@DBD::Mem::Table::ISA = qw(DBI::DBD::SqlEngine::Table);
use Carp qw(croak);
sub new
{
#my ( $class, $tname, $col_names, $data_tbl ) = @_;
my ( $class, $data, $attrs, $flags ) = @_;
my $self = $class->SUPER::new($data, $attrs, $flags);
my $meta = $self->{meta};
$self->{records} = $meta->{data_tbl};
$self->{index} = 0;
$self;
}
sub bootstrap_table_meta
{
my ( $self, $dbh, $meta, $table ) = @_;
defined $meta->{sql_data_source} or $meta->{sql_data_source} = "DBD::Mem::DataSource";
$meta;
}
sub fetch_row
{
my ( $self, $data ) = @_;
return $self->{row} =
( $self->{records} and ( $self->{index} < scalar( @{ $self->{records} } ) ) )
? [ @{ $self->{records}->[ $self->{index}++ ] } ]
: undef;
}
sub push_row
{
my ( $self, $data, $fields ) = @_;
my $currentRow = $self->{index};
$self->{index} = $currentRow + 1;
$self->{records}->[$currentRow] = $fields;
return 1;
}
sub truncate
{
my $self = shift;
return splice @{ $self->{records} }, $self->{index}, 1;
}
sub push_names
{
my ( $self, $data, $names ) = @_;
my $meta = $self->{meta};
$meta->{col_names} = $self->{col_names} = $names;
$self->{org_col_names} = [ @{$names} ];
$self->{col_nums} = {};
$self->{col_nums}{ $names->[$_] } = $_ for ( 0 .. scalar @$names - 1 );
}
sub drop ($)
{
my ($self, $data) = @_;
delete $data->{Database}{sql_meta}{$self->{table}};
return 1;
} # drop
sub seek
{
my ( $self, $data, $pos, $whence ) = @_;
return unless defined $self->{records};
my ($currentRow) = $self->{index};
if ( $whence == 0 )
{
$currentRow = $pos;
}
elsif ( $whence == 1 )
{
$currentRow += $pos;
}
elsif ( $whence == 2 )
{
$currentRow = @{ $self->{records} } + $pos;
}
else
{
croak $self . "->seek: Illegal whence argument ($whence)";
}
$currentRow < 0 and
croak "Illegal row number: $currentRow";
$self->{index} = $currentRow;
}
1;
=head1 NAME
DBD::Mem - a DBI driver for Mem & MLMem files
=head1 SYNOPSIS
use DBI;
$dbh = DBI->connect('dbi:Mem:', undef, undef, {});
$dbh = DBI->connect('dbi:Mem:', undef, undef, {RaiseError => 1});
# or
$dbh = DBI->connect('dbi:Mem:');
$dbh = DBI->connect('DBI:Mem(RaiseError=1):');
and other variations on connect() as shown in the L<DBI> docs and
<DBI::DBD::SqlEngine metadata|DBI::DBD::SqlEngine/Metadata>.
Use standard DBI prepare, execute, fetch, placeholders, etc.,
see L<QUICK START> for an example.
=head1 DESCRIPTION
DBD::Mem 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) for improved functionality.
DBD::Mem doesn't store any data persistently - all data has the lifetime of
the instantiated C<$dbh>. The main reason to use DBD::Mem is to use extended
features of L<SQL::Statement> where temporary tables are required. One can
use DBD::Mem to simulate C<VIEWS> or sub-queries.
Bundling C<DBD::Mem> with L<DBI> will allow us further compatibility checks
of L<DBI::DBD::SqlEngine> beyond the capabilities of L<DBD::File> and
L<DBD::DBM>. This will ensure DBI provided basis for drivers like
L<DBD::AnyData2> or L<DBD::Amazon> are better prepared and tested for
not-file based backends.
=head2 Metadata
There're no new meta data introduced by C<DBD::Mem>. See
L<DBI::DBD::SqlEngine/Metadata> for full description.
=head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS
If you need help installing or using DBD::Mem, please write to the DBI
users mailing list at L<mailto: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 DBI::DBD::SqlEngine or DBD::Mem or
use one of them as an example are suggested to join the DBI developers
mailing list at L<mailto: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 C<< $dbh->mem_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.
=head1 AUTHOR AND COPYRIGHT
This module is written by Jens Rehsack < rehsack AT cpan.org >.
Copyright (c) 2016- by 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.
=head1 SEE ALSO
L<DBI> for the Database interface of the Perl Programming Language.
L<SQL::Statement> and L<DBI::SQL::Nano> for the available SQL engines.
L<SQL::Statement::RAM> where the implementation is shamelessly stolen from
to allow DBI bundled Pure-Perl drivers increase the test coverage.
L<DBD::SQLite> using C<dbname=:memory:> for an incredible fast in-memory database engine.
=cut
DBM.pm 0000644 00000145600 15053110135 0005504 0 ustar 00 #######################################################################
#
# DBD::DBM - a DBI driver for DBM files
#
# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
# Copyright (c) 2010-2013 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.08';
$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);
use Carp qw/carp/;
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, everything 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;
my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" )
or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() );
return $tbl_meta->{$tname}->{f_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';
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 ) = @_;
$meta->{f_dontopen} = 1;
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_data
{
my ( $className, $meta, $attrs, $flags ) = @_;
$className->SUPER::open_data( $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 usage 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 languages.
=item C<MLDBM::Serializer::JSON>
Additional serializer for MLDBM. JSON is very portable between languages,
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-2013 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
Sponge.pm 0000644 00000017436 15053110135 0006342 0 ustar 00 use strict;
{
package DBD::Sponge;
require DBI;
require Carp;
our @EXPORT = qw(); # Do NOT @EXPORT anything.
our $VERSION = "12.010003";
# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $
#
# 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.
our $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 ======
our $imp_data_size = 0;
# we use default (dummy) connect method
}
{ package DBD::Sponge::db; # ====== DATABASE ======
our $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 ======
our $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
ExampleP.pm 0000644 00000030175 15053110135 0006615 0 ustar 00 {
package DBD::ExampleP;
use strict;
use Symbol;
use DBI qw(:sql_types);
require File::Spec;
our (@EXPORT,$VERSION,@statnames,%statnames,@stattypes,%stattypes,
@statprec,%statprec,$drh,);
@EXPORT = qw(); # Do NOT @EXPORT anything.
$VERSION = "12.014311";
# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $
#
# 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) = @_;
# store only known attributes else pass up to DBI to handle
if ($attrib eq 'examplep_set_err') {
# a fake attribute to enable a test case where STORE issues a warning
$dbh->set_err($value, $value);
return;
}
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
Gofer.pm 0000644 00000137657 15053110135 0006161 0 ustar 00 {
package DBD::Gofer;
use strict;
require DBI;
require DBI::Gofer::Request;
require DBI::Gofer::Response;
require Carp;
our $VERSION = "0.015327";
# $Id: Gofer.pm 15326 2012-06-06 16:32:38Z Tim $
#
# 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('', "can't ping while not connected") # info
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); # XXX needed? It should be the default
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-attributes 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, up to 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
Gofer/Policy/Base.pm 0000644 00000011741 15053110135 0010253 0 ustar 00 package DBD::Gofer::Policy::Base;
# $Id: Base.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
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
Gofer/Policy/rush.pm 0000644 00000005045 15053110135 0010362 0 ustar 00 package DBD::Gofer::Policy::rush;
# $Id: rush.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
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
Gofer/Policy/classic.pm 0000644 00000004072 15053110135 0011021 0 ustar 00 package DBD::Gofer::Policy::classic;
# $Id: classic.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
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
Gofer/Policy/pedantic.pm 0000644 00000002633 15053110135 0011170 0 ustar 00 package DBD::Gofer::Policy::pedantic;
# $Id: pedantic.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
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
Gofer/Transport/Base.pm 0000644 00000030723 15053110135 0011011 0 ustar 00 package DBD::Gofer::Transport::Base;
# $Id: Base.pm 14120 2010-06-07 19:52:19Z H.Merijn $
#
# 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 = "0.014121";
__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 occurring 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
Gofer/Transport/null.pm 0000644 00000005322 15053110135 0011106 0 ustar 00 package DBD::Gofer::Transport::null;
# $Id: null.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
__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
Gofer/Transport/stream.pm 0000644 00000022040 15053110135 0011423 0 ustar 00 package DBD::Gofer::Transport::stream;
# $Id: stream.pm 14598 2010-12-21 22:53:25Z Tim $
#
# 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 = "0.014599";
__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
Gofer/Transport/pipeone.pm 0000644 00000016203 15053110135 0011573 0 ustar 00 package DBD::Gofer::Transport::pipeone;
# $Id: pipeone.pm 10087 2007-10-16 12:42:37Z Tim $
#
# 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 = "0.010088";
__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