Apache-LoggedAuthDBI
view release on metacpan or search on metacpan
SQL_LONGVARBINARY
SQL_VARBINARY
SQL_BINARY
SQL_LONGVARCHAR
SQL_UNKNOWN_TYPE
SQL_ALL_TYPES
SQL_CHAR
SQL_NUMERIC
SQL_DECIMAL
SQL_INTEGER
SQL_SMALLINT
SQL_FLOAT
SQL_REAL
SQL_DOUBLE
SQL_DATETIME
SQL_DATE
SQL_INTERVAL
SQL_TIME
SQL_TIMESTAMP
SQL_VARCHAR
SQL_BOOLEAN
SQL_UDT
SQL_UDT_LOCATOR
SQL_ROW
SQL_REF
SQL_BLOB
SQL_BLOB_LOCATOR
SQL_CLOB
SQL_CLOB_LOCATOR
SQL_ARRAY
SQL_ARRAY_LOCATOR
SQL_MULTISET
SQL_MULTISET_LOCATOR
SQL_TYPE_DATE
SQL_TYPE_TIME
SQL_TYPE_TIMESTAMP
SQL_TYPE_TIME_WITH_TIMEZONE
SQL_TYPE_TIMESTAMP_WITH_TIMEZONE
SQL_INTERVAL_YEAR
SQL_INTERVAL_MONTH
SQL_INTERVAL_DAY
SQL_INTERVAL_HOUR
SQL_INTERVAL_MINUTE
SQL_INTERVAL_SECOND
SQL_INTERVAL_YEAR_TO_MONTH
SQL_INTERVAL_DAY_TO_HOUR
SQL_INTERVAL_DAY_TO_MINUTE
SQL_INTERVAL_DAY_TO_SECOND
SQL_INTERVAL_HOUR_TO_MINUTE
SQL_INTERVAL_HOUR_TO_SECOND
SQL_INTERVAL_MINUTE_TO_SECOND
) ],
sql_cursor_types => [ qw(
SQL_CURSOR_FORWARD_ONLY
SQL_CURSOR_KEYSET_DRIVEN
SQL_CURSOR_DYNAMIC
SQL_CURSOR_STATIC
SQL_CURSOR_TYPE_DEFAULT
) ], # for ODBC cursor types
utils => [ qw(
neat neat_list $neat_maxlen dump_results looks_like_number
data_string_diff data_string_desc data_diff
) ],
profile => [ qw(
dbi_profile dbi_profile_merge dbi_time
) ], # notionally "in" DBI::Profile and normally imported from there
);
$DBI::dbi_debug = 0;
$DBI::neat_maxlen = 400;
# If you get an error here like "Can't find loadable object ..."
# then you haven't installed the DBI correctly. Read the README
# then install it again.
if ( $ENV{DBI_PUREPERL} ) {
eval { bootstrap DBI } if $ENV{DBI_PUREPERL} == 1;
require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2;
$DBI::PurePerl ||= 0; # just to silence "only used once" warnings
}
else {
bootstrap DBI;
}
$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ];
Exporter::export_ok_tags(keys %EXPORT_TAGS);
}
# Alias some handle methods to also be DBI class methods
for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) {
no strict;
*$_ = \&{"DBD::_::common::$_"};
}
use strict;
DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE};
$DBI::connect_via = "connect";
# check if user wants a persistent database connection ( Apache + mod_perl )
if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
$DBI::connect_via = "Apache::DBI::connect";
DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n");
}
%DBI::installed_drh = (); # maps driver names to installed driver handles
# 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 {} }
} 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)
# $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.
foreach $data_type (@data_type_list) {
if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) {
push @ti, grep { $_->[$dt_idx] == $data_type } @$tia;
}
else { # SQL_ALL_TYPES
push @ti, @$tia;
}
last if @ti; # found at least one match
}
# --- format results into list of hash refs
my $idx_fields = keys %$idx_hash;
my @idx_names = map { uc($_) } keys %$idx_hash;
my @idx_values = values %$idx_hash;
Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields"
if @ti && @{$ti[0]} != $idx_fields;
my @out = map {
my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h;
} @ti;
return $out[0] unless wantarray;
return @out;
}
sub data_sources {
my ($dbh, @other) = @_;
my $drh = $dbh->{Driver}; # XXX proxy issues?
return $drh->data_sources(@other);
}
}
{ package # hide from PAUSE
DBD::_::st; # ====== STATEMENT ======
@DBD::_::st::ISA = qw(DBD::_::common);
use strict;
sub bind_param { Carp::croak("Can't bind_param, not implement by driver") }
#
# ********************************************************
#
# BEGIN ARRAY BINDING
#
# Array binding support for drivers which don't support
# array binding, but have sufficient interfaces to fake it.
# NOTE: mixing scalars and arrayrefs requires using bind_param_array
# for *all* params...unless we modify bind_param for the default
# case...
#
# 2002-Apr-10 D. Arnold
sub bind_param_array {
my $sth = shift;
my ($p_id, $value_array, $attr) = @_;
return $sth->set_err(1, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array))
if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY';
return $sth->set_err(1, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array")
unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here
return $sth->set_err(1, "Placeholder '$p_id' is out of range")
if $p_id <= 0; # can't easily/reliably test for too big
# get/create arrayref to hold params
my $hash_of_arrays = $sth->{ParamArrays} ||= { };
# If the bind has attribs then we rely on the driver conforming to
# the DBI spec in that a single bind_param() call with those attribs
# makes them 'sticky' and apply to all later execute(@values) calls.
# Since we only call bind_param() if we're given attribs then
# applications using drivers that don't support bind_param can still
# use bind_param_array() so long as they don't pass any attribs.
$$hash_of_arrays{$p_id} = $value_array;
return $sth->bind_param($p_id, undef, $attr)
if $attr;
1;
}
sub bind_param_inout_array {
my $sth = shift;
# XXX not supported so we just call bind_param_array instead
# and then return an error
my ($p_num, $value_array, $attr) = @_;
$sth->bind_param_array($p_num, $value_array, $attr);
return $sth->set_err(1, "bind_param_inout_array not supported");
}
sub bind_columns {
my $sth = shift;
my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0;
if ($fields <= 0 && !$sth->{Active}) {
return $sth->set_err(1, "Statement has no result columns to bind"
." (perhaps you need to successfully call execute first)");
}
# Backwards compatibility for old-style call with attribute hash
# ref as first arg. Skip arg if undef or a hash ref.
my $attr;
$attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH';
die "bind_columns called with ".@_." refs when $fields needed."
if @_ != $fields;
my $idx = 0;
$sth->bind_col(++$idx, shift, $attr) or return
while (@_);
return 1;
}
sub execute_array {
my $sth = shift;
my ($attr, @array_of_arrays) = @_;
my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point
# get tuple status array or hash attribute
my $tuple_sts = $attr->{ArrayTupleStatus};
return $sth->set_err(1, "ArrayTupleStatus attribute must be an arrayref")
if $tuple_sts and ref $tuple_sts ne 'ARRAY';
# bind all supplied arrays
}
}
return ($err_count) ? undef : scalar(@$tuple_status)||"0E0";
}
sub fetchall_arrayref { # ALSO IN Driver.xst
my ($sth, $slice, $max_rows) = @_;
$max_rows = -1 unless defined $max_rows;
my $mode = ref($slice) || 'ARRAY';
my @rows;
my $row;
if ($mode eq 'ARRAY') {
# we copy the array here because fetch (currently) always
# returns the same array ref. XXX
if ($slice && @$slice) {
$max_rows = -1 unless defined $max_rows;
push @rows, [ @{$row}[ @$slice] ]
while($max_rows-- and $row = $sth->fetch);
}
elsif (defined $max_rows) {
$max_rows = -1 unless defined $max_rows;
push @rows, [ @$row ]
while($max_rows-- and $row = $sth->fetch);
}
else {
push @rows, [ @$row ] while($row = $sth->fetch);
}
}
elsif ($mode eq 'HASH') {
$max_rows = -1 unless defined $max_rows;
if (keys %$slice) {
my @o_keys = keys %$slice;
my @i_keys = map { lc } keys %$slice;
while ($max_rows-- and $row = $sth->fetchrow_hashref('NAME_lc')) {
my %hash;
@hash{@o_keys} = @{$row}{@i_keys};
push @rows, \%hash;
}
}
else {
# XXX assumes new ref each fetchhash
push @rows, $row
while ($max_rows-- and $row = $sth->fetchrow_hashref());
}
}
else { Carp::croak("fetchall_arrayref($mode) invalid") }
return \@rows;
}
sub fetchall_hashref {
my ($sth, $key_field) = @_;
my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
my $names_hash = $sth->FETCH("${hash_key_name}_hash");
my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
my @key_indexes;
my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
foreach (@key_fields) {
my $index = $names_hash->{$_}; # perl index not column
$index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
return $sth->set_err(1, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
unless defined $index;
push @key_indexes, $index;
}
my $rows = {};
my $NAME = $sth->FETCH($hash_key_name);
my @row = (undef) x $num_of_fields;
$sth->bind_columns(\(@row));
while ($sth->fetch) {
my $ref = $rows;
$ref = $ref->{$row[$_]} ||= {} for @key_indexes;
@{$ref}{@$NAME} = @row;
}
return $rows;
}
*dump_results = \&DBI::dump_results;
sub blob_copy_to_file { # returns length or undef on error
my($self, $field, $filename_or_handleref, $blocksize) = @_;
my $fh = $filename_or_handleref;
my($len, $buf) = (0, "");
$blocksize ||= 512; # not too ambitious
local(*FH);
unless(ref $fh) {
open(FH, ">$fh") || return undef;
$fh = \*FH;
}
while(defined($self->blob_read($field, $len, $blocksize, \$buf))) {
print $fh $buf;
$len += length $buf;
}
close(FH);
$len;
}
sub more_results {
shift->{syb_more_results}; # handy grandfathering
}
}
unless ($DBI::PurePerl) { # See install_driver
{ @DBD::_mem::dr::ISA = qw(DBD::_mem::common); }
{ @DBD::_mem::db::ISA = qw(DBD::_mem::common); }
{ @DBD::_mem::st::ISA = qw(DBD::_mem::common); }
# DBD::_mem::common::DESTROY is implemented in DBI.xs
}
1;
__END__
=head1 DESCRIPTION
The DBI is a database access module for the Perl programming language. It defines
a set of methods, variables, and conventions that provide a consistent
database interface, independent of the actual database being used.
It is important to remember that the DBI is just an interface.
The DBI is a layer
The data_string_diff() function only considers logical I<characters>
and not the underlying encoding. See L</data_diff> for an alternative.
The data_string_diff() function was added in DBI 1.46.
=item C<data_diff>
$diff = data_diff($a, $b);
$diff = data_diff($a, $b, $logical);
Returns an informal description of the difference between two strings.
It calls L</data_string_desc> and L</data_string_diff>
and returns the combined results as a multi-line string.
For example, C<data_diff("abc", "ab\x{263a}")> will return:
a: UTF8 off, ASCII, 3 characters 3 bytes
b: UTF8 on, non-ASCII, 3 characters 5 bytes
Strings differ at index 2: a[2]=c, b[2]=\x{263A}
If $a and $b are identical in both the characters they contain I<and>
their physical encoding then data_diff() returns an empty string.
If $logical is true then physical encoding differences are ignored
(but are still reported if there is a difference in the characters).
The data_diff() function was added in DBI 1.46.
=item C<neat>
$str = neat($value);
$str = neat($value, $maxlen);
Return a string containing a neat (and tidy) representation of the
supplied value.
Strings will be quoted, although internal quotes will I<not> be escaped.
Values known to be numeric will be unquoted. Undefined (NULL) values
will be shown as C<undef> (without quotes).
If the string is flagged internally as utf8 then double quotes will
be used, otherwise single quotes are used and unprintable characters
will be replaced by dot (.).
For result strings longer than C<$maxlen> the result string will be
truncated to C<$maxlen-4> and "C<...'>" will be appended. If C<$maxlen> is 0
or C<undef>, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400.
This function is designed to format values for human consumption.
It is used internally by the DBI for L</trace> output. It should
typically I<not> be used for formatting values for database use.
(See also L</quote>.)
=item C<neat_list>
$str = neat_list(\@listref, $maxlen, $field_sep);
Calls C<neat> on each element of the list and returns a string
containing the results joined with C<$field_sep>. C<$field_sep> defaults
to C<", ">.
=item C<looks_like_number>
@bool = looks_like_number(@array);
Returns true for each element that looks like a number.
Returns false for each element that does not look like a number.
Returns C<undef> for each element that is undefined or empty.
=item C<hash>
$hash_value = DBI::hash($buffer, $type);
Return a 32-bit integer 'hash' value corresponding to the contents of $buffer.
The $type parameter selects which kind of hash algorithm should be used.
For the technically curious, type 0 (which is the default if $type
isn't specified) is based on the Perl 5.1 hash except that the value
is forced to be negative (for obscure historical reasons).
Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See
L<http://www.isthe.com/chongo/tech/comp/fnv/> for more information.
Both types are implemented in C and are very fast.
This function doesn't have much to do with databases, except that
it can be handy to store hash values in a database.
=back
=head2 DBI Dynamic Attributes
Dynamic attributes are always associated with the I<last handle used>
(that handle is represented by C<$h> in the descriptions below).
Where an attribute is equivalent to a method call, then refer to
the method call for all related documentation.
Warning: these attributes are provided as a convenience but they
do have limitations. Specifically, they have a short lifespan:
because they are associated with
the last handle used, they should only be used I<immediately> after
calling the method that "sets" them.
If in any doubt, use the corresponding method call.
=over 4
=item C<$DBI::err>
Equivalent to C<$h-E<gt>err>.
=item C<$DBI::errstr>
Equivalent to C<$h-E<gt>errstr>.
=item C<$DBI::state>
Equivalent to C<$h-E<gt>state>.
=item C<$DBI::rows>
Equivalent to C<$h-E<gt>rows>. Please refer to the documentation
for the L</rows> method.
=item C<$DBI::lasth>
Returns the DBI object handle used for the most recent DBI method call.
bound as an SQL_INTEGER type may be returned as an integer.
The values returned by C<ParamValues> can be passed to another
bind_param() method with the same TYPE and will be seen by the
database as the same value.
It is also possible that the keys in the hash returned by C<ParamValues>
are not exactly the same as those implied by the prepared statement.
For example, DBD::Oracle translates 'C<?>' placeholders into 'C<:pN>'
where N is a sequence number starting at 1.
The C<ParamValues> attribute was added in DBI 1.28.
=item C<Statement> (string, read-only)
Returns the statement string passed to the L</prepare> method.
=item C<RowsInCache> (integer, read-only)
If the driver supports a local row cache for C<SELECT> statements, then
this attribute holds the number of un-fetched rows in the cache. If the
driver doesn't, then it returns C<undef>. Note that some drivers pre-fetch
rows on execute, whereas others wait till the first fetch.
See also the L</RowCacheSize> database handle attribute.
=back
=head1 OTHER METHODS
=over 4
=item C<install_method>
DBD::Foo::db->install_method($method_name, \%attr);
Installs the driver-private method named by $method_name into the
DBI method dispatcher so it can be called directly, avoiding the
need to use the func() method.
It is called as a static method on the driver class to which the
method belongs. The method name must begin with the corresponding
registered driver-private prefix. For example, for DBD::Oracle
$method_name must being with 'C<ora_>', and for DBD::AnyData it
must begin with 'C<ad_>'.
The attributes can be used to provide fine control over how the DBI
dispatcher handles the dispatching of the method. However, at this
point, it's undocumented and very liable to change. (Volunteers to
polish up and document the interface are very welcome to get in
touch via dbi-dev@perl.org)
Methods installed using install_method default to the standard error
handling behaviour for DBI methods: clearing err and errstr before
calling the method, and checking for errors to trigger RaiseError
etc. on return. This differs from the default behaviour of func().
Note for driver authors: The DBD::Foo::xx->install_method call won't
work until the class-hierarchy has been setup. Normally the DBI
looks after that just after the driver is loaded. This means
install_method() can't be called at the time the driver is loaded
unless the class-hierarchy is set up first. The way to do that is
to call the setup_driver() method:
DBI->setup_driver('DBD::Foo');
before using install_method().
=back
=head1 FURTHER INFORMATION
=head2 Catalog Methods
An application can retrieve metadata information from the DBMS by issuing
appropriate queries on the views of the Information Schema. Unfortunately,
C<INFORMATION_SCHEMA> views are seldom supported by the DBMS.
Special methods (catalog methods) are available to return result sets
for a small but important portion of that metadata:
column_info
foreign_key_info
primary_key_info
table_info
All catalog methods accept arguments in order to restrict the result sets.
Passing C<undef> to an optional argument does not constrain the search for
that argument.
However, an empty string ('') is treated as a regular search criteria
and will only match an empty value.
B<Note>: SQL/CLI and ODBC differ in the handling of empty strings. An
empty string will not restrict the result set in SQL/CLI.
Most arguments in the catalog methods accept only I<ordinary values>, e.g.
the arguments of C<primary_key_info()>.
Such arguments are treated as a literal string, i.e. the case is significant
and quote characters are taken literally.
Some arguments in the catalog methods accept I<search patterns> (strings
containing '_' and/or '%'), e.g. the C<$table> argument of C<column_info()>.
Passing '%' is equivalent to leaving the argument C<undef>.
B<Caveat>: The underscore ('_') is valid and often used in SQL identifiers.
Passing such a value to a search pattern argument may return more rows than
expected!
To include pattern characters as literals, they must be preceded by an
escape character which can be achieved with
$esc = $dbh->get_info( 14 ); # SQL_SEARCH_PATTERN_ESCAPE
$search_pattern =~ s/([_%])/$esc$1/g;
The ODBC and SQL/CLI specifications define a way to change the default
behaviour described above: All arguments (except I<list value arguments>)
are treated as I<identifier> if the C<SQL_ATTR_METADATA_ID> attribute is
set to C<SQL_TRUE>.
I<Quoted identifiers> are very similar to I<ordinary values>, i.e. their
body (the string within the quotes) is interpreted literally.
I<Unquoted identifiers> are compared in UPPERCASE.
( run in 1.992 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )