Apache-LoggedAuthDBI
view release on metacpan or search on metacpan
ad_ => { class => 'DBD::AnyData', },
ado_ => { class => 'DBD::ADO', },
amzn_ => { class => 'DBD::Amazon', },
best_ => { class => 'DBD::BestWins', },
csv_ => { class => 'DBD::CSV', },
db2_ => { class => 'DBD::DB2', },
dbi_ => { class => 'DBI', },
dbm_ => { class => 'DBD::DBM', },
df_ => { class => 'DBD::DF', },
f_ => { class => 'DBD::File', },
file_ => { class => 'DBD::TextFile', },
ib_ => { class => 'DBD::InterBase', },
ing_ => { class => 'DBD::Ingres', },
ix_ => { class => 'DBD::Informix', },
jdbc_ => { class => 'DBD::JDBC', },
msql_ => { class => 'DBD::mSQL', },
mysql_ => { class => 'DBD::mysql', },
mx_ => { class => 'DBD::Multiplex', },
nullp_ => { class => 'DBD::NullP', },
odbc_ => { class => 'DBD::ODBC', },
ora_ => { class => 'DBD::Oracle', },
pg_ => { class => 'DBD::Pg', },
proxy_ => { class => 'DBD::Proxy', },
rdb_ => { class => 'DBD::RDB', },
sapdb_ => { class => 'DBD::SAP_DB', },
solid_ => { class => 'DBD::Solid', },
sponge_ => { class => 'DBD::Sponge', },
sql_ => { class => 'SQL::Statement', },
syb_ => { class => 'DBD::Sybase', },
tdat_ => { class => 'DBD::Teradata', },
tmpl_ => { class => 'DBD::Template', },
tmplss_ => { class => 'DBD::TemplateSS', },
tuber_ => { class => 'DBD::Tuber', },
uni_ => { class => 'DBD::Unify', },
xbase_ => { class => 'DBD::XBase', },
xl_ => { class => 'DBD::Excel', },
yaswi_ => { class => 'DBD::Yaswi', },
};
sub dump_dbd_registry {
require Data::Dumper;
local $Data::Dumper::Sortkeys=1;
local $Data::Dumper::Indent=1;
print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]);
}
# --- Dynamically create the DBI Standard Interface
my $keeperr = { O=>0x0004 };
%DBI::DBI_methods = ( # Define the DBI interface methods per class:
common => { # Interface methods common to all DBI handle classes
'DESTROY' => $keeperr,
'CLEAR' => $keeperr,
'EXISTS' => $keeperr,
'FETCH' => { O=>0x0404 },
'FIRSTKEY' => $keeperr,
'NEXTKEY' => $keeperr,
'STORE' => { O=>0x0418 | 0x4 },
_not_impl => undef,
can => { O=>0x0100 }, # special case, see dispatch
debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace
dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 },
err => $keeperr,
errstr => $keeperr,
state => $keeperr,
func => { O=>0x0006 },
parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 },
parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 },
private_data => { U =>[1,1], O=>0x0004 },
set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 },
trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 },
trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 },
swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
},
dr => { # Database Driver Interface
'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3 },
'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3 },
'disconnect_all'=>{ U =>[1,1], O=>0x0800 },
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800 },
default_user => { U =>[3,4,'$user, $pass [, \%attr]' ] },
},
db => { # Database Session Class Interface
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
take_imp_data => { U =>[1,1], },
clone => { U =>[1,1,''] },
connected => { O=>0x0100 },
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
commit => { U =>[1,1], O=>0x0480|0x0800 },
rollback => { U =>[1,1], O=>0x0480|0x0800 },
'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 },
last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 },
preparse => { }, # XXX
prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0x2200 },
prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0x2200 },
selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
ping => { U =>[1,1], O=>0x0404 },
disconnect => { U =>[1,1], O=>0x0400|0x0800 },
quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430 },
rows => $keeperr,
tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 },
table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x0800 },
column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x0800 },
primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x0800 },
primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 },
foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x0800 },
type_info_all => { U =>[1,1], O=>0x2200|0x0800 },
type_info => { U =>[1,2,'$data_type'], O=>0x2200 },
get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 },
},
st => { # Statement Class Interface
bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] },
bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] },
# --------------------------------------------------------------------
# === The internal DBI Switch pseudo 'driver' class ===
{ package # hide from PAUSE
DBD::Switch::dr;
DBI->setup_driver('DBD::Switch'); # sets up @ISA
$DBD::Switch::dr::imp_data_size = 0;
$DBD::Switch::dr::imp_data_size = 0; # avoid typo warning
my $drh;
sub driver {
return $drh if $drh; # a package global
my $inner;
($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', {
'Name' => 'Switch',
'Version' => $DBI::VERSION,
'Attribution' => "DBI $DBI::VERSION by Tim Bunce",
});
Carp::croak("DBD::Switch init failed!") unless ($drh && $inner);
return $drh;
}
sub CLONE {
undef $drh;
}
sub FETCH {
my($drh, $key) = @_;
return DBI->trace if $key eq 'DebugDispatch';
return undef if $key eq 'DebugLog'; # not worth fetching, sorry
return $drh->DBD::_::dr::FETCH($key);
undef;
}
sub STORE {
my($drh, $key, $value) = @_;
if ($key eq 'DebugDispatch') {
DBI->trace($value);
} elsif ($key eq 'DebugLog') {
DBI->trace(-1, $value);
} else {
$drh->DBD::_::dr::STORE($key, $value);
}
}
}
# --------------------------------------------------------------------
# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES ===
# We only define default methods for harmless functions.
# We don't, for example, define a DBD::_::st::prepare()
{ package # hide from PAUSE
DBD::_::common; # ====== Common base class methods ======
use strict;
# methods common to all handle types:
sub _not_impl {
my ($h, $method) = @_;
$h->trace_msg("Driver does not implement the $method method.\n");
return; # empty list / undef
}
# generic TIEHASH default methods:
sub FIRSTKEY { }
sub NEXTKEY { }
sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
*dump_handle = \&DBI::dump_handle;
sub install_method {
# special class method called directly by apps and/or drivers
# to install new methods into the DBI dispatcher
# DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' });
my ($class, $method, $attr) = @_;
Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st")
unless $class =~ /^DBD::(\w+)::(dr|db|st)$/;
my ($driver, $subtype) = ($1, $2);
Carp::croak("invalid method name '$method'")
unless $method =~ m/^([a-z]+_)\w+$/;
my $prefix = $1;
my $reg_info = $dbd_prefix_registry->{$prefix};
Carp::croak("method name prefix '$prefix' is not registered") unless $reg_info;
my %attr = %{$attr||{}}; # copy so we can edit
# XXX reformat $attr as needed for _install_method
my ($caller_pkg, $filename, $line) = caller;
DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr);
}
sub parse_trace_flags {
my ($h, $spec) = @_;
my $level = 0;
my $flags = 0;
my @unknown;
for my $word (split /\s*[|&,]\s*/, $spec) {
if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) {
$level = $word;
} elsif ($word eq 'ALL') {
$flags = 0x7FFFFFFF; # XXX last bit causes negative headaches
last;
} elsif (my $flag = $h->parse_trace_flag($word)) {
$flags |= $flag;
}
else {
push @unknown, $word;
}
}
if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) {
Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ".
join(" ", map { DBI::neat($_) } @unknown));
}
$flags |= $level;
return $flags;
}
sub parse_trace_flag {
my ($h, $name) = @_;
for (@$slice) { $_-- }
}
}
my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows});
$sth->finish if defined $MaxRows;
return $rows;
}
sub selectall_hashref {
my ($dbh, $stmt, $key_field, $attr, @bind) = @_;
my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
return unless $sth;
$sth->execute(@bind) || return;
return $sth->fetchall_hashref($key_field);
}
sub selectcol_arrayref {
my ($dbh, $stmt, $attr, @bind) = @_;
my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr);
return unless $sth;
$sth->execute(@bind) || return;
my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
my @values = (undef) x @columns;
my $idx = 0;
for (@columns) {
$sth->bind_col($_, \$values[$idx++]) || return;
}
my @col;
if (my $max = $attr->{MaxRows}) {
push @col, @values while @col<$max && $sth->fetch;
}
else {
push @col, @values while $sth->fetch;
}
return \@col;
}
sub prepare_cached {
my ($dbh, $statement, $attr, $if_active) = @_;
# Needs support at dbh level to clear cache before complaining about
# active children. The XS template code does this. Drivers not using
# the template must handle clearing the cache themselves.
my $cache = $dbh->FETCH('CachedKids');
$dbh->STORE('CachedKids', $cache = {}) unless $cache;
my @attr_keys = ($attr) ? sort keys %$attr : ();
my $key = ($attr) ? join("~~", $statement, @attr_keys, @{$attr}{@attr_keys}) : $statement;
my $sth = $cache->{$key};
if ($sth) {
return $sth unless $sth->FETCH('Active');
Carp::carp("prepare_cached($statement) statement handle $sth still Active")
unless ($if_active ||= 0);
$sth->finish if $if_active <= 1;
return $sth if $if_active <= 2;
}
$sth = $dbh->prepare($statement, $attr);
$cache->{$key} = $sth if $sth;
return $sth;
}
sub ping {
shift->_not_impl('ping');
"0 but true"; # special kind of true 0
}
sub begin_work {
my $dbh = shift;
return $dbh->set_err(1, "Already in a transaction")
unless $dbh->FETCH('AutoCommit');
$dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it
$dbh->STORE('BegunWork', 1); # trigger post commit/rollback action
return 1;
}
sub primary_key {
my ($dbh, @args) = @_;
my $sth = $dbh->primary_key_info(@args) or return;
my ($row, @col);
push @col, $row->[3] while ($row = $sth->fetch);
Carp::croak("primary_key method not called in list context")
unless wantarray; # leave us some elbow room
return @col;
}
sub tables {
my ($dbh, @args) = @_;
my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
my $tables = $sth->fetchall_arrayref or return;
my @tables;
if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
@tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables;
}
else { # temporary old style hack (yeach)
@tables = map {
my $name = $_->[2];
if ($_->[1]) {
my $schema = $_->[1];
# a sad hack (mostly for Informix I recall)
my $quote = ($schema eq uc($schema)) ? '' : '"';
$name = "$quote$schema$quote.$name"
}
$name;
} @$tables;
}
return @tables;
}
sub type_info { # this should be sufficient for all drivers
my ($dbh, $data_type) = @_;
my $idx_hash;
my $tia = $dbh->{dbi_type_info_row_cache};
if ($tia) {
$idx_hash = $dbh->{dbi_type_info_idx_cache};
}
else {
my $temp = $dbh->type_info_all;
return unless $temp && @$temp;
# we cache here because type_info_all may be expensive to call
$tia = $dbh->{dbi_type_info_row_cache} = $temp;
$idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia;
}
( run in 2.604 seconds using v1.01-cache-2.11-cpan-d8267643d1d )