[svn:dbi] r15372 - in dbi/branches/sqlengine: . ex lib/DBD lib/DBI lib/DBI/DBD t
[email protected] Wed, 29 Aug 2012 00:09:56 -0700 (PDT)
| Newsgroups | perl.dbi.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: REHSACK
Date: Wed Aug 29 00:09:55 2012
New Revision: 15372
Added:
dbi/branches/sqlengine/ex/unicode_test.pl
- copied unchanged from r15371, /dbi/trunk/ex/unicode_test.pl
dbi/branches/sqlengine/t/31methcache.t
- copied unchanged from r15371, /dbi/trunk/t/31methcache.t
Modified:
dbi/branches/sqlengine/ (props changed)
dbi/branches/sqlengine/Changes
dbi/branches/sqlengine/DBI.pm
dbi/branches/sqlengine/DBI.xs
dbi/branches/sqlengine/DBIXS.h
dbi/branches/sqlengine/Driver.xst
dbi/branches/sqlengine/Driver_xst.h
dbi/branches/sqlengine/MANIFEST
dbi/branches/sqlengine/Makefile.PL
dbi/branches/sqlengine/Perl.xs
dbi/branches/sqlengine/README
dbi/branches/sqlengine/TODO_2005.txt
dbi/branches/sqlengine/dbipport.h
dbi/branches/sqlengine/dbixs_rev.h
dbi/branches/sqlengine/lib/DBD/File.pm
dbi/branches/sqlengine/lib/DBD/Gofer.pm
dbi/branches/sqlengine/lib/DBI/DBD.pm
dbi/branches/sqlengine/lib/DBI/DBD/SqlEngine.pm
dbi/branches/sqlengine/lib/DBI/FAQ.pm
dbi/branches/sqlengine/lib/DBI/Profile.pm
dbi/branches/sqlengine/lib/DBI/ProfileDumper.pm
dbi/branches/sqlengine/lib/DBI/ProxyServer.pm
dbi/branches/sqlengine/t/01basics.t
dbi/branches/sqlengine/t/08keeperr.t
dbi/branches/sqlengine/t/10examp.t
dbi/branches/sqlengine/t/20meta.t
dbi/branches/sqlengine/t/30subclass.t
dbi/branches/sqlengine/t/35thrclone.t
dbi/branches/sqlengine/t/52dbm_complex.t
dbi/branches/sqlengine/t/85gofer.t
Log:
merge r14895 to r15371
Modified: dbi/branches/sqlengine/Changes
==============================================================================
--- dbi/branches/sqlengine/Changes (original)
+++ dbi/branches/sqlengine/Changes Wed Aug 29 00:09:55 2012
@@ -4,26 +4,111 @@
(As of $Date$ $Revision$)
+=encoding ISO8859-1
+
=cut
-=head2 Changes in DBI 1.617 (svn rXXX)
+=head2 Changes in DBI 1.623
+
+ Added logic to force destruction of children before parents
+ during global destruction. Currently experimental.
+
+ Fixed unused variable / self-assignment compiler warnings.
+
+ Corrected typo in DBI->installed_versions docs RT#78825
+ thanks to Jan Dubois.
+
+=head2 Changes in DBI 1.622 (svn r15327) 6th June 2012
+
+ Fixed lack of =encoding in non-ASCII pod docs. RT#77588
+
+ Corrected typo in DBI::ProfileDumper thanks to Finn Hakansson.
+
+=head2 Changes in DBI 1.621 (svn r15315) 21st May 2012
+
+ Fixed segmentation fault when a thread is created from
+ within another thread RT#77137, thanks to Dave Mitchell.
+ Updated previous Changes to credit Booking.com for sponsoring
+ Dave Mitchell's recent DBI optimization work.
+
+=head2 Changes in DBI 1.620 (svn r15300) 25th April 2012
+
+ Modified column renaming in fetchall_arrayref, added in 1.619,
+ to work on column index numbers not names (an incompatible change).
+ Reworked the fetchall_arrayref documentation.
+ Hash slices in fetchall_arrayref now detect invalid column names.
+
+=head2 Changes in DBI 1.619 (svn r15294) 23rd April 2012
+
+ Fixed the connected method to stop showing the password in
+ trace file (Martin J. Evans).
+ Fixed _install_method to set CvFILE correctly
+ thanks to sprout RT#76296
+ Fixed SqlEngine "list_tables" thanks to David McMath
+ and Norbert Gruener. RT#67223 RT#69260
+
+ Optimized DBI method dispatch thanks to Dave Mitchell.
+ Optimized driver access to DBI internal state thanks to Dave Mitchell.
+ Optimized driver access to handle data thanks to Dave Mitchell.
+ Dave's work on these optimizations was sponsored by Booking.com.
+ Optimized fetchall_arrayref with hash slice thanks
+ to Dagfinn Ilmari Mannsåker. RT#76520
+ Allow renaming columns in fetchall_arrayref hash slices
+ thanks to Dagfinn Ilmari Mannsåker. RT#76572
+ Reserved snmp_ and tree_ for DBD::SNMP and DBD::TreeData
+
+=head2 Changes in DBI 1.618 (svn r15170) 25rd February 2012
+
+ Fixed compiler warnings in Driver_xst.h (Martin J. Evans)
+ Fixed compiler warning in DBI.xs (H.Merijn Brand)
+ Fixed Gofer tests failing on Windows RT74975 (Manoj Kumar)
+ Fixed my_ctx compile errors on Windows (Dave Mitchell)
+
+ Significantly optimized method dispatch via cache (Dave Mitchell)
+ Significantly optimized DBI internals for threads (Dave Mitchell)
+ Dave's work on these optimizations was sponsored by Booking.com.
+ Xsub to xsub calling optimization now enabled for threaded perls.
+ Corrected typo in example in docs (David Precious)
+ Added note that calling clone() without an arg may warn in future.
+ Minor changes to the install_method() docs in DBI::DBD.
+ Updated dbipport.h from Devel::PPPort 3.20
+
+=head2 Changes in DBI 1.617 (svn r15107) 30th January 2012
+
+ NOTE: The officially supported minimum perl version will change
+ from perl 5.8.1 (2003) to perl 5.8.3 (2004) in a future release.
+ (The last change, from perl 5.6 to 5.8.1, was announced
+ in July 2008 and implemented in DBI 1.611 in April 2010.)
- Added pod for default_user to DBI::DBD (Martin J. Evans)
Fixed ParamTypes example in the pod (Martin J. Evans)
Fixed the definition of ArrayTupleStatus and remove confusion over
rows affected in list context of execute_array (Martin J. Evans)
Fixed sql_type_cast example and typo in errors (Martin J. Evans)
- Fixed parameter-count check for complicated statements using
- DBI::DBD::SqlEngine + SQL::Statement::Param (H.Merijn Brand)
+ Fixed Gofer error handling for keeperr methods like ping (Tim Bunce)
+ Fixed $dbh->clone({}) RT73250 (Tim Bunce)
+ Fixed is_nested_call logic error RT73118 (Reini Urban)
Fixed default table_info in DBI::DBD::SqlEngine which passed NAMES
attribute instead of NAME to DBD::Sponge RT72343 (Martin J. Evans)
+ Enhanced performance for threaded perls (Dave Mitchell, Tim Bunce)
+ Dave's work on this optimization was sponsored by Booking.com.
Enhanced and standardized driver trace level mechanism (Tim Bunce)
Removed old code that was an inneffective attempt to detect
people doing DBI->{Attrib}.
+ Clear ParamValues on bind_param param count error RT66127 (Tim Bunce)
+ Changed DBI::ProxyServer to require DBI at compile-time RT62672 (Tim Bunce)
+ Added pod for default_user to DBI::DBD (Martin J. Evans)
Added CON, ENC and DBD trace flags and extended 09trace.t (Martin J. Evans)
Added TXN trace flags and applied CON and TXN to relevant methods (Tim Bunce)
+ Added some more fetchall_arrayref(..., $maxrows) tests (Tim Bunce)
+ Clarified docs for fetchall_arrayref called on an inactive handle.
+ Clarified docs for clone method (Tim Bunce)
+ Added note to DBI::Profile about async queries (Marcel Grünauer).
+ Reserved spatialite_ as a driver prefix for DBD::Spatialite
+ Reserved mo_ as a driver prefix for DBD::MO
+ Updated link to the SQL Reunion 95 docs, RT69577 (Ash Daminato)
+ Changed links for DBI recipes. RT73286 (Martin J. Evans)
=head2 Changes in DBI 1.616 (svn r14616) 30th December 2010
Modified: dbi/branches/sqlengine/DBI.pm
==============================================================================
--- dbi/branches/sqlengine/DBI.pm (original)
+++ dbi/branches/sqlengine/DBI.pm Wed Aug 29 00:09:55 2012
@@ -1,15 +1,17 @@
# $Id$
# vim: ts=8:sw=4:et
#
-# Copyright (c) 1994-2010 Tim Bunce Ireland
+# Copyright (c) 1994-2012 Tim Bunce Ireland
#
# See COPYRIGHT section in pod text below for usage and distribution rights.
#
+package DBI;
+
require 5.008_001;
BEGIN {
-$DBI::VERSION = "1.616"; # ==> ALSO update the version in the pod text below!
+$VERSION = "1.623"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -91,17 +93,16 @@
because relatively few people read it compared with [email protected].
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>.
+and any other lists or forums you may use, I recommend that you read
+"Getting Answers" by Mike Ash: L<http://mikeash.com/getting_answers.html>.
If you think you've found a bug then please also read
"How to Report Bugs Effectively" by Simon Tatham:
L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>.
The DBI home page at L<http://dbi.perl.org/> and the DBI FAQ
-at L<http://faq.dbi-support.com/> are always worth a visit.
-They include links to other resources.
+at L<http://faq.dbi-support.com/> may be worth a visit.
+They include links to other resources, but are rather out-dated.
Before asking any questions, reread this document, consult the
archives and read the DBI FAQ. The archives are listed
@@ -124,8 +125,8 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.616
-($Revision$).
+This is the DBI specification that corresponds to DBI version 1.623
+(see L<DBI::Changes> for details).
The DBI is evolving at a steady pace, so it's good to check that
you have the latest copy.
@@ -153,9 +154,6 @@
# The POD text continues at the end of the file.
-
-package DBI;
-
use Carp();
use DynaLoader ();
use Exporter ();
@@ -311,55 +309,59 @@
# --- Driver Specific Prefix Registry ---
my $dbd_prefix_registry = {
- ad_ => { class => 'DBD::AnyData', },
- ado_ => { class => 'DBD::ADO', },
- amzn_ => { class => 'DBD::Amazon', },
- best_ => { class => 'DBD::BestWins', },
- csv_ => { class => 'DBD::CSV', },
- db2_ => { class => 'DBD::DB2', },
- dbi_ => { class => 'DBI', },
- dbm_ => { class => 'DBD::DBM', },
- df_ => { class => 'DBD::DF', },
- f_ => { class => 'DBD::File', },
- file_ => { class => 'DBD::TextFile', },
- go_ => { class => 'DBD::Gofer', },
- ib_ => { class => 'DBD::InterBase', },
- ing_ => { class => 'DBD::Ingres', },
- ix_ => { class => 'DBD::Informix', },
- jdbc_ => { class => 'DBD::JDBC', },
- monetdb_ => { class => 'DBD::monetdb', },
- msql_ => { class => 'DBD::mSQL', },
- mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
- mysql_ => { class => 'DBD::mysql', },
- mx_ => { class => 'DBD::Multiplex', },
- nullp_ => { class => 'DBD::NullP', },
- odbc_ => { class => 'DBD::ODBC', },
- ora_ => { class => 'DBD::Oracle', },
- pg_ => { class => 'DBD::Pg', },
- pgpp_ => { class => 'DBD::PgPP', },
- plb_ => { class => 'DBD::Plibdata', },
- po_ => { class => 'DBD::PO', },
- proxy_ => { class => 'DBD::Proxy', },
- ram_ => { class => 'DBD::RAM', },
- rdb_ => { class => 'DBD::RDB', },
- sapdb_ => { class => 'DBD::SAP_DB', },
- solid_ => { class => 'DBD::Solid', },
- sponge_ => { class => 'DBD::Sponge', },
- sql_ => { class => 'DBI::DBD::SqlEngine', },
- sqlite_ => { class => 'DBD::SQLite', },
- syb_ => { class => 'DBD::Sybase', },
- sys_ => { class => 'DBD::Sys', },
- tdat_ => { class => 'DBD::Teradata', },
- tmpl_ => { class => 'DBD::Template', },
- tmplss_ => { class => 'DBD::TemplateSS', },
- tuber_ => { class => 'DBD::Tuber', },
- uni_ => { class => 'DBD::Unify', },
- vt_ => { class => 'DBD::Vt', },
- wmi_ => { class => 'DBD::WMI', },
- x_ => { }, # for private use
- xbase_ => { class => 'DBD::XBase', },
- xl_ => { class => 'DBD::Excel', },
- yaswi_ => { class => 'DBD::Yaswi', },
+ ad_ => { class => 'DBD::AnyData', },
+ ado_ => { class => 'DBD::ADO', },
+ amzn_ => { class => 'DBD::Amazon', },
+ best_ => { class => 'DBD::BestWins', },
+ csv_ => { class => 'DBD::CSV', },
+ db2_ => { class => 'DBD::DB2', },
+ dbi_ => { class => 'DBI', },
+ dbm_ => { class => 'DBD::DBM', },
+ df_ => { class => 'DBD::DF', },
+ f_ => { class => 'DBD::File', },
+ file_ => { class => 'DBD::TextFile', },
+ go_ => { class => 'DBD::Gofer', },
+ ib_ => { class => 'DBD::InterBase', },
+ ing_ => { class => 'DBD::Ingres', },
+ ix_ => { class => 'DBD::Informix', },
+ jdbc_ => { class => 'DBD::JDBC', },
+ mo_ => { class => 'DBD::MO', },
+ monetdb_ => { class => 'DBD::monetdb', },
+ msql_ => { class => 'DBD::mSQL', },
+ mvsftp_ => { class => 'DBD::MVS_FTPSQL', },
+ mysql_ => { class => 'DBD::mysql', },
+ mx_ => { class => 'DBD::Multiplex', },
+ nullp_ => { class => 'DBD::NullP', },
+ odbc_ => { class => 'DBD::ODBC', },
+ ora_ => { class => 'DBD::Oracle', },
+ pg_ => { class => 'DBD::Pg', },
+ pgpp_ => { class => 'DBD::PgPP', },
+ plb_ => { class => 'DBD::Plibdata', },
+ po_ => { class => 'DBD::PO', },
+ proxy_ => { class => 'DBD::Proxy', },
+ ram_ => { class => 'DBD::RAM', },
+ rdb_ => { class => 'DBD::RDB', },
+ sapdb_ => { class => 'DBD::SAP_DB', },
+ snmp_ => { class => 'DBD::SNMP', },
+ solid_ => { class => 'DBD::Solid', },
+ spatialite_ => { class => 'DBD::Spatialite', },
+ sponge_ => { class => 'DBD::Sponge', },
+ sql_ => { class => 'DBI::DBD::SqlEngine', },
+ sqlite_ => { class => 'DBD::SQLite', },
+ syb_ => { class => 'DBD::Sybase', },
+ sys_ => { class => 'DBD::Sys', },
+ tdat_ => { class => 'DBD::Teradata', },
+ tmpl_ => { class => 'DBD::Template', },
+ tmplss_ => { class => 'DBD::TemplateSS', },
+ tree_ => { class => 'DBD::TreeData', },
+ tuber_ => { class => 'DBD::Tuber', },
+ uni_ => { class => 'DBD::Unify', },
+ vt_ => { class => 'DBD::Vt', },
+ wmi_ => { class => 'DBD::WMI', },
+ x_ => { }, # for private use
+ xbase_ => { class => 'DBD::XBase', },
+ xl_ => { class => 'DBD::Excel', },
+ yaswi_ => { class => 'DBD::Yaswi', },
};
my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } }
@@ -418,7 +420,7 @@
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
take_imp_data => { U =>[1,1], O=>0x10000 },
clone => { U =>[1,2,'[\%attr]'], T=>0x200 },
- connected => { U =>[1,0], O => 0x0004, T=>0x200 },
+ connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 },
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 },
commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 },
@@ -519,10 +521,8 @@
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));
+ DBI->trace_msg("CLONE DBI for new thread\n");
while ( my ($driver, $drh) = each %DBI::installed_drh) {
no strict 'refs';
next if defined &{"DBD::${driver}::CLONE"};
@@ -825,15 +825,17 @@
sub setup_driver {
my ($class, $driver_class) = @_;
- my $type;
- foreach $type (qw(dr db st)){
- my $class = $driver_class."::$type";
+ my $h_type;
+ foreach $h_type (qw(dr db st)){
+ my $h_class = $driver_class."::$h_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)
+ push @{"${h_class}::ISA"}, "DBD::_::$h_type"
+ unless UNIVERSAL::isa($h_class, "DBD::_::$h_type");
+ # The _mem class stuff is (IIRC) a crufty hack for global destruction
+ # timing issues in early versions of perl5 and possibly no longer needed.
+ my $mem_class = "DBD::_mem::$h_type";
+ push @{"${h_class}_mem::ISA"}, $mem_class
+ unless UNIVERSAL::isa("${h_class}_mem", $mem_class)
or $DBI::PurePerl;
}
}
@@ -1015,9 +1017,7 @@
sub installed_versions {
my ($class, $quiet) = @_;
my %error;
- my %version = ( DBI => $DBI::VERSION );
- $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION
- if $DBI::PurePerl;
+ my %version;
for my $driver ($class->available_drivers($quiet)) {
next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC;
my $drh = eval {
@@ -1032,6 +1032,8 @@
if (wantarray) {
return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version;
}
+ $version{"DBI"} = $DBI::VERSION;
+ $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl;
if (!defined wantarray) { # void context
require Config; # add more detail
$version{OS} = "$^O\t($Config::Config{osvers})";
@@ -1509,8 +1511,11 @@
sub clone {
my ($old_dbh, $attr) = @_;
- my $closure = $old_dbh->{dbi_connect_closure} or return;
- unless ($attr) {
+
+ my $closure = $old_dbh->{dbi_connect_closure}
+ or return $old_dbh->set_err($DBI::stderr, "Can't clone handle");
+
+ unless ($attr) { # XXX deprecated, caller should always pass a hash ref
# copy attributes visible in the attribute cache
keys %$old_dbh; # reset iterator
while ( my ($k, $v) = each %$old_dbh ) {
@@ -1526,6 +1531,7 @@
ShowErrorStatement TaintIn TaintOut
));
}
+
# use Data::Dumper; warn Dumper([$old_dbh, $attr]);
my $new_dbh = &$closure($old_dbh, $attr);
unless ($new_dbh) {
@@ -1533,6 +1539,7 @@
my $drh = $old_dbh->{Driver};
return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state);
}
+ $new_dbh->{dbi_connect_closure} = $closure;
return $new_dbh;
}
@@ -2005,8 +2012,9 @@
my $mode = ref($slice) || 'ARRAY';
my @rows;
- my $row;
+
if ($mode eq 'ARRAY') {
+ my $row;
# we copy the array here because fetch (currently) always
# returns the same array ref. XXX
if ($slice && @$slice) {
@@ -2021,27 +2029,42 @@
else {
push @rows, [ @$row ] while($row = $sth->fetch);
}
+ return \@rows
+ }
+
+ my %row;
+ if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name }
+ keys %$$slice; # reset the iterator
+ while ( my ($idx, $name) = each %$$slice ) {
+ $sth->bind_col($idx+1, \$row{$name});
+ }
}
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;
- # XXX this could be made faster by pre-binding a local hash
- # using bind_columns and then copying it per row
- while ($max_rows-- and $row = $sth->fetchrow_hashref('NAME_lc')) {
- my %hash;
- @hash{@o_keys} = @{$row}{@i_keys};
- push @rows, \%hash;
- }
+ if (keys %$slice) {
+ keys %$slice; # reset the iterator
+ my $name2idx = $sth->FETCH('NAME_lc_hash');
+ while ( my ($name, $unused) = each %$slice ) {
+ my $idx = $name2idx->{lc $name};
+ return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice")
+ if not defined $idx;
+ $sth->bind_col($idx+1, \$row{$name});
+ }
}
else {
- # XXX assumes new ref each fetchhash
- push @rows, $row
- while ($max_rows-- and $row = $sth->fetchrow_hashref());
+ $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) );
}
}
- else { Carp::croak("fetchall_arrayref($mode) invalid") }
+ else {
+ return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid");
+ }
+
+ if (not defined $max_rows) {
+ push @rows, { %row } while ($sth->fetch); # full speed ahead!
+ }
+ else {
+ push @rows, { %row } while ($max_rows-- and $sth->fetch);
+ }
+
return \@rows;
}
@@ -2340,7 +2363,7 @@
For an interesting diversion on the I<real> history of RDBMS and SQL,
from the people who made it happen, see:
- http://ftp.digital.com/pub/DEC/SRC/technical-notes/SRC-1997-018-html/sqlr95.html
+ http://www.mcjones.org/System_R/SQL_Reunion_95/sqlr95.html
Follow the "Full Contents" then "Intergalactic dataspeak" links for the
SQL history.
@@ -2832,7 +2855,7 @@
DBI->installed_versions;
@ary = DBI->installed_versions;
- %hash = DBI->installed_versions;
+ $hash = DBI->installed_versions;
Calls available_drivers() and attempts to load each of them in turn
using install_driver(). For each load that succeeds the driver
@@ -2842,12 +2865,12 @@
When called in array context the list of successfully loaded drivers
is returned (without the 'DBD::' prefix).
-When called in scalar context a reference to the hash is returned
-and the hash will also contain other entries for the C<DBI> version,
-C<OS> name, etc.
+When called in scalar context an extra entry for the C<DBI> is added (and
+C<DBI::PurePerl> if appropriate) and a reference to the hash is returned.
When called in a void context the installed_versions() method will
-print out a formatted list of the hash contents, one per line.
+print out a formatted list of the hash contents, one per line, along with some
+other information about the DBI version and OS.
Due to the potentially high memory cost and unknown risks of loading
in an unknown number of drivers that just happen to be installed
@@ -4305,31 +4328,26 @@
=head3 C<clone>
- $new_dbh = $dbh->clone();
$new_dbh = $dbh->clone(\%attr);
The C<clone> method duplicates the $dbh connection by connecting
with the same parameters ($dsn, $user, $password) as originally used.
The attributes for the cloned connect are the same as those used
-for the original connect, with some other attributes merged over
-them depending on the \%attr parameter.
+for the I<original> connect, with any other attributes in C<\%attr>
+merged over them. Effectively the same as doing:
-If \%attr is given then the attributes it contains are merged into
-the original attributes and override any with the same names.
-Effectively the same as doing:
-
- %attribues_used = ( %original_attributes, %attr );
+ %attributes_used = ( %original_attributes, %attr );
If \%attr is not given then it defaults to a hash containing all
the attributes in the attribute cache of $dbh excluding any non-code
references, plus the main boolean attributes (RaiseError, PrintError,
-AutoCommit, etc.). This behaviour is subject to change.
+AutoCommit, etc.). I<This behaviour is unreliable and so use of clone without
+an argument is deprecated and may cause a warning in a future release.>
The clone method can be used even if the database handle is disconnected.
-The C<clone> method was added in DBI 1.33. It is very new and likely
-to change.
+The C<clone> method was added in DBI 1.33.
=head3 C<data_sources>
@@ -6214,8 +6232,11 @@
($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub);
($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status);
-The execute_for_fetch() method is used to perform bulk operations
-and is most often used via the execute_array() method, not directly.
+The execute_for_fetch() method is used to perform bulk operations and
+although it is most often used via the execute_array() method you can
+use it directly. The main difference between execute_array and
+execute_for_fetch is the former does column or row-wise binding and
+the latter uses row-wise binding.
The fetch subroutine, referenced by $fetch_tuple_sub, is expected
to return a reference to an array (known as a 'tuple') or undef.
@@ -6374,7 +6395,9 @@
returned from a prepared and executed statement handle. It returns a
reference to an array that contains one reference per row.
-If there are no rows to return, C<fetchall_arrayref> returns a reference
+If called on an I<inactive> statement handle, C<fetchall_arrayref> returns undef.
+
+If there are no rows left to return from an I<active> statement handle, C<fetchall_arrayref> returns a reference
to an empty array. If an error occurs, C<fetchall_arrayref> returns the
data fetched thus far, which may be none. You should check C<$sth-E<gt>err>
afterwards (or use the C<RaiseError> attribute) to discover if the data is
@@ -6389,16 +6412,6 @@
With no parameters, or if $slice is undefined, C<fetchall_arrayref>
acts as if passed an empty array ref.
-If $slice is a hash reference, C<fetchall_arrayref> uses L</fetchrow_hashref>
-to fetch each row as a hash reference. If the $slice hash is empty then
-fetchrow_hashref() is simply called in a tight loop and the keys in the hashes
-have whatever name lettercase is returned by default from fetchrow_hashref.
-(See L</FetchHashKeyName> attribute.) If the $slice hash is not
-empty, then it is used as a slice to select individual columns by
-name. The values of the hash should be set to 1. The key names
-of the returned hashes match the letter case of the names in the
-parameter hash, regardless of the L</FetchHashKeyName> attribute.
-
For example, to fetch just the first column of every row:
$tbl_ary_ref = $sth->fetchall_arrayref([0]);
@@ -6407,17 +6420,35 @@
$tbl_ary_ref = $sth->fetchall_arrayref([-2,-1]);
-To fetch all fields of every row as a hash ref:
+Those two examples both return a reference to an array of array refs.
+
+If $slice is a hash reference, C<fetchall_arrayref> fetches each row as a hash
+reference. If the $slice hash is empty then the keys in the hashes have
+whatever name lettercase is returned by default. (See L</FetchHashKeyName>
+attribute.) If the $slice hash is I<not> empty, then it is used as a slice to
+select individual columns by name. The values of the hash should be set to 1.
+The key names of the returned hashes match the letter case of the names in the
+parameter hash, regardless of the L</FetchHashKeyName> attribute.
+
+For example, to fetch all fields of every row as a hash ref:
$tbl_ary_ref = $sth->fetchall_arrayref({});
To fetch only the fields called "foo" and "bar" of every row as a hash ref
-(with keys named "foo" and "BAR"):
+(with keys named "foo" and "BAR", regardless of the original capitalization):
$tbl_ary_ref = $sth->fetchall_arrayref({ foo=>1, BAR=>1 });
-The first two examples return a reference to an array of array refs.
-The third and forth return a reference to an array of hash refs.
+Those two examples both return a reference to an array of hash refs.
+
+If $slice is a I<reference to a hash reference>, that hash is used to select
+and rename columns. The keys are 0-based column index numbers and the values
+are the corresponding keys for the returned row hashes.
+
+For example, to fetch only the first and second columns of every row as a hash
+ref (with keys named "k" and "v" regardless of their original names):
+
+ $tbl_ary_ref = $sth->fetchall_arrayref( \{ 0 => 'k', 1 => 'v' } );
If $max_rows is defined and greater than or equal to zero then it
is used to limit the number of rows fetched before returning.
@@ -6566,7 +6597,7 @@
You do not need to bind output columns in order to fetch data.
For maximum portability between drivers, bind_col() should be called
after execute() and not before.
-See also C<bind_columns> for an example.
+See also L</bind_columns> for an example.
The binding is performed at a low level using Perl aliasing.
Whenever a row is fetched from the database $var_to_bind appears
@@ -6739,7 +6770,7 @@
in these situations.
For drivers which support stored procedures and multiple result sets
-(see more_results) these attributes relate to the I<current> result set.
+(see L</more_results>) these attributes relate to the I<current> result set.
See also L</finish> to learn more about the effect it
may have on some attributes.
@@ -8054,7 +8085,8 @@
http://wdvl.com/Authoring/DB/Intro/toc.html
http://www.hotwired.com/webmonkey/backend/tutorials/tutorial1.html
http://bumppo.net/lists/macperl/1999/06/msg00197.html
- http://gmax.oltrelinux.com/dbirecipes.html
+ http://www.perlmonks.org/?node=DBI%20recipes
+ http://www.perlmonks.org/?node=Speeding%20up%20the%20DBI
Other database related links:
@@ -8099,7 +8131,7 @@
=head1 COPYRIGHT
-The DBI module is Copyright (c) 1994-2009 Tim Bunce. Ireland.
+The DBI module is Copyright (c) 1994-2012 Tim Bunce. Ireland.
All rights reserved.
You may distribute under the terms of either the GNU General Public
Modified: dbi/branches/sqlengine/DBI.xs
==============================================================================
--- dbi/branches/sqlengine/DBI.xs (original)
+++ dbi/branches/sqlengine/DBI.xs Wed Aug 29 00:09:55 2012
@@ -2,10 +2,14 @@
*
* $Id$
*
- * Copyright (c) 1994-2009 Tim Bunce Ireland.
+ * Copyright (c) 1994-2012 Tim Bunce Ireland.
*
* See COPYRIGHT section in DBI.pm for usage and distribution rights.
*/
+#define NEED_grok_number
+#define NEED_grok_numeric_radix
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_flags
#define IN_DBI_XS 1 /* see DBIXS.h */
#define PERL_NO_GET_CONTEXT
@@ -16,19 +20,33 @@
#include <sys/timeb.h>
# endif
-#define MY_VERSION "DBI(" XS_VERSION ")"
+/* The XS dispatcher code can optimize calls to XS driver methods,
+ * bypassing the usual call_sv() and argument handling overheads.
+ * Just-in-case it causes problems there's an (undocumented) way
+ * to disable it by setting an env var.
+ */
+static int use_xsbypass = 1; /* set in dbi_bootinit() */
-#if (defined USE_THREADS || defined PERL_CAPI || defined PERL_OBJECT)
-static int xsbypass = 0; /* disable XSUB->XSUB shortcut */
-#else
-static int xsbypass = 1; /* enable XSUB->XSUB shortcut */
-#endif
#ifndef CvISXSUB
#define CvISXSUB(sv) CvXSUB(sv)
#endif
#define DBI_MAGIC '~'
+/* HvMROMETA introduced in 5.9.5, but mro_meta_init not exported in 5.10.0 */
+#if (PERL_VERSION < 10)
+# define MY_cache_gen(stash) 0
+#else
+# if ((PERL_VERSION == 10) && (PERL_SUBVERSION == 0))
+# define MY_cache_gen(stash) \
+ (HvAUX(stash)->xhv_mro_meta \
+ ? HvAUX(stash)->xhv_mro_meta->cache_gen \
+ : 0)
+# else
+# define MY_cache_gen(stash) HvMROMETA(stash)->cache_gen
+# endif
+#endif
+
/* If the tests fail with errors about 'setlinebuf' then try */
/* deleting the lines in the block below except the setvbuf one */
#ifndef PerlIO_setlinebuf
@@ -62,6 +80,25 @@
#define DBI_save_hv_fetch_ent
#endif
+/* prior to 5.8.9: when a CV is duped, the mg dup method is called,
+ * then *afterwards*, any_ptr is copied from the old CV to the new CV.
+ * This wipes out anything which the dup method did to any_ptr.
+ * This needs working around */
+#if defined(USE_ITHREADS) && (PERL_VERSION == 8) && (PERL_SUBVERSION < 9)
+# define BROKEN_DUP_ANY_PTR
+#endif
+
+/* types of method name */
+
+typedef enum {
+ methtype_ordinary, /* nothing special about this method name */
+ methtype_DESTROY,
+ methtype_FETCH,
+ methtype_can,
+ methtype_fetch_star, /* fetch*, i.e. fetch() or fetch_...() */
+ methtype_set_err
+} meth_types;
+
static imp_xxh_t *dbih_getcom _((SV *h));
static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp));
@@ -82,18 +119,54 @@
static I32 dbi_hash _((const char *string, long i));
static void dbih_dumphandle _((pTHX_ SV *h, const char *msg, int level));
static int dbih_dumpcom _((pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level));
+static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg);
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param);
+#endif
char *neatsvpv _((SV *sv, STRLEN maxlen));
SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo);
-
-DBISTATE_DECLARE;
+static meth_types get_meth_type(const char * const name);
struct imp_drh_st { dbih_drc_t com; };
struct imp_dbh_st { dbih_dbc_t com; };
struct imp_sth_st { dbih_stc_t com; };
struct imp_fdh_st { dbih_fdc_t com; };
+/* identify the type of a method name for dispatch behaviour */
+/* (should probably be folded into the IMA flags mechanism) */
+
+static meth_types
+get_meth_type(const char * const name)
+{
+ switch (name[0]) {
+ case 'D':
+ if strEQ(name,"DESTROY")
+ return methtype_DESTROY;
+ break;
+ case 'F':
+ if strEQ(name,"FETCH")
+ return methtype_FETCH;
+ break;
+ case 'c':
+ if strEQ(name,"can")
+ return methtype_can;
+ break;
+ case 'f':
+ if strnEQ(name,"fetch", 5) /* fetch* */
+ return methtype_fetch_star;
+ break;
+ case 's':
+ if strEQ(name,"set_err")
+ return methtype_set_err;
+ break;
+ }
+ return methtype_ordinary;
+}
+
/* Internal Method Attributes (attached to dispatch methods when installed) */
+/* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free()
+ * to ensure that they are duped and correctly ref-counted */
typedef struct dbi_ima_st {
U8 minargs;
@@ -108,6 +181,16 @@
U32 method_trace;
const char *usage_msg;
U32 flags;
+ meth_types meth_type;
+
+ /* cached outer to inner method mapping */
+ HV *stash; /* the stash we found the GV in */
+ GV *gv; /* the GV containing the inner sub */
+ U32 generation; /* cache invalidation */
+#ifdef BROKEN_DUP_ANY_PTR
+ PerlInterpreter *my_perl; /* who owns this struct */
+#endif
+
} dbi_ima_t;
/* These values are embedded in the data passed to install_method */
@@ -161,40 +244,84 @@
/* 32 bit magic FNV-0 and FNV-1 prime */
#define FNV_32_PRIME ((UV)0x01000193)
+
+/* perl doesn't know anything about the dbi_ima_t struct attached to the
+ * CvXSUBANY(cv).any_ptr slot, so add some magic to the CV to handle
+ * duping and freeing.
+ */
+
+static MGVTBL dbi_ima_vtbl = { 0, 0, 0, 0, dbi_ima_free,
+ 0,
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+ dbi_ima_dup
+#else
+ 0
+#endif
+#if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION >= 9))
+ , 0
+#endif
+ };
+
+static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg)
+{
+ dbi_ima_t *ima = (dbi_ima_t *)(CvXSUBANY((CV*)sv).any_ptr);
+#ifdef BROKEN_DUP_ANY_PTR
+ if (ima->my_perl != my_perl)
+ return 0;
+#endif
+ SvREFCNT_dec(ima->stash);
+ SvREFCNT_dec(ima->gv);
+ Safefree(ima);
+ return 0;
+}
+
+#if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR)
+static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param)
+{
+ dbi_ima_t *ima, *nima;
+ CV *cv = (CV*) mg->mg_ptr;
+ CV *ncv = (CV*)ptr_table_fetch(PL_ptr_table, (cv));
+
+ PERL_UNUSED_VAR(param);
+ mg->mg_ptr = (char *)ncv;
+ ima = (dbi_ima_t*) CvXSUBANY(cv).any_ptr;
+ Newx(nima, 1, dbi_ima_t);
+ *nima = *ima; /* structure copy */
+ CvXSUBANY(ncv).any_ptr = nima;
+ nima->stash = NULL;
+ nima->gv = NULL;
+ return 0;
+}
+#endif
+
+
+
/* --- make DBI safe for multiple perl interpreters --- */
-/* Contributed by Murray Nesbitt of ActiveState */
+/* Originally contributed by Murray Nesbitt of ActiveState, */
+/* but later updated to use MY_CTX */
+
+#define MY_CXT_KEY "DBI::_guts" XS_VERSION
+
typedef struct {
- SV *dbi_last_h;
+ SV *dbi_last_h; /* maybe better moved into dbistate_t? */
dbistate_t* dbi_state;
-} PERINTERP_t;
+} my_cxt_t;
-#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
+START_MY_CXT
-# define dPERINTERP_SV \
- SV *perinterp_sv = *hv_fetch(PL_modglobal, MY_VERSION, \
- sizeof(MY_VERSION)-1, TRUE)
-
-# define dPERINTERP_PTR(T,name) \
- T name = (perinterp_sv && SvIOK(perinterp_sv) \
- ? INT2PTR(T, SvIVX(perinterp_sv)) : (T)NULL)
-# define dPERINTERP \
- dPERINTERP_SV; dPERINTERP_PTR(PERINTERP_t *, PERINTERP)
-# define INIT_PERINTERP \
- dPERINTERP; \
- PERINTERP = malloc_using_sv(sizeof(PERINTERP_t)); \
- sv_setiv(perinterp_sv, PTR2IV(PERINTERP))
+#undef DBIS
+#define DBIS (MY_CXT.dbi_state)
-# undef DBIS
-# define DBIS (PERINTERP->dbi_state)
+#define g_dbi_last_h (MY_CXT.dbi_last_h)
-#else
- static PERINTERP_t Interp;
-# define dPERINTERP typedef int _interp_DBI_dummy
-# define PERINTERP (&Interp)
-# define INIT_PERINTERP
-#endif
+/* allow the 'static' dbi_state struct to be accessed from other files */
+dbistate_t**
+_dbi_state_lval(pTHX)
+{
+ dMY_CXT;
+ return &(MY_CXT.dbi_state);
+}
-#define g_dbi_last_h (PERINTERP->dbi_last_h)
/* --- */
@@ -376,7 +503,7 @@
int dbc_s, int stc_s, int fdc_s)
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
static const char msg[] = "you probably need to rebuild the DBD driver (or possibly the DBI)";
(void)need_dbixs_cv;
if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS))
@@ -396,19 +523,16 @@
dbi_bootinit(dbistate_t * parent_dbis)
{
dTHX;
+ dMY_CXT;
dbistate_t* DBISx;
- INIT_PERINTERP;
DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st));
-
- /* publish address of dbistate so dynaloaded DBD's can find it,
- * taking care to store the value in the same way it'll be used
- * to avoid problems on some architectures, for example see
- * http://rt.cpan.org/Public/Bug/Display.html?id=32309
- */
- sv_setiv(get_sv(DBISTATE_PERLNAME, GV_ADDMULTI), 0); /* force SvIOK */
DBIS = DBISx;
- DBIS_PUBLISHED_LVALUE = DBISx;
+
+ /* make DBIS available to DBD modules the "old" (<= 1.618) way,
+ * so that unrecompiled DBD's will still work against a newer DBI */
+ sv_setiv(get_sv("DBI::_dbistate", GV_ADDMULTI),
+ PTR2IV(MY_CXT.dbi_state));
/* store version and size so we can spot DBI/DBD version mismatch */
DBIS->check_version = check_version;
@@ -426,12 +550,6 @@
DBIS->thr_owner = PERL_GET_THX;
#endif
- DBISTATE_INIT; /* check DBD code to set DBIS from DBISTATE_PERLNAME */
-
- if (DBIS_TRACE_LEVEL > 9) {
- sv_dump(DBISTATE_ADDRSV);
- }
-
/* store some function pointers so DBD's can call our functions */
DBIS->getcom = dbih_getcom;
DBIS->clearcom = dbih_clearcom;
@@ -461,6 +579,12 @@
gv_fetchpv("DBI::errstr", GV_ADDMULTI, SVt_PV);
gv_fetchpv("DBI::lasth", GV_ADDMULTI, SVt_PV);
gv_fetchpv("DBI::rows", GV_ADDMULTI, SVt_PV);
+
+ /* we only need to check the env var on the initial boot
+ * which is handy because it can core dump during CLONE on windows
+ */
+ if (!parent_dbis && getenv("PERL_DBI_XSBYPASS"))
+ use_xsbypass = atoi(getenv("PERL_DBI_XSBYPASS"));
}
@@ -485,7 +609,7 @@
neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging only */
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
STRLEN len;
SV *nsv = Nullsv;
SV *infosv = Nullsv;
@@ -552,7 +676,7 @@
v = SvPV(sv,len);
else {
/* handle Overload magic refs */
- SvAMAGIC_off(sv); /* should really be done via local scoping */
+ (void)SvAMAGIC_off(sv); /* should really be done via local scoping */
v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */
SvAMAGIC_on(sv);
}
@@ -769,14 +893,13 @@
dbih_logmsg(imp_xxh_t *imp_xxh, const char *fmt, ...)
{
dTHX;
- dPERINTERP;
va_list args;
#ifdef I_STDARG
va_start(args, fmt);
#else
va_start(args);
#endif
- (void) PerlIO_vprintf(DBIS->logfp, fmt, args);
+ (void) PerlIO_vprintf(DBIc_DBISTATE(imp_xxh)->logfp, fmt, args);
va_end(args);
(void)imp_xxh;
return 1;
@@ -785,7 +908,7 @@
static void
close_trace_file(pTHX)
{
- dPERINTERP;
+ dMY_CXT;
if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout())
return;
@@ -802,7 +925,7 @@
set_trace_file(SV *file)
{
dTHX;
- dPERINTERP;
+ dMY_CXT;
const char *filename;
PerlIO *fp = Nullfp;
IO *io;
@@ -818,7 +941,7 @@
return 0;
}
close_trace_file(aTHX);
- SvREFCNT_inc(io);
+ (void)SvREFCNT_inc(io);
DBIS->logfp_ref = io;
}
else if (isGV_with_GP(file)) {
@@ -828,7 +951,7 @@
return 0;
}
close_trace_file(aTHX);
- SvREFCNT_inc(io);
+ (void)SvREFCNT_inc(io);
DBIS->logfp_ref = io;
}
else {
@@ -893,9 +1016,8 @@
set_trace(SV *h, SV *level_sv, SV *file)
{
dTHX;
- dPERINTERP;
D_imp_xxh(h);
- int RETVAL = DBIS->debug; /* Return trace level in effect now */
+ int RETVAL = DBIc_DBISTATE(imp_xxh)->debug; /* Return trace level in effect now */
IV level = parse_trace_flags(h, level_sv, RETVAL);
set_trace_file(file);
if (level != RETVAL) { /* set value */
@@ -921,7 +1043,6 @@
dbih_inner(pTHX_ SV *orv, const char *what)
{ /* convert outer to inner handle else croak(what) if what is not NULL */
/* if what is NULL then return NULL for invalid handles */
- dPERINTERP;
MAGIC *mg;
SV *ohv; /* outer HV after derefing the RV */
SV *hrv; /* dbi inner handle RV-to-HV */
@@ -932,8 +1053,11 @@
if (!ohv || SvTYPE(ohv) != SVt_PVHV) {
if (!what)
return NULL;
- if (DBIS_TRACE_LEVEL)
- sv_dump(orv);
+ if (1) {
+ dMY_CXT;
+ if (DBIS_TRACE_LEVEL)
+ sv_dump(orv);
+ }
if (!SvOK(orv))
croak("%s given an undefined handle %s",
what, "(perhaps returned from a previous call which failed)");
@@ -973,34 +1097,50 @@
static imp_xxh_t *
dbih_getcom(SV *hrv) /* used by drivers via DBIS func ptr */
{
- dTHX;
- imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ hrv, 0);
- if (!imp_xxh) /* eg after take_imp_data */
- croak("Invalid DBI handle %s, has no dbi_imp_data", neatsvpv(hrv,0));
- return imp_xxh;
+ MAGIC *mg;
+ SV *sv;
+
+ /* short-cut common case */
+ if ( SvROK(hrv)
+ && (sv = SvRV(hrv))
+ && SvRMAGICAL(sv)
+ && (mg = SvMAGIC(sv))
+ && mg->mg_type == DBI_MAGIC
+ && mg->mg_ptr
+ )
+ return (imp_xxh_t *) mg->mg_ptr;
+
+ {
+ dTHX;
+ imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ hrv, 0);
+ if (!imp_xxh) /* eg after take_imp_data */
+ croak("Invalid DBI handle %s, has no dbi_imp_data", neatsvpv(hrv,0));
+ return imp_xxh;
+ }
}
static imp_xxh_t *
dbih_getcom2(pTHX_ SV *hrv, MAGIC **mgp) /* Get com struct for handle. Must be fast. */
{
- dPERINTERP;
- imp_xxh_t *imp_xxh;
MAGIC *mg;
SV *sv;
/* important and quick sanity check (esp non-'safe' Oraperl) */
if (SvROK(hrv)) /* must at least be a ref */
sv = SvRV(hrv);
- else if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */
- sv = DBI_LAST_HANDLE;
- else if (sv_derived_from(hrv, "DBI::common")) {
- /* probably a class name, if ref($h)->foo() */
- return 0;
- }
else {
- sv_dump(hrv);
- croak("Invalid DBI handle %s", neatsvpv(hrv,0));
- sv = &PL_sv_undef; /* avoid "might be used uninitialized" warning */
+ dMY_CXT;
+ if (hrv == DBI_LAST_HANDLE) /* special for var::FETCH */
+ sv = DBI_LAST_HANDLE;
+ else if (sv_derived_from(hrv, "DBI::common")) {
+ /* probably a class name, if ref($h)->foo() */
+ return 0;
+ }
+ else {
+ sv_dump(hrv);
+ croak("Invalid DBI handle %s", neatsvpv(hrv,0));
+ sv = &PL_sv_undef; /* avoid "might be used uninitialized" warning */
+ }
}
/* Short cut for common case. We assume that a magic var always */
@@ -1016,14 +1156,10 @@
if (mgp) /* let caller pickup magic struct for this handle */
*mgp = mg;
- if (!mg->mg_obj) /* eg after take_imp_data */
- return 0;
-
- /* ignore 'cast increases required alignment' warning */
- /* not a problem since we created the pointers anyway. */
- imp_xxh = (imp_xxh_t*)(void*)SvPVX(mg->mg_obj);
+ if (!mg) /* may happen during global destruction */
+ return (imp_xxh_t *) 0;
- return imp_xxh;
+ return (imp_xxh_t *) mg->mg_ptr;
}
@@ -1075,7 +1211,6 @@
dbih_make_fdsv(SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)
{
dTHX;
- dPERINTERP;
D_imp_sth(sth);
const STRLEN cn_len = strlen(col_name);
imp_fdh_t *imp_fdh;
@@ -1084,7 +1219,7 @@
croak("panic: dbih_makefdsv %s '%s' imp_size %ld invalid",
imp_class, col_name, (long)imp_size);
if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
- PerlIO_printf(DBILOGFP," dbih_make_fdsv(%s, %s, %ld, '%s')\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_make_fdsv(%s, %s, %ld, '%s')\n",
neatsvpv(sth,0), imp_class, (long)imp_size, col_name);
fdsv = dbih_make_com(sth, (imp_xxh_t*)imp_sth, imp_class, imp_size, cn_len+2, 0);
imp_fdh = (imp_fdh_t*)(void*)SvPVX(fdsv);
@@ -1098,12 +1233,12 @@
dbih_make_com(SV *p_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV* imp_templ)
{
dTHX;
- dPERINTERP;
static const char *errmsg = "Can't make DBI com handle for %s: %s";
HV *imp_stash;
SV *dbih_imp_sv;
imp_xxh_t *imp;
- (void)extra; /* unused */
+ int trace_level;
+ PERL_UNUSED_VAR(extra);
if ( (imp_stash = gv_stashpv(imp_class, FALSE)) == NULL)
croak(errmsg, imp_class, "unknown package");
@@ -1122,9 +1257,18 @@
}
}
- if ((p_imp_xxh ? DBIc_TRACE_LEVEL(p_imp_xxh) : DBIS_TRACE_LEVEL) >= 5)
+ if (p_imp_xxh) {
+ trace_level = DBIc_TRACE_LEVEL(p_imp_xxh);
+ }
+ else {
+ dMY_CXT;
+ trace_level = DBIS_TRACE_LEVEL;
+ }
+ if (trace_level >= 5) {
+ dMY_CXT;
PerlIO_printf(DBILOGFP," dbih_make_com(%s, %p, %s, %ld, %p) thr#%p\n",
neatsvpv(p_h,0), (void*)p_imp_xxh, imp_class, (long)imp_size, (void*)imp_templ, (void*)PERL_GET_THX);
+ }
if (imp_templ && SvOK(imp_templ)) {
U32 imp_templ_flags;
@@ -1165,7 +1309,13 @@
*SvEND(dbih_imp_sv) = '\0';
}
- DBIc_DBISTATE(imp) = DBIS;
+ if (p_imp_xxh) {
+ DBIc_DBISTATE(imp) = DBIc_DBISTATE(p_imp_xxh);
+ }
+ else {
+ dMY_CXT;
+ DBIc_DBISTATE(imp) = DBIS;
+ }
DBIc_IMP_STASH(imp) = imp_stash;
if (!p_h) { /* only a driver (drh) has no parent */
@@ -1208,7 +1358,6 @@
static void
dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV *parent, SV *imp_datasv)
{
- dPERINTERP;
SV *h;
char *errmsg = "Can't setup DBI handle of %s to %s: %s";
SV *dbih_imp_sv;
@@ -1219,14 +1368,25 @@
HV *imp_mem_stash;
imp_xxh_t *imp;
imp_xxh_t *parent_imp;
+ int trace_level;
h = dbih_inner(aTHX_ orv, "dbih_setup_handle");
parent = dbih_inner(aTHX_ parent, NULL); /* check parent valid (& inner) */
- parent_imp = (parent) ? DBIh_COM(parent) : NULL;
+ if (parent) {
+ parent_imp = DBIh_COM(parent);
+ trace_level = DBIc_TRACE_LEVEL(parent_imp);
+ }
+ else {
+ dMY_CXT;
+ parent_imp = NULL;
+ trace_level = DBIS_TRACE_LEVEL;
+ }
- if ((parent_imp ? DBIc_TRACE_LEVEL(parent_imp) : DBIS_TRACE_LEVEL) >= 5)
+ if (trace_level >= 5) {
+ dMY_CXT;
PerlIO_printf(DBILOGFP," dbih_setup_handle(%s=>%s, %s, %lx, %s)\n",
neatsvpv(orv,0), neatsvpv(h,0), imp_class, (long)parent, neatsvpv(imp_datasv,0));
+ }
if (mg_find(SvRV(h), DBI_MAGIC) != NULL)
croak(errmsg, neatsvpv(orv,0), imp_class, "already a DBI (or ~magic) handle");
@@ -1336,11 +1496,17 @@
}
/* Use DBI magic on inner handle to carry handle attributes */
- sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, Nullch, 0);
+ /* Note that we store the imp_sv in mg_obj, but as a shortcut, */
+ /* also store a direct pointer to imp, aka PVX(dbih_imp_sv), */
+ /* in mg_ptr (with mg_len set to null, so it wont be freed) */
+ sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, (char*)imp, 0);
SvREFCNT_dec(dbih_imp_sv); /* since sv_magic() incremented it */
SvRMAGICAL_on(SvRV(h)); /* so DBI magic gets sv_clear'd ok */
+ {
+ dMY_CXT; /* XXX would be nice to get rid of this */
DBI_SET_LAST_HANDLE(h);
+ }
if (1) {
/* This is a hack to work-around the fast but poor way old versions of
@@ -1376,7 +1542,7 @@
static int
dbih_dumpcom(pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level)
{
- dPERINTERP;
+ dMY_CXT;
SV *flags = sv_2mortal(newSVpv("",0));
SV *inner;
static const char pad[] = " ";
@@ -1461,7 +1627,6 @@
dbih_clearcom(imp_xxh_t *imp_xxh)
{
dTHX;
- dPERINTERP;
dTHR;
int dump = FALSE;
int debug = DBIc_TRACE_LEVEL(imp_xxh);
@@ -1475,9 +1640,9 @@
#ifdef DBI_USE_THREADS
if (DBIc_THR_USER(imp_xxh) != my_perl) { /* don't clear handle that belongs to another thread */
if (debug >= 3) {
- PerlIO_printf(DBILOGFP," skipped dbih_clearcom: DBI handle (type=%d, %s) is owned by thread %p not current thread %p\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh)," skipped dbih_clearcom: DBI handle (type=%d, %s) is owned by thread %p not current thread %p\n",
DBIc_TYPE(imp_xxh), HvNAME(DBIc_IMP_STASH(imp_xxh)), (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ;
- PerlIO_flush(DBILOGFP);
+ PerlIO_flush(DBIc_LOGPIO(imp_xxh));
}
return;
}
@@ -1554,7 +1719,7 @@
DBIc_COMSET_off(imp_xxh);
if (debug >= 4)
- PerlIO_printf(DBILOGFP," dbih_clearcom 0x%lx (com 0x%lx, type %d) done.\n\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh)," dbih_clearcom 0x%lx (com 0x%lx, type %d) done.\n\n",
(long)DBIc_MY_H(imp_xxh), (long)imp_xxh, DBIc_TYPE(imp_xxh));
}
@@ -1569,7 +1734,6 @@
* in which case it adjusts the row buffer to match NUM_OF_FIELDS.
*/
dTHX;
- dPERINTERP;
I32 i = DBIc_NUM_FIELDS(imp_sth);
AV *av = DBIc_FIELDS_AV(imp_sth);
@@ -1581,14 +1745,14 @@
return av;
/* we need to adjust the size of the array */
if (DBIc_TRACE_LEVEL(imp_sth) >= 2)
- PerlIO_printf(DBILOGFP," dbih_setup_fbav realloc from %ld to %ld fields\n", (long)(av_len(av)+1), (long)i);
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav realloc from %ld to %ld fields\n", (long)(av_len(av)+1), (long)i);
SvREADONLY_off(av);
if (i < av_len(av)+1) /* trim to size if too big */
av_fill(av, i-1);
}
else {
if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
- PerlIO_printf(DBILOGFP," dbih_setup_fbav alloc for %ld fields\n", (long)i);
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav alloc for %ld fields\n", (long)i);
av = newAV();
DBIc_FIELDS_AV(imp_sth) = av;
@@ -1602,7 +1766,7 @@
while(i--) /* field 1 stored at index 0 */
av_store(av, i, newSV(0));
if (DBIc_TRACE_LEVEL(imp_sth) >= 6)
- PerlIO_printf(DBILOGFP," dbih_setup_fbav now %ld fields\n", (long)(av_len(av)+1));
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav now %ld fields\n", (long)(av_len(av)+1));
SvREADONLY_on(av); /* protect against shift @$row etc */
return av;
}
@@ -1652,14 +1816,13 @@
dbih_sth_bind_col(SV *sth, SV *col, SV *ref, SV *attribs)
{
dTHX;
- dPERINTERP;
D_imp_sth(sth);
AV *av;
int idx = SvIV(col);
int fields = DBIc_NUM_FIELDS(imp_sth);
if (fields <= 0) {
- attribs = attribs; /* avoid 'unused variable' warning */
+ PERL_UNUSED_VAR(attribs);
croak("Statement has no result columns to bind%s",
DBIc_ACTIVE(imp_sth)
? "" : " (perhaps you need to call execute first)");
@@ -1669,7 +1832,7 @@
av = dbih_setup_fbav(imp_sth);
if (DBIc_TRACE_LEVEL(imp_sth) >= 5)
- PerlIO_printf(DBILOGFP," dbih_sth_bind_col %s => %s %s\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," dbih_sth_bind_col %s => %s %s\n",
neatsvpv(col,0), neatsvpv(ref,0), neatsvpv(attribs,0));
if (idx < 1 || idx > fields)
@@ -1834,7 +1997,6 @@
dbih_set_attr_k(SV *h, SV *keysv, int dbikey, SV *valuesv)
{
dTHX;
- dPERINTERP;
dTHR;
D_imp_xxh(h);
STRLEN keylen;
@@ -1846,7 +2008,7 @@
(void)dbikey;
if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
- PerlIO_printf(DBILOGFP," STORE %s %s => %s\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh)," STORE %s %s => %s\n",
neatsvpv(h,0), neatsvpv(keysv,0), neatsvpv(valuesv,0));
if (internal && strEQ(key, "Active")) {
@@ -2057,7 +2219,7 @@
/* the DBI classes and may be of use to simple perl DBD's. */
if (strnNE(key,"private_",8) && strnNE(key,"dbd_",4) && strnNE(key,"dbi_",4)) {
if (DBIc_TRACE_LEVEL(imp_xxh)) { /* change to DBIc_WARN(imp_xxh) once we can validate prefix against registry */
- PerlIO_printf(DBILOGFP,"$h->{%s}=%s ignored for invalid driver-specific attribute\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh),"$h->{%s}=%s ignored for invalid driver-specific attribute\n",
neatsvpv(keysv,0), neatsvpv(valuesv,0));
}
return FALSE;
@@ -2075,7 +2237,6 @@
dbih_get_attr_k(SV *h, SV *keysv, int dbikey)
{
dTHX;
- dPERINTERP;
dTHR;
D_imp_xxh(h);
STRLEN keylen;
@@ -2152,7 +2313,7 @@
}
if (DBIc_TRACE_LEVEL(imp_sth) >= 10 || (num_fields_mismatch && DBIc_WARN(imp_xxh))) {
- PerlIO_printf(DBILOGFP," FETCH $h->{%s} from $h->{NAME} with $h->{NUM_OF_FIELDS} = %d"
+ PerlIO_printf(DBIc_LOGPIO(imp_sth)," FETCH $h->{%s} from $h->{NAME} with $h->{NUM_OF_FIELDS} = %d"
" and %ld entries in $h->{NAME}%s\n",
neatsvpv(keysv,0), DBIc_NUM_FIELDS(imp_sth), AvFILL(name_av)+1,
(num_fields_mismatch) ? " (possible bug in driver)" : "");
@@ -2403,7 +2564,7 @@
(void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0);
}
if (DBIc_TRACE_LEVEL(imp_xxh) >= 3)
- PerlIO_printf(DBILOGFP," .. FETCH %s %s = %s%s\n", neatsvpv(h,0),
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh)," .. FETCH %s %s = %s%s\n", neatsvpv(h,0),
neatsvpv(keysv,0), neatsvpv(valuesv,0), cacheit?" (cached)":"");
if (valuesv == &PL_sv_yes || valuesv == &PL_sv_no || valuesv == &PL_sv_undef)
return valuesv; /* no need to mortalize yes or no */
@@ -2550,13 +2711,12 @@
if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(*svp);
if (HvKEYS(hv)) {
- dPERINTERP;
if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level)
trace_level = DBIc_TRACE_LEVEL(imp_xxh);
if (trace_level >= 2) {
- PerlIO_printf(DBILOGFP," >> %s %s clearing %d CachedKids\n",
+ PerlIO_printf(DBIc_LOGPIO(imp_xxh)," >> %s %s clearing %d CachedKids\n",
meth_name, neatsvpv(h,0), (int)HvKEYS(hv));
- PerlIO_flush(DBILOGFP);
+ PerlIO_flush(DBIc_LOGPIO(imp_xxh));
}
/* This will probably recurse through dispatch to DESTROY the kids */
/* For drh we should probably explicitly do dbh disconnects */
@@ -2955,7 +3115,7 @@
XS(XS_DBI_dispatch)
{
dXSARGS;
- dPERINTERP;
+ dMY_CXT;
SV *h = ST(0); /* the DBI handle we are working with */
SV *st1 = ST(1); /* used in debugging */
@@ -2969,7 +3129,7 @@
I32 trace_flags = DBIS->debug; /* local copy may change during dispatch */
I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK);
int is_DESTROY;
- int is_FETCH;
+ meth_types meth_type;
int is_unrelated_to_Statement = 0;
int keep_error = FALSE;
UV ErrCount = UV_MAX;
@@ -2977,15 +3137,32 @@
int call_depth;
int is_nested_call;
NV profile_t1 = 0.0;
+ int is_orig_method_name = 1;
const char *meth_name = GvNAME(CvGV(cv));
- const dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
- const U32 ima_flags = (ima) ? ima->flags : 0;
+ dbi_ima_t *ima = (dbi_ima_t*)CvXSUBANY(cv).any_ptr;
+ U32 ima_flags;
imp_xxh_t *imp_xxh = NULL;
SV *imp_msv = Nullsv;
SV *qsv = Nullsv; /* quick result from a shortcut method */
+#ifdef BROKEN_DUP_ANY_PTR
+ if (ima->my_perl != my_perl) {
+ /* we couldn't dup the ima struct at clone time, so do it now */
+ dbi_ima_t *nima;
+ Newx(nima, 1, dbi_ima_t);
+ *nima = *ima; /* structure copy */
+ CvXSUBANY(cv).any_ptr = nima;
+ nima->stash = NULL;
+ nima->gv = NULL;
+ nima->my_perl = my_perl;
+ ima = nima;
+ }
+#endif
+
+ ima_flags = ima->flags;
+ meth_type = ima->meth_type;
if (trace_level >= 9) {
PerlIO *logfp = DBILOGFP;
PerlIO_printf(logfp,"%c >> %-11s DISPATCH (%s rc%ld/%ld @%ld g%x ima%lx pid#%ld)",
@@ -2996,7 +3173,7 @@
PerlIO_flush(logfp);
}
- if ( ( (is_DESTROY=(*meth_name=='D' && strEQ(meth_name,"DESTROY")))) ) {
+ if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) {
/* note that croak()'s won't propagate, only append to $@ */
keep_error = TRUE;
}
@@ -3007,8 +3184,13 @@
data (without having to go through FETCH and STORE methods) and
for tie and non-tie methods to call each other.
*/
- if (SvROK(h) && SvRMAGICAL(SvRV(h)) && (mg=mg_find(SvRV(h),'P'))!=NULL) {
-
+ if (SvROK(h)
+ && SvRMAGICAL(SvRV(h))
+ && (
+ ((mg=SvMAGIC(SvRV(h)))->mg_type == 'P')
+ || ((mg=mg_find(SvRV(h),'P')) != NULL)
+ )
+ ) {
if (mg->mg_obj==NULL || !SvOK(mg->mg_obj) || SvRV(mg->mg_obj)==NULL) { /* maybe global destruction */
if (trace_level >= 3)
PerlIO_printf(DBILOGFP,
@@ -3058,7 +3240,7 @@
imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle Attributes */
if (!imp_xxh) {
- if (strEQ(meth_name, "can")) { /* ref($h)->can("foo") */
+ if (meth_type == methtype_can) { /* ref($h)->can("foo") */
const char *can_meth = SvPV_nolen(st1);
SV *rv = &PL_sv_undef;
GV *gv = gv_fetchmethod_autoload(gv_stashsv(orig_h,FALSE), can_meth, FALSE);
@@ -3117,12 +3299,12 @@
#endif
/* Check method call against Internal Method Attributes */
- if (ima) {
+ if (ima_flags) {
if (ima_flags & (IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) {
if (ima_flags & IMA_STUB) {
- if (*meth_name == 'c' && strEQ(meth_name,"can")) {
+ if (meth_type == methtype_can) {
const char *can_meth = SvPV_nolen(st1);
SV *dbi_msv = Nullsv;
/* find handle implementors method (GV or CV) */
@@ -3152,6 +3334,8 @@
croak("%s->%s() invalid redirect method name %s",
neatsvpv(h,0), meth_name, neatsvpv(meth_name_sv,0));
meth_name = SvPV_nolen(meth_name_sv);
+ meth_type = get_meth_type(meth_name);
+ is_orig_method_name = 0;
}
if (ima_flags & IMA_KEEP_ERR)
keep_error = TRUE;
@@ -3208,11 +3392,44 @@
/* record this inner handle for use by DBI::var::FETCH */
if (is_DESTROY) {
+ /* force destruction of any outstanding children */
+ if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) {
+ AV *av = (AV*)SvRV(*tmp_svp);
+ I32 kidslots;
+ PerlIO *logfp = DBILOGFP;
+
+ for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) {
+ SV **hp = av_fetch(av, kidslots, FALSE);
+ if (!hp || !SvROK(*hp) || SvTYPE(SvRV(*hp))!=SVt_PVHV)
+ break;
+
+ if (trace_level >= 1) {
+ PerlIO_printf(logfp, "on DESTROY handle %s still has child %s (refcnt %ld, obj %d, dirty=%d)\n",
+ neatsvpv(h,0), neatsvpv(*hp, 0), (long)SvREFCNT(*hp), !!sv_isobject(*hp), PL_dirty);
+ if (trace_level >= 9)
+ sv_dump(SvRV(*hp));
+ }
+ if (sv_isobject(*hp)) { /* call DESTROY on the handle */
+ PUSHMARK(SP);
+ XPUSHs(*hp);
+ PUTBACK;
+ call_method("DESTROY", G_DISCARD|G_EVAL|G_KEEPERR);
+ }
+ else {
+ imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ *hp, 0);
+ if (imp_xxh && DBIc_COMSET(imp_xxh)) {
+ dbih_clearcom(imp_xxh);
+ sv_setsv(*hp, &PL_sv_undef);
+ }
+ }
+ }
+ }
+
if (DBIc_TYPE(imp_xxh) <= DBIt_DB ) { /* is dbh or drh */
imp_xxh_t *parent_imp;
if (SvOK(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh))
- && !PL_dirty
+ && !PL_dirty /* XXX - remove? */
) {
/* copy err/errstr/state values to $DBI::err etc still work */
sv_setsv(DBIc_ERR(parent_imp), DBIc_ERR(imp_xxh));
@@ -3243,12 +3460,12 @@
}
}
- is_nested_call = (call_depth > 1 || (DBIc_PARENT_COM(imp_xxh) && DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh))) >= 1);
+ is_nested_call = ( call_depth > 1 || (DBIc_PARENT_COM(imp_xxh) && (DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) >= 1)) );
/* --- dispatch --- */
- if (!keep_error && !(*meth_name=='s' && strEQ(meth_name,"set_err"))) {
+ if (!keep_error && meth_type != methtype_set_err) {
SV *err_sv;
if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) {
PerlIO *logfp = DBILOGFP;
@@ -3271,7 +3488,8 @@
* Other restrictions may be added over time.
* It's an undocumented hack.
*/
- || (!is_nested_call && !PL_dirty && strNE(meth_name, "set_err") && strNE(meth_name, "DESTROY") &&
+ || (!is_nested_call && !PL_dirty && meth_type != methtype_set_err &&
+ meth_type != methtype_DESTROY &&
(hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0))
)
)
@@ -3346,7 +3564,7 @@
/* The "quick_FETCH" logic... */
/* Shortcut for fetching attributes to bypass method call overheads */
- if ( (is_FETCH = (*meth_name=='F' && strEQ(meth_name,"FETCH"))) && !DBIc_COMPAT(imp_xxh)) {
+ if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) {
STRLEN kl;
const char *key = SvPV(st1, kl);
SV **attr_svp;
@@ -3363,18 +3581,18 @@
if (*key == 'P' && strEQ(key, "Profile"))
profile_t1 = 0.0;
}
+ if (qsv) { /* skip real method call if we already have a 'quick' value */
+ ST(0) = sv_mortalcopy(qsv);
+ outitems = 1;
+ goto post_dispatch;
+ }
}
- if (qsv) { /* skip real method call if we already have a 'quick' value */
-
- ST(0) = sv_mortalcopy(qsv);
- outitems = 1;
-
- }
- else {
+ {
+ CV *meth_cv;
#ifdef DBI_save_hv_fetch_ent
HE save_mh;
- if (is_FETCH)
+ if (meth_type == methtype_FETCH)
save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */
#endif
@@ -3391,7 +3609,31 @@
}
}
- imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), meth_name, FALSE);
+ if (is_orig_method_name
+ && ima->stash == DBIc_IMP_STASH(imp_xxh)
+ && ima->generation == PL_sub_generation +
+ MY_cache_gen(DBIc_IMP_STASH(imp_xxh))
+ )
+ imp_msv = (SV*)ima->gv;
+ else {
+ imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh),
+ meth_name, FALSE);
+ if (is_orig_method_name) {
+ /* clear stale entry, if any */
+ SvREFCNT_dec(ima->stash);
+ SvREFCNT_dec(ima->gv);
+ if (!imp_msv) {
+ ima->stash = NULL;
+ ima->gv = NULL;
+ }
+ else {
+ ima->stash = (HV*)SvREFCNT_inc(DBIc_IMP_STASH(imp_xxh));
+ ima->gv = (GV*)SvREFCNT_inc(imp_msv);
+ ima->generation = PL_sub_generation +
+ MY_cache_gen(DBIc_IMP_STASH(imp_xxh));
+ }
+ }
+ }
/* if method was a 'func' then try falling back to real 'func' method */
if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) {
@@ -3402,6 +3644,7 @@
PUTBACK;
++items;
meth_name = "func";
+ meth_type = methtype_ordinary;
}
}
@@ -3433,7 +3676,7 @@
PerlIO_flush(logfp);
}
- if (!imp_msv) {
+ if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) {
if (PL_dirty || is_DESTROY) {
outitems = 0;
goto post_dispatch;
@@ -3454,44 +3697,39 @@
*/
/* SHORT-CUT ALERT! */
- if (xsbypass && isGV(imp_msv) && CvISXSUB(GvCV(imp_msv))
- && CvXSUB(GvCV(imp_msv))) {
+ if (use_xsbypass && CvISXSUB(meth_cv) && CvXSUB(meth_cv)) {
/* If we are calling an XSUB we jump directly to its C code and
* bypass perl_call_sv(), pp_entersub() etc. This is fast.
- * This code is copied from a small section of pp_entersub().
+ * This code is based on a small section of pp_entersub().
*/
- I32 markix = TOPMARK;
- CV *xscv = GvCV(imp_msv);
- (void)(*CvXSUB(xscv))(aTHXo_ xscv); /* Call the C code directly */
+ (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code directly */
if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */
- if (++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
+ if (ax != PL_stack_sp - PL_stack_base ) { /* outitems != 1 */
+ ST(0) =
+ (ax > PL_stack_sp - PL_stack_base)
+ ? &PL_sv_undef /* outitems == 0 */
+ : *PL_stack_sp; /* outitems > 1 */
+ PL_stack_sp = PL_stack_base + ax;
}
outitems = 1;
}
else {
- outitems = PL_stack_sp - (PL_stack_base + markix);
+ outitems = PL_stack_sp - (PL_stack_base + ax - 1);
}
}
else {
/* sv_dump(imp_msv); */
- outitems = call_sv(isGV(imp_msv) ? (SV*)GvCV(imp_msv) : imp_msv,
+ outitems = call_sv((SV*)meth_cv,
(is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) );
}
- SPAGAIN;
- /* XXX restore local vars so ST(n) works below */
- SP -= outitems;
- ax = (SP - PL_stack_base) + 1;
+ XSprePUSH; /* reset SP to base of stack frame */
#ifdef DBI_save_hv_fetch_ent
- if (is_FETCH)
+ if (meth_type == methtype_FETCH)
PL_hv_fetch_ent_mh = save_mh; /* see start of block */
#endif
}
@@ -3517,7 +3755,7 @@
if (trace_level >= (is_nested_call ? 3 : 1)) {
PerlIO *logfp = DBILOGFP;
- const int is_fetch = (*meth_name=='f' && DBIc_TYPE(imp_xxh)==DBIt_ST && strnEQ(meth_name,"fetch",5));
+ const int is_fetch = (meth_type == methtype_fetch_star && DBIc_TYPE(imp_xxh)==DBIt_ST);
const int row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh) : 0;
if (is_fetch && row_count>=2 && trace_level<=4 && SvOK(ST(0))) {
/* skip the 'middle' rows to reduce output */
@@ -3681,7 +3919,7 @@
const char *err_meth_name = meth_name;
char intro[200];
- if (*meth_name=='s' && strEQ(meth_name,"set_err")) {
+ if (meth_type == methtype_set_err) {
SV **sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, GV_ADDWARN);
if (SvOK(*sem_svp))
err_meth_name = SvPV_nolen(*sem_svp);
@@ -4144,9 +4382,16 @@
BOOT:
- (void)cv;
- (void)items; /* avoid 'unused variable' warning */
+ {
+ MY_CXT_INIT;
+ PERL_UNUSED_VAR(MY_CXT);
+ }
+ PERL_UNUSED_VAR(cv);
+ PERL_UNUSED_VAR(items);
dbi_bootinit(NULL);
+ /* make this sub into a fake XS so it can bee seen by DBD::* modules;
+ * never actually call it as an XS sub, or it will crash and burn! */
+ (void) newXS("DBI::_dbi_state_lval", (XSUBADDR_t)_dbi_state_lval, __FILE__);
I32
@@ -4246,9 +4491,14 @@
void
_clone_dbis()
CODE:
- dPERINTERP;
+ dMY_CXT;
+ dbistate_t * parent_dbis = DBIS;
+
(void)cv;
- dbi_bootinit(DBIS);
+ {
+ MY_CXT_CLONE;
+ }
+ dbi_bootinit(parent_dbis);
void
@@ -4259,7 +4509,7 @@
SV * imp_datasv
SV * imp_class
PPCODE:
- dPERINTERP;
+ dMY_CXT;
HV *outer;
SV *outer_ref;
HV *class_stash = gv_stashsv(class, GV_ADDWARN);
@@ -4267,7 +4517,7 @@
if (DBIS_TRACE_LEVEL >= 5) {
PerlIO_printf(DBILOGFP, " New %s (for %s, parent=%s, id=%s)\n",
neatsvpv(class,0), SvPV_nolen(imp_class), neatsvpv(parent,0), neatsvpv(imp_datasv,0));
- (void)cv; /* avoid unused warning */
+ PERL_UNUSED_VAR(cv);
}
(void)hv_store((HV*)SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class), 0);
@@ -4372,12 +4622,13 @@
SV * attribs
CODE:
{
- dPERINTERP;
+ dMY_CXT;
/* install another method name/interface for the DBI dispatcher */
SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) : Nullsv;
CV *cv;
SV **svp;
- dbi_ima_t *ima = NULL;
+ dbi_ima_t *ima;
+ MAGIC *mg;
(void)dbi_class;
if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */
@@ -4386,15 +4637,13 @@
if (trace_msg)
sv_catpvf(trace_msg, "install_method %-21s", meth_name);
+ Newxz(ima, 1, dbi_ima_t);
+
if (attribs && SvOK(attribs)) {
/* convert and store method attributes in a fast access form */
- SV *sv;
if (SvTYPE(SvRV(attribs)) != SVt_PVHV)
croak("install_method %s: bad attribs", meth_name);
- sv = newSV(sizeof(*ima));
- ima = (dbi_ima_t*)(void*)SvPVX(sv);
- memzero((char*)ima, sizeof(*ima));
DBD_ATTRIB_GET_IV(attribs, "O",1, svp, ima->flags);
DBD_ATTRIB_GET_UV(attribs, "T",1, svp, ima->method_trace);
DBD_ATTRIB_GET_IV(attribs, "H",1, svp, ima->hidearg);
@@ -4418,8 +4667,24 @@
}
if (trace_msg)
PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg));
+ file = savepv(file);
cv = newXS(meth_name, XS_DBI_dispatch, file);
+ SvPVX((SV *)cv) = file;
+ SvLEN((SV *)cv) = 1;
CvXSUBANY(cv).any_ptr = ima;
+ ima->meth_type = get_meth_type(GvNAME(CvGV(cv)));
+
+ /* Attach magic to handle duping and freeing of the dbi_ima_t struct.
+ * Due to the poor interface of the mg dup function, sneak a pointer
+ * to the original CV in the mg_ptr field (we get called with a
+ * pointer to the mg, but not the SV) */
+ mg = sv_magicext((SV*)cv, NULL, DBI_MAGIC, &dbi_ima_vtbl,
+ (char *)cv, 0);
+#ifdef BROKEN_DUP_ANY_PTR
+ ima->my_perl = my_perl; /* who owns this struct */
+#else
+ mg->mg_flags |= MGf_DUP;
+#endif
ST(0) = &PL_sv_yes;
}
@@ -4433,10 +4698,10 @@
_debug_dispatch = 1
CODE:
{
- dPERINTERP;
+ dMY_CXT;
IV level;
if (!DBIS) {
- ix=ix; /* avoid 'unused variable' warnings */
+ PERL_UNUSED_VAR(ix);
croak("DBI not initialised");
}
/* Return old/current value. No change if new value not given. */
@@ -4454,7 +4719,7 @@
#ifdef MULTIPLICITY
(void *)my_perl,
#else
- NULL,
+ (void*)NULL,
#endif
log_where(Nullsv, 0, "", "", 1, 1, 0)
);
@@ -4489,7 +4754,7 @@
SV * sv
CODE:
{
- dPERINTERP;
+ dMY_CXT;
(void)cv;
PerlIO_printf(DBILOGFP, "DBI::_svdump(%s)", neatsvpv(sv,0));
#ifdef DEBUGGING
@@ -4511,7 +4776,7 @@
NV t2
CODE:
SV *leaf = &PL_sv_undef;
- (void)cv; /* avoid unused var warnings */
+ PERL_UNUSED_VAR(cv);
if (SvROK(method))
method = SvRV(method);
if (dbih_inner(aTHX_ h, NULL)) { /* is a DBI handle */
@@ -4552,8 +4817,8 @@
if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV)
croak("dbi_profile_merge_nodes(%s,...) destination is not an array reference", neatsvpv(dest,0));
if (items <= 1) {
- (void)cv; /* avoid unused var warnings */
- (void)ix;
+ PERL_UNUSED_VAR(cv);
+ PERL_UNUSED_VAR(ix);
RETVAL = 0;
}
else {
@@ -4617,7 +4882,7 @@
FETCH(sv)
SV * sv
CODE:
- dPERINTERP;
+ dMY_CXT;
/* Note that we do not come through the dispatcher to get here. */
char *meth = SvPV_nolen(SvRV(sv)); /* what should this tie do ? */
char type = *meth++; /* is this a $ or & style */
@@ -4726,7 +4991,7 @@
SV *imp_xxh_sv;
SV **tmp_svp;
CODE:
- (void)cv; /* unused */
+ PERL_UNUSED_VAR(cv);
/*
* Remove and return the imp_xxh_t structure that's attached to the inner
* hash of the handle. Effectively this removes the 'brain' of the handle
@@ -4811,6 +5076,7 @@
dbih_getcom2(aTHX_ h, &mg); /* get the MAGIC so we can change it */
imp_xxh_sv = mg->mg_obj; /* take local copy of the imp_data pointer */
mg->mg_obj = Nullsv; /* sever the link from handle to imp_xxh */
+ mg->mg_ptr = NULL; /* and sever the shortcut too */
if (DBIc_TRACE_LEVEL(imp_xxh) >= 9)
sv_dump(imp_xxh_sv);
/* --- housekeeping */
@@ -4901,10 +5167,9 @@
ALIAS:
fetchrow = 1
PPCODE:
- dPERINTERP;
SV *retsv;
if (CvDEPTH(cv) == 99) {
- ix = ix; /* avoid 'unused variable' warning' */
+ PERL_UNUSED_VAR(ix);
croak("Deep recursion, probably fetchrow-fetch-fetchrow loop");
}
PUSHMARK(sp);
@@ -4931,7 +5196,7 @@
/* let dbih_get_fbav know what's going on */
bound_av = dbih_get_fbav(imp_sth);
if (DBIc_TRACE_LEVEL(imp_sth) >= 3) {
- PerlIO_printf(DBILOGFP,
+ PerlIO_printf(DBIc_LOGPIO(imp_sth),
"fetchrow: updating fbav 0x%lx from 0x%lx\n",
(long)bound_av, (long)av);
}
@@ -5016,7 +5281,7 @@
CODE:
int num_fields;
if (CvDEPTH(cv) == 99) {
- (void)ix; /* avoid 'unused variable' warning' */
+ PERL_UNUSED_VAR(ix);
croak("Deep recursion. Probably fetch-fetchrow-fetch loop.");
}
PUSHMARK(sp);
@@ -5238,7 +5503,7 @@
PerlIO *pio;
CODE:
{
- dPERINTERP;
+ dMY_CXT;
(void)cv;
if (SvROK(sv)) {
D_imp_xxh(sv);
@@ -5298,8 +5563,8 @@
XSRETURN_NO;
}
- SvREFCNT_inc(h1i);
- SvREFCNT_inc(h2i);
+ (void)SvREFCNT_inc(h1i);
+ (void)SvREFCNT_inc(h2i);
sv_unmagic(h1, 'P'); /* untie(%$h1) */
sv_unmagic(h2, 'P'); /* untie(%$h2) */
@@ -5323,10 +5588,9 @@
DESTROY(imp_xxh_rv)
SV * imp_xxh_rv
CODE:
- dPERINTERP;
/* ignore 'cast increases required alignment' warning */
imp_xxh_t *imp_xxh = (imp_xxh_t*)SvPVX(SvRV(imp_xxh_rv));
- DBIS->clearcom(imp_xxh);
+ DBIc_DBISTATE(imp_xxh)->clearcom(imp_xxh);
(void)cv;
# end
Modified: dbi/branches/sqlengine/DBIXS.h
==============================================================================
--- dbi/branches/sqlengine/DBIXS.h (original)
+++ dbi/branches/sqlengine/DBIXS.h Wed Aug 29 00:09:55 2012
@@ -223,12 +223,19 @@
#define DBIc_TRACE_MATCHES(this, crnt) \
( ((crnt & DBIc_TRACE_LEVEL_MASK) >= (this & DBIc_TRACE_LEVEL_MASK)) \
|| ((crnt & DBIc_TRACE_FLAGS_MASK) & (this & DBIc_TRACE_FLAGS_MASK)) )
-/* DBIc_TRACE: true if flags match & DBI level>=flaglevel, or if DBI level>level
+
+/* DBIc_TRACE(imp, flags, flag_level, fallback_level)
+ True if flags match the handle trace flags & handle trace level >= flag_level,
+ OR if handle trace_level > fallback_level (typically > flag_level).
This is the main trace testing macro to be used by drivers.
(Drivers should define their own DBDf_TRACE_* macros for the top 8 bits: 0xFF000000)
- DBIc_TRACE(imp, 0, 0, 4) = if level >= 4
- DBIc_TRACE(imp, DBDf_FOO, 2, 4) = if tracing DBDf_FOO & level>=2 or level>=4
- DBIc_TRACE(imp, DBDf_FOO, 2, 0) = as above but never trace just due to level
+ DBIc_TRACE(imp, 0, 0, 4) = if trace level >= 4
+ DBIc_TRACE(imp, DBDf_TRACE_FOO, 2, 4) = if tracing DBDf_FOO & level>=2 or level>=4
+ DBIc_TRACE(imp, DBDf_TRACE_FOO, 2, 0) = as above but never trace just due to level
+ e.g.
+ if (DBIc_TRACE(imp_xxh, DBIf_TRACE_SQL|DBIf_TRACE_xxx, 2, 0)) {
+ PerlIO_printf(DBIc_LOGPIO(imp_sth), "\tThe %s wibbled the %s\n", ...);
+ }
*/
#define DBIc_TRACE(imp, flags, flaglevel, level) \
( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \
@@ -467,8 +474,6 @@
#define set_attr(h, k, v) set_attr_k(h, k, 0, v)
#define get_attr(h, k) get_attr_k(h, k, 0)
-#define DBISTATE_PERLNAME "DBI::_dbistate"
-#define DBISTATE_ADDRSV (get_sv(DBISTATE_PERLNAME, 0x05))
#define DBILOGFP (DBIS->logfp)
#ifdef IN_DBI_XS
#define DBILOGMSG (dbih_logmsg)
@@ -476,28 +481,45 @@
#define DBILOGMSG (DBIS->logmsg)
#endif
-
/* --- perl object (ActiveState) / multiplicity hooks and hoops --- */
/* note that USE_ITHREADS implies MULTIPLICITY */
-#define DBIS_PUBLISHED_LVALUE (*(INT2PTR(dbistate_t**, &SvIVX(DBISTATE_ADDRSV))))
+
+typedef dbistate_t** (*_dbi_state_lval_t)(pTHX);
+
+# define _DBISTATE_DECLARE_COMMON \
+ static _dbi_state_lval_t dbi_state_lval_p = 0; \
+ static dbistate_t** dbi_get_state(pTHX) { \
+ if (!dbi_state_lval_p) { \
+ CV *cv = get_cv("DBI::_dbi_state_lval", 0); \
+ if (!cv) \
+ croak("Unable to get DBI state function. DBI not loaded."); \
+ dbi_state_lval_p = (_dbi_state_lval_t)CvXSUB(cv); \
+ } \
+ return dbi_state_lval_p(aTHX); \
+ } \
+ typedef int dummy_dbistate /* keep semicolon from feeling lonely */
+
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
-# define DBISTATE_DECLARE typedef int dummy_dbistate /* keep semicolon from feeling lonely */
-# define DBISTATE_INIT_DBIS typedef int dummy_dbistate2; /* keep semicolon from feeling lonely */
+# define DBISTATE_DECLARE _DBISTATE_DECLARE_COMMON
+# define _DBISTATE_INIT_DBIS
# undef DBIS
-# define DBIS DBIS_PUBLISHED_LVALUE
-# define dbis DBIS_PUBLISHED_LVALUE /* temp for old drivers using 'dbis' instead of 'DBIS' */
+# define DBIS (*dbi_get_state(aTHX))
+# define dbis DBIS /* temp for old drivers using 'dbis' instead of 'DBIS' */
#else /* plain and simple non perl object / multiplicity case */
-# define DBISTATE_DECLARE static dbistate_t *DBIS
-# define DBISTATE_INIT_DBIS (DBIS = DBIS_PUBLISHED_LVALUE)
+# define DBISTATE_DECLARE \
+ static dbistate_t *DBIS; \
+ _DBISTATE_DECLARE_COMMON
+
+# define _DBISTATE_INIT_DBIS DBIS = *dbi_get_state(aTHX);
#endif
# define DBISTATE_INIT { /* typically use in BOOT: of XS file */ \
- DBISTATE_INIT_DBIS; \
+ _DBISTATE_INIT_DBIS \
if (DBIS == NULL) \
- croak("Unable to get DBI state from %s at %p. DBI not loaded.", DBISTATE_PERLNAME, (void*)DBISTATE_ADDRSV); \
+ croak("Unable to get DBI state. DBI not loaded."); \
DBIS->check_version(__FILE__, DBISTATE_VERSION, sizeof(*DBIS), NEED_DBIXS_VERSION, \
sizeof(dbih_drc_t), sizeof(dbih_dbc_t), sizeof(dbih_stc_t), sizeof(dbih_fdc_t) \
); \
Modified: dbi/branches/sqlengine/Driver.xst
==============================================================================
--- dbi/branches/sqlengine/Driver.xst (original)
+++ dbi/branches/sqlengine/Driver.xst Wed Aug 29 00:09:55 2012
@@ -15,7 +15,7 @@
PROTOTYPES: DISABLE
BOOT:
- items = 0; /* avoid 'unused variable' warning */
+ PERL_UNUSED_VAR(items);
DBISTATE_INIT;
/* XXX this interface will change: */
DBI_IMP_SIZE("DBD::~DRIVER~::dr::imp_data_size", sizeof(imp_drh_t));
@@ -46,7 +46,7 @@
disconnect_all = 1
CODE:
D_imp_drh(drh);
- if (0) ix = ix; /* avoid unused variable warning */
+ PERL_UNUSED_VAR(ix);
ST(0) = dbd_discon_all(drh, imp_drh) ? &PL_sv_yes : &PL_sv_no;
#endif /* dbd_discon_all */
@@ -623,7 +623,7 @@
CODE:
D_imp_sth(sth);
AV *av;
- if (0) ix = ix; /* avoid unused variable warning */
+ PERL_UNUSED_VAR(ix);
av = dbd_st_fetch(sth, imp_sth);
ST(0) = (av) ? sv_2mortal(newRV((SV *)av)) : &PL_sv_undef;
@@ -644,7 +644,7 @@
for(i=0; i < num_fields; ++i) {
PUSHs(AvARRAY(av)[i]);
}
- if (0) ix = ix; /* avoid unused variable warning */
+ PERL_UNUSED_VAR(ix);
}
@@ -731,7 +731,7 @@
CODE:
D_imp_sth(sth);
SV *valuesv;
- if (0) ix = ix; /* avoid unused variable warning */
+ PERL_UNUSED_VAR(ix);
valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv);
if (!valuesv)
valuesv = DBIc_DBISTATE(imp_sth)->get_attr(sth, keysv);
Modified: dbi/branches/sqlengine/Driver_xst.h
==============================================================================
--- dbi/branches/sqlengine/Driver_xst.h (original)
+++ dbi/branches/sqlengine/Driver_xst.h Wed Aug 29 00:09:55 2012
@@ -28,7 +28,7 @@
if (debug >= 3) {
PerlIO_printf(DBIc_LOGPIO(imp_xxh),
" -> %s (trampoline call with %d (%ld) params)\n", methname, params, (long)items);
- xxx = xxx; /* avoid unused var warning */
+ PERL_UNUSED_VAR(xxx);
}
EXTEND(SP, params);
PUSHMARK(SP);
@@ -61,10 +61,15 @@
&& DBIc_NUM_PARAMS(imp_sth) != DBIc_NUM_PARAMS_AT_EXECUTE
) {
char errmsg[99];
+ /* clear any previous ParamValues before error is generated */
+ SV **svp = hv_fetch((HV*)DBIc_MY_H(imp_sth),"ParamValues",11,FALSE);
+ if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
+ HV *hv = (HV*)SvRV(*svp);
+ hv_clear(hv);
+ }
sprintf(errmsg,"called with %d bind variables when %d are needed",
(int)items-1, DBIc_NUM_PARAMS(imp_sth));
- sv_setpv(DBIc_ERRSTR(imp_sth), errmsg);
- sv_setiv(DBIc_ERR(imp_sth), (IV)-1);
+ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, "-1", -1, errmsg, Nullch, Nullch);
return 0;
}
idx = sv_2mortal(newSViv(0));
@@ -90,8 +95,7 @@
if (SvOK(slice)) { /* should never get here */
char errmsg[99];
sprintf(errmsg,"slice param not supported by XS version of fetchall_arrayref");
- sv_setpv(DBIc_ERRSTR(imp_sth), errmsg);
- sv_setiv(DBIc_ERR(imp_sth), (IV)-1);
+ DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, "-1", -1, errmsg, Nullch, Nullch);
return &PL_sv_undef;
}
else {
Modified: dbi/branches/sqlengine/MANIFEST
==============================================================================
--- dbi/branches/sqlengine/MANIFEST (original)
+++ dbi/branches/sqlengine/MANIFEST Wed Aug 29 00:09:55 2012
@@ -92,6 +92,7 @@
t/19fhtrace.t
t/20meta.t
t/30subclass.t
+t/31methcache.t Test caching of inner methods
t/35thrclone.t
t/40profile.t
t/41prof_dump.t
Modified: dbi/branches/sqlengine/Makefile.PL
==============================================================================
--- dbi/branches/sqlengine/Makefile.PL (original)
+++ dbi/branches/sqlengine/Makefile.PL Wed Aug 29 00:09:55 2012
@@ -49,17 +49,19 @@
}
if ($Config{useithreads}) {
- print "\n";
- print "*** You are using a perl configured with threading enabled.\n";
- print "*** You should be aware that using multiple threads is\n";
- print "*** not recommended for production environments.\n";
- print "\n";
- sleep 1;
+ if ($] < 5.012) { # recent perls are reasonably fre of thread bugs
+ print "\n";
+ print "*** You are using a perl configured with threading enabled.\n";
+ print "*** You should be aware that using multiple threads is\n";
+ print "*** not recommended for production environments.\n";
+ print "\n";
+ sleep 1;
+ }
$::opt_thread = 1;
}
else {
- if ($Config{archname} =~ /thread/ && $::opt_thread) {
+ if ($Config{archname} =~ /\bthread/ && $::opt_thread) {
# oh dear... tell it like it is:
print "\n";
print "DBI versions from 1.29 onwards no longer support the old style\n";
Modified: dbi/branches/sqlengine/Perl.xs
==============================================================================
--- dbi/branches/sqlengine/Perl.xs (original)
+++ dbi/branches/sqlengine/Perl.xs Wed Aug 29 00:09:55 2012
@@ -41,7 +41,7 @@
dbd_st_rows(SV *h, imp_sth_t *imp_sth)
{
dTHX;
- h = h; /* silence unused var warning */
+ PERL_UNUSED_VAR(h);
DBIh_SET_ERR_CHAR(h, imp_sth, 0, 1, "err msg", "12345", Nullch);
return -1;
}
Modified: dbi/branches/sqlengine/README
==============================================================================
--- dbi/branches/sqlengine/README (original)
+++ dbi/branches/sqlengine/README Wed Aug 29 00:09:55 2012
@@ -19,7 +19,7 @@
make test
make install
Then delete the source directory tree since it's no longer needed.
- Or else use an installer like the cpan, cpanplus, or cpanm commands.
+ Or else use an installer like cpanm, cpanplus, or cpan commands.
Use the 'perldoc DBI' command to read the DBI documentation.
See GETTING HELP section in DBI.pm for how to get help.
Modified: dbi/branches/sqlengine/TODO_2005.txt
==============================================================================
--- dbi/branches/sqlengine/TODO_2005.txt (original)
+++ dbi/branches/sqlengine/TODO_2005.txt Wed Aug 29 00:09:55 2012
@@ -7,6 +7,10 @@
goes out of scope, should trigger rollback not commit. (ODBC does a commit)
RISK: This will break code that assumes a commit.
REMEDY: Explicitly $dbh->commit where required.
+MJE: I may misunderstand this but ODBC commits in this case because
+ AutoCommit is turned back on again when the block completes and that
+ causes any outstanding txn to be committed. Neither DBD::ODBC or ODBC
+ turned AutoCommit back on themselves.
Always taint check the $sql for do() and prepare()
if perl is in taint mode (can't be disabled).
@@ -57,6 +61,8 @@
Add dDBIS to be used in functions (eg like dTHR) that can't access it via a imp_xxh
Remove PERL_POLLUTE (so some names will require PL_ or Perl_ prefixes)
+ - MJE I believe this is effectively done now as PERL_POLLUTE was removed
+ in 5.13.3
Update dbipport.h from latest Devel::PPPort.
Modified: dbi/branches/sqlengine/dbipport.h
==============================================================================
--- dbi/branches/sqlengine/dbipport.h (original)
+++ dbi/branches/sqlengine/dbipport.h Wed Aug 29 00:09:55 2012
@@ -4,9 +4,9 @@
/*
----------------------------------------------------------------------
- ppport.h -- Perl/Pollution/Portability Version 3.19
+ ppport.h -- Perl/Pollution/Portability Version 3.20
- Automatically created by Devel::PPPort running under perl 5.010000.
+ Automatically created by Devel::PPPort running under perl 5.010001.
Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
includes in parts/inc/ instead.
@@ -21,7 +21,7 @@
=head1 NAME
-ppport.h - Perl/Pollution/Portability version 3.19
+ppport.h - Perl/Pollution/Portability version 3.20
=head1 SYNOPSIS
@@ -56,7 +56,7 @@
=head1 COMPATIBILITY
This version of F<ppport.h> is designed to support operation with Perl
-installations back to 5.003, and has been tested up to 5.10.0.
+installations back to 5.003, and has been tested up to 5.11.5.
=head1 OPTIONS
@@ -358,7 +358,7 @@
=head1 COPYRIGHT
-Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz.
+Version 3.x, Copyright (c) 2004-2010, Marcus Holland-Moritz.
Version 2.x, Copyright (C) 2001, Paul Marquess.
@@ -378,7 +378,7 @@
# Disable broken TRIE-optimization
BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 }
-my $VERSION = 3.19;
+my $VERSION = 3.20;
my %opt = (
quiet => 0,
@@ -447,6 +447,12 @@
: die "invalid spec: $_" } qw(
AvFILLp|5.004050||p
AvFILL|||
+BhkDISABLE||5.014000|
+BhkENABLE||5.014000|
+BhkENTRY_set||5.014000|
+BhkENTRY|||
+BhkFLAGS|||
+CALL_BLOCK_HOOKS|||
CLASS|||n
CPERLscope|5.005000||p
CX_CURPAD_SAVE|||
@@ -467,7 +473,7 @@
CvPADLIST|||
CvSTASH|||
CvWEAKOUTSIDE|||
-DEFSV_set|5.011000||p
+DEFSV_set|5.010001||p
DEFSV|5.004050||p
END_EXTERN_C|5.005000||p
ENTER|||
@@ -489,7 +495,7 @@
GetVars|||
GvSVn|5.009003||p
GvSV|||
-Gv_AMupdate|||
+Gv_AMupdate||5.011000|
HEf_SVKEY||5.004000|
HeHASH||5.004000|
HeKEY||5.004000|
@@ -498,8 +504,9 @@
HeSVKEY_force||5.004000|
HeSVKEY_set||5.004000|
HeSVKEY||5.004000|
-HeUTF8||5.011000|
+HeUTF8||5.010001|
HeVAL||5.004000|
+HvENAME||5.013007|
HvNAMELEN_get|5.009003||p
HvNAME_get|5.009003||p
HvNAME|||
@@ -518,9 +525,10 @@
IVTYPE|5.006000||p
IVdf|5.006000||p
LEAVE|||
+LINKLIST||5.013006|
LVRET|||
MARK|||
-MULTICALL||5.011000|
+MULTICALL||5.014000|
MY_CXT_CLONE|5.009002||p
MY_CXT_INIT|5.007003||p
MY_CXT|5.007003||p
@@ -540,6 +548,9 @@
Nullcv|||
Nullhv|||
Nullsv|||
+OP_CLASS||5.013007|
+OP_DESC||5.007003|
+OP_NAME||5.007003|
ORIGMARK|||
PAD_BASE_SV|||
PAD_CLONE_VARS|||
@@ -561,7 +572,7 @@
PERLIO_FUNCS_CAST|5.009003||p
PERLIO_FUNCS_DECL|5.009003||p
PERL_ABS|5.008001||p
-PERL_BCDVERSION|5.011000||p
+PERL_BCDVERSION|5.014000||p
PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
PERL_HASH|5.004000||p
PERL_INT_MAX|5.004000||p
@@ -579,10 +590,10 @@
PERL_MAGIC_env|5.007002||p
PERL_MAGIC_ext|5.007002||p
PERL_MAGIC_fm|5.007002||p
-PERL_MAGIC_glob|5.011000||p
+PERL_MAGIC_glob|5.014000||p
PERL_MAGIC_isaelem|5.007002||p
PERL_MAGIC_isa|5.007002||p
-PERL_MAGIC_mutex|5.011000||p
+PERL_MAGIC_mutex|5.014000||p
PERL_MAGIC_nkeys|5.007002||p
PERL_MAGIC_overload_elem|5.007002||p
PERL_MAGIC_overload_table|5.007002||p
@@ -634,7 +645,7 @@
PERL_SUBVERSION|5.006000||p
PERL_SYS_INIT3||5.006000|
PERL_SYS_INIT|||
-PERL_SYS_TERM||5.011000|
+PERL_SYS_TERM||5.014000|
PERL_UCHAR_MAX|5.004000||p
PERL_UCHAR_MIN|5.004000||p
PERL_UINT_MAX|5.004000||p
@@ -656,10 +667,10 @@
PL_DBsub|||pn
PL_DBtrace|||pn
PL_Sv|5.005000||p
-PL_bufend|5.011000||p
-PL_bufptr|5.011000||p
+PL_bufend|5.014000||p
+PL_bufptr|5.014000||p
PL_compiling|5.004050||p
-PL_copline|5.011000||p
+PL_copline|5.014000||p
PL_curcop|5.004050||p
PL_curstash|5.004050||p
PL_debstash|5.004050||p
@@ -668,27 +679,31 @@
PL_dirty|5.004050||p
PL_dowarn|||pn
PL_errgv|5.004050||p
-PL_error_count|5.011000||p
-PL_expect|5.011000||p
+PL_error_count|5.014000||p
+PL_expect|5.014000||p
PL_hexdigit|5.005000||p
PL_hints|5.005000||p
-PL_in_my_stash|5.011000||p
-PL_in_my|5.011000||p
+PL_in_my_stash|5.014000||p
+PL_in_my|5.014000||p
+PL_keyword_plugin||5.011002|
PL_last_in_gv|||n
PL_laststatval|5.005000||p
-PL_lex_state|5.011000||p
-PL_lex_stuff|5.011000||p
-PL_linestr|5.011000||p
+PL_lex_state|5.014000||p
+PL_lex_stuff|5.014000||p
+PL_linestr|5.014000||p
PL_modglobal||5.005000|n
PL_na|5.004050||pn
PL_no_modify|5.006000||p
PL_ofsgv|||n
-PL_parser|5.009005||p
+PL_opfreehook||5.011000|n
+PL_parser|5.009005|5.009005|p
+PL_peepp||5.007003|n
PL_perl_destruct_level|5.004050||p
PL_perldb|5.004050||p
PL_ppaddr|5.006000||p
-PL_rsfp_filters|5.004050||p
-PL_rsfp|5.004050||p
+PL_rpeepp||5.013005|n
+PL_rsfp_filters|5.014000||p
+PL_rsfp|5.014000||p
PL_rs|||n
PL_signals|5.008001||p
PL_stack_base|5.004050||p
@@ -701,8 +716,8 @@
PL_sv_yes|5.004050||pn
PL_tainted|5.004050||p
PL_tainting|5.004050||p
-PL_tokenbuf|5.011000||p
-POP_MULTICALL||5.011000|
+PL_tokenbuf|5.014000||p
+POP_MULTICALL||5.014000|
POPi|||n
POPl|||n
POPn|||n
@@ -717,7 +732,7 @@
PTR2ul|5.007001||p
PTRV|5.006000||p
PUSHMARK|||
-PUSH_MULTICALL||5.011000|
+PUSH_MULTICALL||5.014000|
PUSHi|||
PUSHmortal|5.009002||p
PUSHn|||
@@ -828,6 +843,7 @@
SvNOKp|||
SvNOK|||
SvNVX|||
+SvNV_nomg||5.013002|
SvNV_set|||
SvNVx|||
SvNV|||
@@ -861,6 +877,7 @@
SvPV_nolen|5.006000||p
SvPV_nomg_const_nolen|5.009003||p
SvPV_nomg_const|5.009003||p
+SvPV_nomg_nolen||5.013007|
SvPV_nomg|5.007002||p
SvPV_renew|5.009003||p
SvPV_set|||
@@ -906,6 +923,7 @@
SvTAINTED_on||5.004000|
SvTAINTED||5.004000|
SvTAINT|||
+SvTRUE_nomg||5.013006|
SvTRUE|||
SvTYPE|||
SvUNLOCK||5.007003|
@@ -933,7 +951,7 @@
UVxf|5.006000||p
WARN_ALL|5.006000||p
WARN_AMBIGUOUS|5.006000||p
-WARN_ASSERTIONS|5.011000||p
+WARN_ASSERTIONS|5.014000||p
WARN_BAREWORD|5.006000||p
WARN_CLOSED|5.006000||p
WARN_CLOSURE|5.006000||p
@@ -1005,37 +1023,52 @@
XST_mUNDEF|||
XST_mUV|5.008001||p
XST_mYES|||
+XS_APIVERSION_BOOTCHECK||5.013004|
XS_VERSION_BOOTCHECK|||
XS_VERSION|||
XSprePUSH|5.006000||p
XS|||
+XopDISABLE||5.014000|
+XopENABLE||5.014000|
+XopENTRY_set||5.014000|
+XopENTRY||5.014000|
+XopFLAGS||5.013007|
ZeroD|5.009002||p
Zero|||
_aMY_CXT|5.007003||p
+_append_range_to_invlist|||
+_new_invlist|||
_pMY_CXT|5.007003||p
+_swash_inversion_hash|||
+_swash_to_invlist|||
aMY_CXT_|5.007003||p
aMY_CXT|5.007003||p
-aTHXR_|5.011000||p
-aTHXR|5.011000||p
+aTHXR_|5.014000||p
+aTHXR|5.014000||p
aTHX_|5.006000||p
aTHX|5.006000||p
+add_alternate|||
+add_cp_to_invlist|||
add_data|||n
+add_range_to_invlist|||
+add_utf16_textfilter|||
addmad|||
allocmy|||
amagic_call|||
amagic_cmp_locale|||
amagic_cmp|||
+amagic_deref_call||5.013007|
amagic_i_ncmp|||
amagic_ncmp|||
+anonymise_cv_maybe|||
any_dup|||
ao|||
-append_elem|||
-append_list|||
append_madprops|||
apply_attrs_my|||
apply_attrs_string||5.006001|
apply_attrs|||
apply|||
+assert_uft8_cache_coherent|||
atfork_lock||5.007003|n
atfork_unlock||5.007003|n
av_arylen_p||5.009003|
@@ -1063,10 +1096,12 @@
block_end|||
block_gimme||5.004000|
block_start|||
+blockhook_register||5.013003|
boolSV|5.004000||p
boot_core_PerlIO|||
boot_core_UNIVERSAL|||
boot_core_mro|||
+bytes_cmp_utf8||5.013007|
bytes_from_utf8||5.007001|
bytes_to_uni|||n
bytes_to_utf8||5.006001|
@@ -1076,6 +1111,7 @@
call_method|5.006000||p
call_pv|5.006000||p
call_sv|5.006000||p
+caller_cx||5.013005|
calloc||5.007002|n
cando|||
cast_i32||5.006000|
@@ -1084,76 +1120,73 @@
cast_uv||5.006000|
check_type_and_open|||
check_uni|||
+check_utf8_print|||
checkcomma|||
checkposixcc|||
ckWARN|5.006000||p
-ck_anoncode|||
-ck_bitop|||
-ck_concat|||
-ck_defined|||
-ck_delete|||
-ck_die|||
-ck_each|||
-ck_eof|||
-ck_eval|||
-ck_exec|||
-ck_exists|||
-ck_exit|||
-ck_ftst|||
-ck_fun|||
-ck_glob|||
-ck_grep|||
-ck_index|||
-ck_join|||
-ck_lfun|||
-ck_listiob|||
-ck_match|||
-ck_method|||
-ck_null|||
-ck_open|||
-ck_readline|||
-ck_repeat|||
-ck_require|||
-ck_return|||
-ck_rfun|||
-ck_rvconst|||
-ck_sassign|||
-ck_select|||
-ck_shift|||
-ck_sort|||
-ck_spair|||
-ck_split|||
-ck_subr|||
-ck_substr|||
-ck_svconst|||
-ck_trunc|||
-ck_unpack|||
+ck_entersub_args_list||5.013006|
+ck_entersub_args_proto_or_list||5.013006|
+ck_entersub_args_proto||5.013006|
+ck_warner_d||5.011001|v
+ck_warner||5.011001|v
+ckwarn_common|||
ckwarn_d||5.009003|
ckwarn||5.009003|
cl_and|||n
cl_anything|||n
-cl_init_zero|||n
cl_init|||n
cl_is_anything|||n
cl_or|||n
clear_placeholders|||
+clone_params_del|||n
+clone_params_new|||n
closest_cop|||
convert|||
cop_free|||
+cop_hints_2hv||5.013007|
+cop_hints_fetch_pvn||5.013007|
+cop_hints_fetch_pvs||5.013007|
+cop_hints_fetch_pv||5.013007|
+cop_hints_fetch_sv||5.013007|
+cophh_2hv||5.013007|
+cophh_copy||5.013007|
+cophh_delete_pvn||5.013007|
+cophh_delete_pvs||5.013007|
+cophh_delete_pv||5.013007|
+cophh_delete_sv||5.013007|
+cophh_fetch_pvn||5.013007|
+cophh_fetch_pvs||5.013007|
+cophh_fetch_pv||5.013007|
+cophh_fetch_sv||5.013007|
+cophh_free||5.013007|
+cophh_new_empty||5.014000|
+cophh_store_pvn||5.013007|
+cophh_store_pvs||5.013007|
+cophh_store_pv||5.013007|
+cophh_store_sv||5.013007|
cr_textfilter|||
create_eval_scope|||
+croak_no_modify||5.013003|
croak_nocontext|||vn
-croak_xs_usage||5.011000|
+croak_sv||5.013001|
+croak_xs_usage||5.010001|
croak|||v
csighandler||5.009003|n
curmad|||
+curse|||
custom_op_desc||5.007003|
custom_op_name||5.007003|
+custom_op_register||5.013007|
+custom_op_xop||5.013007|
cv_ckproto_len|||
cv_clone|||
cv_const_sv||5.004000|
cv_dump|||
+cv_get_call_checker||5.013006|
+cv_set_call_checker||5.013006|
cv_undef|||
+cvgv_set|||
+cvstash_set|||
cx_dump||5.005000|
cx_dup|||
cxinc|||
@@ -1168,7 +1201,7 @@
dORIGMARK|||
dSP|||
dTHR|5.004050||p
-dTHXR|5.011000||p
+dTHXR|5.014000||p
dTHXa|5.006000||p
dTHXoa|5.006000||p
dTHX|5.006000||p
@@ -1191,13 +1224,13 @@
deb||5.007003|v
del_sv|||
delete_eval_scope|||
-delimcpy||5.004000|
-deprecate_old|||
-deprecate|||
+delimcpy||5.004000|n
+deprecate_commaless_var_list|||
despatch_signals||5.007001|
destroy_matcher|||
die_nocontext|||vn
-die_where|||
+die_sv||5.013001|
+die_unwind|||
die|||v
dirp_dup|||
div128|||
@@ -1207,8 +1240,8 @@
do_aspawn|||
do_binmode||5.004050|
do_chomp|||
-do_chop|||
do_close|||
+do_delete_local|||
do_dump_pad|||
do_eof|||
do_exec3|||
@@ -1220,7 +1253,6 @@
do_ipcctl|||
do_ipcget|||
do_join|||
-do_kv|||
do_magic_dump||5.006000|
do_msgrcv|||
do_msgsnd|||
@@ -1272,6 +1304,7 @@
doref||5.009003|
dounwind|||
dowantarray|||
+dump_all_perl|||
dump_all||5.006000|
dump_eval||5.006000|
dump_exec_pos|||
@@ -1279,7 +1312,9 @@
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
+dump_packsubs_perl|||
dump_packsubs||5.006000|
+dump_sub_perl|||
dump_sub||5.006000|
dump_sv_child|||
dump_trie_interim_list|||
@@ -1309,14 +1344,21 @@
find_in_my_stash|||
find_runcv||5.008001|
find_rundefsvoffset||5.009002|
+find_rundefsv||5.013002|
find_script|||
find_uninit_var|||
first_symbol|||n
+foldEQ_latin1||5.013008|n
+foldEQ_locale||5.013002|n
+foldEQ_utf8_flags||5.013010|
+foldEQ_utf8||5.013002|
+foldEQ||5.013002|n
fold_constants|||
forbid_setid|||
force_ident|||
force_list|||
force_next|||
+force_strict_version|||
force_version|||
force_word|||
forget_pmop|||
@@ -1328,17 +1370,16 @@
free_tied_hv_pool|||
free_tmps|||
gen_constant_list|||
-get_arena|||
get_aux_mg|||
get_av|5.006000||p
get_context||5.006000|n
-get_cvn_flags||5.009005|
+get_cvn_flags|5.009005||p
+get_cvs|5.011000||p
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
-get_isa_hash|||
get_mstats|||
get_no_modify|||
get_num|||
@@ -1358,6 +1399,8 @@
gp_free|||
gp_ref|||
grok_bin|5.007003||p
+grok_bslash_c|||
+grok_bslash_o|||
grok_hex|5.007003||p
grok_number|5.007002||p
grok_numeric_radix|5.007002||p
@@ -1367,6 +1410,7 @@
gv_HVadd|||
gv_IOadd|||
gv_SVadd|||
+gv_add_by_type||5.011000|
gv_autoload4||5.004000|
gv_check|||
gv_const_sv||5.009003|
@@ -1385,7 +1429,7 @@
gv_fetchpvn_flags|5.009002||p
gv_fetchpvs|5.009004||p
gv_fetchpv|||
-gv_fetchsv||5.009002|
+gv_fetchsv|5.009002||p
gv_fullname3||5.004000|
gv_fullname4||5.006001|
gv_fullname|||
@@ -1393,34 +1437,40 @@
gv_handler||5.007001|
gv_init_sv|||
gv_init|||
+gv_magicalize_isa|||
+gv_magicalize_overload|||
gv_name_set||5.009004|
gv_stashpvn|5.004000||p
gv_stashpvs|5.009003||p
gv_stashpv|||
gv_stashsv|||
+gv_try_downgrade|||
he_dup|||
hek_dup|||
hfreeentries|||
hsplit|||
-hv_assert||5.011000|
+hv_assert|||
hv_auxinit|||n
hv_backreferences_p|||
hv_clear_placeholders||5.009001|
hv_clear|||
hv_common_key_len||5.010000|
hv_common||5.010000|
-hv_copy_hints_hv|||
+hv_copy_hints_hv||5.009004|
hv_delayfree_ent||5.004000|
hv_delete_common|||
hv_delete_ent||5.004000|
hv_delete|||
hv_eiter_p||5.009003|
hv_eiter_set||5.009003|
+hv_ename_add|||
+hv_ename_delete|||
hv_exists_ent||5.004000|
hv_exists|||
hv_fetch_ent||5.004000|
hv_fetchs|5.009003||p
hv_fetch|||
+hv_fill||5.013002|
hv_free_ent||5.004000|
hv_iterinit|||
hv_iterkeysv||5.004000|
@@ -1445,6 +1495,7 @@
hv_store_flags||5.008000|
hv_stores|5.009004||p
hv_store|||
+hv_undef_flags|||
hv_undef|||
ibcmp_locale||5.004000|
ibcmp_utf8||5.007003|
@@ -1455,6 +1506,7 @@
incpush|||
ingroup|||
init_argv_symbols|||
+init_dbargs|||
init_debugger|||
init_global_struct|||
init_i18nl10n||5.006000|
@@ -1467,14 +1519,25 @@
init_predump_symbols|||
init_stacks||5.005000|
init_tm||5.007002|
-instr|||
+instr|||n
intro_my|||
intuit_method|||
intuit_more|||
invert|||
+invlist_array|||
+invlist_destroy|||
+invlist_extend|||
+invlist_intersection|||
+invlist_len|||
+invlist_max|||
+invlist_set_array|||
+invlist_set_len|||
+invlist_set_max|||
+invlist_trim|||
+invlist_union|||
+invoke_exception_hook|||
io_close|||
isALNUMC|5.006000||p
-isALNUM|||
isALPHA|||
isASCII|5.006000||p
isBLANK|5.006001||p
@@ -1483,20 +1546,22 @@
isGRAPH|5.006000||p
isGV_with_GP|5.009004||p
isLOWER|||
+isOCTAL||5.013005|
isPRINT|5.004000||p
isPSXSPC|5.006001||p
isPUNCT|5.006000||p
isSPACE|||
isUPPER|||
+isWORDCHAR||5.013006|
isXDIGIT|5.006000||p
is_an_int|||
+is_ascii_string||5.011000|n
is_gv_magical_sv|||
is_handle_constructor|||n
+is_inplace_av|||
is_list_assignment|||
is_lvalue_sub||5.007001|
is_uni_alnum_lc||5.006000|
-is_uni_alnumc_lc||5.006000|
-is_uni_alnumc||5.006000|
is_uni_alnum||5.006000|
is_uni_alpha_lc||5.006000|
is_uni_alpha||5.006000|
@@ -1522,12 +1587,21 @@
is_uni_upper||5.006000|
is_uni_xdigit_lc||5.006000|
is_uni_xdigit||5.006000|
-is_utf8_alnumc||5.006000|
+is_utf8_X_LVT|||
+is_utf8_X_LV_LVT_V|||
+is_utf8_X_LV|||
+is_utf8_X_L|||
+is_utf8_X_T|||
+is_utf8_X_V|||
+is_utf8_X_begin|||
+is_utf8_X_extend|||
+is_utf8_X_non_hangul|||
+is_utf8_X_prepend|||
is_utf8_alnum||5.006000|
is_utf8_alpha||5.006000|
is_utf8_ascii||5.006000|
is_utf8_char_slow|||n
-is_utf8_char||5.006000|
+is_utf8_char||5.006000|n
is_utf8_cntrl||5.006000|
is_utf8_common|||
is_utf8_digit||5.006000|
@@ -1536,24 +1610,41 @@
is_utf8_idfirst||5.006000|
is_utf8_lower||5.006000|
is_utf8_mark||5.006000|
+is_utf8_perl_space||5.011001|
+is_utf8_perl_word||5.011001|
+is_utf8_posix_digit||5.011001|
is_utf8_print||5.006000|
is_utf8_punct||5.006000|
is_utf8_space||5.006000|
-is_utf8_string_loclen||5.009003|
-is_utf8_string_loc||5.008001|
-is_utf8_string||5.006001|
+is_utf8_string_loclen||5.009003|n
+is_utf8_string_loc||5.008001|n
+is_utf8_string||5.006001|n
is_utf8_upper||5.006000|
is_utf8_xdigit||5.006000|
+is_utf8_xidcont||5.013010|
+is_utf8_xidfirst||5.013010|
isa_lookup|||
items|||n
ix|||n
jmaybe|||
join_exact|||
+keyword_plugin_standard|||
keyword|||
leave_scope|||
-lex_end|||
-lex_start|||
-linklist|||
+lex_bufutf8||5.011002|
+lex_discard_to||5.011002|
+lex_grow_linestr||5.011002|
+lex_next_chunk||5.011002|
+lex_peek_unichar||5.011002|
+lex_read_space||5.011002|
+lex_read_to||5.011002|
+lex_read_unichar||5.011002|
+lex_start||5.009005|
+lex_stuff_pvn||5.011002|
+lex_stuff_pvs||5.013005|
+lex_stuff_pv||5.013006|
+lex_stuff_sv||5.011002|
+lex_unstuff||5.011002|
listkids|||
list|||
load_module_nocontext|||vn
@@ -1565,18 +1656,19 @@
mPUSHi|5.009002||p
mPUSHn|5.009002||p
mPUSHp|5.009002||p
-mPUSHs|5.011000||p
+mPUSHs|5.010001||p
mPUSHu|5.009002||p
mXPUSHi|5.009002||p
mXPUSHn|5.009002||p
mXPUSHp|5.009002||p
-mXPUSHs|5.011000||p
+mXPUSHs|5.010001||p
mXPUSHu|5.009002||p
mad_free|||
madlex|||
madparse|||
magic_clear_all_env|||
magic_clearenv|||
+magic_clearhints|||
magic_clearhint|||
magic_clearisa|||
magic_clearpack|||
@@ -1598,7 +1690,8 @@
magic_get|||
magic_killbackrefs|||
magic_len|||
-magic_methcall|||
+magic_methcall1|||
+magic_methcall|||v
magic_methpack|||
magic_nextpack|||
magic_regdata_cnt|||
@@ -1637,19 +1730,24 @@
markstack_grow|||
matcher_matches_sv|||
measure_struct|||
+memEQs|5.009005||p
memEQ|5.004000||p
+memNEs|5.009005||p
memNE|5.004000||p
mem_collxfrm|||
mem_log_common|||n
mess_alloc|||
mess_nocontext|||vn
+mess_sv||5.013001|
mess||5.006000|v
method_common|||
mfree||5.007002|n
mg_clear|||
mg_copy|||
mg_dup|||
+mg_findext||5.013008|
mg_find|||
+mg_free_type||5.013006|
mg_free|||
mg_get|||
mg_length||5.005000|
@@ -1665,19 +1763,23 @@
more_bodies|||
more_sv|||
moreswitches|||
-mro_get_from_name||5.011000|
+mro_clean_isarev|||
+mro_gather_and_rename|||
+mro_get_from_name||5.010001|
mro_get_linear_isa_dfs|||
mro_get_linear_isa||5.009005|
-mro_get_private_data||5.011000|
+mro_get_private_data||5.010001|
mro_isa_changed_in|||
mro_meta_dup|||
mro_meta_init|||
mro_method_changed_in||5.009005|
-mro_register||5.011000|
-mro_set_mro||5.011000|
-mro_set_private_data||5.011000|
+mro_package_moved|||
+mro_register||5.010001|
+mro_set_mro||5.010001|
+mro_set_private_data||5.010001|
mul128|||
mulexp10|||n
+munge_qwlist_to_paren_list|||
my_atof2||5.007002|
my_atof||5.006000|
my_attrs|||
@@ -1719,7 +1821,8 @@
my_letohi|||n
my_letohl|||n
my_letohs|||n
-my_lstat|||
+my_lstat_flags|||
+my_lstat||5.014000|
my_memcmp||5.004000|n
my_memset|||n
my_ntohl|||
@@ -1730,7 +1833,8 @@
my_snprintf|5.009004||pvn
my_socketpair||5.007003|n
my_sprintf|5.009003||pvn
-my_stat|||
+my_stat_flags|||
+my_stat||5.014000|
my_strftime||5.007002|
my_strlcat|5.009004||pn
my_strlcpy|5.009004||pn
@@ -1753,7 +1857,7 @@
newCVREF|||
newDEFSVOP|||
newFORM|||
-newFOROP|||
+newFOROP||5.013007|
newGIVENOP||5.009003|
newGIVWHENOP|||
newGP|||
@@ -1790,14 +1894,15 @@
newSVhek||5.009003|
newSViv|||
newSVnv|||
+newSVpv_share||5.013006|
newSVpvf_nocontext|||vn
newSVpvf||5.004000|v
-newSVpvn_flags|5.011000||p
+newSVpvn_flags|5.010001||p
newSVpvn_share|5.007001||p
-newSVpvn_utf8|5.011000||p
+newSVpvn_utf8|5.010001||p
newSVpvn|5.004050||p
-newSVpvs_flags|5.011000||p
-newSVpvs_share||5.009003|
+newSVpvs_flags|5.010001||p
+newSVpvs_share|5.009003||p
newSVpvs|5.009003||p
newSVpv|||
newSVrv|||
@@ -1807,7 +1912,7 @@
newTOKEN|||
newUNOP|||
newWHENOP||5.009003|
-newWHILEOP||5.009003|
+newWHILEOP||5.013007|
newXS_flags||5.009004|
newXSproto||5.006000|
newXS||5.006000|
@@ -1823,7 +1928,7 @@
next_symbol|||
nextargv|||
nextchar|||
-ninstr|||
+ninstr|||n
no_bareword_allowed|||
no_fh_allowed|||
no_op|||
@@ -1831,22 +1936,29 @@
nothreadhook||5.008000|
nuke_stacks|||
num_overflow|||n
-offer_nice_chunk|||
oopsAV|||
oopsHV|||
+op_append_elem||5.013006|
+op_append_list||5.013006|
op_clear|||
op_const_sv|||
+op_contextualize||5.013006|
op_dump||5.006000|
op_free|||
op_getmad_weak|||
op_getmad|||
+op_linklist||5.013006|
+op_lvalue||5.013007|
op_null||5.007002|
+op_prepend_elem||5.013006|
op_refcnt_dec|||
op_refcnt_inc|||
op_refcnt_lock||5.009002|
op_refcnt_unlock||5.009002|
+op_scope||5.013007|
op_xmldump|||
open_script|||
+opt_scalarhv|||
pMY_CXT_|5.007003||p
pMY_CXT|5.007003||p
pTHX_|5.006000||p
@@ -1854,16 +1966,18 @@
packWARN|5.007003||p
pack_cat||5.007003|
pack_rec|||
+package_version|||
package|||
packlist||5.008001|
pad_add_anon|||
+pad_add_name_sv|||
pad_add_name|||
pad_alloc|||
pad_block_start|||
pad_check_dup|||
pad_compname_type|||
pad_findlex|||
-pad_findmy|||
+pad_findmy||5.011002|
pad_fixup_inner_anons|||
pad_free|||
pad_leavemy|||
@@ -1872,11 +1986,20 @@
pad_push|||
pad_reset|||
pad_setsv|||
-pad_sv||5.011000|
+pad_sv|||
pad_swipe|||
pad_tidy|||
-pad_undef|||
+padlist_dup|||
+parse_arithexpr||5.013008|
+parse_barestmt||5.013007|
+parse_block||5.013007|
parse_body|||
+parse_fullexpr||5.013008|
+parse_fullstmt||5.013005|
+parse_label||5.013007|
+parse_listexpr||5.013008|
+parse_stmtseq||5.013006|
+parse_termexpr||5.013008|
parse_unicode_opts|||
parser_dup|||
parser_free|||
@@ -1894,18 +2017,18 @@
perl_run|||n
pidgone|||
pm_description|||
-pmflag|||
pmop_dump||5.006000|
pmop_xmldump|||
pmruntime|||
pmtrans|||
pop_scope|||
+populate_isa|||v
pregcomp||5.009005|
pregexec|||
pregfree2||5.011000|
pregfree|||
-prepend_elem|||
prepend_madprops|||
+prescan_version||5.011004|
printbuf|||
printf_nocontext|||vn
process_special_blocks|||
@@ -1937,14 +2060,20 @@
reentrant_size|||
ref_array_or_hash|||
refcounted_he_chain_2hv|||
-refcounted_he_fetch|||
+refcounted_he_fetch_pvn|||
+refcounted_he_fetch_pvs|||
+refcounted_he_fetch_pv|||
+refcounted_he_fetch_sv|||
refcounted_he_free|||
-refcounted_he_new_common|||
-refcounted_he_new|||
+refcounted_he_inc|||
+refcounted_he_new_pvn|||
+refcounted_he_new_pvs|||
+refcounted_he_new_pv|||
+refcounted_he_new_sv|||
refcounted_he_value|||
refkids|||
refto|||
-ref||5.011000|
+ref||5.014000|
reg_check_named_buff_matched|||
reg_named_buff_all||5.009005|
reg_named_buff_exists||5.009005|
@@ -1971,7 +2100,7 @@
regclass|||
regcppop|||
regcppush|||
-regcurly|||n
+regcurly|||
regdump_extflags|||
regdump||5.005000|
regdupe_internal|||
@@ -1995,13 +2124,15 @@
reguni|||
regwhite|||n
reg|||
-repeatcpy|||
+repeatcpy|||n
report_evil_fh|||
report_uninit|||
+report_wrongway_fh|||
require_pv||5.006000|
require_tie_mod|||
restore_magic|||
-rninstr|||
+rninstr|||n
+rpeep|||
rsignal_restore|||
rsignal_save|||
rsignal_state||5.004000|
@@ -2010,6 +2141,7 @@
run_user_filter|||
runops_debug||5.005000|
runops_standard||5.005000|
+rv2cv_op_cv||5.013006|
rvpv_dup|||
rxres_free|||
rxres_restore|||
@@ -2023,6 +2155,7 @@
save_I32|||
save_I8||5.006000|
save_adelete||5.011000|
+save_aelem_flags||5.011000|
save_aelem||5.004050|
save_alloc||5.006000|
save_aptr|||
@@ -2039,10 +2172,11 @@
save_generic_svref||5.005030|
save_gp||5.004000|
save_hash|||
+save_hdelete||5.011000|
save_hek_flags|||n
save_helem_flags||5.011000|
save_helem||5.004050|
-save_hints|||
+save_hints||5.010001|
save_hptr|||
save_int|||
save_item|||
@@ -2053,13 +2187,13 @@
save_magic|||
save_mortalizesv||5.007001|
save_nogv|||
-save_op|||
-save_padsv_and_mortalize||5.011000|
+save_op||5.005000|
+save_padsv_and_mortalize||5.010001|
save_pptr|||
-save_pushi32ptr|||
+save_pushi32ptr||5.010001|
save_pushptri32ptr|||
-save_pushptrptr|||
-save_pushptr||5.011000|
+save_pushptrptr||5.010001|
+save_pushptr||5.010001|
save_re_context||5.006000|
save_scalar_at|||
save_scalar|||
@@ -2072,7 +2206,9 @@
savepvs||5.009003|
savepv|||
savesharedpvn||5.009005|
+savesharedpvs||5.013006|
savesharedpv||5.007003|
+savesharedsvpv||5.013006|
savestack_grow_cnt||5.008001|
savestack_grow|||
savesvpv||5.009002|
@@ -2100,7 +2236,6 @@
scan_version||5.009001|
scan_vstring||5.009005|
scan_word|||
-scope|||
screaminstr||5.005000|
search_const|||
seed||5.008001|
@@ -2111,6 +2246,8 @@
set_numeric_local||5.006000|
set_numeric_radix||5.006000|
set_numeric_standard||5.006000|
+set_regclass_bit_fold|||
+set_regclass_bit|||
setdefout|||
share_hek_flags|||
share_hek||5.004000|
@@ -2133,7 +2270,7 @@
start_force|||
start_glob|||
start_subparse||5.004000|
-stashpv_hvname_match||5.011000|
+stashpv_hvname_match||5.014000|
stdize_locale|||
store_cop_label|||
strEQ|||
@@ -2151,6 +2288,7 @@
sublex_done|||
sublex_push|||
sublex_start|||
+sv_2bool_flags||5.013006|
sv_2bool|||
sv_2cv|||
sv_2io|||
@@ -2160,7 +2298,7 @@
sv_2iv|||
sv_2mortal|||
sv_2num|||
-sv_2nv|||
+sv_2nv_flags||5.013001|
sv_2pv_flags|5.007002||p
sv_2pv_nolen|5.006000||p
sv_2pvbyte_nolen|5.006000||p
@@ -2175,7 +2313,9 @@
sv_backoff|||
sv_bless|||
sv_cat_decode||5.008001|
+sv_catpv_flags||5.013006|
sv_catpv_mg|5.004050||p
+sv_catpv_nomg||5.013006|
sv_catpvf_mg_nocontext|||pvn
sv_catpvf_mg|5.006000|5.004000|pv
sv_catpvf_nocontext|||vn
@@ -2184,6 +2324,9 @@
sv_catpvn_mg|5.004050||p
sv_catpvn_nomg|5.007002||p
sv_catpvn|||
+sv_catpvs_flags||5.013006|
+sv_catpvs_mg||5.013006|
+sv_catpvs_nomg||5.013006|
sv_catpvs|5.009003||p
sv_catpv|||
sv_catsv_flags||5.007002|
@@ -2191,24 +2334,33 @@
sv_catsv_nomg|5.007002||p
sv_catsv|||
sv_catxmlpvn|||
+sv_catxmlpv|||
sv_catxmlsv|||
sv_chop|||
sv_clean_all|||
sv_clean_objs|||
sv_clear|||
+sv_cmp_flags||5.013006|
+sv_cmp_locale_flags||5.013006|
sv_cmp_locale||5.004000|
sv_cmp|||
+sv_collxfrm_flags||5.013006|
sv_collxfrm|||
+sv_compile_2op_is_broken|||
sv_compile_2op||5.008001|
sv_copypv||5.007003|
+sv_dec_nomg||5.013002|
sv_dec|||
sv_del_backref|||
sv_derived_from||5.004000|
sv_destroyable||5.010000|
sv_does||5.009004|
sv_dump|||
+sv_dup_common|||
sv_dup_inc_multiple|||
+sv_dup_inc|||
sv_dup|||
+sv_eq_flags||5.013006|
sv_eq|||
sv_exp_grow|||
sv_force_normal_flags||5.007001|
@@ -2219,8 +2371,9 @@
sv_gets||5.004000|
sv_grow|||
sv_i_ncmp|||
+sv_inc_nomg||5.013002|
sv_inc|||
-sv_insert_flags||5.011000|
+sv_insert_flags||5.010001|
sv_insert|||
sv_isa|||
sv_isobject|||
@@ -2228,7 +2381,7 @@
sv_kill_backrefs|||
sv_len_utf8||5.006000|
sv_len|||
-sv_magic_portable|5.011000|5.004000|p
+sv_magic_portable|5.014000|5.004000|p
sv_magicext||5.007003|
sv_magic|||
sv_mortalcopy|||
@@ -2243,6 +2396,7 @@
sv_pos_b2u_midway|||
sv_pos_b2u||5.006000|
sv_pos_u2b_cached|||
+sv_pos_u2b_flags||5.011005|
sv_pos_u2b_forwards|||n
sv_pos_u2b_midway|||n
sv_pos_u2b||5.006000|
@@ -2277,11 +2431,13 @@
sv_setpviv||5.008001|
sv_setpvn_mg|5.004050||p
sv_setpvn|||
+sv_setpvs_mg||5.013006|
sv_setpvs|5.009004||p
sv_setpv|||
sv_setref_iv|||
sv_setref_nv|||
sv_setref_pvn|||
+sv_setref_pvs||5.013006|
sv_setref_pv|||
sv_setref_uv||5.007001|
sv_setsv_cow|||
@@ -2296,6 +2452,7 @@
sv_true||5.005000|
sv_unglob|||
sv_uni_display||5.007003|
+sv_unmagicext||5.013008|
sv_unmagic|||
sv_unref_flags||5.007001|
sv_unref|||
@@ -2321,7 +2478,6 @@
sv_xmlpeek|||
svtype|||
swallow_bom|||
-swap_match_buff|||
swash_fetch||5.007002|
swash_get|||
swash_init||5.006000|
@@ -2333,6 +2489,7 @@
sys_term||5.010000|n
taint_env|||
taint_proper|||
+tied_method|||v
tmps_grow||5.006000|
toLOWER|||
toUPPER|||
@@ -2357,11 +2514,14 @@
tokereport|||
too_few_arguments|||
too_many_arguments|||
+try_amagic_bin|||
+try_amagic_un|||
uiv_2buf|||n
unlnk|||
unpack_rec|||
unpack_str||5.007003|
unpackstring||5.008001|
+unreferenced_to_tmp_stack|||
unshare_hek_or_pvn|||
unshare_hek|||
unsharepvn||5.004000|
@@ -2369,11 +2529,13 @@
update_debugger_info|||
upg_version||5.009005|
usage|||
+utf16_textfilter|||
utf16_to_utf8_reversed||5.006001|
utf16_to_utf8||5.006001|
utf8_distance||5.006000|
utf8_hop||5.006000|
utf8_length||5.007001|
+utf8_mg_len_cache_update|||
utf8_mg_pos_cache_update|||
utf8_to_bytes||5.006001|
utf8_to_uvchr||5.007001|
@@ -2390,9 +2552,6 @@
vcmp||5.009000|
vcroak||5.006000|
vdeb||5.007003|
-vdie_common|||
-vdie_croak_common|||
-vdie|||
vform||5.006000|
visit|||
vivify_defelem|||
@@ -2408,24 +2567,32 @@
vwarn||5.006000|
wait4pid|||
warn_nocontext|||vn
+warn_sv||5.013001|
warner_nocontext|||vn
warner|5.006000|5.004000|pv
warn|||v
watch|||
whichsig|||
+with_queued_errors|||
write_no_mem|||
write_to_stderr|||
+xmldump_all_perl|||
xmldump_all|||
xmldump_attr|||
xmldump_eval|||
xmldump_form|||
xmldump_indent|||v
+xmldump_packsubs_perl|||
xmldump_packsubs|||
+xmldump_sub_perl|||
xmldump_sub|||
xmldump_vindent|||
+xs_apiversion_bootcheck|||
+xs_version_bootcheck|||
yyerror|||
yylex|||
yyparse|||
+yyunlex|||
yywarn|||
);
@@ -3659,6 +3826,14 @@
#endif
#endif
+#ifndef memEQs
+# define memEQs(s1, l, s2) \
+ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
+#endif
+
+#ifndef memNEs
+# define memNEs(s1, l, s2) !memEQs(s1, l, s2)
+#endif
#ifndef MoveD
# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
#endif
@@ -4027,11 +4202,11 @@
#endif
#ifndef isASCII
-# define isASCII(c) ((c) <= 127)
+# define isASCII(c) ((U8) (c) <= 127)
#endif
#ifndef isCNTRL
-# define isCNTRL(c) ((c) < ' ' || (c) == 127)
+# define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127)
#endif
#ifndef isGRAPH
@@ -4103,6 +4278,7 @@
# define PL_debstash debstash
# define PL_defgv defgv
# define PL_diehook diehook
+# define PL_dirty dirty
# define PL_dowarn dowarn
# define PL_errgv errgv
# define PL_error_count error_count
@@ -4119,11 +4295,14 @@
# define PL_perldb perldb
# define PL_rsfp_filters rsfp_filters
# define PL_rsfp rsfp
+# define PL_stack_base stack_base
# define PL_stack_sp stack_sp
# define PL_statcache statcache
# define PL_stdingv stdingv
# define PL_sv_arenaroot sv_arenaroot
+# define PL_sv_no sv_no
# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
# define PL_tainted tainted
# define PL_tainting tainting
# define PL_tokenbuf tokenbuf
@@ -5310,6 +5489,12 @@
} STMT_END
#endif
+/* Hint: newSVpvn_share
+ * The SVs created by this function only mimic the behaviour of
+ * shared PVs without really being shared. Only use if you know
+ * what you're doing.
+ */
+
#ifndef newSVpvn_share
#if defined(NEED_newSVpvn_share)
@@ -5362,6 +5547,17 @@
#ifndef isGV_with_GP
# define isGV_with_GP(gv) isGV(gv)
#endif
+
+#ifndef gv_fetchpvn_flags
+# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
+#endif
+
+#ifndef gv_fetchsv
+# define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt)
+#endif
+#ifndef get_cvn_flags
+# define get_cvn_flags(name, namelen, flags) get_cv(name, flags)
+#endif
#ifndef WARN_ALL
# define WARN_ALL 0
#endif
@@ -5610,6 +5806,10 @@
# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
#endif
+#ifndef newSVpvs_share
+# define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0)
+#endif
+
#ifndef sv_catpvs
# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
#endif
@@ -5625,10 +5825,6 @@
#ifndef hv_stores
# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
#endif
-#ifndef gv_fetchpvn_flags
-# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt)
-#endif
-
#ifndef gv_fetchpvs
# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
#endif
@@ -5636,6 +5832,9 @@
#ifndef gv_stashpvs
# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
#endif
+#ifndef get_cvs
+# define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags)
+#endif
#ifndef SvGETMAGIC
# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
#endif
Modified: dbi/branches/sqlengine/dbixs_rev.h
==============================================================================
--- dbi/branches/sqlengine/dbixs_rev.h (original)
+++ dbi/branches/sqlengine/dbixs_rev.h Wed Aug 29 00:09:55 2012
@@ -1,3 +1,3 @@
-/* Sun Feb 6 12:56:22 2011 */
-/* Code modified since last checkin */
-#define DBIXS_REVISION 14685
+/* Fri Jul 13 13:32:02 2012 */
+/* Mixed revision working copy (15349:15353) */
+#define DBIXS_REVISION 15349
Modified: dbi/branches/sqlengine/lib/DBD/File.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBD/File.pm (original)
+++ dbi/branches/sqlengine/lib/DBD/File.pm Wed Aug 29 00:09:55 2012
@@ -117,7 +117,7 @@
my $str = shift;
ref $str and return "";
defined $str or return "";
- $str =~ s/([;:])/\\$1/g;
+ $str =~ s/([;:\\])/\\$1/g;
return $str;
} # dsn_quote
Modified: dbi/branches/sqlengine/lib/DBD/Gofer.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBD/Gofer.pm (original)
+++ dbi/branches/sqlengine/lib/DBD/Gofer.pm Wed Aug 29 00:09:55 2012
@@ -97,7 +97,12 @@
if (my $warnings = $response->warnings) {
warn $_ for @$warnings;
}
- return $h->set_err($response->err_errstr_state);
+ my ($err, $errstr, $state) = $response->err_errstr_state;
+ # Only set_err() if there's an error else leave the current values
+ # (The current values will normally be set undef by the DBI dispatcher
+ # except for methods marked KEEPERR such as ping.)
+ $h->set_err($err, $errstr, $state) if defined $err;
+ return undef;
}
@@ -833,6 +838,8 @@
driver or transport. These are described below or in the documentation of the
transport module being used.
+=encoding ISO8859-1
+
=head1 DESCRIPTION
DBD::Gofer is a DBI database driver that forwards requests to another DBI
@@ -959,7 +966,7 @@
Driver-private sth attributes can be set in the prepare() call. TODO
-Some driver-private dbh attributes may not be available if the driver has not
+Some driver-private sth attributes may not be available if the driver has not
implemented the private_attribute_info() method (added in DBI 1.54).
=head2 Multiple Resultsets
Modified: dbi/branches/sqlengine/lib/DBI/DBD.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/DBD.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/DBD.pm Wed Aug 29 00:09:55 2012
@@ -789,11 +789,11 @@
$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 [email protected])
+The C<\%attr> attributes can be used to provide fine control over how the DBI
+dispatcher handles the dispatching of the method. However it's undocumented
+at the moment. See the IMA_* #define's in DBI.xs and the O=>0x000x values in
+the initialization of %DBI::DBI_methods in DBI.pm. (Volunteers to polish up
+and document the interface are very welcome to get in touch via [email protected]).
Methods installed using install_method default to the standard error
handling behaviour for DBI methods: clearing err and errstr before
@@ -1975,7 +1975,7 @@
The (obsolete) macros such as C<DBIh_EVENT2> should be removed from drivers.
The names C<dbis> and C<DBIS>, which were used in previous versions of
-this document, should be replaced with the C<DBIc_STATE(imp_xxh)> macro.
+this document, should be replaced with the C<DBIc_DBISTATE(imp_xxh)> macro.
The name C<DBILOGFP>, which was also used in previous versions of this
document, should be replaced by C<DBIc_LOGPIO(imp_xxh)>.
Modified: dbi/branches/sqlengine/lib/DBI/DBD/SqlEngine.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/DBD/SqlEngine.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/DBD/SqlEngine.pm Wed Aug 29 00:09:55 2012
@@ -685,6 +685,7 @@
my @tables = $dbh->func("get_avail_tables") or return;
foreach my $ref (@tables)
{
+ # rt69260 and rt67223 - the same issue in 2 different queues
push @table_list, $ref->[2];
}
@@ -778,6 +779,9 @@
$sth->finish;
my $stmt = $sth->{sql_stmt};
+ # SQL::Statement and DBI::SQL::Nano will return the list of required params
+ # when called in list context. Do not look into the several items, they're
+ # implementation specific and may change without warning
unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) )
{
my $msg = "You passed $nparm parameters where $req_prm required";
Modified: dbi/branches/sqlengine/lib/DBI/FAQ.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/FAQ.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/FAQ.pm Wed Aug 29 00:09:55 2012
@@ -16,7 +16,7 @@
### and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
### Requests for other distribution rights, including incorporation into
### commercial products, such as books, magazine articles or CD-ROMs should be
-### made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+### made to Alligator Descartes.
###
package DBI::FAQ;
@@ -52,6 +52,9 @@
That's B<very> old. A newer FAQ can be found at L<http://faq.dbi-support.com/>
+Neither this document nor that web site are actively maintained.
+Volunteers are welcome.
+
=head1 DESCRIPTION
This document serves to answer the most frequently asked questions on both
@@ -160,7 +163,6 @@
the DBI drivers list and the DBI module pages which can be found on:
http://dbi.perl.org/
- http://www.symbolstone.org/technology/perl/DBI
This list is automatically generated on a nightly basis from CPAN and should
be up-to-date.
@@ -320,7 +322,6 @@
Perl DBI" are available online at:
http://dbi.perl.org/
- http://www.symbolstone.org/technology/perl/DBI
in the driver information table. These summaries contain standardised
information on each driver and database which should aid you in selecting
@@ -330,7 +331,6 @@
=item I<Rambles, Tidbits and Observations>
http://dbi.perl.org/tidbits
- http://www.symbolstone.org/technology/perl/DBI/tidbits
There are a series of occasional rambles from various people on the
DBI mailing lists who, in an attempt to clear up a simple point, end up
@@ -342,7 +342,6 @@
A list of articles discussing the DBI can be found on the DBI WWW page at:
http://dbi.perl.org/
- http://www.symbolstone.org/technology/perl/DBI
These articles are of varying quality and age, from the original Perl Journal
article written by Alligator and Tim, to more recent debacles published online
@@ -356,7 +355,6 @@
can all be read from the main DBI WWW page at:
http://dbi.perl.org/
- http://www.symbolstone.org/technology/perl/DBI
=item I<Mailing Lists>
@@ -404,7 +402,6 @@
files for each driver in advance online at:
http://dbi.perl.org/
- http://www.symbolstone.org/technology/perl/DBI
If it's a known problem, you'll probably have to wait till it gets fixed. If
you're I<really> needing it fixed, try the following:
@@ -761,11 +758,6 @@
thread-safe (but not thread-hot) by automatically blocking threads
intering the DBI while it's already in use.
-For some OCI example code for Oracle that has multi-threaded C<SELECT>
-statements, see:
-
- http://www.symbolstone.org/technology/oracle/oci/orathreads.tar.gz
-
=head2 5.2 How do I handle BLOB data with DBI?
Handling BLOB data with the DBI is very straight-forward. BLOB columns are
@@ -950,7 +942,7 @@
=head1 AUTHOR
-Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+Alligator Descartes.
Portions are Copyright their original stated authors.
=head1 COPYRIGHT
@@ -966,7 +958,7 @@
and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ).
Requests for other distribution rights, including incorporation into
commercial products, such as books, magazine articles or CD-ROMs should be
-made to Alligator Descartes <I<http://www.symbolstone.org/descarte/contact.html>>.
+made to Alligator Descartes.
=for html
<!--#include virtual="/technology/perl/DBI/templatebottom.html" -->
Modified: dbi/branches/sqlengine/lib/DBI/Profile.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/Profile.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/Profile.pm Wed Aug 29 00:09:55 2012
@@ -651,6 +651,9 @@
DBI::PurePerl does not support profiling (though it could in theory).
+For asynchronous queries, time spent while the query is running on the
+backend is not counted.
+
A few platforms don't support the gettimeofday() high resolution
time function used by the DBI (and available via the dbi_time() function).
In which case you'll get integer resolution time which is mostly useless.
Modified: dbi/branches/sqlengine/lib/DBI/ProfileDumper.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/ProfileDumper.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/ProfileDumper.pm Wed Aug 29 00:09:55 2012
@@ -30,7 +30,7 @@
# another way to say it
use DBI::ProfileDumper;
$dbh->{Profile} = DBI::ProfileDumper->new(
- Path => [ '!Statement' ]
+ Path => [ '!Statement' ],
File => 'dbi.prof' );
# using a custom path
Modified: dbi/branches/sqlengine/lib/DBI/ProxyServer.pm
==============================================================================
--- dbi/branches/sqlengine/lib/DBI/ProxyServer.pm (original)
+++ dbi/branches/sqlengine/lib/DBI/ProxyServer.pm Wed Aug 29 00:09:55 2012
@@ -26,7 +26,7 @@
use strict;
use RPC::PlServer 0.2001;
-# require DBI; # deferred till AcceptVersion() to aid threading
+require DBI;
require Config;
Modified: dbi/branches/sqlengine/t/01basics.t
==============================================================================
--- dbi/branches/sqlengine/t/01basics.t (original)
+++ dbi/branches/sqlengine/t/01basics.t Wed Aug 29 00:09:55 2012
@@ -316,7 +316,7 @@
my @installed_drivers = DBI->installed_versions;
cmp_ok(scalar(@installed_drivers), '>=', 1, '... make sure we got at least one');
- like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBI::Spounge');
+ like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBD::Sponge');
}
## testing dbi_debug
Modified: dbi/branches/sqlengine/t/08keeperr.t
==============================================================================
--- dbi/branches/sqlengine/t/08keeperr.t (original)
+++ dbi/branches/sqlengine/t/08keeperr.t Wed Aug 29 00:09:55 2012
@@ -2,18 +2,18 @@
use strict;
-use Test::More tests => 72;
+use Test::More tests => 79;
## ----------------------------------------------------------------------------
## 08keeperr.t
## ----------------------------------------------------------------------------
-#
+#
## ----------------------------------------------------------------------------
BEGIN {
use_ok('DBI');
-}
-
+}
+
$|=1;
$^W=1;
@@ -71,13 +71,25 @@
# test ping does not destroy the errstr
sub ping_keeps_err {
- my $dbh = DBI->connect('DBI:Sponge:');
- $dbh->{PrintError} = 0;
- eval {$dbh->do(q/invalid sql statement/)};
- ok(defined($dbh->errstr), "Error from invalid SQL");
- ok($dbh->ping, "ping returns true"); # for me this returns false!
- ok(defined($dbh->errstr), "Error exists after ping");
+ my $dbh = DBI->connect('DBI:ExampleP:', undef, undef, { PrintError => 0 });
+
+ $dbh->set_err(42, "ERROR 42");
+ is $dbh->err, 42;
+ is $dbh->errstr, "ERROR 42";
+ ok $dbh->ping, "ping returns true";
+ is $dbh->err, 42, "err unchanged after ping";
+ is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
+
$dbh->disconnect;
+
+ $dbh->set_err(42, "ERROR 42");
+ is $dbh->err, 42, "err unchanged after ping";
+ is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
+ ok !$dbh->ping, "ping returns false";
+ # it's reasonable for ping() to set err/errstr if it fails
+ # so here we just test that there is an error
+ ok $dbh->err, "err true after failed ping";
+ ok $dbh->errstr, "errstr true after failed ping";
}
## ----------------------------------------------------------------------------
@@ -107,21 +119,21 @@
# HandleSetErr handler
$dbh->{HandleSetErr} = sub {
my ($h, $err, $errstr, $state) = @_;
- return 0
+ return 0
unless defined $err;
++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls
- return 1
+ return 1
if $state && $state eq "return"; # for tests
($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123")
if $state && $state eq "override"; # for tests
- return 0
+ return 0
if $err; # be transparent for errors
local $^W;
print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n";
return 0;
};
-# start our tests
+# start our tests
ok(!defined $DBI::err, '... $DBI::err is not defined');
@@ -143,9 +155,9 @@
ok(defined $DBI::err, '... $DBI::err is defined');
is($DBI::err, "0", '... $DBI::err is "0"');
-is($DBI::errstr, "(got info)\n(got warn)",
+is($DBI::errstr, "(got info)\n(got warn)",
'... $DBI::errstr is as we expected');
-is($dbh->errstr, "(got info)\n(got warn)",
+is($dbh->errstr, "(got info)\n(got warn)",
'... $dbh->errstr matches $DBI::errstr');
is($DBI::state, "AA001", '... $DBI::state is AA001');
cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1');
@@ -160,9 +172,9 @@
is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's still a warn
is($dbh->err, "0", '... $dbh->err is "0"');
is($DBI::state, "AA001", '... $DBI::state is AA001');
-is($DBI::errstr, "(got info)\n(got warn)\n(got more info)",
+is($DBI::errstr, "(got info)\n(got warn)\n(got more info)",
'... $DBI::errstr is as we expected');
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info)",
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info)",
'... $dbh->errstr matches $DBI::errstr');
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
is_deeply(\@handlewarn, [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)');
@@ -180,7 +192,7 @@
ok(defined $DBI::err, '... $DBI::err is defined');
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)",
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)",
'... $dbh->errstr is as we expected');
is($DBI::state, "AA002", '... $DBI::state is AA002');
is_deeply(\@handlewarn, [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)');
@@ -192,7 +204,7 @@
ok(defined $DBI::err, '... $DBI::err is defined');
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)",
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)",
'... $dbh->errstr is as we expected');
is_deeply(\@handlewarn, [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)');
@@ -203,7 +215,7 @@
ok(defined $DBI::err, '... $DBI::err is defined');
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn)",
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn)",
'... $dbh->errstr is as we expected');
is_deeply(\@handlewarn, [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)');
@@ -214,7 +226,7 @@
ok(defined $DBI::err, '... $DBI::err is defined');
cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200');
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now AA003]\n(got new error)",
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now AA003]\n(got new error)",
'... $dbh->errstr is as we expected');
is_deeply(\@handlewarn, [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)');
@@ -241,7 +253,7 @@
ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); # PrintError
ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); # PrintError
ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); # PrintError
-is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn",
+is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn",
'... $dbh->errstr is as we expected');
is($warn{failed}, 4, '... $warn{failed} is 4');
is_deeply(\@handlewarn, [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)');
Modified: dbi/branches/sqlengine/t/10examp.t
==============================================================================
--- dbi/branches/sqlengine/t/10examp.t (original)
+++ dbi/branches/sqlengine/t/10examp.t Wed Aug 29 00:09:55 2012
@@ -14,7 +14,7 @@
require File::Spec;
require VMS::Filespec if $^O eq 'VMS';
-use Test::More tests => 210;
+use Test::More tests => 229;
do {
# provide some protection against growth in size of '.' during the test
@@ -234,6 +234,29 @@
ok($r->[0]->{SizE} == $row_a[1]);
ok($r->[0]->{nAMe} eq $row_a[2]);
+ok ! $csr_b->fetchall_arrayref({ NoneSuch=>1 });
+like $DBI::errstr, qr/Invalid column name/;
+
+print "fetchall_arrayref renaming hash slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref(\{ 1 => "Koko", 2 => "Nimi"});
+ok($r && @$r);
+ok($r->[0]->{Koko} == $row_a[1]);
+ok($r->[0]->{Nimi} eq $row_a[2]);
+
+ok ! eval { $csr_b->fetchall_arrayref(\{ 9999 => "Koko" }) };
+like $@, qr/\Qis not a valid column/;
+
+print "fetchall_arrayref empty renaming hash slice\n";
+ok($csr_b->execute());
+$r = $csr_b->fetchall_arrayref(\{});
+ok($r && @$r);
+ok(keys %{$r->[0]} == 0);
+
+ok($csr_b->execute());
+ok(!$csr_b->fetchall_arrayref(\[]));
+like $DBI::errstr, qr/\Qfetchall_arrayref(REF) invalid/;
+
print "fetchall_arrayref hash\n";
ok($csr_b->execute());
$r = $csr_b->fetchall_arrayref({});
@@ -253,6 +276,15 @@
ok($r);
is_deeply($r, [[$row_a[0]]]);
+$r = $csr_b->fetchall_arrayref([], 1);
+is @$r, 1, 'should fetch one row';
+
+$r = $csr_b->fetchall_arrayref([], 99999);
+ok @$r, 'should fetch all the remaining rows';
+
+$r = $csr_b->fetchall_arrayref([], 99999);
+is $r, undef, 'should return undef as there are no more rows';
+
# ---
print "selectrow_array\n";
@@ -319,7 +351,7 @@
print "selectcol_arrayref column slice\n";
$r = $dbh->selectcol_arrayref($std_sql, { Columns => [3,2] }, $dir);
ok($r);
-# use Data::Dumper; warn Dumper([\@row_b, $r]);
+# warn Dumper([\@row_b, $r]);
ok(@$r == $rows * 2);
ok($r->[0] eq $row_b[2]);
ok($r->[1] eq $row_b[1]);
@@ -356,14 +388,16 @@
like $@, qr/\[for Statement "select mode from \?" with ParamValues: 1='val1', 2='val2', 3='val3', 4='val4', 5='val5', 6='val6', 7='val7', 8='val8', 9='val9', 10='val10', 11='val11'\]/;
# this test relies on the fact that ShowErrorStatement is set above
-eval {
- local $se_sth1->{PrintError} = 0;
- $se_sth1->execute(1,2);
-};
-unlike($@, qr/ParamValues:/, 'error string does not contain ParamValues');
-is($se_sth1->{ParamValues}, undef, 'ParamValues is empty')
+TODO: {
+ local $TODO = "rt66127 not fixed yet";
+ eval {
+ local $se_sth1->{PrintError} = 0;
+ $se_sth1->execute(1,2);
+ };
+ unlike($@, qr/ParamValues:/, 'error string does not contain ParamValues');
+ is($se_sth1->{ParamValues}, undef, 'ParamValues is empty')
or diag(Dumper($se_sth1->{ParamValues}));
-
+};
# check that $dbh->{Statement} tracks last _executed_ sth
$se_sth1 = $dbh->prepare("select mode from ?");
ok($se_sth1->{Statement} eq "select mode from ?");
Modified: dbi/branches/sqlengine/t/20meta.t
==============================================================================
--- dbi/branches/sqlengine/t/20meta.t (original)
+++ dbi/branches/sqlengine/t/20meta.t Wed Aug 29 00:09:55 2012
@@ -1,5 +1,6 @@
#!perl -w
+use strict;
use Test::More tests => 8;
$|=1;
@@ -8,7 +9,7 @@
BEGIN { use_ok( 'DBI', ':sql_types' ) }
BEGIN { use_ok( 'DBI::DBD::Metadata' ) } # just to check for syntax errors etc
-$dbh = DBI->connect("dbi:ExampleP:.","","", { FetchHashKeyName => 'NAME_lc' })
+my $dbh = DBI->connect("dbi:ExampleP:.","","", { FetchHashKeyName => 'NAME_lc' })
or die "Unable to connect to ExampleP driver: $DBI::errstr";
isa_ok($dbh, 'DBI::db');
Modified: dbi/branches/sqlengine/t/30subclass.t
==============================================================================
--- dbi/branches/sqlengine/t/30subclass.t (original)
+++ dbi/branches/sqlengine/t/30subclass.t Wed Aug 29 00:09:55 2012
@@ -66,7 +66,7 @@
# =================================================
package main;
-use Test::More tests => 36;
+use Test::More tests => 43;
BEGIN {
use_ok( 'DBI' );
@@ -139,13 +139,24 @@
is($dbh2 != $dbh, 1);
is($dbh2->{CompatMode}, 1);
-my $dbh3 = $dbh->clone;
+my $dbh3 = $dbh->clone({});
isa_ok( $dbh3, 'MyDBI::db', 'Clone B' );
is($dbh3 != $dbh, 1);
is($dbh3 != $dbh2, 1);
isa_ok( $dbh3, 'MyDBI::db');
is($dbh3->{CompatMode}, 1);
+my $dbh2c = $dbh2->clone;
+isa_ok( $dbh2c, 'MyDBI::db', "Clone of clone A" );
+is($dbh2c != $dbh2, 1);
+is($dbh2c->{CompatMode}, 1);
+
+my $dbh3c = $dbh3->clone({ CompatMode => 0 });
+isa_ok( $dbh3c, 'MyDBI::db', 'Clone of clone B' );
+is((grep { $dbh3c == $_ } $dbh, $dbh2, $dbh3), 0);
+isa_ok( $dbh3c, 'MyDBI::db');
+ok(!$dbh3c->{CompatMode});
+
$tmp = $dbh->sponge_test_installed_method('foo','bar');
isa_ok( $tmp, "ARRAY", "installed method" );
is_deeply( $tmp, [qw( foo bar )] );
Modified: dbi/branches/sqlengine/t/35thrclone.t
==============================================================================
--- dbi/branches/sqlengine/t/35thrclone.t (original)
+++ dbi/branches/sqlengine/t/35thrclone.t Wed Aug 29 00:09:55 2012
@@ -52,6 +52,11 @@
cmp_ok($dbh->{Driver}->{Kids}, '==', 1, '... the Driver has one Kid')
unless $DBI::PurePerl && ok(1);
}
+
+ # RT #77137: a thread created from a thread was crashing the
+ # interpreter
+
+ threads->new(sub {})->join();
}
# load up the threads
Modified: dbi/branches/sqlengine/t/52dbm_complex.t
==============================================================================
--- dbi/branches/sqlengine/t/52dbm_complex.t (original)
+++ dbi/branches/sqlengine/t/52dbm_complex.t Wed Aug 29 00:09:55 2012
@@ -90,7 +90,7 @@
my $haveSS = DBD::DBM::Statement->isa('SQL::Statement');
-plan skip_all => "Not running with SQL::Statement" unless ( $haveSS );
+plan skip_all => "DBI::SQL::Nano is being used" unless ( $haveSS );
plan skip_all => "Not running with MLDBM" unless ( @mldbm_types );
do "t/lib.pl";
Modified: dbi/branches/sqlengine/t/85gofer.t
==============================================================================
--- dbi/branches/sqlengine/t/85gofer.t (original)
+++ dbi/branches/sqlengine/t/85gofer.t Wed Aug 29 00:09:55 2012
@@ -163,7 +163,7 @@
END { unlink glob "fruit.???" }
ok $dbh->do("DROP TABLE IF EXISTS fruit");
ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
- die "$test_run_tag aborted\n" if $DBI::err;
+ die "$test_run_tag aborted ($DBI::errstr)\n" if $DBI::err;
my $sth = do {
local $dbh->{RaiseError} = 0;