Apache-LoggedAuthDBI
view release on metacpan or search on metacpan
# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
# These are dynamically associated with the last handle used.
tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list
tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list
tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean
tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg
tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg
sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; }
sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") }
{ # used to catch DBI->{Attrib} mistake
sub DBI::DBI_tie::TIEHASH { bless {} }
sub DBI::DBI_tie::STORE { Carp::carp("DBI->{$_[1]} is invalid syntax (you probably want \$h->{$_[1]})");}
*DBI::DBI_tie::FETCH = \&DBI::DBI_tie::STORE;
}
tie %DBI::DBI => 'DBI::DBI_tie';
# --- Driver Specific Prefix Registry ---
my $dbd_prefix_registry = {
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 },
# extract dbi:driver prefix from $dsn into $1
$dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i
or '' =~ /()/; # ensure $1 etc are empty if match fails
my $driver_attrib_spec = $2 || '';
# Set $driver. Old style driver, if specified, overrides new dsn style.
$driver = $old_driver || $1 || $ENV{DBI_DRIVER}
or Carp::croak("Can't connect to data source $dsn, no database driver specified "
."and DBI_DSN env var not set");
if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') {
my $dbi_autoproxy = $ENV{DBI_AUTOPROXY};
my $proxy = 'Proxy';
if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) {
$proxy = $1;
my $attr_spec = $2 || '';
$driver_attrib_spec = ($driver_attrib_spec) ? "$driver_attrib_spec,$attr_spec" : $attr_spec;
}
$dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn";
$driver = $proxy;
DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n");
}
my %attributes; # take a copy we can delete from
if ($old_driver) {
%attributes = %$attr if $attr;
}
else { # new-style connect so new default semantics
%attributes = (
PrintError => 1,
AutoCommit => 1,
ref $attr ? %$attr : (),
# attributes in DSN take precedence over \%attr connect parameter
$driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (),
);
}
$attr = \%attributes; # now set $attr to refer to our local copy
my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver)
or die "panic: $class->install_driver($driver) failed";
# attributes in DSN take precedence over \%attr connect parameter
$user = $attr->{Username} if defined $attr->{Username};
$pass = delete $attr->{Password} if defined $attr->{Password};
($user, $pass) = $drh->default_user($user, $pass, $attr)
if !(defined $user && defined $pass);
$attr->{Username} = $user; # store username as attribute
my $connect_closure = sub {
my ($old_dbh, $override_attr) = @_;
my $attr = {
# copy so we can edit them each time we're called
%attributes,
# merge in modified attr in %$old_dbh, this should also copy in
# the dbi_connect_closure attribute so we can reconnect again.
%{ $override_attr || {} },
};
#warn "connect_closure: ".Data::Dumper::Dumper([\%attributes, $override_attr]);
my $dbh;
unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) {
$user = '' if !defined $user;
$dsn = '' if !defined $dsn;
# $drh->errstr isn't safe here because $dbh->DESTROY may not have
# been called yet and so the dbh errstr would not have been copied
# up to the drh errstr. Certainly true for connect_cached!
my $errstr = $DBI::errstr;
$errstr = '(no error string)' if !defined $errstr;
my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
DBI->trace_msg(" $msg\n");
# XXX HandleWarn
unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) {
Carp::croak($msg) if $attr->{RaiseError};
Carp::carp ($msg) if $attr->{PrintError};
}
$! = 0; # for the daft people who do DBI->connect(...) || die "$!";
return $dbh; # normally undef, but HandleError could change it
}
# handle basic RootClass subclassing:
my $rebless_class = $attr->{RootClass} || ($class ne 'DBI' ? $class : '');
if ($rebless_class) {
no strict 'refs';
if ($attr->{RootClass}) { # explicit attribute (rather than static call)
delete $attr->{RootClass};
DBI::_load_class($rebless_class, 0);
}
unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) {
Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored");
$rebless_class = undef;
$class = 'DBI';
}
else {
$dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db
DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st'
DBI::_rebless($dbh, $rebless_class); # appends '::db'
}
}
if (%$attr) {
DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, delete $attr->{DbTypeSubclass}, $attr)
if $attr->{DbTypeSubclass};
my $a;
foreach $a (qw(RaiseError PrintError AutoCommit)) { # do these first
next unless exists $attr->{$a};
$dbh->{$a} = delete $attr->{$a};
}
foreach $a (keys %$attr) {
eval { $dbh->{$a} = $attr->{$a} } or $@ && warn $@;
}
}
# if we've been subclassed then let the subclass know that we're connected
$dbh->connected($dsn, $user, $pass, $attr) if ref $dbh ne 'DBI::db';
# if the caller has provided a callback then call it
# XXX debatable as there's no "server side" here
# (and now many uses would trigger warnings on DESTROY)
# $this->STORE(Active => 1);
$this;
}
sub connect_cached {
my $drh = shift;
my ($dsn, $user, $auth, $attr)= @_;
# 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 = $drh->FETCH('CachedKids');
$drh->STORE('CachedKids', $cache = {}) unless $cache;
my @attr_keys = $attr ? sort keys %$attr : ();
my $key = do { local $^W; # silence undef warnings
join "~~", $dsn, $user||'', $auth||'', $attr ? (@attr_keys,@{$attr}{@attr_keys}) : ()
};
my $dbh = $cache->{$key};
if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
# XXX warn if BegunWork?
# XXX warn if $dbh->FETCH('AutoCommit') != $attr->{AutoCommit} ?
# but that's just one (bad) case of a more general issue.
return $dbh;
}
$dbh = $drh->connect(@_);
$cache->{$key} = $dbh; # replace prev entry, even if connect failed
return $dbh;
}
}
{ package # hide from PAUSE
DBD::_::db; # ====== DATABASE ======
@DBD::_::db::ISA = qw(DBD::_::common);
use strict;
sub clone {
my ($old_dbh, $attr) = @_;
my $closure = $old_dbh->{dbi_connect_closure} or return;
unless ($attr) {
# copy attributes visible in the attribute cache
keys %$old_dbh; # reset iterator
while ( my ($k, $v) = each %$old_dbh ) {
# ignore non-code refs, i.e., caches, handles, Err etc
next if ref $v && ref $v ne 'CODE'; # HandleError etc
$attr->{$k} = $v;
}
# explicitly set attributes which are unlikely to be in the
# attribute cache, i.e., boolean's and some others
$attr->{$_} = $old_dbh->FETCH($_) for (qw(
AutoCommit ChopBlanks InactiveDestroy
LongTruncOk PrintError PrintWarn Profile RaiseError
ShowErrorStatement TaintIn TaintOut
));
}
# use Data::Dumper; warn Dumper([$old_dbh, $attr]);
my $new_dbh = &$closure($old_dbh, $attr);
unless ($new_dbh) {
# need to copy err/errstr from driver back into $old_dbh
my $drh = $old_dbh->{Driver};
return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
}
return $new_dbh;
}
sub quote_identifier {
my ($dbh, @id) = @_;
my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef;
my $info = $dbh->{dbi_quote_identifier_cache} ||= [
$dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR
$dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR
$dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION
];
my $quote = $info->[0];
foreach (@id) { # quote the elements
next unless defined;
s/$quote/$quote$quote/g; # escape embedded quotes
$_ = qq{$quote$_$quote};
}
# strip out catalog if present for special handling
my $catalog = (@id >= 3) ? shift @id : undef;
# join the dots, ignoring any null/undef elements (ie schema)
my $quoted_id = join '.', grep { defined } @id;
if ($catalog) { # add catalog correctly
$quoted_id = ($info->[2] == 2) # SQL_CL_END
? $quoted_id . $info->[1] . $catalog
: $catalog . $info->[1] . $quoted_id;
}
return $quoted_id;
}
sub quote {
my ($dbh, $str, $data_type) = @_;
return "NULL" unless defined $str;
unless ($data_type) {
$str =~ s/'/''/g; # ISO SQL2
return "'$str'";
}
my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ];
my ($prefixes, $suffixes) = @$dbi_literal_quote_cache;
my $lp = $prefixes->{$data_type};
my $ls = $suffixes->{$data_type};
if ( ! defined $lp || ! defined $ls ) {
my $ti = $dbh->type_info($data_type);
$lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'";
$ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'";
}
( run in 2.549 seconds using v1.01-cache-2.11-cpan-f56aa216473 )