/linkedfs/usr/lib/perl5/vendor_perl/5.8.6/i386-linux/DBI.pm
Perl | 7160 lines | 6033 code | 994 blank | 133 comment | 442 complexity | 81a020ca5ba4aa7046b23fda929c7b40 MD5 | raw file
Possible License(s): GPL-2.0, MIT, LGPL-3.0
Large files files are truncated, but you can click here to view the full file
- # $Id: DBI.pm,v 11.43 2004/02/01 11:16:16 timbo Exp $
- # vim: ts=8:sw=4
- #
- # Copyright (c) 1994-2004 Tim Bunce Ireland
- #
- # See COPYRIGHT section in pod text below for usage and distribution rights.
- #
- require 5.006_00;
- BEGIN {
- $DBI::VERSION = "1.47"; # ==> ALSO update the version in the pod text below!
- }
- =head1 NAME
- DBI - Database independent interface for Perl
- =head1 SYNOPSIS
- use DBI;
- @driver_names = DBI->available_drivers;
- @data_sources = DBI->data_sources($driver_name, \%attr);
- $dbh = DBI->connect($data_source, $username, $auth, \%attr);
- $rv = $dbh->do($statement);
- $rv = $dbh->do($statement, \%attr);
- $rv = $dbh->do($statement, \%attr, @bind_values);
- $ary_ref = $dbh->selectall_arrayref($statement);
- $hash_ref = $dbh->selectall_hashref($statement, $key_field);
- $ary_ref = $dbh->selectcol_arrayref($statement);
- $ary_ref = $dbh->selectcol_arrayref($statement, \%attr);
- @row_ary = $dbh->selectrow_array($statement);
- $ary_ref = $dbh->selectrow_arrayref($statement);
- $hash_ref = $dbh->selectrow_hashref($statement);
- $sth = $dbh->prepare($statement);
- $sth = $dbh->prepare_cached($statement);
- $rc = $sth->bind_param($p_num, $bind_value);
- $rc = $sth->bind_param($p_num, $bind_value, $bind_type);
- $rc = $sth->bind_param($p_num, $bind_value, \%attr);
- $rv = $sth->execute;
- $rv = $sth->execute(@bind_values);
- $rv = $sth->execute_array(\%attr, ...);
- $rc = $sth->bind_col($col_num, \$col_variable);
- $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind);
- @row_ary = $sth->fetchrow_array;
- $ary_ref = $sth->fetchrow_arrayref;
- $hash_ref = $sth->fetchrow_hashref;
- $ary_ref = $sth->fetchall_arrayref;
- $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows );
- $hash_ref = $sth->fetchall_hashref( $key_field );
- $rv = $sth->rows;
- $rc = $dbh->begin_work;
- $rc = $dbh->commit;
- $rc = $dbh->rollback;
- $quoted_string = $dbh->quote($string);
- $rc = $h->err;
- $str = $h->errstr;
- $rv = $h->state;
- $rc = $dbh->disconnect;
- I<The synopsis above only lists the major methods and parameters.>
- =head2 GETTING HELP
- If you have questions about DBI, or DBD driver modules, you can get
- help from the I<dbi-users@perl.org> mailing list. You can get help
- on subscribing and using the list by emailing I<dbi-users-help@perl.org>.
- (To help you make the best use of the dbi-users mailing list,
- and any other lists or forums you may use, I I<strongly>
- recommend that you read "How To Ask Questions The Smart Way"
- by Eric Raymond: L<http://www.catb.org/~esr/faqs/smart-questions.html>)
- The DBI home page at L<http://dbi.perl.org/> is always worth a visit
- and includes an FAQ and links to other resources.
- Before asking any questions, reread this document, consult the
- archives and read the DBI FAQ. The archives are listed
- at the end of this document and on the DBI home page.
- An FAQ is installed as a L<DBI::FAQ> module so
- you can read it by executing C<perldoc DBI::FAQ>.
- However the DBI::FAQ module is currently (2004) outdated relative
- to the online FAQ on the DBI home page.
- This document often uses terms like I<references>, I<objects>,
- I<methods>. If you're not familar with those terms then it would
- be a good idea to read at least the following perl manuals first:
- L<perlreftut>, L<perldsc>, L<perllol>, and L<perlboot>.
- Please note that Tim Bunce does not maintain the mailing lists or the
- web page (generous volunteers do that). So please don't send mail
- directly to him; he just doesn't have the time to answer questions
- personally. The I<dbi-users> mailing list has lots of experienced
- people who should be able to help you if you need it. If you do email
- Tim he's very likely to just forward it to the mailing list.
- =head2 NOTES
- This is the DBI specification that corresponds to the DBI version 1.47.
- The DBI is evolving at a steady pace, so it's good to check that
- you have the latest copy.
- The significant user-visible changes in each release are documented
- in the L<DBI::Changes> module so you can read them by executing
- C<perldoc DBI::Changes>.
- Some DBI changes require changes in the drivers, but the drivers
- can take some time to catch up. Newer versions of the DBI have
- added features that may not yet be supported by the drivers you
- use. Talk to the authors of your drivers if you need a new feature
- that's not yet supported.
- Features added after DBI 1.21 (February 2002) are marked in the
- text with the version number of the DBI release they first appeared in.
- Extensions to the DBI API often use the C<DBIx::*> namespace.
- See L</Naming Conventions and Name Space>. DBI extension modules
- can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>.
- And all modules related to the DBI can be found at
- L<http://search.cpan.org/search?query=DBI&mode=all>.
- =cut
- # The POD text continues at the end of the file.
- package DBI;
- use Carp();
- use DynaLoader ();
- use Exporter ();
- BEGIN {
- @ISA = qw(Exporter DynaLoader);
- # Make some utility functions available if asked for
- @EXPORT = (); # we export nothing by default
- @EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags:
- %EXPORT_TAGS = (
- sql_types => [ qw(
- SQL_GUID
- SQL_WLONGVARCHAR
- SQL_WVARCHAR
- SQL_WCHAR
- SQL_BIT
- SQL_TINYINT
- 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 {} }
- 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', },
- 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', },
- };
- 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, ...]'] },
- bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] },
- bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] },
- execute => { U =>[1,0,'[@args]'], O=>0x1040 },
- bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] },
- bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] },
- execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040 },
- execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040 },
- fetch => undef, # alias for fetchrow_arrayref
- fetchrow_arrayref => undef,
- fetchrow_hashref => undef,
- fetchrow_array => undef,
- fetchrow => undef, # old alias for fetchrow_array
- fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
- fetchall_hashref => { U =>[2,2,'$key_field'] },
- blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] },
- blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
- dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] },
- more_results => { U =>[1,1] },
- finish => { U =>[1,1] },
- cancel => { U =>[1,1], O=>0x0800 },
- rows => $keeperr,
- _get_fbav => undef,
- _set_fbav => { T=>6 },
- },
- );
- while ( my ($class, $meths) = each %DBI::DBI_methods ) {
- while ( my ($method, $info) = each %$meths ) {
- my $fullmeth = "DBI::${class}::$method";
- DBI->_install_method($fullmeth, 'DBI.pm', $info);
- }
- }
- {
- package DBI::common;
- @DBI::dr::ISA = ('DBI::common');
- @DBI::db::ISA = ('DBI::common');
- @DBI::st::ISA = ('DBI::common');
- }
- # End of init code
- END {
- return unless defined &DBI::trace_msg; # return unless bootstrap'd ok
- local ($!,$?);
- DBI->trace_msg(" -- DBI::END\n", 2);
- # Let drivers know why we are calling disconnect_all:
- $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning
- DBI->disconnect_all() if %DBI::installed_drh;
- }
- sub CLONE {
- my $olddbis = $DBI::_dbistate;
- _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure
- DBI->trace_msg(sprintf "CLONE DBI for new thread %s\n",
- $DBI::PurePerl ? "" : sprintf("(dbis %x -> %x)",$olddbis, $DBI::_dbistate));
- while ( my ($driver, $drh) = each %DBI::installed_drh) {
- no strict 'refs';
- next if defined &{"DBD::${driver}::CLONE"};
- warn("$driver has no driver CLONE() function so is unsafe threaded\n");
- }
- %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize
- }
- sub parse_dsn {
- my ($class, $dsn) = @_;
- $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return;
- my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3);
- $driver ||= $ENV{DBI_DRIVER} || '';
- $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr;
- return ($scheme, $driver, $attr, $attr_hash, $dsn);
- }
- # --- The DBI->connect Front Door methods
- sub connect_cached {
- # For library code using connect_cached() with mod_perl
- # we redirect those calls to Apache::DBI::connect() as well
- my ($class, $dsn, $user, $pass, $attr) = @_;
- # XXX modifies callers data!
- ($attr ||= {})->{dbi_connect_method} =
- ($DBI::connect_via eq "Apache::DBI::connect")
- ? 'Apache::DBI::connect' : 'connect_cached';
- return $class->connect($dsn, $user, $pass, $attr);
- }
- sub connect {
- my $class = shift;
- my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_;
- my $driver;
- if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style
- Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions");
- ($old_driver, $attr) = ($attr, $old_driver);
- }
- my $connect_meth = $attr->{dbi_connect_method};
- $connect_meth ||= $DBI::connect_via; # fallback to default
- $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver;
- if ($DBI::dbi_debug) {
- local $^W = 0;
- pop @_ if $connect_meth ne 'connect';
- 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 $@;
- }
- }
- # 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
- # especially useful with connect_cached() XXX not enabled/tested/documented
- if (0 and $dbh and my $oc = $dbh->{OnConnect}) { # XXX
- $oc->($dbh, $dsn, $user, $pass, $attr) if ref $oc eq 'CODE';
- }
- DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug;
- return $dbh;
- };
- my $dbh = &$connect_closure(undef, undef);
- $dbh->{dbi_connect_closure} = $connect_closure if $dbh;
- return $dbh;
- }
- sub disconnect_all {
- keys %DBI::installed_drh; # reset iterator
- while ( my ($name, $drh) = each %DBI::installed_drh ) {
- $drh->disconnect_all() if ref $drh;
- }
- }
- sub disconnect { # a regular beginners bug
- Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)");
- }
- sub install_driver { # croaks on failure
- my $class = shift;
- my($driver, $attr) = @_;
- my $drh;
- $driver ||= $ENV{DBI_DRIVER} || '';
- # allow driver to be specified as a 'dbi:driver:' string
- $driver = $1 if $driver =~ s/^DBI:(.*?)://i;
- Carp::croak("usage: $class->install_driver(\$driver [, \%attr])")
- unless ($driver and @_<=3);
- # already installed
- return $drh if $drh = $DBI::installed_drh{$driver};
- $class->trace_msg(" -> $class->install_driver($driver"
- .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n")
- if $DBI::dbi_debug;
- # --- load the code
- my $driver_class = "DBD::$driver";
- eval qq{package # hide from PAUSE
- DBI::_firesafe; # just in case
- require $driver_class; # load the driver
- };
- if ($@) {
- my $err = $@;
- my $advice = "";
- if ($err =~ /Can't find loadable object/) {
- $advice = "Perhaps DBD::$driver was statically linked into a new perl binary."
- ."\nIn which case you need to use that new perl binary."
- ."\nOr perhaps only the .pm file was installed but not the shared object file."
- }
- elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) {
- my @drv = $class->available_drivers(1);
- $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n"
- ."or perhaps the capitalisation of '$driver' isn't right.\n"
- ."Available drivers: ".join(", ", @drv).".";
- }
- elsif ($err =~ /Can't load .*? for module DBD::/) {
- $advice = "Perhaps a required shared library or dll isn't installed where expected";
- }
- elsif ($err =~ /Can't locate .*? in \@INC/) {
- $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed";
- }
- Carp::croak("install_driver($driver) failed: $err$advice\n");
- }
- if ($DBI::dbi_debug) {
- no strict 'refs';
- (my $driver_file = $driver_class) =~ s/::/\//g;
- my $dbd_ver = ${"$driver_class\::VERSION"} || "undef";
- $class->trace_msg(" install_driver: $driver_class version $dbd_ver"
- ." loaded from $INC{qq($driver_file.pm)}\n");
- }
- # --- do some behind-the-scenes checks and setups on the driver
- $class->setup_driver($driver_class);
- # --- run the driver function
- $drh = eval { $driver_class->driver($attr || {}) };
- unless ($drh && ref $drh && !$@) {
- my $advice = "";
- # catch people on case in-sensitive systems using the wrong case
- $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right."
- if $@ =~ /locate object method/;
- Carp::croak("$driver_class initialisation failed: $@$advice");
- }
- $DBI::installed_drh{$driver} = $drh;
- $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug;
- $drh;
- }
- *driver = \&install_driver; # currently an alias, may change
- sub setup_driver {
- my ($class, $driver_class) = @_;
- my $type;
- foreach $type (qw(dr db st)){
- my $class = $driver_class."::$type";
- no strict 'refs';
- push @{"${class}::ISA"}, "DBD::_::$type"
- unless UNIVERSAL::isa($class, "DBD::_::$type");
- my $mem_class = "DBD::_mem::$type";
- push @{"${class}_mem::ISA"}, $mem_class
- unless UNIVERSAL::isa("${class}_mem", $mem_class)
- or $DBI::PurePerl;
- }
- }
- sub _rebless {
- my $dbh = shift;
- my ($outer, $inner) = DBI::_handles($dbh);
- my $class = shift(@_).'::db';
- bless $inner => $class;
- bless $outer => $class; # outer last for return
- }
- sub _set_isa {
- my ($classes, $topclass) = @_;
- my $trace = DBI->trace_msg(" _set_isa([@$classes])\n");
- foreach my $suffix ('::db','::st') {
- my $previous = $topclass || 'DBI'; # trees are rooted here
- foreach my $class (@$classes) {
- my $base_class = $previous.$suffix;
- my $sub_class = $class.$suffix;
- my $sub_class_isa = "${sub_class}::ISA";
- no strict 'refs';
- if (@$sub_class_isa) {
- DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n")
- if $trace;
- }
- else {
- @$sub_class_isa = ($base_class) unless @$sub_class_isa;
- DBI->trace_msg(" $sub_class_isa = $base_class\n")
- if $trace;
- }
- $previous = $class;
- }
- }
- }
- sub _rebless_dbtype_subclass {
- my ($dbh, $rootclass, $DbTypeSubclass, $attr) = @_;
- # determine the db type names for class hierarchy
- my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass, $attr);
- # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc)
- $_ = $rootclass.'::'.$_ foreach (@hierarchy);
- # load the modules from the 'top down'
- DBI::_load_class($_, 1) foreach (reverse @hierarchy);
- # setup class hierarchy if needed, does both '::db' and '::st'
- DBI::_set_isa(\@hierarchy, $rootclass);
- # finally bless the handle into the subclass
- DBI::_rebless($dbh, $hierarchy[0]);
- }
- sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC
- my ($dbh, $DbTypeSubclass, $attr) = @_;
- if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') {
- # treat $DbTypeSubclass as a comma separated list of names
- my @dbtypes = split /\s*,\s*/, $DbTypeSubclass;
- $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n");
- return @dbtypes;
- }
- # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future?
- my $driver = $dbh->{Driver}->{Name};
- if ( $driver eq 'Proxy' ) {
- # XXX Looking into the internals of DBD::Proxy is questionable!
- ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i
- or die "Can't determine driver name from proxy";
- }
- my @dbtypes = (ucfirst($driver));
- if ($driver eq 'ODBC' || $driver eq 'ADO') {
- # XXX will move these out and make extensible later:
- my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar'
- my %_dbtype_name_map = (
- 'Microsoft SQL Server' => 'MSSQL',
- 'SQL Server' => 'Sybase',
- 'Adaptive Server Anywhere' => 'ASAny',
- 'ADABAS D' => 'AdabasD',
- );
- my $name;
- $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME
- if $driver eq 'ODBC';
- $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value
- if $driver eq 'ADO';
- die "Can't determine driver name! ($DBI::errstr)\n"
- unless $name;
- my $dbtype;
- if ($_dbtype_name_map{$name}) {
- $dbtype = $_dbtype_name_map{$name};
- }
- else {
- if ($name =~ /($_dbtype_name_regexp)/) {
- $dbtype = lc($1);
- }
- else { # generic mangling for other names:
- $dbtype = lc($name);
- }
- $dbtype =~ s/\b(\w)/\U$1/g;
- $dbtype =~ s/\W+/_/g;
- }
- # add ODBC 'behind' ADO
- push @dbtypes, 'ODBC' if $driver eq 'ADO';
- # add discovered dbtype in front of ADO/ODBC
- unshift @dbtypes, $dbtype;
- }
- @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes)
- if (ref $DbTypeSubclass eq 'CODE');
- $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n");
- return @dbtypes;
- }
- sub _load_class {
- my ($load_class, $missing_ok) = @_;
- DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2);
- no strict 'refs';
- return 1 if @{"$load_class\::ISA"}; # already loaded/exists
- (my $module = $load_class) =~ s!::!/!g;
- DBI->trace_msg(" _load_class require $module\n", 2);
- eval { require "$module.pm"; };
- return 1 unless $@;
- return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/;
- die $@;
- }
- sub init_rootclass { # deprecated
- return 1;
- }
- *internal = \&DBD::Switch::dr::driver;
- sub available_drivers {
- my($quiet) = @_;
- my(@drivers, $d, $f);
- local(*DBI::DIR, $@);
- my(%seen_dir, %seen_dbd);
- my $haveFileSpec = eval { require File::Spec };
- foreach $d (@INC){
- chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness
- my $dbd_dir =
- ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD");
- next unless -d $dbd_dir;
- next if $seen_dir{$d};
- $seen_dir{$d} = 1;
- # XXX we have a problem here with case insensitive file systems
- # XXX since we can't tell what case must be used when loading.
- opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n";
- foreach $f (readdir(DBI::DIR)){
- next unless $f =~ s/\.pm$//;
- next if $f eq 'NullP';
- if ($seen_dbd{$f}){
- Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n"
- unless $quiet;
- } else {
- push(@drivers, $f);
- }
- $seen_dbd{$f} = $d;
- }
- closedir(DBI::DIR);
- }
- # "return sort @drivers" will not DWIM in scalar context.
- return wantarray ? sort @drivers : @drivers;
- }
- sub installed_versions {
- my ($class, $quiet) = @_;
- my %error;
- my %version = ( DBI => $DBI::VERSION );
- $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION
- if $DBI::PurePerl;
- for my $driver ($class->available_drivers($quiet)) {
- next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
- my $drh = eval {
- local $SIG{__WARN__} = sub {};
- $class->install_driver($driver);
- };
- ($error{"DBD::$driver"}=$@),next if $@;
- no strict 'refs';
- my $vers = ${"DBD::$driver" . '::VERSION'};
- $version{"DBD::$driver"} = $vers || '?';
- }
- if (wantarray) {
- return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
- }
- if (!defined wantarray) { # void context
- require Config; # add more detail
- $version{OS} = "$^O\t($Config::Config{osvers})";
- $version{Perl} = "$]\t($Config::Config{archname})";
- $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_})
- for keys %error;
- printf " %-16s: %s\n",$_,$version{$_}
- for reverse sort keys %version;
- }
- return \%version;
- }
- sub data_sources {
- my ($class, $driver, @other) = @_;
- my $drh = $class->install_driver($driver);
- my @ds = $drh->data_sources(@other);
- return @ds;
- }
- sub neat_list {
- my ($listref, $maxlen, $sep) = @_;
- $maxlen = 0 unless defined $maxlen; # 0 == use internal default
- $sep = ", " unless defined $sep;
- join($sep, map { neat($_,$maxlen) } @$listref);
- }
- sub dump_results { # also aliased as a method in DBD::_::st
- my ($sth, $maxlen, $lsep, $fsep, $fh) = @_;
- return 0 unless $sth;
- $maxlen ||= 35;
- $lsep ||= "\n";
- $fh ||= \*STDOUT;
- my $rows = 0;
- my $ref;
- while($ref = $sth->fetch) {
- print $fh $lsep if $rows++ and $lsep;
- my $str = neat_list($ref,$maxlen,$fsep);
- print $fh $str; # done on two lines to avoid 5.003 errors
- }
- print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n";
- $rows;
- }
- sub data_diff {
- my ($a, $b, $logical) = @_;
- my $diff = data_string_diff($a, $b);
- return "" if $logical and !$diff;
- my $a_desc = data_string_desc($a);
- my $b_desc = data_string_desc($b);
- return "" if !$diff and $a_desc eq $b_desc;
- $diff ||= "Strings contain the same sequence of characters"
- if length($a);
- $diff .= "\n" if $diff;
- return "a: $a_desc\nb: $b_desc\n$diff";
- }
-
- sub data_string_diff {
- # Compares 'logical' characters, not bytes, so a latin1 string and an
- # an equivalent unicode string will compare as equal even though their
- # byte encodings are different.
- my ($a, $b) = @_;
- unless (defined $a and defined $b) { # one undef
- return ""
- if !defined $a and !defined $b;
- return "String a is undef, string b has ".length($b)." characters"
- if !defined $a;
- return "String b is undef, string a has ".length($a)." characters"
- if !defined $b;
- }
- require utf8;
- # hack to cater for perl 5.6
- *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
- my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a);
- my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b);
- my $i = 0;
- while (@a_chars && @b_chars) {
- ++$i, shift(@a_chars), shift(@b_chars), next
- if $a_chars[0] == $b_chars[0];# compare ordinal values
- my @desc = map {
- $_ > 255 ? # if wide character...
- sprintf("\\x{%04X}", $_) : # \x{...}
- chr($_) =~ /[[:cntrl:]]/ ? # else if control character ...
- sprintf("\\x%02X", $_) : # \x..
- chr($_) # else as themselves
- } ($a_chars[0], $b_chars[0]);
- # highlight probable double-encoding?
- foreach my $c ( @desc ) {
- next unless $c =~ m/\\x\{08(..)}/;
- $c .= "='" .chr(hex($1)) ."'"
- }
- return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]";
- }
- return "String a truncated after $i characters" if @b_chars;
- return "String b truncated after $i characters" if @a_chars;
- return "";
- }
- sub data_string_desc { # describe a data string
- my ($a) = @_;
- require bytes;
- require utf8;
- # hacks to cater for perl 5.6
- *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8;
- *utf8::valid = sub { 1 } unless defined &utf8::valid;
- # Give sufficient info to help diagnose at least these kinds of situations:
- # - valid UTF8 byte sequence but UTF8 flag not set
- # (might be ascii so also need to check for hibit to make it worthwhile)
- # - UTF8 flag set but invalid UTF8 byte sequence
- # could do better here, but this'll do for now
- my $utf8 = sprintf "UTF8 %s%s",
- utf8::is_utf8($a) ? "on" : "off",
- utf8::valid($a||'') ? "" : " but INVALID encoding";
- return "$utf8, undef" unless defined $a;
- my $is_ascii = $a =~ m/^[\000-\177]*$/;
- return sprintf "%s, %s, %d characters %d bytes",
- $utf8, $is_ascii ? "ASCII" : "non-ASCII",
- length($a), bytes::length($a);
- }
- sub connect_test_perf {
- my($class, $dsn,$dbuser,$dbpass, $attr) = @_;
- Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr;
- # these are non standard attributes just for this special method
- my $loops ||= $attr->{dbi_loops} || 5;
- my $par ||= $attr->{dbi_par} || 1; # parallelism
- my $verb ||= $attr->{dbi_verb} || 1;
- print "$dsn: testing $loops sets of $par connections:\n";
- require Benchmark;
- require "FileHandle.pm"; # don't let toke.c create empty FileHandle package
- $| = 1;
- my $t0 = new Benchmark; # not currently used
- my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n");
- my $t1 = new Benchmark;
- my $loop;
- for $loop (1..$loops) {
- my @cons;
- print "Connecting... " if $verb;
- for (1..$par) {
- print "$_ ";
- push @cons, ($drh->connect($dsn,$dbuser,$dbpass)
- or Carp::croak("Can't connect # $_: $DBI::errstr\n"));
- }
- print "\nDisconnecting...\n" if $verb;
- for (@cons) {
- $_->disconnect or warn "bad disconnect $DBI::errstr"
- }
- }
- my $t2 = new Benchmark;
- my $td = Benchmark::timediff($t2, $t1);
- printf "Made %2d connections in %s\n", $loops*$par, Benchmark::timestr($td);
- print "\n";
- return $td;
- }
- # Help people doing DBI->errstr, might even document it one day
- # XXX probably best moved to cheaper XS code
- sub err { $DBI::err }
- sub errstr { $DBI::errstr }
- # --- Private Internal Function for Creating New DBI Handles
- sub _new_handle {
- my ($class, $parent, $attr, $imp_data, $imp_class) = @_;
- Carp::croak('Usage: DBI::_new_handle'
- .'($class_name, parent_handle, \%attr, $imp_data)'."\n"
- .'got: ('.join(", ",$class, $parent, $attr, $imp_data).")\n")
- unless (@_ == 5 and (!$parent or ref $parent)
- and ref $attr eq 'HASH'
- and $imp_class);
- $attr->{ImplementorClass} = $imp_class
- or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given");
- DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n")
- if $DBI::dbi_debug >= 3;
- # This is how we create a DBI style Object:
- my (%hash, $i, $h);
- $i = tie %hash, $class, $attr; # ref to inner hash (for driver)
- $h = bless \%hash, $class; # ref to outer hash (for application)
- # The above tie and bless may migrate down into _setup_handle()...
- # Now add magic so DBI method dispatch works
- DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
- return $h unless wantarray;
- ($h, $i);
- }
- # XXX minimum constructors for the tie's (alias to XS version)
- sub DBI::st::TIEHASH { bless $_[1] => $_[0] };
- *DBI::dr::TIEHASH = \&DBI::st::TIEHASH;
- *DBI::db::TIEHASH = \&DBI::st::TIEHASH;
- # These three special constructors are called by the drivers
- # The way they are called is likely to change.
- my $profile;
- sub _new_drh { # called by DBD::<drivername>::driver()
- my ($class, $initial_attr, $imp_data) = @_;
- # Provide default storage for State,Err and Errstr.
- # Note that these are shared by all child handles by default! XXX
- # State must be undef to get automatic faking in DBI::var::FETCH
- my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, 0, '');
- my $attr = {
- # these attributes get copied down to child handles by default
- 'State' => \$h_state_store, # Holder for DBI::state
- 'Err' => \$h_err_store, # Holder for DBI::err
- 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr
- 'TraceLevel' => 0,
- FetchHashKeyName=> 'NAME',
- %$initial_attr,
- };
- my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class);
- # XXX DBI_PROFILE unless DBI::PurePerl because for some reason
- # it kills the t/zz_*_pp.t tests (they silently exit early)
- if ($ENV{DBI_PROFILE} && !$DBI::PurePerl) {
- # The profile object created here when the first driver is loaded
- # is shared by all drivers so we end up with just one set of profile
- # data and thus the 'total time in DBI' is really the true total.
- if (!$profile) { # first time
- $h->{Profile} = $ENV{DBI_PROFILE};
- $profile = $h->{Profile};
- }
- else {
- $h->{Profile} = $profile;
- }
- }
- return $h unless wantarray;
- ($h, $i);
- }
- sub _new_dbh { # called by DBD::<drivername>::dr::connect()
- my ($drh, $attr, $imp_data) = @_;
- my $imp_class = $drh->{ImplementorClass}
- or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass");
- substr($imp_class,-4,4) = '::db';
- my $app_class = ref $drh;
- substr($app_class,-4,4) = '::db';
- $attr->{Err} ||= \my $err;
- $attr->{Errstr} ||= \my $errstr;
- $attr->{State} ||= \my $state;
- _new_handle($app_class, $drh, $attr, $imp_data, $imp_class);
- }
- sub _new_sth { # called by DBD::<drivername>::db::prepare)
- my ($dbh, $attr, $imp_data) = @_;
- my $imp_class = $dbh->{ImplementorClass}
- or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass");
- substr($imp_class,-4,4) = '::st';
- my $app_class = ref $dbh;
- substr($app_class,-4,4) = '::st';
- _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
- }
- # end of DBI package
- # --------------------------------------------------------------------
- # === 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) = @_;
- # 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.
- 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,…
Large files files are truncated, but you can click here to view the full file