Apache-LoggedAuthDBI
view release on metacpan or search on metacpan
my @args = @_; $args[2] = '****'; # hide password
DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n");
}
Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])')
if (ref $old_driver or ($attr and not ref $attr) or ref $pass);
# 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 $@;
}
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) = @_;
# 0xddDDDDrL (driver, DBI, reserved, Level)
return 0x00000100 if $name eq 'SQL';
return;
}
}
{ package # hide from PAUSE
DBD::_::dr; # ====== DRIVER ======
@DBD::_::dr::ISA = qw(DBD::_::common);
use strict;
sub default_user {
my ($drh, $user, $pass, $attr) = @_;
$user = $ENV{DBI_USER} unless defined $user;
$pass = $ENV{DBI_PASS} unless defined $pass;
return ($user, $pass);
}
sub connect { # normally overridden, but a handy default
my ($drh, $dsn, $user, $auth) = @_;
my ($this) = DBI::_new_dbh($drh, {
'Name' => $dsn,
});
# XXX debatable as there's no "server side" here
# (and now many uses would trigger warnings on DESTROY)
C<bind_col> call. In fact the whole \%attr parameter is 'sticky'
in the sense that a driver only needs to consider the \%attr parameter
for the first call for a given $sth and column.
The TYPE attribute for bind_col() was first specified in DBI 1.41.
=item C<bind_columns>
$rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
Calls L</bind_col> for each column of the C<SELECT> statement.
The C<bind_columns> method will die if the number of references does not
match the number of fields.
For maximum portability between drivers, bind_columns() should be called
after execute() and not before.
For example:
$dbh->{RaiseError} = 1; # do this, or check every call for errors
$sth = $dbh->prepare(q{ SELECT region, sales FROM sales_by_region });
$sth->execute;
my ($region, $sales);
# Bind Perl variables to columns:
$rv = $sth->bind_columns(\$region, \$sales);
# you can also use Perl's \(...) syntax (see perlref docs):
# $sth->bind_columns(\($region, $sales));
# Column binding is the most efficient way to fetch data
while ($sth->fetch) {
print "$region: $sales\n";
}
For compatibility with old scripts, the first parameter will be
ignored if it is C<undef> or a hash reference.
Here's a more fancy example that binds columns to the values I<inside>
a hash (thanks to H.Merijn Brand):
$sth->execute;
my %row;
$sth->bind_columns( \( @row{ @{$sth->{NAME_lc} } } ));
while ($sth->fetch) {
print "$row{region}: $row{sales}\n";
}
=item C<dump_results>
$rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh);
Fetches all the rows from C<$sth>, calls C<DBI::neat_list> for each row, and
prints the results to C<$fh> (defaults to C<STDOUT>) separated by C<$lsep>
(default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35.
This method is designed as a handy utility for prototyping and
testing queries. Since it uses L</neat_list> to
format and edit the string for reading by humans, it is not recomended
for data transfer applications.
=back
=head2 Statement Handle Attributes
This section describes attributes specific to statement handles. Most
of these attributes are read-only.
Changes to these statement handle attributes do not affect any other
existing or future statement handles.
Attempting to set or get the value of an unknown attribute generates a warning,
except for private driver specific attributes (which all have names
starting with a lowercase letter).
Example:
... = $h->{NUM_OF_FIELDS}; # get/read
Some drivers cannot provide valid values for some or all of these
attributes until after C<$sth-E<gt>execute> has been successfully
called. Typically the attribute will be C<undef> in these situations.
Some attributes, like NAME, are not appropriate to some types of
statement, like SELECT. Typically the attribute will be C<undef>
in these situations.
See also L</finish> to learn more about the effect it
may have on some attributes.
=over 4
=item C<NUM_OF_FIELDS> (integer, read-only)
Number of fields (columns) in the data the prepared statement may return.
Statements that don't return rows of data, like C<DELETE> and C<CREATE>
set C<NUM_OF_FIELDS> to 0.
=item C<NUM_OF_PARAMS> (integer, read-only)
The number of parameters (placeholders) in the prepared statement.
See SUBSTITUTION VARIABLES below for more details.
=item C<NAME> (array-ref, read-only)
Returns a reference to an array of field names for each column. The
names may contain spaces but should not be truncated or have any
trailing space. Note that the names have the letter case (upper, lower
or mixed) as returned by the driver being used. Portable applications
should use L</NAME_lc> or L</NAME_uc>.
print "First column name: $sth->{NAME}->[0]\n";
=item C<NAME_lc> (array-ref, read-only)
Like L</NAME> but always returns lowercase names.
above. The error code and error string will be recorded in the
handle and available via C<$h-E<gt>err> and C<$DBI::errstr> etc.
The set_err() method always returns an undef or empty list as
approriate. Since your method should nearly always return an undef
or empty list as soon as an error is detected it's handy to simply
return what set_err() returns, as shown in the example above.
If the handle has C<RaiseError>, C<PrintError>, or C<HandleError>
etc. set then the set_err() method will honour them. This means
that if C<RaiseError> is set then set_err() won't return in the
normal way but will 'throw an exception' that can be caught with
an C<eval> block.
You can stash private data into DBI handles
via C<$h-E<gt>{private_..._*}>. See the entry under L</ATTRIBUTES
COMMON TO ALL HANDLES> for info and important caveats.
=head1 TRACING
The DBI has a powerful tracing mechanism built in. It enables you
to see what's going on 'behind the scenes', both within the DBI and
the drivers you're using.
=head2 Trace Settings
Which details are written to the trace output is controlled by a
combination of a I<trace level>, an integer from 0 to 15, and a set
of I<trace flags> that are either on or off. Together these are known
as the I<trace settings> and are stored together in a single integer.
For normal use you only need to set the trace level, and generally
only to a value between 1 and 4.
Each handle has it's own trace settings, and so does the DBI.
When you call a method the DBI merges the handles settings into its
own for the duration of the call: the trace flags of the handle are
OR'd into the trace flags of the DBI, and if the handle has a higher
trace level then the DBI trace level is raised to match it.
The previous DBI trace setings are restored when the called method
returns.
=head2 Trace Levels
Trace I<levels> are as follows:
0 - Trace disabled.
1 - Trace DBI method calls returning with results or errors.
2 - Trace method entry with parameters and returning with results.
3 - As above, adding some high-level information from the driver
and some internal information from the DBI.
4 - As above, adding more detailed information from the driver.
5 to 15 - As above but with more and more obscure information.
Trace level 1 is best for a simple overview of what's happening.
Trace level 2 is a good choice for general purpose tracing.
Levels 3 and above are best reserved for investigating a specific
problem, when you need to see "inside" the driver and DBI.
The trace output is detailed and typically very useful. Much of the
trace output is formatted using the L</neat> function, so strings
in the trace output may be edited and truncated by that function.
=head2 Trace Flags
Trace I<flags> are used to enable tracing of specific activities
within the DBI and drivers. The DBI defines some trace flags and
drivers can define others. DBI trace flag names begin with a capital
letter and driver specific names begin with a lowercase letter, as
usual.
Curently the DBI only defines two trace flags:
ALL - turn on all DBI and driver flags (not recommended)
SQL - trace SQL statements executed (not yet implemented)
The L</parse_trace_flags> and L</parse_trace_flag> methods are used
to convert trace flag names into the coresponding integer bit flags.
=head2 Enabling Trace
The C<$h-E<gt>trace> method sets the trace settings for a handle
and C<DBI-E<gt>trace> does the same for the DBI.
In addition to the L</trace> method, you can enable the same trace
information, and direct the output to a file, by setting the
C<DBI_TRACE> environment variable before starting Perl.
See L</DBI_TRACE> for more information.
Finally, you can set, or get, the trace settings for a handle using
the C<TraceLevel> attribute.
All of those methods use parse_trace_flags() and so allow you set
both the trace level and multiple trace flags by using a string
containing the trace level and/or flag names separated by vertical
bar ("C<|>") or comma ("C<,>") characters. For example:
local $h->{TraceLevel} = "3|SQL|foo";
=head2 Trace Output
Initially trace output is written to C<STDERR>. Both the
C<$h-E<gt>trace> and C<DBI-E<gt>trace> methods take an optional
$trace_filename parameter. If specified, and can be opened in
append mode, then I<all> trace output (currently including that
from other handles) is redirected to that file. A warning is
generated if the file can't be opened.
Further calls to trace() without a $trace_filename do not alter where
the trace output is sent. If $trace_filename is undefined, then
trace output is sent to C<STDERR> and the previous trace file is closed.
Currently $trace_filename can't be a filehandle. But meanwhile you
can use the special strings C<"STDERR"> and C<"STDOUT"> to select
those filehandles.
=head2 Tracing Tips
You can add tracing to your own application code using the
L</trace_msg> method.
It can sometimes be handy to compare trace files from two different
=head2 FAQ
Please also read the DBI FAQ which is installed as a DBI::FAQ module.
You can use I<perldoc> to read it by executing the C<perldoc DBI::FAQ> command.
=head1 AUTHORS
DBI by Tim Bunce. This pod text by Tim Bunce, J. Douglas Dunlop,
Jonathan Leffler and others. Perl by Larry Wall and the
C<perl5-porters>.
=head1 COPYRIGHT
The DBI module is Copyright (c) 1994-2004 Tim Bunce. Ireland.
All rights reserved.
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file.
=head1 SUPPORT / WARRANTY
The DBI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND.
=head2 Support
My consulting company, Data Plan Services, offers annual and
multi-annual support contracts for the DBI. These provide sustained
support for DBI development, and sustained value for you in return.
Contact me for details.
=head2 Sponsor Enhancements
The DBI Roadmap is available at L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
If your company would benefit from a specific new DBI feature,
please consider sponsoring its development. Work is performed
rapidly, and usually on a fixed-price payment-on-delivery basis.
Contact me for details.
Using such targeted financing allows you to contribute to DBI
development, and rapidly get something specific and valuable in return.
=head1 ACKNOWLEDGEMENTS
I would like to acknowledge the valuable contributions of the many
people I have worked with on the DBI project, especially in the early
years (1992-1994). In no particular order: Kevin Stock, Buzz Moschetti,
Kurt Andersen, Ted Lemon, William Hails, Garth Kennedy, Michael Peppler,
Neil S. Briscoe, Jeff Urlwin, David J. Hughes, Jeff Stander,
Forrest D Whitcher, Larry Wall, Jeff Fried, Roy Johnson, Paul Hudson,
Georg Rehfeld, Steve Sizemore, Ron Pool, Jon Meek, Tom Christiansen,
Steve Baumgarten, Randal Schwartz, and a whole lot more.
Then, of course, there are the poor souls who have struggled through
untold and undocumented obstacles to actually implement DBI drivers.
Among their ranks are Jochen Wiedmann, Alligator Descartes, Jonathan
Leffler, Jeff Urlwin, Michael Peppler, Henrik Tougaard, Edwin Pratomo,
Davide Migliavacca, Jan Pazdziora, Peter Haworth, Edmund Mergl, Steve
Williams, Thomas Lowery, and Phlip Plumlee. Without them, the DBI would
not be the practical reality it is today. I'm also especially grateful
to Alligator Descartes for starting work on the first edition of the
"Programming the Perl DBI" book and letting me jump on board.
The DBI and DBD::Oracle were originally developed while I was Technical
Director (CTO) of the Paul Ingram Group (www.ig.co.uk). So I'd
especially like to thank Paul for his generosity and vision in
supporting this work for many years.
=head1 CONTRIBUTING
As you can see above, many people have contributed to the DBI and
drivers in many ways over many years.
If you'd like to help then see L<http://dbi.perl.org/contributing>
and L<http://search.cpan.org/~timb/DBI/Roadmap.pod>
If you'd like the DBI to do something new or different then a good way
to make that happen is to do it yourself and send me a patch to the
source code that shows the changes. (But read "Speak before you patch"
below.)
=head2 Browsing the source code repository
Use http://svn.perl.org/modules/dbi/trunk (basic)
or http://svn.perl.org/viewcvs/modules/ (more useful)
=head2 How to create a patch using Subversion
The DBI source code is maintained using Subversion (a replacement
for CVS, see L<http://subversion.tigris.org/>). To access the source
you'll need to install a Subversion client. Then, to get the source
code, do:
svn checkout http://svn.perl.org/modules/dbi/trunk
If it prompts for a username and password use your perl.org account
if you have one, else just 'guest' and 'guest'. The source code will
be in a new subdirectory called C<trunk>.
To keep informed about changes to the source you can send an empty email
to dbi-changes@perl.org after which you'll get an email with the
change log message and diff of each change checked-in to the source.
After making your changes you can generate a patch file, but before
you do, make sure your source is still upto date using:
svn update
If you get any conflicts reported you'll need to fix them first.
Then generate the patch file from within the C<trunk> directory using:
svn diff > foo.patch
Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org.
=head2 How to create a patch without Subversion
Unpack a fresh copy of the distribution:
tar xfz DBI-1.40.tar.gz
( run in 1.062 second using v1.01-cache-2.11-cpan-5837b0d9d2c )