From 7c48e67cf07ee41bfde7139a62bb232bd23a4a48 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Wed, 6 Jun 2012 16:41:29 +0000 Subject: Imported from /srv/lorry/lorry-area/perl-dbi-tarball/DBI-1.622.tar.gz. --- Changes | 2275 +++++++++ DBI.pm | 8323 ++++++++++++++++++++++++++++++++ DBI.xs | 5560 +++++++++++++++++++++ DBIXS.h | 573 +++ Driver.xst | 778 +++ Driver_xst.h | 122 + MANIFEST | 121 + META.json | 67 + META.yml | 41 + Makefile.PL | 397 ++ Perl.xs | 54 + README | 145 + TODO_2005.txt | 579 +++ TODO_gofer.txt | 56 + dbd_xsh.h | 58 + dbi_sql.h | 96 + dbilogstrip.PL | 71 + dbipport.h | 7258 ++++++++++++++++++++++++++++ dbiprof.PL | 287 ++ dbiproxy.PL | 208 + dbivport.h | 52 + dbixs_rev.h | 4 + dbixs_rev.pl | 51 + ex/corogofer.pl | 32 + ex/perl_dbi_nulls_test.pl | 176 + ex/profile.pl | 25 + lib/Bundle/DBI.pm | 51 + lib/DBD/DBM.pm | 1461 ++++++ lib/DBD/ExampleP.pm | 428 ++ lib/DBD/File.pm | 1637 +++++++ lib/DBD/File/Developers.pod | 556 +++ lib/DBD/File/HowTo.pod | 270 ++ lib/DBD/File/Roadmap.pod | 176 + lib/DBD/Gofer.pm | 1292 +++++ lib/DBD/Gofer/Policy/Base.pm | 162 + lib/DBD/Gofer/Policy/classic.pm | 79 + lib/DBD/Gofer/Policy/pedantic.pm | 53 + lib/DBD/Gofer/Policy/rush.pm | 90 + lib/DBD/Gofer/Transport/Base.pm | 410 ++ lib/DBD/Gofer/Transport/corostream.pm | 144 + lib/DBD/Gofer/Transport/null.pm | 111 + lib/DBD/Gofer/Transport/pipeone.pm | 253 + lib/DBD/Gofer/Transport/stream.pm | 292 ++ lib/DBD/NullP.pm | 166 + lib/DBD/Proxy.pm | 997 ++++ lib/DBD/Sponge.pm | 305 ++ lib/DBI/Const/GetInfo/ANSI.pm | 236 + lib/DBI/Const/GetInfo/ODBC.pm | 1363 ++++++ lib/DBI/Const/GetInfoReturn.pm | 105 + lib/DBI/Const/GetInfoType.pm | 54 + lib/DBI/DBD.pm | 3489 +++++++++++++ lib/DBI/DBD/Metadata.pm | 493 ++ lib/DBI/DBD/SqlEngine.pm | 1232 +++++ lib/DBI/DBD/SqlEngine/Developers.pod | 422 ++ lib/DBI/DBD/SqlEngine/HowTo.pod | 218 + lib/DBI/FAQ.pm | 966 ++++ lib/DBI/Gofer/Execute.pm | 900 ++++ lib/DBI/Gofer/Request.pm | 200 + lib/DBI/Gofer/Response.pm | 218 + lib/DBI/Gofer/Serializer/Base.pm | 64 + lib/DBI/Gofer/Serializer/DataDumper.pm | 53 + lib/DBI/Gofer/Serializer/Storable.pm | 59 + lib/DBI/Gofer/Transport/Base.pm | 176 + lib/DBI/Gofer/Transport/pipeone.pm | 61 + lib/DBI/Gofer/Transport/stream.pm | 76 + lib/DBI/Profile.pm | 949 ++++ lib/DBI/ProfileData.pm | 737 +++ lib/DBI/ProfileDumper.pm | 351 ++ lib/DBI/ProfileDumper/Apache.pm | 219 + lib/DBI/ProfileSubs.pm | 50 + lib/DBI/ProxyServer.pm | 890 ++++ lib/DBI/PurePerl.pm | 1259 +++++ lib/DBI/SQL/Nano.pm | 1010 ++++ lib/DBI/Util/CacheMemory.pm | 117 + lib/DBI/Util/_accessor.pm | 65 + lib/DBI/W32ODBC.pm | 181 + lib/Win32/DBIODBC.pm | 248 + t/01basics.t | 336 ++ t/02dbidrv.t | 254 + t/03handle.t | 410 ++ t/04mods.t | 59 + t/05concathash.t | 190 + t/06attrs.t | 311 ++ t/07kids.t | 102 + t/08keeperr.t | 291 ++ t/09trace.t | 137 + t/10examp.t | 579 +++ t/11fetch.t | 124 + t/12quote.t | 48 + t/13taint.t | 133 + t/14utf8.t | 76 + t/15array.t | 254 + t/16destroy.t | 147 + t/19fhtrace.t | 306 ++ t/20meta.t | 32 + t/30subclass.t | 182 + t/31methcache.t | 153 + t/35thrclone.t | 81 + t/40profile.t | 485 ++ t/41prof_dump.t | 105 + t/42prof_data.t | 150 + t/43prof_env.t | 52 + t/48dbi_dbd_sqlengine.t | 81 + t/49dbd_file.t | 174 + t/50dbm_simple.t | 264 + t/51dbm_file.t | 130 + t/52dbm_complex.t | 359 ++ t/60preparse.t | 148 + t/65transact.t | 35 + t/70callbacks.t | 207 + t/72childhandles.t | 149 + t/80proxy.t | 473 ++ t/85gofer.t | 264 + t/86gofer_fail.t | 168 + t/87gofer_cache.t | 108 + t/90sql_type_cast.t | 148 + t/lib.pl | 33 + t/pod-coverage.t | 8 + t/pod.t | 8 + test.pl | 201 + typemap | 3 + 121 files changed, 60761 insertions(+) create mode 100644 Changes create mode 100644 DBI.pm create mode 100644 DBI.xs create mode 100644 DBIXS.h create mode 100644 Driver.xst create mode 100644 Driver_xst.h create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 Perl.xs create mode 100644 README create mode 100644 TODO_2005.txt create mode 100644 TODO_gofer.txt create mode 100644 dbd_xsh.h create mode 100644 dbi_sql.h create mode 100644 dbilogstrip.PL create mode 100644 dbipport.h create mode 100644 dbiprof.PL create mode 100644 dbiproxy.PL create mode 100644 dbivport.h create mode 100644 dbixs_rev.h create mode 100644 dbixs_rev.pl create mode 100644 ex/corogofer.pl create mode 100644 ex/perl_dbi_nulls_test.pl create mode 100644 ex/profile.pl create mode 100644 lib/Bundle/DBI.pm create mode 100644 lib/DBD/DBM.pm create mode 100644 lib/DBD/ExampleP.pm create mode 100644 lib/DBD/File.pm create mode 100644 lib/DBD/File/Developers.pod create mode 100644 lib/DBD/File/HowTo.pod create mode 100644 lib/DBD/File/Roadmap.pod create mode 100644 lib/DBD/Gofer.pm create mode 100644 lib/DBD/Gofer/Policy/Base.pm create mode 100644 lib/DBD/Gofer/Policy/classic.pm create mode 100644 lib/DBD/Gofer/Policy/pedantic.pm create mode 100644 lib/DBD/Gofer/Policy/rush.pm create mode 100644 lib/DBD/Gofer/Transport/Base.pm create mode 100644 lib/DBD/Gofer/Transport/corostream.pm create mode 100644 lib/DBD/Gofer/Transport/null.pm create mode 100644 lib/DBD/Gofer/Transport/pipeone.pm create mode 100644 lib/DBD/Gofer/Transport/stream.pm create mode 100644 lib/DBD/NullP.pm create mode 100644 lib/DBD/Proxy.pm create mode 100644 lib/DBD/Sponge.pm create mode 100644 lib/DBI/Const/GetInfo/ANSI.pm create mode 100644 lib/DBI/Const/GetInfo/ODBC.pm create mode 100644 lib/DBI/Const/GetInfoReturn.pm create mode 100644 lib/DBI/Const/GetInfoType.pm create mode 100644 lib/DBI/DBD.pm create mode 100644 lib/DBI/DBD/Metadata.pm create mode 100644 lib/DBI/DBD/SqlEngine.pm create mode 100644 lib/DBI/DBD/SqlEngine/Developers.pod create mode 100644 lib/DBI/DBD/SqlEngine/HowTo.pod create mode 100644 lib/DBI/FAQ.pm create mode 100644 lib/DBI/Gofer/Execute.pm create mode 100644 lib/DBI/Gofer/Request.pm create mode 100644 lib/DBI/Gofer/Response.pm create mode 100644 lib/DBI/Gofer/Serializer/Base.pm create mode 100644 lib/DBI/Gofer/Serializer/DataDumper.pm create mode 100644 lib/DBI/Gofer/Serializer/Storable.pm create mode 100644 lib/DBI/Gofer/Transport/Base.pm create mode 100644 lib/DBI/Gofer/Transport/pipeone.pm create mode 100644 lib/DBI/Gofer/Transport/stream.pm create mode 100644 lib/DBI/Profile.pm create mode 100644 lib/DBI/ProfileData.pm create mode 100644 lib/DBI/ProfileDumper.pm create mode 100644 lib/DBI/ProfileDumper/Apache.pm create mode 100644 lib/DBI/ProfileSubs.pm create mode 100644 lib/DBI/ProxyServer.pm create mode 100644 lib/DBI/PurePerl.pm create mode 100644 lib/DBI/SQL/Nano.pm create mode 100644 lib/DBI/Util/CacheMemory.pm create mode 100644 lib/DBI/Util/_accessor.pm create mode 100644 lib/DBI/W32ODBC.pm create mode 100644 lib/Win32/DBIODBC.pm create mode 100755 t/01basics.t create mode 100755 t/02dbidrv.t create mode 100644 t/03handle.t create mode 100644 t/04mods.t create mode 100644 t/05concathash.t create mode 100644 t/06attrs.t create mode 100644 t/07kids.t create mode 100644 t/08keeperr.t create mode 100644 t/09trace.t create mode 100644 t/10examp.t create mode 100644 t/11fetch.t create mode 100644 t/12quote.t create mode 100644 t/13taint.t create mode 100644 t/14utf8.t create mode 100644 t/15array.t create mode 100644 t/16destroy.t create mode 100644 t/19fhtrace.t create mode 100644 t/20meta.t create mode 100644 t/30subclass.t create mode 100644 t/31methcache.t create mode 100644 t/35thrclone.t create mode 100644 t/40profile.t create mode 100644 t/41prof_dump.t create mode 100644 t/42prof_data.t create mode 100644 t/43prof_env.t create mode 100644 t/48dbi_dbd_sqlengine.t create mode 100644 t/49dbd_file.t create mode 100755 t/50dbm_simple.t create mode 100644 t/51dbm_file.t create mode 100644 t/52dbm_complex.t create mode 100755 t/60preparse.t create mode 100644 t/65transact.t create mode 100644 t/70callbacks.t create mode 100644 t/72childhandles.t create mode 100644 t/80proxy.t create mode 100644 t/85gofer.t create mode 100644 t/86gofer_fail.t create mode 100644 t/87gofer_cache.t create mode 100644 t/90sql_type_cast.t create mode 100644 t/lib.pl create mode 100644 t/pod-coverage.t create mode 100644 t/pod.t create mode 100755 test.pl create mode 100644 typemap diff --git a/Changes b/Changes new file mode 100644 index 0000000..2351905 --- /dev/null +++ b/Changes @@ -0,0 +1,2275 @@ +=head1 NAME + +DBI::Changes - List of significant changes to the DBI + +(As of $Date: 2012-06-06 17:37:26 +0100 (Wed, 06 Jun 2012) $ $Revision: 15327 $) + +=encoding ISO8859-1 + +=cut + +=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.) + + 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 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) + + 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 + + Fixed spurious dbi_profile lines written to the log when + profiling is enabled and a trace flag, like SQL, is used. + Fixed to recognize SQL::Statement errors even if instantiated + with RaiseError=0 (Jens Rehsack) + Fixed RT#61513 by catching attribute assignment to tied table access + interface (Jens Rehsack) + Fixing some misbehavior of DBD::File when running within the Gofer + server. + Fixed compiler warnings RT#62640 + + Optimized connect() to remove redundant FETCH of \%attrib values. + Improved initialization phases in DBI::DBD::SqlEngine (Jens Rehsack) + + Added DBD::Gofer::Transport::corostream. An experimental proof-of-concept + transport that enables asynchronous database calls with few code changes. + It enables asynchronous use of DBI frameworks like DBIx::Class. + + Added additional notes on DBDs which avoid creating a statement in + the do() method and the effects on error handlers (Martin J. Evans) + Adding new attribute "sql_dialect" to DBI::DBD::SqlEngine to allow + users control used SQL dialect (ANSI, CSV or AnyData), defaults to + CSV (Jens Rehsack) + Add documentation for DBI::DBD::SqlEngine attributes (Jens Rehsack) + Documented dbd_st_execute return (Martin J. Evans) + Fixed typo in InactiveDestroy thanks to Emmanuel Rodriguez. + +=head2 Changes in DBI 1.615 (svn r14438) 21st September 2010 + + Fixed t/51dbm_file for file/directory names with whitespaces in them + RT#61445 (Jens Rehsack) + Fixed compiler warnings from ignored hv_store result (Martin J. Evans) + Fixed portability to VMS (Craig A. Berry) + +=head2 Changes in DBI 1.614 (svn r14408) 17th September 2010 + + Fixed bind_param () in DBI::DBD::SqlEngine (rt#61281) + Fixed internals to not refer to old perl symbols that + will no longer be visible in perl >5.13.3 (Andreas Koenig) + Many compiled drivers are likely to need updating. + Fixed issue in DBD::File when absolute filename is used as table name + (Jens Rehsack) + Croak manually when file after tie doesn't exists in DBD::DBM + when it have to exists (Jens Rehsack) + Fixed issue in DBD::File when users set individual file name for tables + via f_meta compatibility interface - reported by H.Merijn Brand while + working on RT#61168 (Jens Rehsack) + + Changed 50dbm_simple to simplify and fix problems (Martin J. Evans) + Changed 50dbm_simple to skip aggregation tests when not using + SQL::Statement (Jens Rehsack) + Minor speed improvements in DBD::File (Jens Rehsack) + + Added $h->{AutoInactiveDestroy} as simpler safer form of + $h->{InactiveDestroy} (David E. Wheeler) + Added ability for parallel testing "prove -j4 ..." (Jens Rehsack) + Added tests for delete in DBM (H.Merijn Brand) + Added test for absolute filename as table to 51dbm_file (Jens Rehsack) + Added two initialization phases to DBI::DBD::SqlEngine (Jens Rehsack) + Added improved developers documentation for DBI::DBD::SqlEngine + (Jens Rehsack) + Added guides how to write DBI drivers using DBI::DBD::SqlEngine + or DBD::File (Jens Rehsack) + Added register_compat_map() and table_meta_attr_changed() to + DBD::File::Table to support clean fix of RT#61168 (Jens Rehsack) + +=head2 Changes in DBI 1.613 (svn r14271) 22nd July 2010 + + Fixed Win32 prerequisite module from PathTools to File::Spec. + + Changed attribute headings and fixed references in DBI pod (Martin J. Evans) + Corrected typos in DBI::FAQ and DBI::ProxyServer (Ansgar Burchardt) + +=head2 Changes in DBI 1.612 (svn r14254) 16th July 2010 + +NOTE: This is a minor release for the DBI core but a major release for +DBD::File and drivers that depend on it, like DBD::DBM and DBD::CSV. + +This is also the first release where the bulk of the development work +has been done by other people. I'd like to thank (in no particular order) +Jens Rehsack, Martin J. Evans, and H.Merijn Brand for all their contributions. + + Fixed DBD::File's {ChopBlank} handling (it stripped \s instead of space + only as documented in DBI) (H.Merijn Brand) + Fixed DBD::DBM breakage with SQL::Statement (Jens Rehsack, fixes RT#56561) + Fixed DBD::File file handle leak (Jens Rehsack) + Fixed problems in 50dbm.t when running tests with multiple + dbms (Martin J. Evans) + Fixed DBD::DBM bugs found during tests (Jens Rehsack) + Fixed DBD::File doesn't find files without extensions under some + circumstances (Jens Rehsack, H.Merijn Brand, fixes RT#59038) + + Changed Makefile.PL to modernize with CONFLICTS, recommended dependencies + and resources (Jens Rehsack) + Changed DBI::ProfileDumper to rename any existing profile file by + appending .prev, instead of overwriting it. + Changed DBI::ProfileDumper::Apache to work in more configurations + including vhosts using PerlOptions +Parent. + Add driver_prefix method to DBI (Jens Rehsack) + + Added more tests to 50dbm_simple.t to prove optimizations in + DBI::SQL::Nano and SQL::Statement (Jens Rehsack) + Updated tests to cover optional installed SQL::Statement (Jens Rehsack) + Synchronize API between SQL::Statement and DBI::SQL::Nano (Jens Rehsack) + Merged some optimizations from SQL::Statement into DBI::SQL::Nano + (Jens Rehsack) + Added basic test for DBD::File (H.Merijn Brand, Jens Rehsack) + Extract dealing with Perl SQL engines from DBD::File into + DBI::DBD::SqlEngine for better subclassing of 3rd party non-db DBDs + (Jens Rehsack) + + Updated and clarified documentation for finish method (Tim Bunce). + Changes to DBD::File for better English and hopefully better + explanation (Martin J. Evans) + Update documentation of DBD::DBM to cover current implementation, + tried to explain some things better and changes most examples to + preferred style of Merijn and myself (Jens Rehsack) + Added developer documentation (including a roadmap of future plans) + for DBD::File + +=head2 Changes in DBI 1.611 (svn r13935) 29th April 2010 + + NOTE: minimum perl version is now 5.8.1 (as announced in DBI 1.607) + + Fixed selectcol_arrayref MaxRows attribute to count rows not values + thanks to Vernon Lyon. + Fixed DBI->trace(0, *STDERR); (H.Merijn Brand) + which tried to open a file named "*main::STDERR" in perl-5.10.x + Fixes in DBD::DBM for use under threads (Jens Rehsack) + + Changed "Issuing rollback() due to DESTROY without explicit disconnect" + warning to not be issued if ReadOnly set for that dbh. + + Added f_lock and f_encoding support to DBD::File (H.Merijn Brand) + Added ChildCallbacks => { ... } to Callbacks as a way to + specify Callbacks for child handles. + With tests added by David E. Wheeler. + Added DBI::sql_type_cast($value, $type, $flags) to cast a string value + to an SQL type. e.g. SQL_INTEGER effectively does $value += 0; + Has other options plus an internal interface for drivers. + + Documentation changes: + Small fixes in the documentation of DBD::DBM (H.Merijn Brand) + Documented specification of type casting behaviour for bind_col() + based on DBI::sql_type_cast() and two new bind_col attributes + StrictlyTyped and DiscardString. Thanks to Martin Evans. + Document fetchrow_hashref() behaviour for functions, + aliases and duplicate names (H.Merijn Brand) + Updated DBI::Profile and DBD::File docs to fix pod nits + thanks to Frank Wiegand. + Corrected typos in Gopher documentation reported by Jan Krynicky. + Documented the Callbacks attribute thanks to David E. Wheeler. + Corrected the Timeout examples as per rt 50621 (Martin J. Evans). + Removed some internal broken links in the pod (Martin J. Evans) + Added Note to column_info for drivers which do not + support it (Martin J. Evans) + Updated dbipport.h to Devel::PPPort 3.19 (H.Merijn Brand) + +=head2 Changes in DBI 1.609 (svn r12816) 8th June 2009 + + Fixes to DBD::File (H.Merijn Brand) + added f_schema attribute + table names case sensitive when quoted, insensitive when unquoted + workaround a bug in SQL::Statement (temporary fix) related + to the "You passed x parameters where y required" error + + Added ImplementorClass and Name info to the "Issuing rollback() due to + DESTROY without explicit disconnect" warning to identify the handle. + Applies to compiled drivers when they are recompiled. + Added DBI->visit_handles($coderef) method. + Added $h->visit_child_handles($coderef) method. + Added docs for column_info()'s COLUMN_DEF value. + Clarified docs on stickyness of data type via bind_param(). + Clarified docs on stickyness of data type via bind_col(). + +=head2 Changes in DBI 1.608 (svn r12742) 5th May 2009 + + Fixes to DBD::File (H.Merijn Brand) + bind_param () now honors the attribute argument + added f_ext attribute + File::Spec is always required. (CORE since 5.00405) + Fail and set errstr on parameter count mismatch in execute () + Fixed two small memory leaks when running in mod_perl + one in DBI->connect and one in DBI::Gofer::Execute. + Both due to "local $ENV{...};" leaking memory. + Fixed DBD_ATTRIB_DELETE macro for driver authors + and updated DBI::DBD docs thanks to Martin J. Evans. + Fixed 64bit issues in trace messages thanks to Charles Jardine. + Fixed FETCH_many() method to work with drivers that incorrectly return + an empty list from $h->FETCH. Affected gofer. + + Added 'sqlite_' as registered prefix for DBD::SQLite. + Corrected many typos in DBI docs thanks to Martin J. Evans. + Improved DBI::DBD docs thanks to H.Merijn Brand. + +=head2 Changes in DBI 1.607 (svn r11571) 22nd July 2008 + + NOTE: Perl 5.8.1 is now the minimum supported version. + If you need support for earlier versions send me a patch. + + Fixed missing import of carp in DBI::Gofer::Execute. + + Added note to docs about effect of execute(@empty_array). + Clarified docs for ReadOnly thanks to Martin Evans. + +=head2 Changes in DBI 1.605 (svn r11434) 16th June 2008 + + Fixed broken DBIS macro with threads on big-endian machines + with 64bit ints but 32bit pointers. Ticket #32309. + Fixed the selectall_arrayref, selectrow_arrayref, and selectrow_array + methods that get embedded into compiled drivers to use the + inner sth handle when passed a $sth instead of an sql string. + Drivers will need to be recompiled to pick up this change. + Fixed leak in neat() for some kinds of values thanks to Rudolf Lippan. + Fixed DBI::PurePerl neat() to behave more like XS neat(). + + Increased default $DBI::neat_maxlen from 400 to 1000. + Increased timeout on tests to accomodate very slow systems. + Changed behaviour of trace levels 1..4 to show less information + at lower levels. + Changed the format of the key used for $h->{CachedKids} + (which is undocumented so you shouldn't depend on it anyway) + Changed gofer error handling to avoid duplicate error text in errstr. + Clarified docs re ":N" style placeholders. + Improved gofer retry-on-error logic and refactored to aid subclassing. + Improved gofer trace output in assorted ways. + + Removed the beeps "\a" from Makefile.PL warnings. + Removed check for PlRPC-modules from Makefile.PL + + Added sorting of ParamValues reported by ShowErrorStatement + thanks to to Rudolf Lippan. + Added cache miss trace message to DBD::Gofer transport class. + Added $drh->dbixs_revision method. + Added explicit LICENSE specification (perl) to META.yaml + +=head2 Changes in DBI 1.604 (svn rev 10994) 24th March 2008 + + Fixed fetchall_arrayref with $max_rows argument broken in 1.603, + thanks to Greg Sabino Mullane. + Fixed a few harmless compiler warnings on cygwin. + +=head2 Changes in DBI 1.603 + + Fixed pure-perl fetchall_arrayref with $max_rows argument + to not error when fetching after all rows already fetched. + (Was fixed for compiled drivers back in DBI 1.31.) + Thanks to Mark Overmeer. + Fixed C sprintf formats and casts, fixing compiler warnings. + + Changed dbi_profile() to accept a hash of profiles and apply to all. + Changed gofer stream transport to improve error reporting. + Changed gofer test timeout to avoid spurious failures on slow systems. + + Added options to t/85gofer.t so it's more useful for manual testing. + +=head2 Changes in DBI 1.602 (svn rev 10706) 8th February 2008 + + Fixed potential coredump if stack reallocated while calling back + into perl from XS code. Thanks to John Gardiner Myers. + Fixed DBI::Util::CacheMemory->new to not clear the cache. + Fixed avg in DBI::Profile as_text() thanks to Abe Ingersoll. + Fixed DBD::DBM bug in push_names thanks to J M Davitt. + Fixed take_imp_data for some platforms thanks to Jeffrey Klein. + Fixed docs tie'ing CacheKids (ie LRU cache) thanks to Peter John Edwards. + + Expanded DBI::DBD docs for driver authors thanks to Martin Evans. + Enhanced t/80proxy.t test script. + Enhanced t/85gofer.t test script thanks to Stig. + Enhanced t/10examp.t test script thanks to David Cantrell. + Documented $DBI::stderr as the default value of err for internal errors. + + Gofer changes: + track_recent now also keeps track of N most recent errors. + The connect method is now also counted in stats. + +=head2 Changes in DBI 1.601 (svn rev 10103), 21st October 2007 + + Fixed t/05thrclone.t to work with Test::More >= 0.71 + thanks to Jerry D. Hedden and Michael G Schwern. + Fixed DBI for VMS thanks to Peter (Stig) Edwards. + + Added client-side caching to DBD::Gofer. Can use any cache with + get($k)/set($k,$v) methods, including all the Cache and Cache::Cache + distribution modules plus Cache::Memcached, Cache::FastMmap etc. + Works for all transports. Overridable per handle. + + Added DBI::Util::CacheMemory for use with DBD::Gofer caching. + It's a very fast and small strict subset of Cache::Memory. + +=head2 Changes in DBI 1.59 (svn rev 9874), 23rd August 2007 + + Fixed DBI::ProfileData to unescape headers lines read from data file. + Fixed DBI::ProfileData to not clobber $_, thanks to Alexey Tourbin. + Fixed DBI::SQL::Nano to not clobber $_, thanks to Alexey Tourbin. + Fixed DBI::PurePerl to return undef for ChildHandles if weaken not available. + Fixed DBD::Proxy disconnect error thanks to Philip Dye. + Fixed DBD::Gofer::Transport::Base bug (typo) in timeout code. + Fixed DBD::Proxy rows method thanks to Philip Dye. + Fixed dbiprof compile errors, thanks to Alexey Tourbin. + Fixed t/03handle.t to skip some tests if ChildHandles not available. + + Added check_response_sub to DBI::Gofer::Execute + +=head2 Changes in DBI 1.58 (svn rev 9678), 25th June 2007 + + Fixed code triggering fatal error in bleadperl, thanks to Steve Hay. + Fixed compiler warning thanks to Jerry D. Hedden. + Fixed t/40profile.t to use int(dbi_time()) for systems like Cygwin where + time() seems to be rounded not truncated from the high resolution time. + Removed dump_results() test from t/80proxy.t. + +=head2 Changes in DBI 1.57 (svn rev 9639), 13th June 2007 + + Note: this release includes a change to the DBI::hash() function which will + now produce different values than before *if* your perl was built with 64-bit + 'int' type (i.e. "perl -V:intsize" says intsize='8'). It's relatively rare + for perl to be configured that way, even on 64-bit systems. + + Fixed XS versions of select*_*() methods to call execute() + fetch() etc., with inner handle instead of outer. + Fixed execute_for_fetch() to not cache errstr values + thanks to Bart Degryse. + Fixed unused var compiler warning thanks to JDHEDDEN. + Fixed t/86gofer_fail tests to be less likely to fail falsely. + + Changed DBI::hash to return 'I32' type instead of 'int' so results are + portable/consistent regardless of size of the int type. + Corrected timeout example in docs thanks to Egmont Koblinger. + Changed t/01basic.t to warn instead of failing when it detects + a problem with Math::BigInt (some recent versions had problems). + + Added support for !Time and !Time~N to DBI::Profile Path. See docs. + Added extra trace info to connect_cached thanks to Walery Studennikov. + Added non-random (deterministic) mode to DBI_GOFER_RANDOM mechanism. + Added DBIXS_REVISION macro that drivers can use. + Added more docs for private_attribute_info() method. + + DBI::Profile changes: + dbi_profile() now returns ref to relevant leaf node. + Don't profile DESTROY during global destruction. + Added as_node_path_list() and as_text() methods. + DBI::ProfileDumper changes: + Don't write file if there's no profile data. + Uses full natural precision when saving data (was using %.6f) + Optimized flush_to_disk(). + Locks the data file while writing. + Enabled filename to be a code ref for dynamic names. + DBI::ProfileDumper::Apache changes: + Added Quiet=>1 to avoid write to STDERR in flush_to_disk(). + Added Dir=>... to specify a writable destination directory. + Enabled DBI_PROFILE_APACHE_LOG_DIR for mod_perl 1 as well as 2. + Added parent pid to default data file name. + DBI::ProfileData changes: + Added DeleteFiles option to rename & delete files once read. + Locks the data files while reading. + Added ability to sort by Path elements. + dbiprof changes: + Added --dumpnodes and --delete options. + Added/updated docs for both DBI::ProfileDumper && ::Apache. + +=head2 Changes in DBI 1.56 (svn rev 9660), 18th June 2007 + + Fixed printf arg warnings thanks to JDHEDDEN. + Fixed returning driver-private sth attributes via gofer. + + Changed pod docs docs to use =head3 instead of =item + so now in html you get links to individual methods etc. + Changed default gofer retry_limit from 2 to 0. + Changed tests to workaround Math::BigInt broken versions. + Changed dbi_profile_merge() to dbi_profile_merge_nodes() + old name still works as an alias for the new one. + Removed old DBI internal sanity check that's no longer valid + causing "panic: DESTROY (dbih_clearcom)" when tracing enabled + + Added DBI_GOFER_RANDOM env var that can be use to trigger random + failures and delays when executing gofer requests. Designed to help + test automatic retry on failures and timeout handling. + Added lots more docs to all the DBD::Gofer and DBI::Gofer classes. + +=head2 Changes in DBI 1.55 (svn rev 9504), 4th May 2007 + + Fixed set_err() so HandleSetErr hook is executed reliably, if set. + Fixed accuracy of profiling when perl configured to use long doubles. + Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm Nooning. + Fixed potential corruption in selectall_arrayref and selectrow_arrayref + for compiled drivers, thanks to Rob Davies. + Rebuild your compiled drivers after installing DBI. + + Changed some handle creation code from perl to C code, + to reduce handle creation cost by ~20%. + Changed internal implementation of the CachedKids attribute + so it's a normal handle attribute (and initially undef). + Changed connect_cached and prepare_cached to avoid a FETCH method call, + and thereby reduced cost by ~5% and ~30% respectively. + Changed _set_fbav to not croak when given a wrongly sized array, + it now warns and adjusts the row buffer to match. + Changed some internals to improve performance with threaded perls. + Changed DBD::NullP to be slightly more useful for testing. + Changed File::Spec prerequisite to not require a minimum version. + Changed tests to work with other DBMs thanks to ZMAN. + Changed ex/perl_dbi_nulls_test.pl to be more descriptive. + + Added more functionality to the (undocumented) Callback mechanism. + Callbacks can now elect to provide a value to be returned, in which case + the method won't be called. A callback for "*" is applied to all methods + that don't have their own callback. + Added $h->{ReadOnly} attribute. + Added support for DBI Profile Path to contain refs to scalars + which will be de-ref'd for each profile sample. + Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed) + Added details for SQLite 3.3 to NULL handling docs thanks to Alex Teslik. + Added take_imp_data() to DBI::PurePerl. + + Gofer related changes: + Fixed gofer pipeone & stream transports to avoid risk of hanging. + Improved error handling and tracing significantly. + Added way to generate random 1-in-N failures for methods. + Added automatic retry-on-error mechanism to gofer transport base class. + Added tests to show automatic retry mechanism works a treat! + Added go_retry_hook callback hook so apps can fine-tune retry behaviour. + Added header to request and response packets for sanity checking + and to enable version skew between client and server. + Added forced_single_resultset, max_cached_sth_per_dbh and max_cached_dbh_per_drh + to gofer executor config. + Driver-private methods installed with install_method are now proxied. + No longer does a round-trip to the server for methods it knows + have not been overridden by the remote driver. + Most significant aspects of gofer behaviour are controlled by policy mechanism. + Added policy-controlled caching of results for some methods, such as schema metadata. + The connect_cached and prepare_cached methods cache on client and server. + The bind_param_array and execute_array methods are now supported. + Worked around a DBD::Sybase bind_param bug (which is fixed in DBD::Sybase 1.07) + Added goferperf.pl utility (doesn't get installed). + Many other assorted Gofer related bug fixes, enhancements and docs. + The http and mod_perl transports have been remove to their own distribution. + Client and server will need upgrading together for this release. + +=head2 Changes in DBI 1.54 (svn rev 9157), 23rd February 2007 + + NOTE: This release includes the 'next big thing': DBD::Gofer. + Take a look! + + WARNING: This version has some subtle changes in DBI internals. + It's possible, though doubtful, that some may affect your code. + I recommend some extra testing before using this release. + Or perhaps I'm just being over cautious... + + Fixed type_info when called for multiple dbh thanks to Cosimo Streppone. + Fixed compile warnings in bleadperl on freebsd-6.1-release + and solaris 10g thanks to Philip M. Gollucci. + Fixed to compile for perl built with -DNO_MATHOMS thanks to Jerry D. Hedden. + Fixed to work for bleadperl (r29544) thanks to Nicholas Clark. + Users of Perl >= 5.9.5 will require DBI >= 1.54. + Fixed rare error when profiling access to $DBI::err etc tied variables. + Fixed DBI::ProfileDumper to not be affected by changes to $/ and $, + thanks to Michael Schwern. + + Changed t/40profile.t to skip tests for perl < 5.8.0. + Changed setting trace file to no longer write "Trace file set" to new file. + Changed 'handle cleared whilst still active' warning for dbh + to only be given for dbh that have active sth or are not AutoCommit. + Changed take_imp_data to call finish on all Active child sth. + Changed DBI::PurePerl trace() method to be more consistent. + Changed set_err method to effectively not append to errstr if the new errstr + is the same as the current one. + Changed handle factory methods, like connect, prepare, and table_info, + to copy any error/warn/info state of the handle being returned + up into the handle the method was called on. + Changed row buffer handling to not alter NUM_OF_FIELDS if it's + inconsistent with number of elements in row buffer array. + Updated DBI::DBD docs re handling multiple result sets. + Updated DBI::DBD docs for driver authors thanks to Ammon Riley + and Dean Arnold. + Updated column_info docs to note that if a table doesn't exist + you get an sth for an empty result set and not an error. + + Added new DBD::Gofer 'stateless proxy' driver and framework, + and the DBI test suite is now also executed via DBD::Gofer, + and DBD::Gofer+DBI::PurePerl, in addition to DBI::PurePerl. + Added ability for trace() to support filehandle argument, + including tracing into a string, thanks to Dean Arnold. + Added ability for drivers to implement func() method + so proxy drivers can proxy the func method itself. + Added SQL_BIGINT type code (resolved to the ODBC/JDBC value (-5)) + Added $h->private_attribute_info method. + +=head2 Changes in DBI 1.53 (svn rev 7995), 31st October 2006 + + Fixed checks for weaken to work with early 5.8.x versions + Fixed DBD::Proxy handling of some methods, including commit and rollback. + Fixed t/40profile.t to be more insensitive to long double precision. + Fixed t/40profile.t to be insensitive to small negative shifts in time + thanks to Jamie McCarthy. + Fixed t/40profile.t to skip tests for perl < 5.8.0. + Fixed to work with current 'bleadperl' (~5.9.5) thanks to Steve Peters. + Users of Perl >= 5.9.5 will require DBI >= 1.53. + Fixed to be more robust against drivers not handling multiple result + sets properly, thanks to Gisle Aas. + + Added array context support to execute_array and execute_for_fetch + methods which returns executed tuples and rows affected. + Added Tie::Cache::LRU example to docs thanks to Brandon Black. + +=head2 Changes in DBI 1.52 (svn rev 6840), 30th July 2006 + + Fixed memory leak (per handle) thanks to Nicholas Clark and Ephraim Dan. + Fixed memory leak (16 bytes per sth) thanks to Doru Theodor Petrescu. + Fixed execute_for_fetch/execute_array to RaiseError thanks to Martin J. Evans. + Fixed for perl 5.9.4. Users of Perl >= 5.9.4 will require DBI >= 1.52. + + Updated DBD::File to 0.35 to match the latest release on CPAN. + + Added $dbh->statistics_info specification thanks to Brandon Black. + + Many changes and additions to profiling: + Profile Path can now uses sane strings instead of obscure numbers, + can refer to attributes, assorted magical values, and even code refs! + Parsing of non-numeric DBI_PROFILE env var values has changed. + Changed DBI::Profile docs extensively - many new features. + See DBI::Profile docs for more information. + +=head2 Changes in DBI 1.51 (svn rev 6475), 6th June 2006 + + Fixed $dbh->clone method 'signature' thanks to Jeffrey Klein. + Fixed default ping() method to return false if !$dbh->{Active}. + Fixed t/40profile.t to be insensitive to long double precision. + Fixed for perl 5.8.0's more limited weaken() function. + Fixed DBD::Proxy to not alter $@ in disconnect or AUTOLOADd methods. + Fixed bind_columns() to use return set_err(...) instead of die() + to report incorrect number of parameters, thanks to Ben Thul. + Fixed bind_col() to ignore undef as bind location, thanks to David Wheeler. + Fixed for perl 5.9.x for non-threaded builds thanks to Nicholas Clark. + Users of Perl >= 5.9.x will require DBI >= 1.51. + Fixed fetching of rows as hash refs to preserve utf8 on field names + from $sth->{NAME} thanks to Alexey Gaidukov. + Fixed build on Win32 (dbd_postamble) thanks to David Golden. + + Improved performance for thread-enabled perls thanks to Gisle Aas. + Drivers can now use PERL_NO_GET_CONTEXT thanks to Gisle Aas. + Driver authors please read the notes in the DBI::DBD docs. + Changed DBI::Profile format to always include a percentage, + if not exiting then uses time between the first and last DBI call. + Changed DBI::ProfileData to be more forgiving of systems with + unstable clocks (where time may go backwards occasionally). + Clarified the 'Subclassing the DBI' docs. + Assorted minor changes to docs from comments on annocpan.org. + Changed Makefile.PL to avoid incompatible options for old gcc. + + Added 'fetch array of hash refs' example to selectall_arrayref + docs thanks to Tom Schindl. + Added docs for $sth->{ParamArrays} thanks to Martin J. Evans. + Added reference to $DBI::neat_maxlen in TRACING section of docs. + Added ability for DBI::Profile Path to include attributes + and a summary of where the code was called from. + +=head2 Changes in DBI 1.50 (svn rev 2307), 13 December 2005 + + Fixed Makefile.PL options for gcc bug introduced in 1.49. + Fixed handle magic order to keep DBD::Oracle happy. + Fixed selectrow_array to return empty list on error. + + Changed dbi_profile_merge() to be able to recurse and merge + sub-trees of profile data. + + Added documentation for dbi_profile_merge(), including how to + measure the time spent inside the DBI for an http request. + +=head2 Changes in DBI 1.49 (svn rev 2287), 29th November 2005 + + Fixed assorted attribute handling bugs in DBD::Proxy. + Fixed croak() in DBD::NullP thanks to Sergey Skvortsov. + Fixed handling of take_imp_data() and dbi_imp_data attribute. + Fixed bugs in DBD::DBM thanks to Jeff Zucker. + Fixed bug in DBI::ProfileDumper thanks to Sam Tregar. + Fixed ping in DBD::Proxy thanks to George Campbell. + Fixed dangling ref in $sth after parent $dbh destroyed + with thanks to il@rol.ru for the bug report #13151 + Fixed prerequisites to include Storable thanks to Michael Schwern. + Fixed take_imp_data to be more practical. + + Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0. + Changed internals to be more strictly coded thanks to Andy Lester. + Changed warning about multiple copies of Driver.xst found in @INC + to ignore duplicated directories thanks to Ed Avis. + Changed Driver.xst to enable drivers to define an dbd_st_prepare_sv + function where the statement parameter is an SV. That enables + compiled drivers to support SQL strings that are UTF-8. + Changed "use DBI" to only set $DBI::connect_via if not already set. + Changed docs to clarify pre-method clearing of err values. + + Added ability for DBI::ProfileData to edit profile path on loading. + This enables aggregation of different SQL statements into the same + profile node - very handy when not using placeholders or when working + multiple separate tables for the same thing (ie logtable_2005_11_28) + Added $sth->{ParamTypes} specification thanks to Dean Arnold. + Added $h->{Callbacks} attribute to enable code hooks to be invoked + when certain methods are called. For example: + $dbh->{Callbacks}->{prepare} = sub { ... }; + With thanks to David Wheeler for the kick start. + Added $h->{ChildHandles} (using weakrefs) thanks to Sam Tregar + I've recoded it in C so there's no significant performance impact. + Added $h->{Type} docs (returns 'dr', 'db', or 'st') + Adding trace message in DESTROY if InactiveDestroy enabled. + Added %drhs = DBI->installed_drivers(); + + Ported DBI::ProfileDumper::Apache to mod_perl2 RC5+ + thanks to Philip M. Golluci + +=head2 Changes in DBI 1.48 (svn rev 928), 14th March 2005 + + Fixed DBI::DBD::Metadata generation of type_info_all thanks to Steffen Goeldner + (driver authors who have used it should rerun it). + + Updated docs for NULL Value placeholders thanks to Brian Campbell. + + Added multi-keyfield nested hash fetching to fetchall_hashref() + thanks to Zhuang (John) Li for polishing up my draft. + Added registered driver prefixes: amzn_ for DBD::Amazon and yaswi_ for DBD::Yaswi. + + +=head2 Changes in DBI 1.47 (svn rev 854), 2nd February 2005 + + Fixed DBI::ProxyServer to not create pid files by default. + References: Ubuntu Security Notice USN-70-1, CAN-2005-0077 + Thanks to Javier Fernández-Sanguino Peńa from the + Debian Security Audit Project, and Jonathan Leffler. + Fixed some tests to work with older Test::More versions. + Fixed setting $DBI::err/errstr in DBI::PurePerl. + Fixed potential undef warning from connect_cached(). + Fixed $DBI::lasth handling for DESTROY so lasth points to + parent even if DESTROY called other methods. + Fixed DBD::Proxy method calls to not alter $@. + Fixed DBD::File problem with encoding pragma thanks to Erik Rijkers. + + Changed error handling so undef errstr doesn't cause warning. + Changed DBI::DBD docs to use =head3/=head4 pod thanks to + Jonathan Leffler. This may generate warnings for perl 5.6. + Changed DBI::PurePerl to set autoflush on trace filehandle. + Changed DBD::Proxy to treat Username as a local attribute + so recent DBI version can be used with old DBI::ProxyServer. + Changed driver handle caching in DBD::File. + Added $GetInfoType{SQL_DATABASE_NAME} thanks to Steffen Goeldner. + + Updated docs to recommend some common DSN string attributes. + Updated connect_cached() docs with issues and suggestions. + Updated docs for NULL Value placeholders thanks to Brian Campbell. + Updated docs for primary_key_info and primary_keys. + Updated docs to clarify that the default fetchrow_hashref behaviour, + of returning a ref to a new hash for each row, will not change. + Updated err/errstr/state docs for DBD authors thanks to Steffen Goeldner. + Updated handle/attribute docs for DBD authors thanks to Steffen Goeldner. + Corrected and updated LongReadLen docs thanks to Bart Lateur. + Added DBD::JDBC as a registered driver. + +=head2 Changes in DBI 1.46 (svn rev 584), 16th November 2004 + + Fixed parsing bugs in DBI::SQL::Nano thanks to Jeff Zucker. + Fixed a couple of bad links in docs thanks to Graham Barr. + Fixed test.pl Win32 undef warning thanks to H.Merijn Brand & David Repko. + Fixed minor issues in DBI::DBD::Metadata thanks to Steffen Goeldner. + Fixed DBI::PurePerl neat() to use double quotes for utf8. + + Changed execute_array() definition, and default implementation, + to not consider scalar values for execute tuple count. See docs. + Changed DBD::File to enable ShowErrorStatement by default, + which affects DBD::File subclasses such as DBD::CSV and DBD::DBM. + Changed use DBI qw(:utils) tag to include $neat_maxlen. + Updated Roadmap and ToDo. + + Added data_string_diff() data_string_desc() and data_diff() + utility functions to help diagnose Unicode issues. + All can be imported via the use DBI qw(:utils) tag. + +=head2 Changes in DBI 1.45 (svn rev 480), 6th October 2004 + + Fixed DBI::DBD code for drivers broken in 1.44. + Fixed "Free to wrong pool"/"Attempt to free unreferenced scalar" in FETCH. + +=head2 Changes in DBI 1.44 (svn rev 478), 5th October 2004 + + Fixed build issues on VMS thanks to Jakob Snoer. + Fixed DBD::File finish() method to return 1 thanks to Jan Dubois. + Fixed rare core dump during global destruction thanks to Mark Jason Dominus. + Fixed risk of utf8 flag persisting from one row to the next. + + Changed bind_param_array() so it doesn't require all bind arrays + to have the same number of elements. + Changed bind_param_array() to error if placeholder number <= 0. + Changed execute_array() definition, and default implementation, + to effectively NULL-pad shorter bind arrays. + Changed execute_array() to return "0E0" for 0 as per the docs. + Changed execute_for_fetch() definition, and default implementation, + to return "0E0" for 0 like execute() and execute_array(). + Changed Test::More prerequisite to Test::Simple (which is also the name + of the distribution both are packaged in) to work around ppm behaviour. + + Corrected docs to say that get/set of unknown attribute generates + a warning and is no longer fatal. Thanks to Vadim. + Corrected fetchall_arrayref() docs example thanks to Drew Broadley. + + Added $h1->swap_inner_handle($h2) sponsored by BizRate.com + + +=head2 Changes in DBI 1.43 (svn rev 377), 2nd July 2004 + + Fixed connect() and connect_cached() RaiseError/PrintError + which would sometimes show "(no error string)" as the error. + Fixed compiler warning thanks to Paul Marquess. + Fixed "trace level set to" trace message thanks to H.Merijn Brand. + Fixed DBD::DBM $dbh->{dbm_tables}->{...} to be keyed by the + table name not the file name thanks to Jeff Zucker. + Fixed last_insert_id(...) thanks to Rudy Lippan. + Fixed propagation of scalar/list context into proxied methods. + Fixed DBI::Profile::DESTROY to not alter $@. + Fixed DBI::ProfileDumper new() docs thanks to Michael Schwern. + Fixed _load_class to propagate $@ thanks to Drew Taylor. + Fixed compile warnings on Win32 thanks to Robert Baron. + Fixed problem building with recent versions of MakeMaker. + Fixed DBD::Sponge not to generate warning with threads. + Fixed DBI_AUTOPROXY to work more than once thanks to Steven Hirsch. + + Changed TraceLevel 1 to not show recursive/nested calls. + Changed getting or setting an invalid attribute to no longer be + a fatal error but generate a warning instead. + Changed selectall_arrayref() to call finish() if + $attr->{MaxRows} is defined. + Changed all tests to use Test::More and enhanced the tests thanks + to Stevan Little and Andy Lester. See http://qa.perl.org/phalanx/ + Changed Test::More minimum prerequisite version to 0.40 (2001). + Changed DBI::Profile header to include the date and time. + + Added DBI->parse_dsn($dsn) method. + Added warning if build directory path contains white space. + Added docs for parse_trace_flags() and parse_trace_flag(). + Removed "may change" warnings from the docs for table_info(), + primary_key_info(), and foreign_key_info() methods. + +=head2 Changes in DBI 1.42 (svn rev 222), 12th March 2004 + + Fixed $sth->{NUM_OF_FIELDS} of non-executed statement handle + to be undef as per the docs (it was 0). + Fixed t/41prof_dump.t to work with perl5.9.1. + Fixed DBD_ATTRIB_DELETE macro thanks to Marco Paskamp. + Fixed DBI::PurePerl looks_like_number() and $DBI::rows. + Fixed ref($h)->can("foo") to not croak. + + Changed attributes (NAME, TYPE etc) of non-executed statement + handle to be undef instead of triggering an error. + Changed ShowErrorStatement to apply to more $dbh methods. + Changed DBI_TRACE env var so just does this at load time: + DBI->trace(split '=', $ENV{DBI_TRACE}, 2); + Improved "invalid number of parameters" error message. + Added DBI::common as base class for DBI::db, DBD::st etc. + Moved methods common to all handles into DBI::common. + + Major tracing enhancement: + + Added $h->parse_trace_flags("foo|SQL|7") to map a group of + trace flags into the corresponding trace flag bits. + Added automatic calling of parse_trace_flags() if + setting the trace level to a non-numeric value: + $h->{TraceLevel}="foo|SQL|7"; $h->trace("foo|SQL|7"); + DBI->connect("dbi:Driver(TraceLevel=SQL|foo):...", ...); + Currently no trace flags have been defined. + Added to, and reworked, the trace documentation. + Added dbivport.h for driver authors to use. + + Major driver additions that Jeff Zucker and I have been working on: + + Added DBI::SQL::Nano a 'smaller than micro' SQL parser + with an SQL::Statement compatible API. If SQL::Statement + is installed then DBI::SQL::Nano becomes an empty subclass + of SQL::Statement, unless the DBI_SQL_NANO env var is true. + Added DBD::File, modified to use DBI::SQL::Nano. + Added DBD::DBM, an SQL interface to DBM files using DBD::File. + + Documentation changes: + + Corrected typos in docs thanks to Steffen Goeldner. + Corrected execute_for_fetch example thanks to Dean Arnold. + +=head2 Changes in DBI 1.41 (svn rev 130), 22nd February 2004 + + Fixed execute_for_array() so tuple_status parameter is optional + as per docs, thanks to Ed Avis. + Fixed execute_for_array() docs to say that it returns undef if + any of the execute() calls fail. + Fixed take_imp_data() test on m68k reported by Christian Hammers. + Fixed write_typeinfo_pm inconsistencies in DBI::DBD::Metadata + thanks to Andy Hassall. + Fixed $h->{TraceLevel} to not return DBI->trace trace level + which it used to if DBI->trace trace level was higher. + + Changed set_err() to append to errstr, with a leading "\n" if it's + not empty, so that multiple error/warning messages are recorded. + Changed trace to limit elements dumped when an array reference is + returned from a method to the max(40, $DBI::neat_maxlen/10) + so that fetchall_arrayref(), for example, doesn't flood the trace. + Changed trace level to be a four bit integer (levels 0 thru 15) + and a set of topic flags (no topics have been assigned yet). + Changed column_info() to check argument count. + Extended bind_param() TYPE attribute specification to imply + standard formating of value, eg SQL_DATE implies 'YYYY-MM-DD'. + + Added way for drivers to indicate 'success with info' or 'warning' + by setting err to "0" for warning and "" for information. + Both values are false and so don't trigger RaiseError etc. + Thanks to Steffen Goeldner for the original idea. + Added $h->{HandleSetErr} = sub { ... } to be called at the + point that an error, warn, or info state is recorded. + The code can alter the err, errstr, and state values + (e.g., to promote an error to a warning, or the reverse). + Added $h->{PrintWarn} attribute to enable printing of warnings + recorded by the driver. Defaults to same value as $^W (perl -w). + Added $h->{ErrCount} attribute, incremented whenever an error is + recorded by the driver via set_err(). + Added $h->{Executed} attribute, set if do()/execute() called. + Added \%attr parameter to foreign_key_info() method. + Added ref count of inner handle to "DESTROY ignored for outer" msg. + Added Win32 build config checks to DBI::DBD thanks to Andy Hassall. + Added bind_col to Driver.xst so drivers can define their own. + Added TYPE attribute to bind_col and specified the expected + driver behaviour. + + Major update to signal handling docs thanks to Lincoln Baxter. + Corrected dbiproxy usage doc thanks to Christian Hammers. + Corrected type_info_all index hash docs thanks to Steffen Goeldner. + Corrected type_info COLUMN_SIZE to chars not bytes thanks to Dean Arnold. + Corrected get_info() docs to include details of DBI::Const::GetInfoType. + Clarified that $sth->{PRECISION} is OCTET_LENGTH for char types. + +=head2 Changes in DBI 1.40, 7th January 2004 + + Fixed handling of CachedKids when DESTROYing threaded handles. + Fixed sql_user_name() in DBI::DBD::Metadata (used by write_getinfo_pm) + to use $dbh->{Username}. Driver authors please update your code. + + Changed connect_cached() when running under Apache::DBI + to route calls to Apache::DBI::connect(). + + Added CLONE() to DBD::Sponge and DBD::ExampleP. + Added warning when starting a new thread about any loaded driver + which does not have a CLONE() function. + Added new prepare_cache($sql, \%attr, 3) option to manage Active handles. + Added SCALE and NULLABLE support to DBD::Sponge. + Added missing execute() in fetchall_hashref docs thanks to Iain Truskett. + Added a CONTRIBUTING section to the docs with notes on creating patches. + +=head2 Changes in DBI 1.39, 27th November 2003 + + Fixed STORE to not clear error during nested DBI call, again/better, + thanks to Tony Bowden for the report and helpful test case. + Fixed DBI dispatch to not try to use AUTOLOAD for driver methods unless + the method has been declared (as methods should be when using AUTOLOAD). + This fixes a problem when the Attribute::Handlers module is loaded. + Fixed cwd check code to use $Config{path_sep} thanks to Steve Hay. + Fixed unqualified croak() calls thanks to Steffen Goeldner. + Fixed DBD::ExampleP TYPE and PRECISION attributes thanks to Tom Lowery. + Fixed tracing of methods that only get traced at high trace levels. + + The level 1 trace no longer includes nested method calls so it generally + just shows the methods the application explicitly calls. + Added line to trace log (level>=4) when err/errstr is cleared. + Updated docs for InactiveDestroy and point out where and when the + trace includes the process id. + Update DBI::DBD docs thanks to Steffen Goeldner. + Removed docs saying that the DBI->data_sources method could be + passed a $dbh. The $dbh->data_sources method should be used instead. + Added link to 'DBI recipes' thanks to Giuseppe Maxia: + http://gmax.oltrelinux.com/dbirecipes.html (note that this + is not an endorsement that the recipies are 'optimal') + + Note: There is a bug in perl 5.8.2 when configured with threads + and debugging enabled (bug #24463) which causes a DBI test to fail. + +=head2 Changes in DBI 1.38, 21th August 2003 + + NOTE: The DBI now requires perl version 5.6.0 or later. + (As per notice in DBI 1.33 released 27th February 2003) + + Fixed spurious t/03handles failure on 64bit perls reported by H.Merijn Brand. + Fixed spurious t/15array failure on some perl versions thanks to Ed Avis. + Fixed build using dmake on windows thanks to Steffen Goeldner. + Fixed build on using some shells thanks to Gurusamy Sarathy. + Fixed ParamValues to only be appended to ShowErrorStatement if not empty. + Fixed $dbh->{Statement} not being writable by drivers in some cases. + Fixed occasional undef warnings on connect failures thanks to Ed Avis. + Fixed small memory leak when using $sth->{NAME..._hash}. + Fixed 64bit warnings thanks to Marian Jancar. + Fixed DBD::Proxy::db::DESTROY to not alter $@ thanks to Keith Chapman. + Fixed Makefile.PL status from WriteMakefile() thanks to Leon Brocard. + + Changed "Can't set ...->{Foo}: unrecognised attribute" from an error to a + warning when running with DBI::ProxyServer to simplify upgrades. + Changed execute_array() to no longer require ArrayTupleStatus attribute. + Changed DBI->available_drivers to not hide DBD::Sponge. + Updated/moved placeholder docs to a better place thanks to Johan Vromans. + Changed dbd_db_do4 api in Driver.xst to match dbd_st_execute (return int, + not bool), relevant only to driver authors. + Changed neat(), and thus trace(), so strings marked as utf8 are presented + in double quotes instead of single quotes and are not sanitized. + + Added $dbh->data_sources method. + Added $dbh->last_insert_id method. + Added $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status) method. + Added DBI->installed_versions thanks to Jeff Zucker. + Added $DBI::Profile::ON_DESTROY_DUMP variable. + Added docs for DBD::Sponge thanks to Mark Stosberg. + +=head2 Changes in DBI 1.37, 15th May 2003 + + Fixed "Can't get dbh->{Statement}: unrecognised attribute" error in test + caused by change to perl internals in 5.8.0 + Fixed to build with latest development perl (5.8.1@19525). + Fixed C code to use all ANSI declarations thanks to Steven Lembark. + +=head2 Changes in DBI 1.36, 11th May 2003 + + Fixed DBI->connect to carp instead of croak on 'old-style' usage. + Fixed connect(,,, { RootClass => $foo }) to not croak if module not found. + Fixed code generated by DBI::DBD::Metadata thanks to DARREN@cpan.org (#2270) + Fixed DBI::PurePerl to not reset $@ during method dispatch. + Fixed VMS build thanks to Michael Schwern. + Fixed Proxy disconnect thanks to Steven Hirsch. + Fixed error in DBI::DBD docs thanks to Andy Hassall. + + Changed t/40profile.t to not require Time::HiRes. + Changed DBI::ProxyServer to load DBI only on first request, which + helps threaded server mode, thanks to Bob Showalter. + Changed execute_array() return value from row count to executed + tuple count, and now the ArrayTupleStatus attribute is mandatory. + NOTE: That is an API definition change that may affect your code. + Changed CompatMode attribute to also disable attribute 'quick FETCH'. + Changed attribute FETCH to be slightly faster thanks to Stas Bekman. + + Added workaround for perl bug #17575 tied hash nested FETCH + thanks to Silvio Wanka. + Added Username and Password attributes to connect(..., \%attr) and so + also embedded in DSN like "dbi:Driver(Username=user,Password=pass):..." + Username and Password can't contain ")", ",", or "=" characters. + The predence is DSN first, then \%attr, then $user & $pass parameters, + and finally the DBI_USER & DBI_PASS environment variables. + The Username attribute is stored in the $dbh but the Password is not. + Added ProxyServer HOWTO configure restrictions docs thanks to Jochen Wiedmann. + Added MaxRows attribute to selectcol_arrayref prompted by Wojciech Pietron. + Added dump_handle as a method not just a DBI:: utility function. + Added on-demand by-row data feed into execute_array() using code ref, + or statement handle. For example, to insert from a select: + $insert_sth->execute_array( { ArrayTupleFetch => $select_sth, ... } ) + Added warning to trace log when $h->{foo}=... is ignored due to + invalid prefix (e.g., not 'private_'). + +=head2 Changes in DBI 1.35, 7th March 2003 + + Fixed memory leak in fetchrow_hashref introduced in DBI 1.33. + Fixed various DBD::Proxy errors introduced in DBI 1.33. + Fixed to ANSI C in dbd_dr_data_sources thanks to Jonathan Leffler. + Fixed $h->can($method_name) to return correct code ref. + Removed DBI::Format from distribution as it's now part of the + separate DBI::Shell distribution by Tom Lowery. + Updated DBI::DBD docs with a note about the CLONE method. + Updated DBI::DBD docs thanks to Jonathan Leffler. + Updated DBI::DBD::Metadata for perl 5.5.3 thanks to Jonathan Leffler. + Added note to install_method docs about setup_driver() method. + +=head2 Changes in DBI 1.34, 28th February 2003 + + Fixed DBI::DBD docs to refer to DBI::DBD::Metadata thanks to Jonathan Leffler. + Fixed dbi_time() compile using BorlandC on Windows thanks to Steffen Goeldner. + Fixed profile tests to do enough work to measure on Windows. + Fixed disconnect_all() to not be required by drivers. + + Added $okay = $h->can($method_name) to check if a method exists. + Added DBD::*::*->install_method($method_name, \%attr) so driver private + methods can be 'installed' into the DBI dispatcher and no longer + need to be called using $h->func(..., $method_name). + + Enhanced $dbh->clone() and documentation. + Enhanced docs to note that dbi_time(), and thus profiling, is limited + to only millisecond (seconds/1000) resolution on Windows. + Removed old DBI::Shell from distribution and added Tom Lowery's improved + version to the Bundle::DBI file. + Updated minimum version numbers for modules in Bundle::DBI. + +=head2 Changes in DBI 1.33, 27th February 2003 + + NOTE: Future versions of the DBI *will not* support perl 5.6.0 or earlier. + : Perl 5.6.1 will be the minimum supported version. + + NOTE: The "old-style" connect: DBI->connect($database, $user, $pass, $driver); + : has been deprecated for several years and will now generate a warning. + : It will be removed in a later release. Please change any old connect() calls. + + Added $dbh2 = $dbh1->clone to make a new connection to the database + that is identical to the original one. clone() can be called even after + the original handle has been disconnected. See the docs for more details. + + Fixed merging of profile data to not sum DBIprof_FIRST_TIME values. + Fixed unescaping of newlines in DBI::ProfileData thanks to Sam Tregar. + Fixed Taint bug with fetchrow_hashref with help from Bradley Baetz. + Fixed $dbh->{Active} for DBD::Proxy, reported by Bob Showalter. + Fixed STORE to not clear error during nested DBI call, + thanks to Tony Bowden for the report and helpful test case. + Fixed DBI::PurePerl error clearing behaviour. + Fixed dbi_time() and thus DBI::Profile on Windows thanks to Smejkal Petr. + Fixed problem that meant ShowErrorStatement could show wrong statement, + thanks to Ron Savage for the report and test case. + Changed Apache::DBI hook to check for $ENV{MOD_PERL} instead of + $ENV{GATEWAY_INTERFACE} thanks to Ask Bjoern Hansen. + No longer tries to dup trace logfp when an interpreter is being cloned. + Database handles no longer inherit shared $h->err/errstr/state storage + from their drivers, so each $dbh has it's own $h->err etc. values + and is no longer affected by calls made on other dbh's. + Now when a dbh is destroyed it's err/errstr/state values are copied + up to the driver so checking $DBI::errstr still works as expected. + + Build / portability fixes: + Fixed t/40profile.t to not use Time::HiRes. + Fixed t/06attrs.t to not be locale sensitive, reported by Christian Hammers. + Fixed sgi compiler warnings, reported by Paul Blake. + Fixed build using make -j4, reported by Jonathan Leffler. + Fixed build and tests under VMS thanks to Craig A. Berry. + + Documentation changes: + Documented $high_resolution_time = dbi_time() function. + Documented that bind_col() can take an atribute hash. + Clarified documentation for ParamValues attribute hash keys. + Many good DBI documentation tweaks from Jonathan Leffler, + including a major update to the DBI::DBD driver author guide. + Clarified that execute() should itself call finish() if it's + called on a statement handle that's still active. + Clarified $sth->{ParamValues}. Driver authors please note. + Removed "NEW" markers on some methods and attributes and + added text to each giving the DBI version it was added in, + if it was added after DBI 1.21 (Feb 2002). + + Changes of note for authors of all drivers: + Added SQL_DATA_TYPE, SQL_DATETIME_SUB, NUM_PREC_RADIX, and + INTERVAL_PRECISION fields to docs for type_info_all. There were + already in type_info(), but type_info_all() didn't specify the + index values. Please check and update your type_info_all() code. + Added DBI::DBD::Metadata module that auto-generates your drivers + get_info and type_info_all data and code, thanks mainly to + Jonathan Leffler and Steffen Goeldner. If you've not implemented + get_info and type_info_all methods and your database has an ODBC + driver available then this will do all the hard work for you! + Drivers should no longer pass Err, Errstr, or State to _new_drh + or _new_dbh functions. + Please check that you support the slightly modified behaviour of + $sth->{ParamValues}, e.g., always return hash with keys if possible. + + Changes of note for authors of compiled drivers: + Added dbd_db_login6 & dbd_st_finish3 prototypes thanks to Jonathan Leffler. + All dbd_*_*() functions implemented by drivers must have a + corresponding #define dbd_*_* _*_* otherwise + the driver may not work with a future release of the DBI. + + Changes of note for authors of drivers which use Driver.xst: + Some new method hooks have been added are are enabled by + defining corresponding macros: + $drh->data_sources() - dbd_dr_data_sources + $dbh->do() - dbd_db_do4 + The following methods won't be compiled into the driver unless + the corresponding macro has been #defined: + $drh->disconnect_all() - dbd_discon_all + + +=head2 Changes in DBI 1.32, 1st December 2002 + + Fixed to work with 5.005_03 thanks to Tatsuhiko Miyagawa (I've not tested it). + Reenabled taint tests (accidentally left disabled) spotted by Bradley Baetz. + Improved docs for FetchHashKeyName attribute thanks to Ian Barwick. + Fixed core dump if fetchrow_hashref given bad argument (name of attribute + with a value that wasn't an array reference), spotted by Ian Barwick. + Fixed some compiler warnings thanks to David Wheeler. + Updated Steven Hirsch's enhanced proxy work (seems I left out a bit). + Made t/40profile.t tests more reliable, reported by Randy, who is part of + the excellent CPAN testers team: http://testers.cpan.org/ + (Please visit, see the valuable work they do and, ideally, join in!) + +=head2 Changes in DBI 1.31, 29th November 2002 + + The fetchall_arrayref method, when called with a $maxrows parameter, + no longer gives an error if called again after all rows have been + fetched. This simplifies application logic when fetching in batches. + Also added batch-fetch while() loop example to the docs. + The proxy now supports non-lazy (synchronous) prepare, positioned + updates (for selects containing 'for update'), PlRPC config set + via attributes, and accurate propagation of errors, all thanks + to Steven Hirsch (plus a minor fix from Sean McMurray and doc + tweaks from Michael A Chase). + The DBI_AUTOPROXY env var can now hold the full dsn of the proxy driver + plus attributes, like "dbi:Proxy(proxy_foo=>1):host=...". + Added TaintIn & TaintOut attributes to give finer control over + tainting thanks to Bradley Baetz. + The RootClass attribute no longer ignores failure to load a module, + but also doesn't try to load a module if the class already exists, + with thanks to James FitzGibbon. + HandleError attribute works for connect failures thanks to David Wheeler. + The connect() RaiseError/PrintError message now includes the username. + Changed "last handle unknown or destroyed" warning to be a trace message. + Removed undocumented $h->event() method. + Further enhancements to DBD::PurePerl accuracy. + The CursorName attribute now defaults to undef and not an error. + + DBI::Profile changes: + New DBI::ProfileDumper, DBI::ProfileDumper::Apache, and + DBI::ProfileData modules (to manage the storage and processing + of profile data), plus dbiprof program for analyzing profile + data - with many thanks to Sam Tregar. + Added $DBI::err (etc) tied variable lookup time to profile. + Added time for DESTROY method into parent handles profile (used to be ignored). + + Documentation changes: + Documented $dbh = $sth->{Database} attribute. + Documented $dbh->connected(...) post-connection call when subclassing. + Updated some minor doc issues thanks to H.Merijn Brand. + Updated Makefile.PL example in DBI::DBD thanks to KAWAI,Takanori. + Fixed execute_array() example thanks to Peter van Hardenberg. + + Changes for driver authors, not required but strongly recommended: + Change DBIS to DBIc_DBISTATE(imp_xxh) [or imp_dbh, imp_sth etc] + Change DBILOGFP to DBIc_LOGPIO(imp_xxh) [or imp_dbh, imp_sth etc] + Any function from which all instances of DBIS and DBILOGFP are + removed can also have dPERLINTERP removed (a good thing). + All use of the DBIh_EVENT* macros should be removed. + Major update to DBI::DBD docs thanks largely to Jonathan Leffler. + Add these key values: 'Err' => \my $err, 'Errstr' => \my $errstr, + to the hash passed to DBI::_new_dbh() in your driver source code. + That will make each $dbh have it's own $h->err and $h->errstr + values separate from other $dbh belonging to the same driver. + If you have a ::db or ::st DESTROY methods that do nothing + you can now remove them - which speeds up handle destruction. + + +=head2 Changes in DBI 1.30, 18th July 2002 + + Fixed problems with selectrow_array, selectrow_arrayref, and + selectall_arrayref introduced in DBI 1.29. + Fixed FETCHing a handle attribute to not clear $DBI::err etc (broken in 1.29). + Fixed core dump at trace level 9 or above. + Fixed compilation with perl 5.6.1 + ithreads (i.e. Windows). + Changed definition of behaviour of selectrow_array when called in a scalar + context to match fetchrow_array. + Corrected selectrow_arrayref docs which showed selectrow_array thanks to Paul DuBois. + +=head2 Changes in DBI 1.29, 15th July 2002 + + NOTE: This release changes the specified behaviour for the + : fetchrow_array method when called in a scalar context: + : The DBI spec used to say that it would return the FIRST field. + : Which field it returns (i.e., the first or the last) is now undefined. + : This does not affect statements that only select one column, which is + : usually the case when fetchrow_array is called in a scalar context. + : FYI, this change was triggered by discovering that the fetchrow_array + : implementation in Driver.xst (used by most compiled drivers) + : didn't match the DBI specification. Rather than change the code + : to match, and risk breaking existing applications, I've changed the + : specification (that part was always of dubious value anyway). + + NOTE: Future versions of the DBI may not support for perl 5.5 much longer. + : If you are still using perl 5.005_03 you should be making plans to + : upgrade to at least perl 5.6.1, or 5.8.0. Perl 5.8.0 is due to be + : released in the next week or so. (Although it's a "point 0" release, + : it is the most throughly tested release ever.) + + Added XS/C implementations of selectrow_array, selectrow_arrayref, and + selectall_arrayref to Driver.xst. See DBI 1.26 Changes for more info. + Removed support for the old (fatally flawed) "5005" threading model. + Added support for new perl 5.8 iThreads thanks to Gerald Richter. + (Threading support and safety should still be regarded as beta + quality until further notice. But it's much better than it was.) + Updated the "Threads and Thread Safety" section of the docs. + The trace output can be sent to STDOUT instead of STDERR by using + "STDOUT" as the name of the file, i.e., $h->trace(..., "STDOUT") + Added pointer to perlreftut, perldsc, perllol, and perlboot manuals + into the intro section of the docs, suggested by Brian McCain. + Fixed DBI::Const::GetInfo::* pod docs thanks to Zack Weinberg. + Some changes to how $dbh method calls are treated by DBI::Profile: + Meta-data methods now clear $dbh->{Statement} on entry. + Some $dbh methods are now profiled as if $dbh->{Statement} was empty + (because thet're unlikely to actually relate to its contents). + Updated dbiport.h to ppport.h from perl 5.8.0. + Tested with perl 5.5.3 (vanilla, Solaris), 5.6.1 (vanilla, Solaris), and + perl 5.8.0 (RC3@17527 with iThreads & Multiplicity on Solaris and FreeBSD). + +=head2 Changes in DBI 1.28, 14th June 2002 + + Added $sth->{ParamValues} to return a hash of the most recent + values bound to placeholders via bind_param() or execute(). + Individual drivers need to be updated to support it. + Enhanced ShowErrorStatement to include ParamValues if available: + "DBD::foo::st execute failed: errstr [for statement ``...'' with params: 1='foo']" + Further enhancements to DBD::PurePerl accuracy. + +=head2 Changes in DBI 1.27, 13th June 2002 + + Fixed missing column in C implementation of fetchall_arrayref() + thanks to Philip Molter for the prompt reporting of the problem. + +=head2 Changes in DBI 1.26, 13th June 2002 + + Fixed t/40profile.t to work on Windows thanks to Smejkal Petr. + Fixed $h->{Profile} to return undef, not error, if not set. + Fixed DBI->available_drivers in scalar context thanks to Michael Schwern. + + Added C implementations of selectrow_arrayref() and fetchall_arrayref() + in Driver.xst. All compiled drivers using Driver.xst will now be + faster making those calls. Most noticable with fetchall_arrayref for + many rows or selectrow_arrayref with a fast query. For example, using + DBD::mysql a selectrow_arrayref for a single row using a primary key + is ~20% faster, and fetchall_arrayref for 20000 rows is twice as fast! + Drivers just need to be recompiled and reinstalled to enable it. + The fetchall_arrayref speed up only applies if $slice parameter is not used. + Added $max_rows parameter to fetchall_arrayref() to optionally limit + the number of rows returned. Can now fetch batches of rows. + Added MaxRows attribute to selectall_arrayref() + which then passes it to fetchall_arrayref(). + Changed selectrow_array to make use of selectrow_arrayref. + Trace level 1 now shows first two parameters of all methods + (used to only for that for some, like prepare,execute,do etc) + Trace indicator for recursive calls (first char on trace lines) + now starts at 1 not 2. + + Documented that $h->func() does not trigger RaiseError etc + so applications must explicitly check for errors. + DBI::Profile with DBI_PROFILE now shows percentage time inside DBI. + HandleError docs updated to show that handler can edit error message. + HandleError subroutine interface is now regarded as stable. + +=head2 Changes in DBI 1.25, 5th June 2002 + + Fixed build problem on Windows and some compiler warnings. + Fixed $dbh->{Driver} and $sth->{Statement} for driver internals + These are 'inner' handles as per behaviour prior to DBI 1.16. + Further minor improvements to DBI::PurePerl accuracy. + +=head2 Changes in DBI 1.24, 4th June 2002 + + Fixed reference loop causing a handle/memory leak + that was introduced in DBI 1.16. + Fixed DBI::Format to work with 'filehandles' from IO::Scalar + and similar modules thanks to report by Jeff Boes. + Fixed $h->func for DBI::PurePerl thanks to Jeff Zucker. + Fixed $dbh->{Name} for DBI::PurePerl thanks to Dean Arnold. + + Added DBI method call profiling and benchmarking. + This is a major new addition to the DBI. + See $h->{Profile} attribute and DBI::Profile module. + For a quick trial, set the DBI_PROFILE environment variable and + run your favourite DBI script. Try it with DBI_PROFILE set to 1, + then try 2, 4, 8, 10, and -10. Have fun! + + Added execute_array() and bind_param_array() documentation + with thanks to Dean Arnold. + Added notes about the DBI having not yet been tested with iThreads + (testing and patches for SvLOCK etc welcome). + Removed undocumented Handlers attribute (replaced by HandleError). + Tested with 5.5.3 and 5.8.0 RC1. + +=head2 Changes in DBI 1.23, 25th May 2002 + + Greatly improved DBI::PurePerl in performance and accuracy. + Added more detail to DBI::PurePerl docs about what's not supported. + Fixed undef warnings from t/15array.t and DBD::Sponge. + +=head2 Changes in DBI 1.22, 22nd May 2002 + + Added execute_array() and bind_param_array() with special thanks + to Dean Arnold. Not yet documented. See t/15array.t for examples. + All drivers now automatically support these methods. + Added DBI::PurePerl, a transparent DBI emulation for pure-perl drivers + with special thanks to Jeff Zucker. Perldoc DBI::PurePerl for details. + Added DBI::Const::GetInfo* modules thanks to Steffen Goeldner. + Added write_getinfo_pm utility to DBI::DBD thanks to Steffen Goeldner. + Added $allow_active==2 mode for prepare_cached() thanks to Stephen Clouse. + + Updated DBI::Format to Revision 11.4 thanks to Tom Lowery. + Use File::Spec in Makefile.PL (helps VMS etc) thanks to Craig Berry. + Extend $h->{Warn} to commit/rollback ineffective warning thanks to Jeff Baker. + Extended t/preparse.t and removed "use Devel::Peek" thanks to Scott Hildreth. + Only copy Changes to blib/lib/Changes.pm once thanks to Jonathan Leffler. + Updated internals for modern perls thanks to Jonathan Leffler and Jeff Urlwin. + Tested with perl 5.7.3 (just using default perl config). + + Documentation changes: + + Added 'Catalog Methods' section to docs thanks to Steffen Goeldner. + Updated README thanks to Michael Schwern. + Clarified that driver may choose not to start new transaction until + next use of $dbh after commit/rollback. + Clarified docs for finish method. + Clarified potentials problems with prepare_cached() thanks to Stephen Clouse. + + +=head2 Changes in DBI 1.21, 7th February 2002 + + The minimum supported perl version is now 5.005_03. + + Fixed DBD::Proxy support for AutoCommit thanks to Jochen Wiedmann. + Fixed DBI::ProxyServer bind_param(_inout) handing thanks to Oleg Mechtcheriakov. + Fixed DBI::ProxyServer fetch loop thanks to nobull@mail.com. + Fixed install_driver do-the-right-thing with $@ on error. It, and connect(), + will leave $@ empty on success and holding the error message on error. + Thanks to Jay Lawrence, Gavin Sherlock and others for the bug report. + Fixed fetchrow_hashref to assign columns to the hash left-to-right + so later fields with the same name overwrite earlier ones + as per DBI < 1.15, thanks to Kay Roepke. + + Changed tables() to use quote_indentifier() if the driver returns a + true value for $dbh->get_info(29) # SQL_IDENTIFIER_QUOTE_CHAR + Changed ping() so it no longer triggers RaiseError/PrintError. + Changed connect() to not call $class->install_driver unless needed. + Changed DESTROY to catch fatal exceptions and append to $@. + + Added ISO SQL/CLI & ODBCv3 data type definitions thanks to Steffen Goeldner. + Removed the definition of SQL_BIGINT data type constant as the value is + inconsistent between standards (ODBC=-5, SQL/CLI=25). + Added $dbh->column_info(...) thanks to Steffen Goeldner. + Added $dbh->foreign_key_info(...) thanks to Steffen Goeldner. + Added $dbh->quote_identifier(...) insipred by Simon Oliver. + Added $dbh->set_err(...) for DBD authors and DBI subclasses + (actually been there for a while, now expanded and documented). + Added $h->{HandleError} = sub { ... } addition and/or alternative + to RaiseError/PrintError. See the docs for more info. + Added $h->{TraceLevel} = N attribute to set/get trace level of handle + thus can set trace level via an (eg externally specified) DSN + using the embedded attribute syntax: + $dsn = 'dbi:DB2(PrintError=1,TraceLevel=2):dbname'; + Plus, you can also now do: local($h->{TraceLevel}) = N; + (but that leaks a little memory in some versions of perl). + Added some call tree information to trace output if trace level >= 3 + With thanks to Graham Barr for the stack walking code. + Added experimental undocumented $dbh->preparse(), see t/preparse.t + With thanks to Scott T. Hildreth for much of the work. + Added Fowler/Noll/Vo hash type as an option to DBI::hash(). + + Documentation changes: + + Added DBI::Changes so now you can "perldoc DBI::Changes", yeah! + Added selectrow_arrayref & selectrow_hashref docs thanks to Doug Wilson. + Added 'Standards Reference Information' section to docs to gather + together all references to relevant on-line standards. + Added link to poop.sourceforge.net into the docs thanks to Dave Rolsky. + Added link to hyperlinked BNF for SQL92 thanks to Jeff Zucker. + Added 'Subclassing the DBI' docs thanks to Stephen Clouse, and + then changed some of them to reflect the new approach to subclassing. + Added stronger wording to description of $h->{private_*} attributes. + Added docs for DBI::hash. + + Driver API changes: + + Now a COPY of the DBI->connect() attributes is passed to the driver + connect() method, so it can process and delete any elements it wants. + Deleting elements reduces/avoids the explicit + $dbh->{$_} = $attr->{$_} foreach keys %$attr; + that DBI->connect does after the driver connect() method returns. + + +=head2 Changes in DBI 1.20, 24th August 2001 + + WARNING: This release contains two changes that may affect your code. + : Any code using selectall_hashref(), which was added in March 2001, WILL + : need to be changed. Any code using fetchall_arrayref() with a non-empty + : hash slice parameter may, in a few rare cases, need to be changed. + : See the change list below for more information about the changes. + : See the DBI documentation for a description of current behaviour. + + Fixed memory leak thanks to Toni Andjelkovic. + Changed fetchall_arrayref({ foo=>1, ...}) specification again (sorry): + The key names of the returned hashes is identical to the letter case of + the names in the parameter hash, regardless of the L + attribute. The letter case is ignored for matching. + Changed fetchall_arrayref([...]) array slice syntax specification to + clarify that the numbers in the array slice are perl index numbers + (which start at 0) and not column numbers (which start at 1). + Added { Columns=>... } and { Slice =>... } attributes to selectall_arrayref() + which is passed to fetchall_arrayref() so it can fetch hashes now. + Added a { Columns => [...] } attribute to selectcol_arrayref() so that + the list it returns can be built from more than one column per row. + Why? Consider my %hash = @{$dbh->selectcol_arrayref($sql,{ Columns=>[1,2]})} + to return id-value pairs which can be used directly to build a hash. + Added $hash_ref = $sth->fetchall_hashref( $key_field ) + which returns a ref to a hash with, typically, one element per row. + $key_field is the name of the field to get the key for each row from. + The value of the hash for each row is a hash returned by fetchrow_hashref. + Changed selectall_hashref to return a hash ref (from fetchall_hashref) + and not an array of hashes as it has since DBI 1.15 (end March 2001). + WARNING: THIS CHANGE WILL BREAK ANY CODE USING selectall_hashref()! + Sorry, but I think this is an important regularization of the API. + To get previous selectall_hashref() behaviour (an array of hash refs) + change $ary_ref = $dbh->selectall_hashref( $statement, undef, @bind); + to $ary_ref = $dbh->selectall_arrayref($statement, { Columns=>{} }, @bind); + Added NAME_lc_hash, NAME_uc_hash, NAME_hash statement handle attributes. + which return a ref to a hash of field_name => field_index (0..n-1) pairs. + Fixed select_hash() example thanks to Doug Wilson. + Removed (unbundled) DBD::ADO and DBD::Multiplex from the DBI distribution. + The latest versions of those modules are available from CPAN sites. + Added $dbh->begin_work. This method causes AutoCommit to be turned + off just until the next commit() or rollback(). + Driver authors: if the DBIcf_BegunWork flag is set when your commit or + rollback method is called then please turn AutoCommit on and clear the + DBIcf_BegunWork flag. If you don't then the DBI will but it'll be much + less efficient and won't handle error conditions very cleanly. + Retested on perl 5.4.4, but the DBI won't support 5.4.x much longer. + Added text to SUPPORT section of the docs: + For direct DBI and DBD::Oracle support, enhancement, and related work + I am available for consultancy on standard commercial terms. + Added text to ACKNOWLEDGEMENTS section of the docs: + Much of the DBI and DBD::Oracle was developed while I was Technical + Director (CTO) of the Paul Ingram Group (www.ig.co.uk). So I'd + especially like to thank Paul for his generosity and vision in + supporting this work for many years. + +=head2 Changes in DBI 1.19, 20th July 2001 + + Made fetchall_arrayref({ foo=>1, ...}) be more strict to the specification + in relation to wanting hash slice keys to be lowercase names. + WARNING: If you've used fetchall_arrayref({...}) with a hash slice + that contains keys with uppercase letters then your code will break. + (As far as I recall the spec has always said don't do that.) + Fixed $sth->execute() to update $dbh->{Statement} to $sth->{Statement}. + Added row number to trace output for fetch method calls. + Trace level 1 no longer shows fetches with row>1 (to reduce output volume). + Added $h->{FetchHashKeyName} = 'NAME_lc' or 'NAME_uc' to alter + behaviour of fetchrow_hashref() method. See docs. + Added type_info quote caching to quote() method thanks to Dean Kopesky. + Makes using quote() with second data type param much much faster. + Added type_into_all() caching to type_info(), spotted by Dean Kopesky. + Added new API definition for table_info() and tables(), + driver authors please note! + Added primary_key_info() to DBI API thanks to Steffen Goeldner. + Added primary_key() to DBI API as simpler interface to primary_key_info(). + Indent and other fixes for DBI::DBD doc thanks to H.Merijn Brand. + Added prepare_cached() insert_hash() example thanks to Doug Wilson. + Removed false docs for fetchall_hashref(), use fetchall_arrayref({}). + +=head2 Changes in DBI 1.18, 4th June 2001 + + Fixed that altering ShowErrorStatement also altered AutoCommit! + Thanks to Jeff Boes for spotting that clanger. + Fixed DBD::Proxy to handle commit() and rollback(). Long overdue, sorry. + Fixed incompatibility with perl 5.004 (but no one's using that right? :) + Fixed connect_cached and prepare_cached to not be affected by the order + of elements in the attribute hash. Spotted by Mitch Helle-Morrissey. + Fixed version number of DBI::Shell + reported by Stuhlpfarrer Gerhard and others. + Defined and documented table_info() attribute semantics (ODBC compatible) + thanks to Olga Voronova, who also implemented then in DBD::Oracle. + Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. + +=head2 Changes in DBI 1.16, 30th May 2001 + + Reimplemented fetchrow_hashref in C, now fetches about 25% faster! + Changed behaviour if both PrintError and RaiseError are enabled + to simply do both (in that order, obviously :) + Slight reduction in DBI handle creation overhead. + Fixed $dbh->{Driver} & $sth->{Database} to return 'outer' handles. + Fixed execute param count check to honour RaiseError spotted by Belinda Giardie. + Fixed build for perl5.6.1 with PERLIO thanks to H.Merijn Brand. + Fixed client sql restrictions in ProxyServer.pm thanks to Jochen Wiedmann. + Fixed batch mode command parsing in Shell thanks to Christian Lemburg. + Fixed typo in selectcol_arrayref docs thanks to Jonathan Leffler. + Fixed selectrow_hashref to be available to callers thanks to T.J.Mather. + Fixed core dump if statement handle didn't define Statement attribute. + Added bind_param_inout docs to DBI::DBD thanks to Jonathan Leffler. + Added note to data_sources() method docs that some drivers may + require a connected database handle to be supplied as an attribute. + Trace of install_driver method now shows path of driver file loaded. + Changed many '||' to 'or' in the docs thanks to H.Merijn Brand. + Updated DBD::ADO again (improvements in error handling) from Tom Lowery. + Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. + Updated email and web addresses in DBI::FAQ thanks to Michael A Chase. + +=head2 Changes in DBI 1.15, 28th March 2001 + + Added selectrow_arrayref + Added selectrow_hashref + Added selectall_hashref thanks to Leon Brocard. + Added DBI->connect(..., { dbi_connect_method => 'method' }) + Added $dbh->{Statement} aliased to most recent child $sth->{Statement}. + Added $h->{ShowErrorStatement}=1 to cause the appending of the + relevant Statement text to the RaiseError/PrintError text. + Modified type_info to always return hash keys in uppercase and + to not require uppercase 'DATA_TYPE' key from type_info_all. + Thanks to Jennifer Tong and Rob Douglas. + Added \%attr param to tables() and table_info() methods. + Trace method uses warn() if it can't open the new file. + Trace shows source line and filename during global destruction. + Updated packages: + Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. + Updated DBD::ADO to much improved version 0.4 from Tom Lowery. + Updated DBD::Sponge to include $sth->{PRECISION} thanks to Tom Lowery. + Changed DBD::ExampleP to use lstat() instead of stat(). + Documentation: + Documented $DBI::lasth (which has been there since day 1). + Documented SQL_* names. + Clarified and extended docs for $h->state thanks to Masaaki Hirose. + Clarified fetchall_arrayref({}) docs (thanks to, er, someone!). + Clarified type_info_all re lettercase and index values. + Updated DBI::FAQ to 0.38 thanks to Alligator Descartes. + Added cute bind_columns example thanks to H.Merijn Brand. + Extended docs on \%attr arg to data_sources method. + Makefile.PL + Removed obscure potential 'rm -rf /' (thanks to Ulrich Pfeifer). + Removed use of glob and find (thanks to Michael A. Chase). + Proxy: + Removed debug messages from DBD::Proxy AUTOLOAD thanks to Brian McCauley. + Added fix for problem using table_info thanks to Tom Lowery. + Added better determination of where to put the pid file, and... + Added KNOWN ISSUES section to DBD::Proxy docs thanks to Jochen Wiedmann. + Shell: + Updated DBI::Format to include DBI::Format::String thanks to Tom Lowery. + Added describe command thanks to Tom Lowery. + Added columnseparator option thanks to Tom Lowery (I think). + Added 'raw' format thanks to, er, someone, maybe Tom again. + Known issues: + Perl 5.005 and 5.006 both leak memory doing local($handle->{Foo}). + Perl 5.004 doesn't. The leak is not a DBI or driver bug. + +=head2 Changes in DBI 1.14, 14th June 2000 + + NOTE: This version is the one the DBI book is based on. + NOTE: This version requires at least Perl 5.004. + Perl 5.6 ithreads changes with thanks to Doug MacEachern. + Changed trace output to use PerlIO thanks to Paul Moore. + Fixed bug in RaiseError/PrintError handling. + (% chars in the error string could cause a core dump.) + Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt. + Major documentation polishing thanks to Linda Mui at O'Reilly. + Password parameter now shown as **** in trace output. + Added two fields to type_info and type_info_all. + Added $dsn to PrintError/RaiseError message from DBI->connect(). + Changed prepare_cached() croak to carp if sth still Active. + Added prepare_cached() example to the docs. + Added further DBD::ADO enhancements from Thomas Lowery. + +=head2 Changes in DBI 1.13, 11th July 1999 + + Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt. + Fixed problems with DBD::ExampleP long_list test mode. + Added SQL_WCHAR SQL_WVARCHAR SQL_WLONGVARCHAR and SQL_BIT + to list of known and exportable SQL types. + Improved data fetch performance of DBD::ADO. + Added GetTypeInfo to DBD::ADO thanks to Thomas Lowery. + Actually documented connect_cached thanks to Michael Schwern. + Fixed user/key/cipher bug in ProxyServer thanks to Joshua Pincus. + +=head2 Changes in DBI 1.12, 29th June 1999 + + Fixed significant DBD::ADO bug (fetch skipped first row). + Fixed ProxyServer bug handling non-select statements. + Fixed VMS problem with t/examp.t thanks to Craig Berry. + Trace only shows calls to trace_msg and _set_fbav at high levels. + Modified t/examp.t to workaround Cygwin buffering bug. + +=head2 Changes in DBI 1.11, 17th June 1999 + + Fixed bind_columns argument checking to allow a single arg. + Fixed problems with internal default_user method. + Fixed broken DBD::ADO. + Made default $DBI::rows more robust for some obscure cases. + +=head2 Changes in DBI 1.10, 14th June 1999 + + Fixed trace_msg.al error when using Apache. + Fixed dbd_st_finish enhancement in Driver.xst (internals). + Enable drivers to define default username and password + and temporarily disabled warning added in 1.09. + Thread safety optimised for single thread case. + +=head2 Changes in DBI 1.09, 9th June 1999 + + Added optional minimum trace level parameter to trace_msg(). + Added warning in Makefile.PL that DBI will require 5.004 soon. + Added $dbh->selectcol_arrayref($statement) method. + Fixed fetchall_arrayref hash-slice mode undef NAME problem. + Fixed problem with tainted parameter checking and t/examp.t. + Fixed problem with thread safety code, including 64 bit machines. + Thread safety now enabled by default for threaded perls. + Enhanced code for MULTIPLICITY/PERL_OBJECT from ActiveState. + Enhanced prepare_cached() method. + Minor changes to trace levels (less internal info at level 2). + Trace log now shows "!! ERROR..." before the "<- method" line. + DBI->connect() now warn's if user / password is undefined and + DBI_USER / DBI_PASS environment variables are not defined. + The t/proxy.t test now ignores any /etc/dbiproxy.conf file. + Added portability fixes for MacOS from Chris Nandor. + Updated mailing list address from fugue.com to isc.org. + +=head2 Changes in DBI 1.08, 12th May 1999 + + Much improved DBD::ADO driver thanks to Phlip Plumlee and others. + Connect now allows you to specify attribute settings within the DSN + E.g., "dbi:Driver(RaiseError=>1,Taint=>1,AutoCommit=>0):dbname" + The $h->{Taint} attribute now also enables taint checking of + arguments to almost all DBI methods. + Improved trace output in various ways. + Fixed bug where $sth->{NAME_xx} was undef in some situations. + Fixed code for MULTIPLICITY/PERL_OBJECT thanks to Alex Smishlajev. + Fixed and documented DBI->connect_cached. + Workaround for Cygwin32 build problem with help from Jong-Pork Park. + bind_columns no longer needs undef or hash ref as first parameter. + +=head2 Changes in DBI 1.07, 6th May 1999 + + Trace output now shows contents of array refs returned by DBI. + Changed names of some result columns from type_info, type_info_all, + tables and table_info to match ODBC 3.5 / ISO/IEC standards. + Many fixes for DBD::Proxy and ProxyServer. + Fixed error reporting in install_driver. + Major enhancement to DBI::W32ODBC from Patrick Hollins. + Added $h->{Taint} to taint fetched data if tainting (perl -T). + Added code for MULTIPLICITY/PERL_OBJECT contributed by ActiveState. + Added $sth->more_results (undocumented for now). + +=head2 Changes in DBI 1.06, 6th January 1999 + + Fixed Win32 Makefile.PL problem in 1.04 and 1.05. + Significant DBD::Proxy enhancements and fixes + including support for bind_param_inout (Jochen and I) + Added experimental DBI->connect_cached method. + Added $sth->{NAME_uc} and $sth->{NAME_lc} attributes. + Enhanced fetchrow_hashref to take an attribute name arg. + +=head2 Changes in DBI 1.05, 4th January 1999 + + Improved DBD::ADO connect (thanks to Phlip Plumlee). + Improved thread safety (thanks to Jochen Wiedmann). + [Quick release prompted by truncation of copies on CPAN] + +=head2 Changes in DBI 1.04, 3rd January 1999 + + Fixed error in Driver.xst. DBI build now tests Driver.xst. + Removed unused variable compiler warnings in Driver.xst. + DBI::DBD module now tested during DBI build. + Further clarification in the DBI::DBD driver writers manual. + Added optional name parameter to $sth->fetchrow_hashref. + +=head2 Changes in DBI 1.03, 1st January 1999 + + Now builds with Perl>=5.005_54 (PERL_POLLUTE in DBIXS.h) + DBI trace trims path from "at yourfile.pl line nnn". + Trace level 1 now shows statement passed to prepare. + Assorted improvements to the DBI manual. + Assorted improvements to the DBI::DBD driver writers manual. + Fixed $dbh->quote prototype to include optional $data_type. + Fixed $dbh->prepare_cached problems. + $dbh->selectrow_array behaves better in scalar context. + Added a (very) experimental DBD::ADO driver for Win32 ADO. + Added experimental thread support (perl Makefile.PL -thread). + Updated the DBI::FAQ - thanks to Alligator Descartes. + The following changes were implemented and/or packaged + by Jochen Wiedmann - thanks Jochen: + Added a Bundle for CPAN installation of DBI, the DBI proxy + server and prerequisites (lib/Bundle/DBI.pm). + DBI->available_drivers uses File::Spec, if available. + This makes it work on MacOS. (DBI.pm) + Modified type_info to work with read-only values returned + by type_info_all. (DBI.pm) + Added handling of magic values in $sth->execute, + $sth->bind_param and other methods (Driver.xst) + Added Perl's CORE directory to the linkers path on Win32, + required by recent versions of ActiveState Perl. + Fixed DBD::Sponge to work with empty result sets. + Complete rewrite of DBI::ProxyServer and DBD::Proxy. + +=head2 Changes in DBI 1.02, 2nd September 1998 + + Fixed DBI::Shell including @ARGV and /current. + Added basic DBI::Shell test. + Renamed DBI::Shell /display to /format. + +=head2 Changes in DBI 1.01, 2nd September 1998 + + Many enhancements to Shell (with many contributions from + Jochen Wiedmann, Tom Lowery and Adam Marks). + Assorted fixes to DBD::Proxy and DBI::ProxyServer. + Tidied up trace messages - trace(2) much cleaner now. + Added $dbh->{RowCacheSize} and $sth->{RowsInCache}. + Added experimental DBI::Format (mainly for DBI::Shell). + Fixed fetchall_arrayref($slice_hash). + DBI->connect now honours PrintError=1 if connect fails. + Assorted clarifications to the docs. + +=head2 Changes in DBI 1.00, 14th August 1998 + + The DBI is no longer 'alpha' software! + Added $dbh->tables and $dbh->table_info. + Documented \%attr arg to data_sources method. + Added $sth->{TYPE}, $sth->{PRECISION} and $sth->{SCALE}. + Added $sth->{Statement}. + DBI::Shell now uses neat_list to print results + It also escapes "'" chars and converts newlines to spaces. + +=head2 Changes in DBI 0.95, 10th August 1998 + + WARNING: THIS IS AN EXPERIMENTAL RELEASE! + + Fixed 0.94 slip so it will build on pre-5.005 again. + Added DBI_AUTOPROXY environment variable. + Array ref returned from fetch/fetchrow_arrayref now readonly. + Improved connect error reporting by DBD::Proxy. + All trace/debug messages from DBI now go to trace file. + +=head2 Changes in DBI 0.94, 9th August 1998 + + WARNING: THIS IS AN EXPERIMENTAL RELEASE! + + Added DBD::Shell and dbish interactive DBI shell. Try it! + Any database attribs can be set via DBI->connect(,,, \%attr). + Added _get_fbav and _set_fbav methods for Perl driver developers + (see ExampleP driver for perl usage). Drivers which don't use + one of these methods (either via XS or Perl) are not compliant. + DBI trace now shows adds " at yourfile.pl line nnn"! + PrintError and RaiseError now prepend driver and method name. + The available_drivers method no longer returns NullP or Sponge. + Added $dbh->{Name}. + Added $dbh->quote($value, $data_type). + Added more hints to install_driver failure message. + Added DBD::Proxy and DBI::ProxyServer (from Jochen Wiedmann). + Added $DBI::neat_maxlen to control truncation of trace output. + Added $dbh->selectall_arrayref and $dbh->selectrow_array methods. + Added $dbh->tables. + Added $dbh->type_info and $dbh->type_info_all. + Added $h->trace_msg($msg) to write to trace log. + Added @bool = DBI::looks_like_number(@ary). + Many assorted improvements to the DBI docs. + +=head2 Changes in DBI 0.93, 13th February 1998 + + Fixed DBI::DBD::dbd_postamble bug causing 'Driver.xsi not found' errors. + Changes to handling of 'magic' values in neatsvpv (used by trace). + execute (in Driver.xst) stops binding after first bind error. + This release requires drivers to be rebuilt. + +=head2 Changes in DBI 0.92, 3rd February 1998 + + Fixed per-handle memory leak (with many thanks to Irving Reid). + Added $dbh->prepare_cached() caching variant of $dbh->prepare. + Added some attributes: + $h->{Active} is the handle 'Active' (vague concept) (boolean) + $h->{Kids} e.g. number of sth's associated with a dbh + $h->{ActiveKids} number of the above which are 'Active' + $dbh->{CachedKids} ref to prepare_cached sth cache + Added support for general-purpose 'private_' attributes. + Added experimental support for subclassing the DBI: see t/subclass.t + Added SQL_ALL_TYPES to exported :sql_types. + Added dbd_dbi_dir() and dbd_dbi_arch_dir() to DBI::DBD module so that + DBD Makefile.PLs can work with the DBI installed in non-standard locations. + Fixed 'Undefined value' warning and &sv_no output from neatsvpv/trace. + Fixed small 'once per interpreter' leak. + Assorted minor documentation fixes. + +=head2 Changes in DBI 0.91, 10th December 1997 + + NOTE: This fix may break some existing scripts: + DBI->connect("dbi:...",$user,$pass) was not setting AutoCommit and PrintError! + DBI->connect(..., { ... }) no longer sets AutoCommit or PrintError twice. + DBI->connect(..., { RaiseError=>1 }) now croaks if connect fails. + Fixed $fh parameter of $sth->dump_results; + Added default statement DESTROY method which carps. + Added default driver DESTROY method to silence AUTOLOAD/__DIE__/CGI::Carp + Added more SQL_* types to %EXPORT_TAGS and @EXPORT_OK. + Assorted documentation updates (mainly clarifications). + Added workaround for perl's 'sticky lvalue' bug. + Added better warning for bind_col(umns) where fields==0. + Fixed to build okay with 5.004_54 with or without USE_THREADS. + Note that the DBI has not been tested for thread safety yet. + +=head2 Changes in DBI 0.90, 6th September 1997 + + Can once again be built with Perl 5.003. + The DBI class can be subclassed more easily now. + InactiveDestroy fixed for drivers using the *.xst template. + Slightly faster handle creation. + Changed prototype for dbd_*_*_attrib() to add extra param. + Note: 0.90, 0.89 and possibly some other recent versions have + a small memory leak. This will be fixed in the next release. + +=head2 Changes in DBI 0.89, 25th July 1997 + + Minor fix to neatsvpv (mainly used for debug trace) to workaround + bug in perl where SvPV removes IOK flag from an SV. + Minor updates to the docs. + +=head2 Changes in DBI 0.88, 22nd July 1997 + + Fixed build for perl5.003 and Win32 with Borland. + Fixed documentation formatting. + Fixed DBI_DSN ignored for old-style connect (with explicit driver). + Fixed AutoCommit in DBD::ExampleP + Fixed $h->trace. + The DBI can now export SQL type values: use DBI ':sql_types'; + Modified Driver.xst and renamed DBDI.h to dbd_xsh.h + +=head2 Changes in DBI 0.87, 18th July 1997 + + Fixed minor type clashes. + Added more docs about placeholders and bind values. + +=head2 Changes in DBI 0.86, 16th July 1997 + + Fixed failed connect causing 'unblessed ref' and other errors. + Drivers must handle AutoCommit FETCH and STORE else DBI croaks. + Added $h->{LongReadLen} and $h->{LongTruncOk} attributes for BLOBS. + Added DBI_USER and DBI_PASS env vars. See connect docs for usage. + Added DBI->trace() to set global trace level (like per-handle $h->trace). + PERL_DBI_DEBUG env var renamed DBI_DEBUG (old name still works for now). + Updated docs, including commit, rollback, AutoCommit and Transactions sections. + Added bind_param method and execute(@bind_values) to docs. + Fixed fetchall_arrayref. + + Since the DBIS structure has change the internal version numbers have also + changed (DBIXS_VERSION == 9 and DBISTATE_VERSION == 9) so drivers will have + to be recompiled. The test is also now more sensitive and the version + mismatch error message now more clear about what to do. Old drivers are + likely to core dump (this time) until recompiled for this DBI. In future + DBI/DBD version mismatch will always produce a clear error message. + + Note that this DBI release contains and documents many new features + that won't appear in drivers for some time. Driver writers might like + to read perldoc DBI::DBD and comment on or apply the information given. + +=head2 Changes in DBI 0.85, 25th June 1997 + + NOTE: New-style connect now defaults to AutoCommit mode unless + { AutoCommit => 0 } specified in connect attributes. See the docs. + AutoCommit attribute now defined and tracked by DBI core. + Drivers should use/honour this and not implement their own. + Added pod doc changes from Andreas and Jonathan. + New DBI_DSN env var default for connect method. See docs. + Documented the func method. + Fixed "Usage: DBD::_::common::DESTROY" error. + Fixed bug which set some attributes true when there value was fetched. + Added new internal DBIc_set() macro for drivers to use. + +=head2 Changes in DBI 0.84, 20th June 1997 + + Added $h->{PrintError} attribute which, if set true, causes all errors to + trigger a warn(). + New-style DBI->connect call now automatically sets PrintError=1 unless + { PrintError => 0 } specified in the connect attributes. See the docs. + The old-style connect with a separate driver parameter is deprecated. + Fixed fetchrow_hashref. + Renamed $h->debug to $h->trace() and added a trace filename arg. + Assorted other minor tidy-ups. + +=head2 Changes in DBI 0.83, 11th June 1997 + + Added driver specification syntax to DBI->connect data_source + parameter: DBI->connect('dbi:driver:...', $user, $passwd); + The DBI->data_sources method should return data_source + names with the appropriate 'dbi:driver:' prefix. + DBI->connect will warn if \%attr is true but not a hash ref. + Added the new fetchrow methods: + @row_ary = $sth->fetchrow_array; + $ary_ref = $sth->fetchrow_arrayref; + $hash_ref = $sth->fetchrow_hashref; + The old fetch and fetchrow methods still work. + Driver implementors should implement the new names for + fetchrow_array and fetchrow_arrayref ASAP (use the xs ALIAS: + directive to define aliases for fetch and fetchrow). + Fixed occasional problems with t/examp.t test. + Added automatic errstr reporting to the debug trace output. + Added the DBI FAQ from Alligator Descartes in module form for + easy reading via "perldoc DBI::FAQ". Needs reformatting. + Unknown driver specific attribute names no longer croak. + Fixed problem with internal neatsvpv macro. + +=head2 Changes in DBI 0.82, 23rd May 1997 + + Added $h->{RaiseError} attribute which, if set true, causes all errors to + trigger a die(). This makes it much easier to implement robust applications + in terms of higher level eval { ... } blocks and rollbacks. + Added DBI->data_sources($driver) method for implementation by drivers. + The quote method now returns the string NULL (without quotes) for undef. + Added VMS support thanks to Dan Sugalski. + Added a 'quick start guide' to the README. + Added neatsvpv function pointer to DBIS structure to make it available for + use by drivers. A macro defines neatsvpv(sv,len) as (DBIS->neatsvpv(sv,len)). + Old XS macro SV_YES_NO changes to standard boolSV. + Since the DBIS structure has change the internal version numbers have also + changed (DBIXS_VERSION == 8 and DBISTATE_VERSION == 8) so drivers will have + to be recompiled. + +=head2 Changes in DBI 0.81, 7th May 1997 + + Minor fix to let DBI build using less modern perls. + Fixed a suprious typo warning. + +=head2 Changes in DBI 0.80, 6th May 1997 + + Builds with no changes on NT using perl5.003_99 (with thanks to Jeffrey Urlwin). + Automatically supports Apache::DBI (with thanks to Edmund Mergl). + DBI scripts no longer need to be modified to make use of Apache::DBI. + Added a ping method and an experimental connect_test_perf method. + Added a fetchhash and fetch_all methods. + The func method no longer pre-clears err and errstr. + Added ChopBlanks attribute (currently defaults to off, that may change). + Support for the attribute needs to be implemented by individual drivers. + Reworked tests into standard t/*.t form. + Added more pod text. Fixed assorted bugs. + + +=head2 Changes in DBI 0.79, 7th Apr 1997 + + Minor release. Tidied up pod text and added some more descriptions + (especially disconnect). Minor changes to DBI.xs to remove compiler + warnings. + +=head2 Changes in DBI 0.78, 28th Mar 1997 + + Greatly extended the pod documentation in DBI.pm, including the under + used bind_columns method. Use 'perldoc DBI' to read after installing. + Fixed $h->err. Fetching an attribute value no longer resets err. + Added $h->{InactiveDestroy}, see documentation for details. + Improved debugging of cached ('quick') attribute fetches. + errstr will return err code value if there is no string value. + Added DBI/W32ODBC to the distribution. This is a pure-perl experimental + DBI emulation layer for Win32::ODBC. Note that it's unsupported, your + mileage will vary, and bug reports without fixes will probably be ignored. + +=head2 Changes in DBI 0.77, 21st Feb 1997 + + Removed erroneous $h->errstate and $h->errmsg methods from DBI.pm. + Added $h->err, $h->errstr and $h->state default methods in DBI.xs. + Updated informal DBI API notes in DBI.pm. Updated README slightly. + DBIXS.h now correctly installed into INST_ARCHAUTODIR. + (DBD authors will need to edit their Makefile.PL's to use + -I$(INSTALLSITEARCH)/auto/DBI -I$(INSTALLSITEARCH)/DBI) + + +=head2 Changes in DBI 0.76, 3rd Feb 1997 + + Fixed a compiler type warnings (pedantic IRIX again). + +=head2 Changes in DBI 0.75, 27th Jan 1997 + + Fix problem introduced by a change in Perl5.003_XX. + Updated README and DBI.pm docs. + +=head2 Changes in DBI 0.74, 14th Jan 1997 + + Dispatch now sets dbi_debug to the level of the current handle + (this makes tracing/debugging individual handles much easier). + The '>> DISPATCH' log line now only logged at debug >= 3 (was 2). + The $csr->NUM_OF_FIELDS attribute can be set if not >0 already. + You can log to a file using the env var PERL_DBI_DEBUG=/tmp/dbi.log. + Added a type cast needed by IRIX. + No longer sets perl_destruct_level unless debug set >= 4. + Make compatible with PerlIO and sfio. + +=head2 Changes in DBI 0.73, 10th Oct 1996 + + Fixed some compiler type warnings (IRIX). + Fixed DBI->internal->{DebugLog} = $filename. + Made debug log file unbuffered. + Added experimental bind_param_inout method to interface. + Usage: $dbh->bind_param_inout($param, \$value, $maxlen [, \%attribs ]) + (only currently used by DBD::Oracle at this time.) + +=head2 Changes in DBI 0.72, 23 Sep 1996 + + Using an undefined value as a handle now gives a better + error message (mainly useful for emulators like Oraperl). + $dbh->do($sql, @params) now works for binding placeholders. + +=head2 Changes in DBI 0.71, 10 July 1996 + + Removed spurious abort() from invalid handle check. + Added quote method to DBI interface and added test. + +=head2 Changes in DBI 0.70, 16 June 1996 + + Added extra invalid handle check (dbih_getcom) + Fixed broken $dbh->quote method. + Added check for old GCC in Makefile.PL + +=head2 Changes in DBI 0.69 + + Fixed small memory leak. + Clarified the behaviour of DBI->connect. + $dbh->do now returns '0E0' instead of 'OK'. + Fixed "Can't read $DBI::errstr, lost last handle" problem. + + +=head2 Changes in DBI 0.68, 2 Mar 1996 + + Changes to suit perl5.002 and site_lib directories. + Detects old versions ahead of new in @INC. + + +=head2 Changes in DBI 0.67, 15 Feb 1996 + + Trivial change to test suite to fix a problem shown up by the + Perl5.002gamma release Test::Harness. + + +=head2 Changes in DBI 0.66, 29 Jan 1996 + + Minor changes to bring the DBI into line with 5.002 mechanisms, + specifically the xs/pm VERSION checking mechanism. + No functionality changes. One no-last-handle bug fix (rare problem). + Requires 5.002 (beta2 or later). + + +=head2 Changes in DBI 0.65, 23 Oct 1995 + + Added $DBI::state to hold SQL CLI / ODBC SQLSTATE value. + SQLSTATE "00000" (success) is returned as "" (false), all else is true. + If a driver does not explicitly initialise it (via $h->{State} or + DBIc_STATE(imp_xxh) then $DBI::state will automatically return "" if + $DBI::err is false otherwise "S1000" (general error). + As always, this is a new feature and liable to change. + + The is *no longer* a default error handler! + You can add your own using push(@{$h->{Handlers}}, sub { ... }) + but be aware that this interface may change (or go away). + + The DBI now automatically clears $DBI::err, errstr and state before + calling most DBI methods. Previously error conditions would persist. + Added DBIh_CLEAR_ERROR(imp_xxh) macro. + + DBI now EXPORT_OK's some utility functions, neat($value), + neat_list(@values) and dump_results($sth). + + Slightly enhanced t/min.t minimal test script in an effort to help + narrow down the few stray core dumps that some porters still report. + + Renamed readblob to blob_read (old name still works but warns). + Added default blob_copy_to_file method. + + Added $sth = $dbh->tables method. This returns an $sth for a query + which has these columns: TABLE_CATALOGUE, TABLE_OWNER, TABLE_NAME, + TABLE_TYPE, REMARKS in that order. The TABLE_CATALOGUE column + should be ignored for now. + + +=head2 Changes in DBI 0.64, 23 Oct 1995 + + Fixed 'disconnect invalidates 1 associated cursor(s)' problem. + Drivers using DBIc_ACTIVE_on/off() macros should not need any changes + other than to test for DBIc_ACTIVE_KIDS() instead of DBIc_KIDS(). + Fixed possible core dump in dbih_clearcom during global destruction. + + +=head2 Changes in DBI 0.63, 1 Sep 1995 + + Minor update. Fixed uninitialised memory bug in method + attribute handling and streamlined processing and debugging. + Revised usage definitions for bind_* methods and readblob. + + +=head2 Changes in DBI 0.62, 26 Aug 1995 + + Added method redirection method $h->func(..., $method_name). + This is now the official way to call private driver methods + that are not part of the DBI standard. E.g.: + @ary = $sth->func('ora_types'); + It can also be used to call existing methods. Has very low cost. + + $sth->bind_col columns now start from 1 (not 0) to match SQL. + $sth->bind_columns now takes a leading attribute parameter (or undef), + e.g., $sth->bind_columns($attribs, \$col1 [, \$col2 , ...]); + + Added handy DBD_ATTRIBS_CHECK macro to vet attribs in XS. + Added handy DBD_ATTRIB_GET_SVP, DBD_ATTRIB_GET_BOOL and + DBD_ATTRIB_GET_IV macros for handling attributes. + + Fixed STORE for NUM_OF_FIELDS and NUM_OF_PARAMS. + Added FETCH for NUM_OF_FIELDS and NUM_OF_PARAMS. + + Dispatch no longer bothers to call _untie(). + Faster startup via install_method/_add_dispatch changes. + + +=head2 Changes in DBI 0.61, 22 Aug 1995 + + Added $sth->bind_col($column, \$var [, \%attribs ]); + + This method enables perl variable to be directly and automatically + updated when a row is fetched. It requires no driver support + (if the driver has been written to use DBIS->get_fbav). + Currently \%attribs is unused. + + Added $sth->bind_columns(\$var [, \$var , ...]); + + This method is a short-cut for bind_col which binds all the + columns of a query in one go (with no attributes). It also + requires no driver support. + + Added $sth->bind_param($parameter, $var [, \%attribs ]); + + This method enables attributes to be specified when values are + bound to placeholders. It also enables binding to occur away + from the execute method to improve execute efficiency. + The DBI does not provide a default implementation of this. + See the DBD::Oracle module for a detailed example. + + The DBI now provides default implementations of both fetch and + fetchrow. Each is written in terms of the other. A driver is + expected to implement at least one of them. + + More macro and assorted structure changes in DBDXS.h. Sorry! + The old dbihcom definitions have gone. All fields have macros. + The imp_xxh_t type is now used within the DBI as well as drivers. + Drivers must set DBIc_NUM_FIELDS(imp_sth) and DBIc_NUM_PARAMS(imp_sth). + + test.pl includes a trivial test of bind_param and bind_columns. + + +=head2 Changes in DBI 0.60, 17 Aug 1995 + + This release has significant code changes but much less + dramatic than the previous release. The new implementors data + handling mechanism has matured significantly (don't be put off + by all the struct typedefs in DBIXS.h, there's just to make it + easier for drivers while keeping things type-safe). + + The DBI now includes two new methods: + + do $dbh->do($statement) + + This method prepares, executes and finishes a statement. It is + designed to be used for executing one-off non-select statements + where there is no benefit in reusing a prepared statement handle. + + fetch $array_ref = $sth->fetch; + + This method is the new 'lowest-level' row fetching method. The + previous @row = $sth->fetchrow method now defaults to calling + the fetch method and expanding the returned array reference. + + The DBI now provides fallback attribute FETCH and STORE functions + which drivers should call if they don't recognise an attribute. + + THIS RELEASE IS A GOOD STARTING POINT FOR DRIVER DEVELOPERS! + Study DBIXS.h from the DBI and Oracle.xs etc from DBD::Oracle. + There will be further changes in the interface but nothing + as dramatic as these last two releases! (I hope :-) + + +=head2 Changes in DBI 0.59 15 Aug 1995 + + NOTE: THIS IS AN UNSTABLE RELEASE! + + Major reworking of internal data management! + Performance improvements and memory leaks fixed. + Added a new NullP (empty) driver and a -m flag + to test.pl to help check for memory leaks. + Study DBD::Oracle version 0.21 for more details. + (Comparing parts of v0.21 with v0.20 may be useful.) + + +=head2 Changes in DBI 0.58 21 June 1995 + + Added DBI->internal->{DebugLog} = $filename; + Reworked internal logging. + Added $VERSION. + Made disconnect_all a compulsary method for drivers. + + +=head1 ANCIENT HISTORY + +12th Oct 1994: First public release of the DBI module. + (for Perl 5.000-beta-3h) + +19th Sep 1994: DBperl project renamed to DBI. + +29th Sep 1992: DBperl project started. + +=cut diff --git a/DBI.pm b/DBI.pm new file mode 100644 index 0000000..9b39b14 --- /dev/null +++ b/DBI.pm @@ -0,0 +1,8323 @@ +# $Id: DBI.pm 15327 2012-06-06 16:37:26Z timbo $ +# vim: ts=8:sw=4:et +# +# 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 { +$VERSION = "1.622"; # ==> ALSO update the version in the pod text below! +} + +=head1 NAME + +DBI - Database independent interface for Perl + +=head1 SYNOPSIS + + use DBI; + + @driver_names = DBI->available_drivers; + %drivers = DBI->installed_drivers; + @data_sources = DBI->data_sources($driver_name, \%attr); + + $dbh = DBI->connect($data_source, $username, $auth, \%attr); + + $rv = $dbh->do($statement); + $rv = $dbh->do($statement, \%attr); + $rv = $dbh->do($statement, \%attr, @bind_values); + + $ary_ref = $dbh->selectall_arrayref($statement); + $hash_ref = $dbh->selectall_hashref($statement, $key_field); + + $ary_ref = $dbh->selectcol_arrayref($statement); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); + + @row_ary = $dbh->selectrow_array($statement); + $ary_ref = $dbh->selectrow_arrayref($statement); + $hash_ref = $dbh->selectrow_hashref($statement); + + $sth = $dbh->prepare($statement); + $sth = $dbh->prepare_cached($statement); + + $rc = $sth->bind_param($p_num, $bind_value); + $rc = $sth->bind_param($p_num, $bind_value, $bind_type); + $rc = $sth->bind_param($p_num, $bind_value, \%attr); + + $rv = $sth->execute; + $rv = $sth->execute(@bind_values); + $rv = $sth->execute_array(\%attr, ...); + + $rc = $sth->bind_col($col_num, \$col_variable); + $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); + + @row_ary = $sth->fetchrow_array; + $ary_ref = $sth->fetchrow_arrayref; + $hash_ref = $sth->fetchrow_hashref; + + $ary_ref = $sth->fetchall_arrayref; + $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); + + $hash_ref = $sth->fetchall_hashref( $key_field ); + + $rv = $sth->rows; + + $rc = $dbh->begin_work; + $rc = $dbh->commit; + $rc = $dbh->rollback; + + $quoted_string = $dbh->quote($string); + + $rc = $h->err; + $str = $h->errstr; + $rv = $h->state; + + $rc = $dbh->disconnect; + +I + + +=head2 GETTING HELP + +If you have questions about DBI, or DBD driver modules, you can get +help from the I mailing list. You don't have to subscribe +to the list in order to post, though I'd recommend it. You can get help on +subscribing and using the list by emailing I. + +I don't recommend the DBI cpanforum (at http://www.cpanforum.com/dist/DBI) +because relatively few people read it compared with dbi-users@perl.org. + +To help you make the best use of the dbi-users mailing list, +and any other lists or forums you may use, I recommend that you read +"Getting Answers" by Mike Ash: L. + +If you think you've found a bug then please also read +"How to Report Bugs Effectively" by Simon Tatham: +L. + +The DBI home page at L and the DBI FAQ +at L 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 +at the end of this document and on the DBI home page. + +You might also like to read the Advanced DBI Tutorial at +L + +This document often uses terms like I, I, +I. If you're not familiar with those terms then it would +be a good idea to read at least the following perl manuals first: +L, L, L, and L. + +Please note that Tim Bunce does not maintain the mailing lists or the +web page (generous volunteers do that). So please don't send mail +directly to him; he just doesn't have the time to answer questions +personally. The I mailing list has lots of experienced +people who should be able to help you if you need it. If you do email +Tim he is very likely to just forward it to the mailing list. + +=head2 NOTES + +This is the DBI specification that corresponds to DBI version 1.622 +(see L for details). + +The DBI is evolving at a steady pace, so it's good to check that +you have the latest copy. + +The significant user-visible changes in each release are documented +in the L module so you can read them by executing +C. + +Some DBI changes require changes in the drivers, but the drivers +can take some time to catch up. Newer versions of the DBI have +added features that may not yet be supported by the drivers you +use. Talk to the authors of your drivers if you need a new feature +that is not yet supported. + +Features added after DBI 1.21 (February 2002) are marked in the +text with the version number of the DBI release they first appeared in. + +Extensions to the DBI API often use the C namespace. +See L. DBI extension modules +can be found at L. +And all modules related to the DBI can be found at +L. + +=cut + +# The POD text continues at the end of the file. + +use Carp(); +use DynaLoader (); +use Exporter (); + +BEGIN { +@ISA = qw(Exporter DynaLoader); + +# Make some utility functions available if asked for +@EXPORT = (); # we export nothing by default +@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags: +%EXPORT_TAGS = ( + sql_types => [ qw( + SQL_GUID + SQL_WLONGVARCHAR + SQL_WVARCHAR + SQL_WCHAR + SQL_BIGINT + SQL_BIT + SQL_TINYINT + SQL_LONGVARBINARY + SQL_VARBINARY + SQL_BINARY + SQL_LONGVARCHAR + SQL_UNKNOWN_TYPE + SQL_ALL_TYPES + SQL_CHAR + SQL_NUMERIC + SQL_DECIMAL + SQL_INTEGER + SQL_SMALLINT + SQL_FLOAT + SQL_REAL + SQL_DOUBLE + SQL_DATETIME + SQL_DATE + SQL_INTERVAL + SQL_TIME + SQL_TIMESTAMP + SQL_VARCHAR + SQL_BOOLEAN + SQL_UDT + SQL_UDT_LOCATOR + SQL_ROW + SQL_REF + SQL_BLOB + SQL_BLOB_LOCATOR + SQL_CLOB + SQL_CLOB_LOCATOR + SQL_ARRAY + SQL_ARRAY_LOCATOR + SQL_MULTISET + SQL_MULTISET_LOCATOR + SQL_TYPE_DATE + SQL_TYPE_TIME + SQL_TYPE_TIMESTAMP + SQL_TYPE_TIME_WITH_TIMEZONE + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + SQL_INTERVAL_YEAR + SQL_INTERVAL_MONTH + SQL_INTERVAL_DAY + SQL_INTERVAL_HOUR + SQL_INTERVAL_MINUTE + SQL_INTERVAL_SECOND + SQL_INTERVAL_YEAR_TO_MONTH + SQL_INTERVAL_DAY_TO_HOUR + SQL_INTERVAL_DAY_TO_MINUTE + SQL_INTERVAL_DAY_TO_SECOND + SQL_INTERVAL_HOUR_TO_MINUTE + SQL_INTERVAL_HOUR_TO_SECOND + SQL_INTERVAL_MINUTE_TO_SECOND + DBIstcf_DISCARD_STRING + DBIstcf_STRICT + ) ], + sql_cursor_types => [ qw( + SQL_CURSOR_FORWARD_ONLY + SQL_CURSOR_KEYSET_DRIVEN + SQL_CURSOR_DYNAMIC + SQL_CURSOR_STATIC + SQL_CURSOR_TYPE_DEFAULT + ) ], # for ODBC cursor types + utils => [ qw( + neat neat_list $neat_maxlen dump_results looks_like_number + data_string_diff data_string_desc data_diff sql_type_cast + ) ], + profile => [ qw( + dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time + ) ], # notionally "in" DBI::Profile and normally imported from there +); + +$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields +$DBI::neat_maxlen = 1000; +$DBI::stderr = 2_000_000_000; # a very round number below 2**31 + +# If you get an error here like "Can't find loadable object ..." +# then you haven't installed the DBI correctly. Read the README +# then install it again. +if ( $ENV{DBI_PUREPERL} ) { + eval { bootstrap DBI } if $ENV{DBI_PUREPERL} == 1; + require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2; + $DBI::PurePerl ||= 0; # just to silence "only used once" warnings +} +else { + bootstrap DBI; +} + +$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ]; + +Exporter::export_ok_tags(keys %EXPORT_TAGS); + +} + +# Alias some handle methods to also be DBI class methods +for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) { + no strict; + *$_ = \&{"DBD::_::common::$_"}; +} + +use strict; + +DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; + +$DBI::connect_via ||= "connect"; + +# check if user wants a persistent database connection ( Apache + mod_perl ) +if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) { + $DBI::connect_via = "Apache::DBI::connect"; + DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n"); +} + +# check for weaken support, used by ChildHandles +my $HAS_WEAKEN = eval { + require Scalar::Util; + # this will croak() if this Scalar::Util doesn't have a working weaken(). + Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t + 1; +}; + +%DBI::installed_drh = (); # maps driver names to installed driver handles +sub installed_drivers { %DBI::installed_drh } +%DBI::installed_methods = (); # XXX undocumented, may change +sub installed_methods { %DBI::installed_methods } + +# Setup special DBI dynamic variables. See DBI::var::FETCH for details. +# These are dynamically associated with the last handle used. +tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list +tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list +tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg +tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg +sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; } +sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") } + +# --- 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', }, + 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 => $_ } } + grep { exists $dbd_prefix_registry->{$_}->{class} } + keys %{$dbd_prefix_registry}; + +sub dump_dbd_registry { + require Data::Dumper; + local $Data::Dumper::Sortkeys=1; + local $Data::Dumper::Indent=1; + print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]); +} + +# --- Dynamically create the DBI Standard Interface + +my $keeperr = { O=>0x0004 }; + +%DBI::DBI_methods = ( # Define the DBI interface methods per class: + + common => { # Interface methods common to all DBI handle classes + 'DESTROY' => { O=>0x004|0x10000 }, + 'CLEAR' => $keeperr, + 'EXISTS' => $keeperr, + 'FETCH' => { O=>0x0404 }, + 'FETCH_many' => { O=>0x0404 }, + 'FIRSTKEY' => $keeperr, + 'NEXTKEY' => $keeperr, + 'STORE' => { O=>0x0418 | 0x4 }, + _not_impl => undef, + can => { O=>0x0100 }, # special case, see dispatch + debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace + dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 }, + err => $keeperr, + errstr => $keeperr, + state => $keeperr, + func => { O=>0x0006 }, + parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 }, + parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 }, + private_data => { U =>[1,1], O=>0x0004 }, + set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 }, + trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 }, + trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 }, + swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] }, + private_attribute_info => { }, + visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 }, + }, + dr => { # Database Driver Interface + 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 }, + data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 }, + default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 }, + dbixs_revision => $keeperr, + }, + db => { # Database Session Class Interface + 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, 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 }, + 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 }, + last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 }, + preparse => { }, # XXX + prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 }, + prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 }, + selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + ping => { U =>[1,1], O=>0x0404 }, + disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 }, + quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 }, + quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430 }, + rows => $keeperr, + + tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 }, + table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 }, + column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 }, + primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 }, + primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 }, + foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 }, + statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 }, + type_info_all => { U =>[1,1], O=>0x2200|0x0800 }, + type_info => { U =>[1,2,'$data_type'], O=>0x2200 }, + get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 }, + }, + st => { # Statement Class Interface + bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] }, + bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] }, + bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] }, + execute => { U =>[1,0,'[@args]'], O=>0x1040 }, + + bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] }, + execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 }, + execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 }, + + fetch => undef, # alias for fetchrow_arrayref + fetchrow_arrayref => undef, + fetchrow_hashref => undef, + fetchrow_array => undef, + fetchrow => undef, # old alias for fetchrow_array + + fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] }, + fetchall_hashref => { U =>[2,2,'$key_field'] }, + + blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] }, + blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] }, + dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] }, + more_results => { U =>[1,1] }, + finish => { U =>[1,1] }, + cancel => { U =>[1,1], O=>0x0800 }, + rows => $keeperr, + + _get_fbav => undef, + _set_fbav => { T=>6 }, + }, +); + +while ( my ($class, $meths) = each %DBI::DBI_methods ) { + my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0); + while ( my ($method, $info) = each %$meths ) { + my $fullmeth = "DBI::${class}::$method"; + if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods + # and optionally filter by IMA flags + my $O = $info->{O}||0; + printf "0x%04x %-20s\n", $O, $fullmeth + unless $ima_trace && !($O & $ima_trace); + } + DBI->_install_method($fullmeth, 'DBI.pm', $info); + } +} + +{ + package DBI::common; + @DBI::dr::ISA = ('DBI::common'); + @DBI::db::ISA = ('DBI::common'); + @DBI::st::ISA = ('DBI::common'); +} + +# End of init code + + +END { + return unless defined &DBI::trace_msg; # return unless bootstrap'd ok + local ($!,$?); + DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2); + # Let drivers know why we are calling disconnect_all: + $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning + DBI->disconnect_all() if %DBI::installed_drh; +} + + +sub CLONE { + _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure + 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"}; + warn("$driver has no driver CLONE() function so is unsafe threaded\n"); + } + %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize +} + +sub parse_dsn { + my ($class, $dsn) = @_; + $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return; + my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3); + $driver ||= $ENV{DBI_DRIVER} || ''; + $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr; + return ($scheme, $driver, $attr, $attr_hash, $dsn); +} + +sub visit_handles { + my ($class, $code, $outer_info) = @_; + $outer_info = {} if not defined $outer_info; + my %drh = DBI->installed_drivers; + for my $h (values %drh) { + my $child_info = $code->($h, $outer_info) + or next; + $h->visit_child_handles($code, $child_info); + } + return $outer_info; +} + + +# --- The DBI->connect Front Door methods + +sub connect_cached { + # For library code using connect_cached() with mod_perl + # we redirect those calls to Apache::DBI::connect() as well + my ($class, $dsn, $user, $pass, $attr) = @_; + my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect") + ? 'Apache::DBI::connect' : 'connect_cached'; + $attr = { + $attr ? %$attr : (), # clone, don't modify callers data + dbi_connect_method => $dbi_connect_method, + }; + return $class->connect($dsn, $user, $pass, $attr); +} + +sub connect { + my $class = shift; + my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_; + my $driver; + + if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style + Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions"); + ($old_driver, $attr) = ($attr, $old_driver); + } + + my $connect_meth = $attr->{dbi_connect_method}; + $connect_meth ||= $DBI::connect_via; # fallback to default + + $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver; + + if ($DBI::dbi_debug) { + local $^W = 0; + pop @_ if $connect_meth ne 'connect'; + my @args = @_; $args[2] = '****'; # hide password + DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n"); + } + Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])') + if (ref $old_driver or ($attr and not ref $attr) or ref $pass); + + # extract dbi:driver prefix from $dsn into $1 + $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i + or '' =~ /()/; # ensure $1 etc are empty if match fails + my $driver_attrib_spec = $2 || ''; + + # Set $driver. Old style driver, if specified, overrides new dsn style. + $driver = $old_driver || $1 || $ENV{DBI_DRIVER} + or Carp::croak("Can't connect to data source '$dsn' " + ."because I can't work out what driver to use " + ."(it doesn't seem to contain a 'dbi:driver:' prefix " + ."and the DBI_DRIVER env var is not set)"); + + my $proxy; + if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') { + my $dbi_autoproxy = $ENV{DBI_AUTOPROXY}; + $proxy = 'Proxy'; + if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) { + $proxy = $1; + $driver_attrib_spec = join ",", + ($driver_attrib_spec) ? $driver_attrib_spec : (), + ($2 ) ? $2 : (); + } + $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn"; + $driver = $proxy; + DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n"); + } + # avoid recursion if proxy calls DBI->connect itself + local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; + + my %attributes; # take a copy we can delete from + if ($old_driver) { + %attributes = %$attr if $attr; + } + else { # new-style connect so new default semantics + %attributes = ( + PrintError => 1, + AutoCommit => 1, + ref $attr ? %$attr : (), + # attributes in DSN take precedence over \%attr connect parameter + $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (), + ); + } + $attr = \%attributes; # now set $attr to refer to our local copy + + my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver) + or die "panic: $class->install_driver($driver) failed"; + + # attributes in DSN take precedence over \%attr connect parameter + $user = $attr->{Username} if defined $attr->{Username}; + $pass = $attr->{Password} if defined $attr->{Password}; + delete $attr->{Password}; # always delete Password as closure stores it securely + if ( !(defined $user && defined $pass) ) { + ($user, $pass) = $drh->default_user($user, $pass, $attr); + } + $attr->{Username} = $user; # force the Username to be the actual one used + + my $connect_closure = sub { + my ($old_dbh, $override_attr) = @_; + + #use Data::Dumper; + #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]); + + my $dbh; + unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) { + $user = '' if !defined $user; + $dsn = '' if !defined $dsn; + # $drh->errstr isn't safe here because $dbh->DESTROY may not have + # been called yet and so the dbh errstr would not have been copied + # up to the drh errstr. Certainly true for connect_cached! + my $errstr = $DBI::errstr; + # Getting '(no error string)' here is a symptom of a ref loop + $errstr = '(no error string)' if !defined $errstr; + my $msg = "$class connect('$dsn','$user',...) failed: $errstr"; + DBI->trace_msg(" $msg\n"); + # XXX HandleWarn + unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) { + Carp::croak($msg) if $attr->{RaiseError}; + Carp::carp ($msg) if $attr->{PrintError}; + } + $! = 0; # for the daft people who do DBI->connect(...) || die "$!"; + return $dbh; # normally undef, but HandleError could change it + } + + # merge any attribute overrides but don't change $attr itself (for closure) + my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr }; + + # handle basic RootClass subclassing: + my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : ''); + if ($rebless_class) { + no strict 'refs'; + if ($apply->{RootClass}) { # explicit attribute (ie not static methd call class) + delete $apply->{RootClass}; + DBI::_load_class($rebless_class, 0); + } + unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) { + Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored"); + $rebless_class = undef; + $class = 'DBI'; + } + else { + $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db + DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st' + DBI::_rebless($dbh, $rebless_class); # appends '::db' + } + } + + if (%$apply) { + + if ($apply->{DbTypeSubclass}) { + my $DbTypeSubclass = delete $apply->{DbTypeSubclass}; + DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass); + } + my $a; + foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first + next unless exists $apply->{$a}; + $dbh->{$a} = delete $apply->{$a}; + } + while ( my ($a, $v) = each %$apply) { + eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH + warn $@ if $@; + } + } + + # confirm to driver (ie if subclassed) that we've connected sucessfully + # and finished the attribute setup. pass in the original arguments + $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy; + + DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF; + + return $dbh; + }; + + my $dbh = &$connect_closure(undef, undef); + + $dbh->{dbi_connect_closure} = $connect_closure if $dbh; + + return $dbh; +} + + +sub disconnect_all { + keys %DBI::installed_drh; # reset iterator + while ( my ($name, $drh) = each %DBI::installed_drh ) { + $drh->disconnect_all() if ref $drh; + } +} + + +sub disconnect { # a regular beginners bug + Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)"); +} + + +sub install_driver { # croaks on failure + my $class = shift; + my($driver, $attr) = @_; + my $drh; + + $driver ||= $ENV{DBI_DRIVER} || ''; + + # allow driver to be specified as a 'dbi:driver:' string + $driver = $1 if $driver =~ s/^DBI:(.*?)://i; + + Carp::croak("usage: $class->install_driver(\$driver [, \%attr])") + unless ($driver and @_<=3); + + # already installed + return $drh if $drh = $DBI::installed_drh{$driver}; + + $class->trace_msg(" -> $class->install_driver($driver" + .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n") + if $DBI::dbi_debug & 0xF; + + # --- load the code + my $driver_class = "DBD::$driver"; + eval qq{package # hide from PAUSE + DBI::_firesafe; # just in case + require $driver_class; # load the driver + }; + if ($@) { + my $err = $@; + my $advice = ""; + if ($err =~ /Can't find loadable object/) { + $advice = "Perhaps DBD::$driver was statically linked into a new perl binary." + ."\nIn which case you need to use that new perl binary." + ."\nOr perhaps only the .pm file was installed but not the shared object file." + } + elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) { + my @drv = $class->available_drivers(1); + $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n" + ."or perhaps the capitalisation of '$driver' isn't right.\n" + ."Available drivers: ".join(", ", @drv)."."; + } + elsif ($err =~ /Can't load .*? for module DBD::/) { + $advice = "Perhaps a required shared library or dll isn't installed where expected"; + } + elsif ($err =~ /Can't locate .*? in \@INC/) { + $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed"; + } + Carp::croak("install_driver($driver) failed: $err$advice\n"); + } + if ($DBI::dbi_debug & 0xF) { + no strict 'refs'; + (my $driver_file = $driver_class) =~ s/::/\//g; + my $dbd_ver = ${"$driver_class\::VERSION"} || "undef"; + $class->trace_msg(" install_driver: $driver_class version $dbd_ver" + ." loaded from $INC{qq($driver_file.pm)}\n"); + } + + # --- do some behind-the-scenes checks and setups on the driver + $class->setup_driver($driver_class); + + # --- run the driver function + $drh = eval { $driver_class->driver($attr || {}) }; + unless ($drh && ref $drh && !$@) { + my $advice = ""; + $@ ||= "$driver_class->driver didn't return a handle"; + # catch people on case in-sensitive systems using the wrong case + $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right." + if $@ =~ /locate object method/; + Carp::croak("$driver_class initialisation failed: $@$advice"); + } + + $DBI::installed_drh{$driver} = $drh; + $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF; + $drh; +} + +*driver = \&install_driver; # currently an alias, may change + + +sub setup_driver { + my ($class, $driver_class) = @_; + my $h_type; + foreach $h_type (qw(dr db st)){ + my $h_class = $driver_class."::$h_type"; + no strict 'refs'; + 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; + } +} + + +sub _rebless { + my $dbh = shift; + my ($outer, $inner) = DBI::_handles($dbh); + my $class = shift(@_).'::db'; + bless $inner => $class; + bless $outer => $class; # outer last for return +} + + +sub _set_isa { + my ($classes, $topclass) = @_; + my $trace = DBI->trace_msg(" _set_isa([@$classes])\n"); + foreach my $suffix ('::db','::st') { + my $previous = $topclass || 'DBI'; # trees are rooted here + foreach my $class (@$classes) { + my $base_class = $previous.$suffix; + my $sub_class = $class.$suffix; + my $sub_class_isa = "${sub_class}::ISA"; + no strict 'refs'; + if (@$sub_class_isa) { + DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n") + if $trace; + } + else { + @$sub_class_isa = ($base_class) unless @$sub_class_isa; + DBI->trace_msg(" $sub_class_isa = $base_class\n") + if $trace; + } + $previous = $class; + } + } +} + + +sub _rebless_dbtype_subclass { + my ($dbh, $rootclass, $DbTypeSubclass) = @_; + # determine the db type names for class hierarchy + my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass); + # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc) + $_ = $rootclass.'::'.$_ foreach (@hierarchy); + # load the modules from the 'top down' + DBI::_load_class($_, 1) foreach (reverse @hierarchy); + # setup class hierarchy if needed, does both '::db' and '::st' + DBI::_set_isa(\@hierarchy, $rootclass); + # finally bless the handle into the subclass + DBI::_rebless($dbh, $hierarchy[0]); +} + + +sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC + my ($dbh, $DbTypeSubclass) = @_; + + if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') { + # treat $DbTypeSubclass as a comma separated list of names + my @dbtypes = split /\s*,\s*/, $DbTypeSubclass; + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n"); + return @dbtypes; + } + + # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future? + + my $driver = $dbh->{Driver}->{Name}; + if ( $driver eq 'Proxy' ) { + # XXX Looking into the internals of DBD::Proxy is questionable! + ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i + or die "Can't determine driver name from proxy"; + } + + my @dbtypes = (ucfirst($driver)); + if ($driver eq 'ODBC' || $driver eq 'ADO') { + # XXX will move these out and make extensible later: + my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar' + my %_dbtype_name_map = ( + 'Microsoft SQL Server' => 'MSSQL', + 'SQL Server' => 'Sybase', + 'Adaptive Server Anywhere' => 'ASAny', + 'ADABAS D' => 'AdabasD', + ); + + my $name; + $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME + if $driver eq 'ODBC'; + $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value + if $driver eq 'ADO'; + die "Can't determine driver name! ($DBI::errstr)\n" + unless $name; + + my $dbtype; + if ($_dbtype_name_map{$name}) { + $dbtype = $_dbtype_name_map{$name}; + } + else { + if ($name =~ /($_dbtype_name_regexp)/) { + $dbtype = lc($1); + } + else { # generic mangling for other names: + $dbtype = lc($name); + } + $dbtype =~ s/\b(\w)/\U$1/g; + $dbtype =~ s/\W+/_/g; + } + # add ODBC 'behind' ADO + push @dbtypes, 'ODBC' if $driver eq 'ADO'; + # add discovered dbtype in front of ADO/ODBC + unshift @dbtypes, $dbtype; + } + @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes) + if (ref $DbTypeSubclass eq 'CODE'); + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n"); + return @dbtypes; +} + +sub _load_class { + my ($load_class, $missing_ok) = @_; + DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2); + no strict 'refs'; + return 1 if @{"$load_class\::ISA"}; # already loaded/exists + (my $module = $load_class) =~ s!::!/!g; + DBI->trace_msg(" _load_class require $module\n", 2); + eval { require "$module.pm"; }; + return 1 unless $@; + return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/; + die $@; +} + + +sub init_rootclass { # deprecated + return 1; +} + + +*internal = \&DBD::Switch::dr::driver; + +sub driver_prefix { + my ($class, $driver) = @_; + return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver}; + return; +} + +sub available_drivers { + my($quiet) = @_; + my(@drivers, $d, $f); + local(*DBI::DIR, $@); + my(%seen_dir, %seen_dbd); + my $haveFileSpec = eval { require File::Spec }; + foreach $d (@INC){ + chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness + my $dbd_dir = + ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD"); + next unless -d $dbd_dir; + next if $seen_dir{$d}; + $seen_dir{$d} = 1; + # XXX we have a problem here with case insensitive file systems + # XXX since we can't tell what case must be used when loading. + opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n"; + foreach $f (readdir(DBI::DIR)){ + next unless $f =~ s/\.pm$//; + next if $f eq 'NullP'; + if ($seen_dbd{$f}){ + Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n" + unless $quiet; + } else { + push(@drivers, $f); + } + $seen_dbd{$f} = $d; + } + closedir(DBI::DIR); + } + + # "return sort @drivers" will not DWIM in scalar context. + return wantarray ? sort @drivers : @drivers; +} + +sub installed_versions { + my ($class, $quiet) = @_; + my %error; + my %version = ( DBI => $DBI::VERSION ); + $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION + if $DBI::PurePerl; + for my $driver ($class->available_drivers($quiet)) { + next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC; + my $drh = eval { + local $SIG{__WARN__} = sub {}; + $class->install_driver($driver); + }; + ($error{"DBD::$driver"}=$@),next if $@; + no strict 'refs'; + my $vers = ${"DBD::$driver" . '::VERSION'}; + $version{"DBD::$driver"} = $vers || '?'; + } + if (wantarray) { + return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version; + } + if (!defined wantarray) { # void context + require Config; # add more detail + $version{OS} = "$^O\t($Config::Config{osvers})"; + $version{Perl} = "$]\t($Config::Config{archname})"; + $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_}) + for keys %error; + printf " %-16s: %s\n",$_,$version{$_} + for reverse sort keys %version; + } + return \%version; +} + + +sub data_sources { + my ($class, $driver, @other) = @_; + my $drh = $class->install_driver($driver); + my @ds = $drh->data_sources(@other); + return @ds; +} + + +sub neat_list { + my ($listref, $maxlen, $sep) = @_; + $maxlen = 0 unless defined $maxlen; # 0 == use internal default + $sep = ", " unless defined $sep; + join($sep, map { neat($_,$maxlen) } @$listref); +} + + +sub dump_results { # also aliased as a method in DBD::_::st + my ($sth, $maxlen, $lsep, $fsep, $fh) = @_; + return 0 unless $sth; + $maxlen ||= 35; + $lsep ||= "\n"; + $fh ||= \*STDOUT; + my $rows = 0; + my $ref; + while($ref = $sth->fetch) { + print $fh $lsep if $rows++ and $lsep; + my $str = neat_list($ref,$maxlen,$fsep); + print $fh $str; # done on two lines to avoid 5.003 errors + } + print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n"; + $rows; +} + + +sub data_diff { + my ($a, $b, $logical) = @_; + + my $diff = data_string_diff($a, $b); + return "" if $logical and !$diff; + + my $a_desc = data_string_desc($a); + my $b_desc = data_string_desc($b); + return "" if !$diff and $a_desc eq $b_desc; + + $diff ||= "Strings contain the same sequence of characters" + if length($a); + $diff .= "\n" if $diff; + return "a: $a_desc\nb: $b_desc\n$diff"; +} + + +sub data_string_diff { + # Compares 'logical' characters, not bytes, so a latin1 string and an + # an equivalent Unicode string will compare as equal even though their + # byte encodings are different. + my ($a, $b) = @_; + unless (defined $a and defined $b) { # one undef + return "" + if !defined $a and !defined $b; + return "String a is undef, string b has ".length($b)." characters" + if !defined $a; + return "String b is undef, string a has ".length($a)." characters" + if !defined $b; + } + + require utf8; + # hack to cater for perl 5.6 + *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; + + my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a); + my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b); + my $i = 0; + while (@a_chars && @b_chars) { + ++$i, shift(@a_chars), shift(@b_chars), next + if $a_chars[0] == $b_chars[0];# compare ordinal values + my @desc = map { + $_ > 255 ? # if wide character... + sprintf("\\x{%04X}", $_) : # \x{...} + chr($_) =~ /[[:cntrl:]]/ ? # else if control character ... + sprintf("\\x%02X", $_) : # \x.. + chr($_) # else as themselves + } ($a_chars[0], $b_chars[0]); + # highlight probable double-encoding? + foreach my $c ( @desc ) { + next unless $c =~ m/\\x\{08(..)}/; + $c .= "='" .chr(hex($1)) ."'" + } + return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]"; + } + return "String a truncated after $i characters" if @b_chars; + return "String b truncated after $i characters" if @a_chars; + return ""; +} + + +sub data_string_desc { # describe a data string + my ($a) = @_; + require bytes; + require utf8; + + # hacks to cater for perl 5.6 + *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; + *utf8::valid = sub { 1 } unless defined &utf8::valid; + + # Give sufficient info to help diagnose at least these kinds of situations: + # - valid UTF8 byte sequence but UTF8 flag not set + # (might be ascii so also need to check for hibit to make it worthwhile) + # - UTF8 flag set but invalid UTF8 byte sequence + # could do better here, but this'll do for now + my $utf8 = sprintf "UTF8 %s%s", + utf8::is_utf8($a) ? "on" : "off", + utf8::valid($a||'') ? "" : " but INVALID encoding"; + return "$utf8, undef" unless defined $a; + my $is_ascii = $a =~ m/^[\000-\177]*$/; + return sprintf "%s, %s, %d characters %d bytes", + $utf8, $is_ascii ? "ASCII" : "non-ASCII", + length($a), bytes::length($a); +} + + +sub connect_test_perf { + my($class, $dsn,$dbuser,$dbpass, $attr) = @_; + Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr; + # these are non standard attributes just for this special method + my $loops ||= $attr->{dbi_loops} || 5; + my $par ||= $attr->{dbi_par} || 1; # parallelism + my $verb ||= $attr->{dbi_verb} || 1; + my $meth ||= $attr->{dbi_meth} || 'connect'; + print "$dsn: testing $loops sets of $par connections:\n"; + require "FileHandle.pm"; # don't let toke.c create empty FileHandle package + local $| = 1; + my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n"); + # test the connection and warm up caches etc + $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr"); + my $t1 = dbi_time(); + my $loop; + for $loop (1..$loops) { + my @cons; + print "Connecting... " if $verb; + for (1..$par) { + print "$_ "; + push @cons, ($drh->connect($dsn,$dbuser,$dbpass) + or Carp::croak("connect failed: $DBI::errstr\n")); + } + print "\nDisconnecting...\n" if $verb; + for (@cons) { + $_->disconnect or warn "disconnect failed: $DBI::errstr" + } + } + my $t2 = dbi_time(); + my $td = $t2 - $t1; + printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n", + $par, $loops, $td, $loops*$par, $td/($loops*$par); + return $td; +} + + +# Help people doing DBI->errstr, might even document it one day +# XXX probably best moved to cheaper XS code if this gets documented +sub err { $DBI::err } +sub errstr { $DBI::errstr } + + +# --- Private Internal Function for Creating New DBI Handles + +# XXX move to PurePerl? +*DBI::dr::TIEHASH = \&DBI::st::TIEHASH; +*DBI::db::TIEHASH = \&DBI::st::TIEHASH; + + +# These three special constructors are called by the drivers +# The way they are called is likely to change. + +our $shared_profile; + +sub _new_drh { # called by DBD::::driver() + my ($class, $initial_attr, $imp_data) = @_; + # Provide default storage for State,Err and Errstr. + # Note that these are shared by all child handles by default! XXX + # State must be undef to get automatic faking in DBI::var::FETCH + my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, 0, ''); + my $attr = { + # these attributes get copied down to child handles by default + 'State' => \$h_state_store, # Holder for DBI::state + 'Err' => \$h_err_store, # Holder for DBI::err + 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr + 'TraceLevel' => 0, + FetchHashKeyName=> 'NAME', + %$initial_attr, + }; + my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class); + + # XXX DBI_PROFILE unless DBI::PurePerl because for some reason + # it kills the t/zz_*_pp.t tests (they silently exit early) + if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) { + # The profile object created here when the first driver is loaded + # is shared by all drivers so we end up with just one set of profile + # data and thus the 'total time in DBI' is really the true total. + if (!$shared_profile) { # first time + $h->{Profile} = $ENV{DBI_PROFILE}; # write string + $shared_profile = $h->{Profile}; # read and record object + } + else { + $h->{Profile} = $shared_profile; + } + } + return $h unless wantarray; + ($h, $i); +} + +sub _new_dbh { # called by DBD::::dr::connect() + my ($drh, $attr, $imp_data) = @_; + my $imp_class = $drh->{ImplementorClass} + or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); + substr($imp_class,-4,4) = '::db'; + my $app_class = ref $drh; + substr($app_class,-4,4) = '::db'; + $attr->{Err} ||= \my $err; + $attr->{Errstr} ||= \my $errstr; + $attr->{State} ||= \my $state; + _new_handle($app_class, $drh, $attr, $imp_data, $imp_class); +} + +sub _new_sth { # called by DBD::::db::prepare) + my ($dbh, $attr, $imp_data) = @_; + my $imp_class = $dbh->{ImplementorClass} + or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); + substr($imp_class,-4,4) = '::st'; + my $app_class = ref $dbh; + substr($app_class,-4,4) = '::st'; + _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class); +} + + +# end of DBI package + + + +# -------------------------------------------------------------------- +# === The internal DBI Switch pseudo 'driver' class === + +{ package # hide from PAUSE + DBD::Switch::dr; + DBI->setup_driver('DBD::Switch'); # sets up @ISA + + $DBD::Switch::dr::imp_data_size = 0; + $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning + my $drh; + + sub driver { + return $drh if $drh; # a package global + + my $inner; + ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', { + 'Name' => 'Switch', + 'Version' => $DBI::VERSION, + 'Attribution' => "DBI $DBI::VERSION by Tim Bunce", + }); + Carp::croak("DBD::Switch init failed!") unless ($drh && $inner); + return $drh; + } + sub CLONE { + undef $drh; + } + + sub FETCH { + my($drh, $key) = @_; + return DBI->trace if $key eq 'DebugDispatch'; + return undef if $key eq 'DebugLog'; # not worth fetching, sorry + return $drh->DBD::_::dr::FETCH($key); + undef; + } + sub STORE { + my($drh, $key, $value) = @_; + if ($key eq 'DebugDispatch') { + DBI->trace($value); + } elsif ($key eq 'DebugLog') { + DBI->trace(-1, $value); + } else { + $drh->DBD::_::dr::STORE($key, $value); + } + } +} + + +# -------------------------------------------------------------------- +# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES === + +# We only define default methods for harmless functions. +# We don't, for example, define a DBD::_::st::prepare() + +{ package # hide from PAUSE + DBD::_::common; # ====== Common base class methods ====== + use strict; + + # methods common to all handle types: + + sub _not_impl { + my ($h, $method) = @_; + $h->trace_msg("Driver does not implement the $method method.\n"); + return; # empty list / undef + } + + # generic TIEHASH default methods: + sub FIRSTKEY { } + sub NEXTKEY { } + sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef? + sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" } + + sub FETCH_many { # XXX should move to C one day + my $h = shift; + # scalar is needed to workaround drivers that return an empty list + # for some attributes + return map { scalar $h->FETCH($_) } @_; + } + + *dump_handle = \&DBI::dump_handle; + + sub install_method { + # special class method called directly by apps and/or drivers + # to install new methods into the DBI dispatcher + # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' }); + my ($class, $method, $attr) = @_; + Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st") + unless $class =~ /^DBD::(\w+)::(dr|db|st)$/; + my ($driver, $subtype) = ($1, $2); + Carp::croak("invalid method name '$method'") + unless $method =~ m/^([a-z]+_)\w+$/; + my $prefix = $1; + my $reg_info = $dbd_prefix_registry->{$prefix}; + Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info; + + my $full_method = "DBI::${subtype}::$method"; + $DBI::installed_methods{$full_method} = $attr; + + my (undef, $filename, $line) = caller; + # XXX reformat $attr as needed for _install_method + my %attr = %{$attr||{}}; # copy so we can edit + DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr); + } + + sub parse_trace_flags { + my ($h, $spec) = @_; + my $level = 0; + my $flags = 0; + my @unknown; + for my $word (split /\s*[|&,]\s*/, $spec) { + if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) { + $level = $word; + } elsif ($word eq 'ALL') { + $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches + last; + } elsif (my $flag = $h->parse_trace_flag($word)) { + $flags |= $flag; + } + else { + push @unknown, $word; + } + } + if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) { + Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ". + join(" ", map { DBI::neat($_) } @unknown)); + } + $flags |= $level; + return $flags; + } + + sub parse_trace_flag { + my ($h, $name) = @_; + # 0xddDDDDrL (driver, DBI, reserved, Level) + return 0x00000100 if $name eq 'SQL'; + return 0x00000200 if $name eq 'CON'; + return 0x00000400 if $name eq 'ENC'; + return 0x00000800 if $name eq 'DBD'; + return 0x00001000 if $name eq 'TXN'; + return; + } + + sub private_attribute_info { + return undef; + } + + sub visit_child_handles { + my ($h, $code, $info) = @_; + $info = {} if not defined $info; + for my $ch (@{ $h->{ChildHandles} || []}) { + next unless $ch; + my $child_info = $code->($ch, $info) + or next; + $ch->visit_child_handles($code, $child_info); + } + return $info; + } +} + + +{ package # hide from PAUSE + DBD::_::dr; # ====== DRIVER ====== + @DBD::_::dr::ISA = qw(DBD::_::common); + use strict; + + sub default_user { + my ($drh, $user, $pass, $attr) = @_; + $user = $ENV{DBI_USER} unless defined $user; + $pass = $ENV{DBI_PASS} unless defined $pass; + return ($user, $pass); + } + + sub connect { # normally overridden, but a handy default + my ($drh, $dsn, $user, $auth) = @_; + my ($this) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + }); + # XXX debatable as there's no "server side" here + # (and now many uses would trigger warnings on DESTROY) + # $this->STORE(Active => 1); + # so drivers should set it in their own connect + $this; + } + + + sub connect_cached { + my $drh = shift; + my ($dsn, $user, $auth, $attr) = @_; + + my $cache = $drh->{CachedKids} ||= {}; + my $key = do { local $^W; + join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $dbh = $cache->{$key}; + $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh))) + if (($DBI::dbi_debug & 0xF) >= 4); + + my $cb = $attr->{Callbacks}; # take care not to autovivify + if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) { + # If the caller has provided a callback then call it + if ($cb and $cb = $cb->{"connect_cached.reused"}) { + local $_ = "connect_cached.reused"; + $cb->($dbh, $dsn, $user, $auth, $attr); + } + return $dbh; + } + + # If the caller has provided a callback then call it + if ($cb and $cb = $cb->{"connect_cached.new"}) { + local $_ = "connect_cached.new"; + $cb->($dbh, $dsn, $user, $auth, $attr); + } + + $dbh = $drh->connect(@_); + $cache->{$key} = $dbh; # replace prev entry, even if connect failed + return $dbh; + } + +} + + +{ package # hide from PAUSE + DBD::_::db; # ====== DATABASE ====== + @DBD::_::db::ISA = qw(DBD::_::common); + use strict; + + sub clone { + my ($old_dbh, $attr) = @_; + + my $closure = $old_dbh->{dbi_connect_closure} + or return $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 ) { + # ignore non-code refs, i.e., caches, handles, Err etc + next if ref $v && ref $v ne 'CODE'; # HandleError etc + $attr->{$k} = $v; + } + # explicitly set attributes which are unlikely to be in the + # attribute cache, i.e., boolean's and some others + $attr->{$_} = $old_dbh->FETCH($_) for (qw( + AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy + LongTruncOk PrintError PrintWarn Profile RaiseError + ShowErrorStatement TaintIn TaintOut + )); + } + + # use Data::Dumper; warn Dumper([$old_dbh, $attr]); + my $new_dbh = &$closure($old_dbh, $attr); + unless ($new_dbh) { + # need to copy err/errstr from driver back into $old_dbh + my $drh = $old_dbh->{Driver}; + return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state); + } + $new_dbh->{dbi_connect_closure} = $closure; + return $new_dbh; + } + + sub quote_identifier { + my ($dbh, @id) = @_; + my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef; + + my $info = $dbh->{dbi_quote_identifier_cache} ||= [ + $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR + $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR + $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION + ]; + + my $quote = $info->[0]; + foreach (@id) { # quote the elements + next unless defined; + s/$quote/$quote$quote/g; # escape embedded quotes + $_ = qq{$quote$_$quote}; + } + + # strip out catalog if present for special handling + my $catalog = (@id >= 3) ? shift @id : undef; + + # join the dots, ignoring any null/undef elements (ie schema) + my $quoted_id = join '.', grep { defined } @id; + + if ($catalog) { # add catalog correctly + $quoted_id = ($info->[2] == 2) # SQL_CL_END + ? $quoted_id . $info->[1] . $catalog + : $catalog . $info->[1] . $quoted_id; + } + return $quoted_id; + } + + sub quote { + my ($dbh, $str, $data_type) = @_; + + return "NULL" unless defined $str; + unless ($data_type) { + $str =~ s/'/''/g; # ISO SQL2 + return "'$str'"; + } + + my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ]; + my ($prefixes, $suffixes) = @$dbi_literal_quote_cache; + + my $lp = $prefixes->{$data_type}; + my $ls = $suffixes->{$data_type}; + + if ( ! defined $lp || ! defined $ls ) { + my $ti = $dbh->type_info($data_type); + $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'"; + $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'"; + } + return $str unless $lp || $ls; # no quoting required + + # XXX don't know what the standard says about escaping + # in the 'general case' (where $lp != "'"). + # So we just do this and hope: + $str =~ s/$lp/$lp$lp/g + if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"'); + return "$lp$str$ls"; + } + + sub rows { -1 } # here so $DBI::rows 'works' after using $dbh + + sub do { + my($dbh, $statement, $attr, @params) = @_; + my $sth = $dbh->prepare($statement, $attr) or return undef; + $sth->execute(@params) or return undef; + my $rows = $sth->rows; + ($rows == 0) ? "0E0" : $rows; + } + + sub _do_selectrow { + my ($method, $dbh, $stmt, $attr, @bind) = @_; + my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)) + or return; + $sth->execute(@bind) + or return; + my $row = $sth->$method() + and $sth->finish; + return $row; + } + + sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); } + + # XXX selectrow_array/ref also have C implementations in Driver.xst + sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); } + sub selectrow_array { + my $row = _do_selectrow('fetchrow_arrayref', @_) or return; + return $row->[0] unless wantarray; + return @$row; + } + + # XXX selectall_arrayref also has C implementation in Driver.xst + # which fallsback to this if a slice is given + sub selectall_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr) + or return; + $sth->execute(@bind) || return; + my $slice = $attr->{Slice}; # typically undef, else hash or array ref + if (!$slice and $slice=$attr->{Columns}) { + if (ref $slice eq 'ARRAY') { # map col idx to perl array idx + $slice = [ @{$attr->{Columns}} ]; # take a copy + for (@$slice) { $_-- } + } + } + my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows}); + $sth->finish if defined $MaxRows; + return $rows; + } + + sub selectall_hashref { + my ($dbh, $stmt, $key_field, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + return $sth->fetchall_hashref($key_field); + } + + sub selectcol_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1); + my @values = (undef) x @columns; + my $idx = 0; + for (@columns) { + $sth->bind_col($_, \$values[$idx++]) || return; + } + my @col; + if (my $max = $attr->{MaxRows}) { + push @col, @values while 0 < $max-- && $sth->fetch; + } + else { + push @col, @values while $sth->fetch; + } + return \@col; + } + + sub prepare_cached { + my ($dbh, $statement, $attr, $if_active) = @_; + + # Needs support at dbh level to clear cache before complaining about + # active children. The XS template code does this. Drivers not using + # the template must handle clearing the cache themselves. + my $cache = $dbh->{CachedKids} ||= {}; + my $key = do { local $^W; + join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $sth = $cache->{$key}; + + if ($sth) { + return $sth unless $sth->FETCH('Active'); + Carp::carp("prepare_cached($statement) statement handle $sth still Active") + unless ($if_active ||= 0); + $sth->finish if $if_active <= 1; + return $sth if $if_active <= 2; + } + + $sth = $dbh->prepare($statement, $attr); + $cache->{$key} = $sth if $sth; + + return $sth; + } + + sub ping { + my $dbh = shift; + $dbh->_not_impl('ping'); + # "0 but true" is a special kind of true 0 that is used here so + # applications can check if the ping was a real ping or not + ($dbh->FETCH('Active')) ? "0 but true" : 0; + } + + sub begin_work { + my $dbh = shift; + return $dbh->set_err($DBI::stderr, "Already in a transaction") + unless $dbh->FETCH('AutoCommit'); + $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it + $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action + return 1; + } + + sub primary_key { + my ($dbh, @args) = @_; + my $sth = $dbh->primary_key_info(@args) or return; + my ($row, @col); + push @col, $row->[3] while ($row = $sth->fetch); + Carp::croak("primary_key method not called in list context") + unless wantarray; # leave us some elbow room + return @col; + } + + sub tables { + my ($dbh, @args) = @_; + my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return; + my $tables = $sth->fetchall_arrayref or return; + my @tables; + if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR + @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables; + } + else { # temporary old style hack (yeach) + @tables = map { + my $name = $_->[2]; + if ($_->[1]) { + my $schema = $_->[1]; + # a sad hack (mostly for Informix I recall) + my $quote = ($schema eq uc($schema)) ? '' : '"'; + $name = "$quote$schema$quote.$name" + } + $name; + } @$tables; + } + return @tables; + } + + sub type_info { # this should be sufficient for all drivers + my ($dbh, $data_type) = @_; + my $idx_hash; + my $tia = $dbh->{dbi_type_info_row_cache}; + if ($tia) { + $idx_hash = $dbh->{dbi_type_info_idx_cache}; + } + else { + my $temp = $dbh->type_info_all; + return unless $temp && @$temp; + # we cache here because type_info_all may be expensive to call + # (and we take a copy so the following shift can't corrupt + # the data that may be returned by future calls to type_info_all) + $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ]; + $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia; + } + + my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type}; + Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)") + if $dt_idx && $dt_idx != 1; + + # --- simple DATA_TYPE match filter + my @ti; + my @data_type_list = (ref $data_type) ? @$data_type : ($data_type); + foreach $data_type (@data_type_list) { + if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) { + push @ti, grep { $_->[$dt_idx] == $data_type } @$tia; + } + else { # SQL_ALL_TYPES + push @ti, @$tia; + } + last if @ti; # found at least one match + } + + # --- format results into list of hash refs + my $idx_fields = keys %$idx_hash; + my @idx_names = map { uc($_) } keys %$idx_hash; + my @idx_values = values %$idx_hash; + Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields" + if @ti && @{$ti[0]} != $idx_fields; + my @out = map { + my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h; + } @ti; + return $out[0] unless wantarray; + return @out; + } + + sub data_sources { + my ($dbh, @other) = @_; + my $drh = $dbh->{Driver}; # XXX proxy issues? + return $drh->data_sources(@other); + } + +} + + +{ package # hide from PAUSE + DBD::_::st; # ====== STATEMENT ====== + @DBD::_::st::ISA = qw(DBD::_::common); + use strict; + + sub bind_param { Carp::croak("Can't bind_param, not implement by driver") } + +# +# ******************************************************** +# +# BEGIN ARRAY BINDING +# +# Array binding support for drivers which don't support +# array binding, but have sufficient interfaces to fake it. +# NOTE: mixing scalars and arrayrefs requires using bind_param_array +# for *all* params...unless we modify bind_param for the default +# case... +# +# 2002-Apr-10 D. Arnold + + sub bind_param_array { + my $sth = shift; + my ($p_id, $value_array, $attr) = @_; + + return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) + if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; + + return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array") + unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here + + return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range") + if $p_id <= 0; # can't easily/reliably test for too big + + # get/create arrayref to hold params + my $hash_of_arrays = $sth->{ParamArrays} ||= { }; + + # If the bind has attribs then we rely on the driver conforming to + # the DBI spec in that a single bind_param() call with those attribs + # makes them 'sticky' and apply to all later execute(@values) calls. + # Since we only call bind_param() if we're given attribs then + # applications using drivers that don't support bind_param can still + # use bind_param_array() so long as they don't pass any attribs. + + $$hash_of_arrays{$p_id} = $value_array; + return $sth->bind_param($p_id, undef, $attr) + if $attr; + 1; + } + + sub bind_param_inout_array { + my $sth = shift; + # XXX not supported so we just call bind_param_array instead + # and then return an error + my ($p_num, $value_array, $attr) = @_; + $sth->bind_param_array($p_num, $value_array, $attr); + return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported"); + } + + sub bind_columns { + my $sth = shift; + my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0; + if ($fields <= 0 && !$sth->{Active}) { + return $sth->set_err($DBI::stderr, "Statement has no result columns to bind" + ." (perhaps you need to successfully call execute first)"); + } + # Backwards compatibility for old-style call with attribute hash + # ref as first arg. Skip arg if undef or a hash ref. + my $attr; + $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH'; + + my $idx = 0; + $sth->bind_col(++$idx, shift, $attr) or return + while (@_ and $idx < $fields); + + return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed") + if @_ or $idx != $fields; + + return 1; + } + + sub execute_array { + my $sth = shift; + my ($attr, @array_of_arrays) = @_; + my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point + + # get tuple status array or hash attribute + my $tuple_sts = $attr->{ArrayTupleStatus}; + return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref") + if $tuple_sts and ref $tuple_sts ne 'ARRAY'; + + # bind all supplied arrays + if (@array_of_arrays) { + $sth->{ParamArrays} = { }; # clear out old params + return $sth->set_err($DBI::stderr, + @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected") + if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS; + $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return + foreach (1..@array_of_arrays); + } + + my $fetch_tuple_sub; + + if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand + + return $sth->set_err($DBI::stderr, + "Can't use both ArrayTupleFetch and explicit bind values") + if @array_of_arrays; # previous bind_param_array calls will simply be ignored + + if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) { + my $fetch_sth = $fetch_tuple_sub; + return $sth->set_err($DBI::stderr, + "ArrayTupleFetch sth is not Active, need to execute() it first") + unless $fetch_sth->{Active}; + # check column count match to give more friendly message + my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS}; + return $sth->set_err($DBI::stderr, + "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected") + if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS) + && $NUM_OF_FIELDS != $NUM_OF_PARAMS; + $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref }; + } + elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) { + return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle"); + } + + } + else { + my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} }; + return $sth->set_err($DBI::stderr, + "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected") + if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given; + + # get the length of a bound array + my $maxlen; + my %hash_of_arrays = %{$sth->{ParamArrays}}; + foreach (keys(%hash_of_arrays)) { + my $ary = $hash_of_arrays{$_}; + next unless ref $ary eq 'ARRAY'; + $maxlen = @$ary if !$maxlen || @$ary > $maxlen; + } + # if there are no arrays then execute scalars once + $maxlen = 1 unless defined $maxlen; + my @bind_ids = 1..keys(%hash_of_arrays); + + my $tuple_idx = 0; + $fetch_tuple_sub = sub { + return if $tuple_idx >= $maxlen; + my @tuple = map { + my $a = $hash_of_arrays{$_}; + ref($a) ? $a->[$tuple_idx] : $a + } @bind_ids; + ++$tuple_idx; + return \@tuple; + }; + } + # pass thru the callers scalar or list context + return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts); + } + + sub execute_for_fetch { + my ($sth, $fetch_tuple_sub, $tuple_status) = @_; + # start with empty status array + ($tuple_status) ? @$tuple_status = () : $tuple_status = []; + + my $rc_total = 0; + my $err_count; + while ( my $tuple = &$fetch_tuple_sub() ) { + if ( my $rc = $sth->execute(@$tuple) ) { + push @$tuple_status, $rc; + $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1; + } + else { + $err_count++; + push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ]; + # XXX drivers implementing execute_for_fetch could opt to "last;" here + # if they know the error code means no further executes will work. + } + } + my $tuples = @$tuple_status; + return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors") + if $err_count; + $tuples ||= "0E0"; + return $tuples unless wantarray; + return ($tuples, $rc_total); + } + + + sub fetchall_arrayref { # ALSO IN Driver.xst + my ($sth, $slice, $max_rows) = @_; + + # when batch fetching with $max_rows were very likely to try to + # fetch the 'next batch' after the previous batch returned + # <=$max_rows. So don't treat that as an error. + return undef if $max_rows and not $sth->FETCH('Active'); + + my $mode = ref($slice) || 'ARRAY'; + my @rows; + + if ($mode eq 'ARRAY') { + my $row; + # we copy the array here because fetch (currently) always + # returns the same array ref. XXX + if ($slice && @$slice) { + $max_rows = -1 unless defined $max_rows; + push @rows, [ @{$row}[ @$slice] ] + while($max_rows-- and $row = $sth->fetch); + } + elsif (defined $max_rows) { + push @rows, [ @$row ] + while($max_rows-- and $row = $sth->fetch); + } + 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') { + 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 { + $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) ); + } + } + 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; + } + + sub fetchall_hashref { + my ($sth, $key_field) = @_; + + my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; + my $names_hash = $sth->FETCH("${hash_key_name}_hash"); + my @key_fields = (ref $key_field) ? @$key_field : ($key_field); + my @key_indexes; + my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS'); + foreach (@key_fields) { + my $index = $names_hash->{$_}; # perl index not column + $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields; + return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})") + unless defined $index; + push @key_indexes, $index; + } + my $rows = {}; + my $NAME = $sth->FETCH($hash_key_name); + my @row = (undef) x $num_of_fields; + $sth->bind_columns(\(@row)); + while ($sth->fetch) { + my $ref = $rows; + $ref = $ref->{$row[$_]} ||= {} for @key_indexes; + @{$ref}{@$NAME} = @row; + } + return $rows; + } + + *dump_results = \&DBI::dump_results; + + sub blob_copy_to_file { # returns length or undef on error + my($self, $field, $filename_or_handleref, $blocksize) = @_; + my $fh = $filename_or_handleref; + my($len, $buf) = (0, ""); + $blocksize ||= 512; # not too ambitious + local(*FH); + unless(ref $fh) { + open(FH, ">$fh") || return undef; + $fh = \*FH; + } + while(defined($self->blob_read($field, $len, $blocksize, \$buf))) { + print $fh $buf; + $len += length $buf; + } + close(FH); + $len; + } + + sub more_results { + shift->{syb_more_results}; # handy grandfathering + } + +} + +unless ($DBI::PurePerl) { # See install_driver + { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::db::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::st::ISA = qw(DBD::_mem::common); } + # DBD::_mem::common::DESTROY is implemented in DBI.xs +} + +1; +__END__ + +=head1 DESCRIPTION + +The DBI is a database access module for the Perl programming language. It defines +a set of methods, variables, and conventions that provide a consistent +database interface, independent of the actual database being used. + +It is important to remember that the DBI is just an interface. +The DBI is a layer +of "glue" between an application and one or more database I +modules. It is the driver modules which do most of the real work. The DBI +provides a standard interface and framework for the drivers to operate +within. + + +=head2 Architecture of a DBI Application + + |<- Scope of DBI ->| + .-. .--------------. .-------------. + .-------. | |---| XYZ Driver |---| XYZ Engine | + | Perl | | | `--------------' `-------------' + | script| |A| |D| .--------------. .-------------. + | using |--|P|--|B|---|Oracle Driver |---|Oracle Engine| + | DBI | |I| |I| `--------------' `-------------' + | API | | |... + |methods| | |... Other drivers + `-------' | |... + `-' + +The API, or Application Programming Interface, defines the +call interface and variables for Perl scripts to use. The API +is implemented by the Perl DBI extension. + +The DBI "dispatches" the method calls to the appropriate driver for +actual execution. The DBI is also responsible for the dynamic loading +of drivers, error checking and handling, providing default +implementations for methods, and many other non-database specific duties. + +Each driver +contains implementations of the DBI methods using the +private interface functions of the corresponding database engine. Only authors +of sophisticated/multi-database applications or generic library +functions need be concerned with drivers. + +=head2 Notation and Conventions + +The following conventions are used in this document: + + $dbh Database handle object + $sth Statement handle object + $drh Driver handle object (rarely seen or used in applications) + $h Any of the handle types above ($dbh, $sth, or $drh) + $rc General Return Code (boolean: true=ok, false=error) + $rv General Return Value (typically an integer) + @ary List of values returned from the database, typically a row of data + $rows Number of rows processed (if available, else -1) + $fh A filehandle + undef NULL values are represented by undefined values in Perl + \%attr Reference to a hash of attribute values passed to methods + +Note that Perl will automatically destroy database and statement handle objects +if all references to them are deleted. + + +=head2 Outline Usage + +To use DBI, +first you need to load the DBI module: + + use DBI; + use strict; + +(The C isn't required but is strongly recommended.) + +Then you need to L to your data source and get a I for that +connection: + + $dbh = DBI->connect($dsn, $user, $password, + { RaiseError => 1, AutoCommit => 0 }); + +Since connecting can be expensive, you generally just connect at the +start of your program and disconnect at the end. + +Explicitly defining the required C behaviour is strongly +recommended and may become mandatory in a later version. This +determines whether changes are automatically committed to the +database when executed, or need to be explicitly committed later. + +The DBI allows an application to "prepare" statements for later +execution. A prepared statement is identified by a statement handle +held in a Perl variable. +We'll call the Perl variable C<$sth> in our examples. + +The typical method call sequence for a C statement is: + + prepare, + execute, + execute, + execute. + +for example: + + $sth = $dbh->prepare("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)"); + + while() { + chomp; + my ($foo,$bar,$baz) = split /,/; + $sth->execute( $foo, $bar, $baz ); + } + +The C method can be used for non repeated I-C statement. + +=head1 THE DBI PACKAGE AND CLASS + +In this section, we cover the DBI class methods, utility functions, +and the dynamic attributes associated with generic DBI handles. + +=head2 DBI Constants + +Constants representing the values of the SQL standard types can be +imported individually by name, or all together by importing the +special C<:sql_types> tag. + +The names and values of all the defined SQL standard types can be +produced like this: + + foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) { + printf "%s=%d\n", $_, &{"DBI::$_"}; + } + +These constants are defined by SQL/CLI, ODBC or both. +C is (currently) omitted, because SQL/CLI and ODBC provide +conflicting codes. + +See the L, L, and L methods +for possible uses. + +Note that just because the DBI defines a named constant for a given +data type doesn't mean that drivers will support that data type. + + +=head2 DBI Class Methods + +The following methods are provided by the DBI class: + +=head3 C + + ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn($dsn) + or die "Can't parse DBI DSN '$dsn'"; + +Breaks apart a DBI Data Source Name (DSN) and returns the individual +parts. If $dsn doesn't contain a valid DSN then parse_dsn() returns +an empty list. + +$scheme is the first part of the DSN and is currently always 'dbi'. +$driver is the driver name, possibly defaulted to $ENV{DBI_DRIVER}, +and may be undefined. $attr_string is the contents of the optional attribute +string, which may be undefined. If $attr_string is not empty then $attr_hash +is a reference to a hash containing the parsed attribute names and values. +$driver_dsn is the last part of the DBI DSN string. For example: + + ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) + = DBI->parse_dsn("DBI:MyDriver(RaiseError=>1):db=test;port=42"); + $scheme = 'dbi'; + $driver = 'MyDriver'; + $attr_string = 'RaiseError=>1'; + $attr_hash = { 'RaiseError' => '1' }; + $driver_dsn = 'db=test;port=42'; + +The parse_dsn() method was added in DBI 1.43. + +=head3 C + + $dbh = DBI->connect($data_source, $username, $password) + or die $DBI::errstr; + $dbh = DBI->connect($data_source, $username, $password, \%attr) + or die $DBI::errstr; + +Establishes a database connection, or session, to the requested C<$data_source>. +Returns a database handle object if the connection succeeds. Use +C<$dbh-Edisconnect> to terminate the connection. + +If the connect fails (see below), it returns C and sets both C<$DBI::err> +and C<$DBI::errstr>. (It does I explicitly set C<$!>.) You should generally +test the return status of C and C if it has failed. + +Multiple simultaneous connections to multiple databases through multiple +drivers can be made via the DBI. Simply make one C call for each +database and keep a copy of each returned database handle. + +The C<$data_source> value must begin with "CIC<:>". +The I specifies the driver that will be used to make the +connection. (Letter case is significant.) + +As a convenience, if the C<$data_source> parameter is undefined or empty, +the DBI will substitute the value of the environment variable C. +If just the I part is empty (i.e., the C<$data_source> +prefix is "C"), the environment variable C is +used. If neither variable is set, then C dies. + +Examples of C<$data_source> values are: + + dbi:DriverName:database_name + dbi:DriverName:database_name@hostname:port + dbi:DriverName:database=database_name;host=hostname;port=port + +There is I for the text following the driver name. Each +driver is free to use whatever syntax it wants. The only requirement the +DBI makes is that all the information is supplied in a single string. +You must consult the documentation for the drivers you are using for a +description of the syntax they require. + +It is recommended that drivers support the ODBC style, shown in the +last example above. It is also recommended that that they support the +three common names 'C', 'C', and 'C' (plus 'C' +as an alias for C). This simplifies automatic construction +of basic DSNs: C<"dbi:$driver:database=$db;host=$host;port=$port">. +Drivers should aim to 'do something reasonable' when given a DSN +in this form, but if any part is meaningless for that driver (such +as 'port' for Informix) it should generate an error if that part +is not empty. + +If the environment variable C is defined (and the +driver in C<$data_source> is not "C") then the connect request +will automatically be changed to: + + $ENV{DBI_AUTOPROXY};dsn=$data_source + +C is typically set as "C". +If $ENV{DBI_AUTOPROXY} doesn't begin with 'C' then "dbi:Proxy:" +will be prepended to it first. See the DBD::Proxy documentation +for more details. + +If C<$username> or C<$password> are undefined (rather than just empty), +then the DBI will substitute the values of the C and C +environment variables, respectively. The DBI will warn if the +environment variables are not defined. However, the everyday use +of these environment variables is not recommended for security +reasons. The mechanism is primarily intended to simplify testing. +See below for alternative way to specify the username and password. + +Cconnect> automatically installs the driver if it has not been +installed yet. Driver installation either returns a valid driver +handle, or it I with an error message that includes the string +"C" and the underlying problem. So Cconnect> +will die +on a driver installation failure and will only return C on a +connect failure, in which case C<$DBI::errstr> will hold the error message. +Use C if you need to catch the "C" error. + +The C<$data_source> argument (with the "C" prefix removed) and the +C<$username> and C<$password> arguments are then passed to the driver for +processing. The DBI does not define any interpretation for the +contents of these fields. The driver is free to interpret the +C<$data_source>, C<$username>, and C<$password> fields in any way, and supply +whatever defaults are appropriate for the engine being accessed. +(Oracle, for example, uses the ORACLE_SID and TWO_TASK environment +variables if no C<$data_source> is specified.) + +The C and C attributes for each connection +default to "on". (See L and L for more information.) +However, it is strongly recommended that you explicitly define C +rather than rely on the default. The C attribute defaults to +on if $^W is true, i.e., perl is running with warnings enabled. + +The C<\%attr> parameter can be used to alter the default settings of +C, C, C, and other attributes. For example: + + $dbh = DBI->connect($data_source, $user, $pass, { + PrintError => 0, + AutoCommit => 0 + }); + +The username and password can also be specified using the attributes +C and C, in which case they take precedence +over the C<$username> and C<$password> parameters. + +You can also define connection attribute values within the C<$data_source> +parameter. For example: + + dbi:DriverName(PrintWarn=>1,PrintError=>0,Taint=>1):... + +Individual attributes values specified in this way take precedence over +any conflicting values specified via the C<\%attr> parameter to C. + +The C attribute can be used to specify which driver +method should be called to establish the connection. The only useful +values are 'connect', 'connect_cached', or some specialized case like +'Apache::DBI::connect' (which is automatically the default when running +within Apache). + +Where possible, each session (C<$dbh>) is independent from the transactions +in other sessions. This is useful when you need to hold cursors open +across transactions--for example, if you use one session for your long lifespan +cursors (typically read-only) and another for your short update +transactions. + +For compatibility with old DBI scripts, the driver can be specified by +passing its name as the fourth argument to C (instead of C<\%attr>): + + $dbh = DBI->connect($data_source, $user, $pass, $driver); + +In this "old-style" form of C, the C<$data_source> should not start +with "C". (If it does, the embedded driver_name +will be ignored). Also note that in this older form of C, +the C<$dbh-E{AutoCommit}> attribute is I, the +C<$dbh-E{PrintError}> attribute is off, and the old C +environment variable is +checked if C is not defined. Beware that this "old-style" +C will soon be withdrawn in a future version of DBI. + +=head3 C + + $dbh = DBI->connect_cached($data_source, $username, $password) + or die $DBI::errstr; + $dbh = DBI->connect_cached($data_source, $username, $password, \%attr) + or die $DBI::errstr; + +C is like L, except that the database handle +returned is also +stored in a hash associated with the given parameters. If another call +is made to C with the same parameter values, then the +corresponding cached C<$dbh> will be returned if it is still valid. +The cached database handle is replaced with a new connection if it +has been disconnected or if the C method fails. + +Note that the behaviour of this method differs in several respects from the +behaviour of persistent connections implemented by Apache::DBI. +However, if Apache::DBI is loaded then C will use it. + +Caching connections can be useful in some applications, but it can +also cause problems, such as too many connections, and so should +be used with care. In particular, avoid changing the attributes of +a database handle created via connect_cached() because it will affect +other code that may be using the same handle. When connect_cached() +returns a handle the attributes will be reset to their initial values. +This can cause problems, especially with the C attribute. + +Where multiple separate parts of a program are using connect_cached() +to connect to the same database with the same (initial) attributes +it is a good idea to add a private attribute to the connect_cached() +call to effectively limit the scope of the caching. For example: + + DBI->connect_cached(..., { private_foo_cachekey => "Bar", ... }); + +Handles returned from that connect_cached() call will only be returned +by other connect_cached() call elsewhere in the code if those other +calls also pass in the same attribute values, including the private one. +(I've used C here as an example, you can use +any attribute name with a C prefix.) + +Taking that one step further, you can limit a particular connect_cached() +call to return handles unique to that one place in the code by setting the +private attribute to a unique value for that place: + + DBI->connect_cached(..., { private_foo_cachekey => __FILE__.__LINE__, ... }); + +By using a private attribute you still get connection caching for +the individual calls to connect_cached() but, by making separate +database connections for separate parts of the code, the database +handles are isolated from any attribute changes made to other handles. + +The cache can be accessed (and cleared) via the L attribute: + + my $CachedKids_hashref = $dbh->{Driver}->{CachedKids}; + %$CachedKids_hashref = () if $CachedKids_hashref; + + +=head3 C + + @ary = DBI->available_drivers; + @ary = DBI->available_drivers($quiet); + +Returns a list of all available drivers by searching for C modules +through the directories in C<@INC>. By default, a warning is given if +some drivers are hidden by others of the same name in earlier +directories. Passing a true value for C<$quiet> will inhibit the warning. + +=head3 C + + %drivers = DBI->installed_drivers(); + +Returns a list of driver name and driver handle pairs for all drivers +'installed' (loaded) into the current process. The driver name does not +include the 'DBD::' prefix. + +To get a list of all drivers available in your perl installation you can use +L. + +Added in DBI 1.49. + +=head3 C + + DBI->installed_versions; + @ary = 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 +name and version number are added to a hash. When running under +L drivers which appear not be pure-perl are ignored. + +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 version, +C name, etc. + +When called in a void context the installed_versions() method will +print out a formatted list of the hash contents, one per line. + +Due to the potentially high memory cost and unknown risks of loading +in an unknown number of drivers that just happen to be installed +on the system, this method is not recommended for general use. +Use available_drivers() instead. + +The installed_versions() method is primarily intended as a quick +way to see from the command line what's installed. For example: + + perl -MDBI -e 'DBI->installed_versions' + +The installed_versions() method was added in DBI 1.38. + +=head3 C + + @ary = DBI->data_sources($driver); + @ary = DBI->data_sources($driver, \%attr); + +Returns a list of data sources (databases) available via the named +driver. If C<$driver> is empty or C, then the value of the +C environment variable is used. + +The driver will be loaded if it hasn't been already. Note that if the +driver loading fails then data_sources() I with an error message +that includes the string "C" and the underlying problem. + +Data sources are returned in a form suitable for passing to the +L method (that is, they will include the "C" prefix). + +Note that many drivers have no way of knowing what data sources might +be available for it. These drivers return an empty or incomplete list +or may require driver-specific attributes. + +There is also a data_sources() method defined for database handles. + + +=head3 C + + DBI->trace($trace_setting) + DBI->trace($trace_setting, $trace_filename) + DBI->trace($trace_setting, $trace_filehandle) + $trace_setting = DBI->trace; + +The Ctrace> method sets the I trace +settings and returns the I trace settings. It can also +be used to change where the trace output is sent. + +There's a similar method, C<$h-Etrace>, which sets the trace +settings for the specific handle it's called on. + +See the L section for full details about the DBI's powerful +tracing facilities. + + +=head3 C + + DBI->visit_handles( $coderef ); + DBI->visit_handles( $coderef, $info ); + +Where $coderef is a reference to a subroutine and $info is an arbitrary value +which, if undefined, defaults to a reference to an empty hash. Returns $info. + +For each installed driver handle, if any, $coderef is invoked as: + + $coderef->($driver_handle, $info); + +If the execution of $coderef returns a true value then L +is called on that child handle and passed the returned value as $info. + +For example: + + my $info = $dbh->{Driver}->visit_child_handles(sub { + my ($h, $info) = @_; + ++$info->{ $h->{Type} }; # count types of handles (dr/db/st) + return $info; # visit kids + }); + +See also L. + +=head2 DBI Utility Functions + +In addition to the DBI methods listed in the previous section, +the DBI package also provides several utility functions. + +These can be imported into your code by listing them in +the C statement. For example: + + use DBI qw(neat data_diff); + +Alternatively, all these utility functions (except hash) can be +imported using the C<:utils> import tag. For example: + + use DBI qw(:utils); + +=head3 C + + $description = data_string_desc($string); + +Returns an informal description of the string. For example: + + UTF8 off, ASCII, 42 characters 42 bytes + UTF8 off, non-ASCII, 42 characters 42 bytes + UTF8 on, non-ASCII, 4 characters 6 bytes + UTF8 on but INVALID encoding, non-ASCII, 4 characters 6 bytes + UTF8 off, undef + +The initial C on/off refers to Perl's internal SvUTF8 flag. +If $string has the SvUTF8 flag set but the sequence of bytes it +contains are not a valid UTF-8 encoding then data_string_desc() +will report C. + +The C vs C portion shows C if I the +characters in the string are ASCII (have code points <= 127). + +The data_string_desc() function was added in DBI 1.46. + +=head3 C + + $diff = data_string_diff($a, $b); + +Returns an informal description of the first character difference +between the strings. If both $a and $b contain the same sequence +of characters then data_string_diff() returns an empty string. +For example: + + Params a & b Result + ------------ ------ + 'aaa', 'aaa' '' + 'aaa', 'abc' 'Strings differ at index 2: a[2]=a, b[2]=b' + 'aaa', undef 'String b is undef, string a has 3 characters' + 'aaa', 'aa' 'String b truncated after 2 characters' + +Unicode characters are reported in C<\x{XXXX}> format. Unicode +code points in the range U+0800 to U+08FF are unassigned and most +likely to occur due to double-encoding. Characters in this range +are reported as C<\x{08XX}='C'> where C is the corresponding +latin-1 character. + +The data_string_diff() function only considers logical I +and not the underlying encoding. See L for an alternative. + +The data_string_diff() function was added in DBI 1.46. + +=head3 C + + $diff = data_diff($a, $b); + $diff = data_diff($a, $b, $logical); + +Returns an informal description of the difference between two strings. +It calls L and L +and returns the combined results as a multi-line string. + +For example, C will return: + + a: UTF8 off, ASCII, 3 characters 3 bytes + b: UTF8 on, non-ASCII, 3 characters 5 bytes + Strings differ at index 2: a[2]=c, b[2]=\x{263A} + +If $a and $b are identical in both the characters they contain I +their physical encoding then data_diff() returns an empty string. +If $logical is true then physical encoding differences are ignored +(but are still reported if there is a difference in the characters). + +The data_diff() function was added in DBI 1.46. + +=head3 C + + $str = neat($value); + $str = neat($value, $maxlen); + +Return a string containing a neat (and tidy) representation of the +supplied value. + +Strings will be quoted, although internal quotes will I be escaped. +Values known to be numeric will be unquoted. Undefined (NULL) values +will be shown as C (without quotes). + +If the string is flagged internally as utf8 then double quotes will +be used, otherwise single quotes are used and unprintable characters +will be replaced by dot (.). + +For result strings longer than C<$maxlen> the result string will be +truncated to C<$maxlen-4> and "C<...'>" will be appended. If C<$maxlen> is 0 +or C, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400. + +This function is designed to format values for human consumption. +It is used internally by the DBI for L output. It should +typically I be used for formatting values for database use. +(See also L.) + +=head3 C + + $str = neat_list(\@listref, $maxlen, $field_sep); + +Calls C on each element of the list and returns a string +containing the results joined with C<$field_sep>. C<$field_sep> defaults +to C<", ">. + +=head3 C + + @bool = looks_like_number(@array); + +Returns true for each element that looks like a number. +Returns false for each element that does not look like a number. +Returns C for each element that is undefined or empty. + +=head3 C + + $hash_value = DBI::hash($buffer, $type); + +Return a 32-bit integer 'hash' value corresponding to the contents of $buffer. +The $type parameter selects which kind of hash algorithm should be used. + +For the technically curious, type 0 (which is the default if $type +isn't specified) is based on the Perl 5.1 hash except that the value +is forced to be negative (for obscure historical reasons). +Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See +L for more information. +Both types are implemented in C and are very fast. + +This function doesn't have much to do with databases, except that +it can be handy to store hash values in a database. + +=head3 C + + $sts = DBI::sql_type_cast($sv, $sql_type, $flags); + +sql_type_cast attempts to cast C<$sv> to the SQL type (see L) specified in C<$sql_type>. At present only the SQL types +C, C and C are supported. + +For C the effect is similar to using the value in an expression +that requires an integer. It gives the perl scalar an 'integer aspect'. +(Technically the value gains an IV, or possibly a UV or NV if the value is too +large for an IV.) + +For C the effect is similar to using the value in an expression +that requires a general numeric value. It gives the perl scalar a 'numeric +aspect'. (Technically the value gains an NV.) + +C is similar to C or C but more +general and more cautious. It will look at the string first and if it +looks like an integer (that will fit in an IV or UV) it will act like +C, if it looks like a floating point value it will act +like C, if it looks like neither then it will do nothing - +and thereby avoid the warnings that would be generated by +C and C when given non-numeric data. + +C<$flags> may be: + +=over 4 + +=item C + +If this flag is specified then when the driver successfully casts the +bound perl scalar to a non-string type then the string portion of the +scalar will be discarded. + +=item C + +If C<$sv> cannot be cast to the requested C<$sql_type> then by default +it is left untouched and no error is generated. If you specify +C and the cast fails, this will generate an error. + +=back + +The returned C<$sts> value is: + + -2 sql_type is not handled + -1 sv is undef so unchanged + 0 sv could not be cast cleanly and DBIstcf_STRICT was used + 1 sv could not be cast and DBIstcf_STRICT was not used + 2 sv was cast successfully + +This method is exported by the :utils tag and was introduced in DBI +1.611. + +=head2 DBI Dynamic Attributes + +Dynamic attributes are always associated with the I +(that handle is represented by C<$h> in the descriptions below). + +Where an attribute is equivalent to a method call, then refer to +the method call for all related documentation. + +Warning: these attributes are provided as a convenience but they +do have limitations. Specifically, they have a short lifespan: +because they are associated with +the last handle used, they should only be used I after +calling the method that "sets" them. +If in any doubt, use the corresponding method call. + +=head3 C<$DBI::err> + +Equivalent to C<$h-Eerr>. + +=head3 C<$DBI::errstr> + +Equivalent to C<$h-Eerrstr>. + +=head3 C<$DBI::state> + +Equivalent to C<$h-Estate>. + +=head3 C<$DBI::rows> + +Equivalent to C<$h-Erows>. Please refer to the documentation +for the L method. + +=head3 C<$DBI::lasth> + +Returns the DBI object handle used for the most recent DBI method call. +If the last DBI method call was a DESTROY then $DBI::lasth will return +the handle of the parent of the destroyed handle, if there is one. + + +=head1 METHODS COMMON TO ALL HANDLES + +The following methods can be used by all types of DBI handles. + +=head3 C + + $rv = $h->err; + +Returns the I database engine error code from the last driver +method called. The code is typically an integer but you should not +assume that. + +The DBI resets $h->err to undef before almost all DBI method calls, so the +value only has a short lifespan. Also, for most drivers, the statement +handles share the same error variable as the parent database handle, +so calling a method on one handle may reset the error on the +related handles. + +(Methods which don't reset err before being called include err() and errstr(), +obviously, state(), rows(), func(), trace(), trace_msg(), ping(), and the +tied hash attribute FETCH() and STORE() methods.) + +If you need to test for specific error conditions I have your program be +portable to different database engines, then you'll need to determine what the +corresponding error codes are for all those engines and test for all of them. + +The DBI uses the value of $DBI::stderr as the C value for internal errors. +Drivers should also do likewise. The default value for $DBI::stderr is 2000000000. + +A driver may return C<0> from err() to indicate a warning condition +after a method call. Similarly, a driver may return an empty string +to indicate a 'success with information' condition. In both these +cases the value is false but not undef. The errstr() and state() +methods may be used to retrieve extra information in these cases. + +See L for more information. + +=head3 C + + $str = $h->errstr; + +Returns the native database engine error message from the last DBI +method called. This has the same lifespan issues as the L method +described above. + +The returned string may contain multiple messages separated by +newline characters. + +The errstr() method should not be used to test for errors, use err() +for that, because drivers may return 'success with information' or +warning messages via errstr() for methods that have not 'failed'. + +See L for more information. + +=head3 C + + $str = $h->state; + +Returns a state code in the standard SQLSTATE five character format. +Note that the specific success code C<00000> is translated to any empty string +(false). If the driver does not support SQLSTATE (and most don't), +then state() will return C (General Error) for all errors. + +The driver is free to return any value via C, e.g., warning +codes, even if it has not declared an error by returning a true value +via the L method described above. + +The state() method should not be used to test for errors, use err() +for that, because drivers may return a 'success with information' or +warning state code via state() for methods that have not 'failed'. + +=head3 C + + $rv = $h->set_err($err, $errstr); + $rv = $h->set_err($err, $errstr, $state); + $rv = $h->set_err($err, $errstr, $state, $method); + $rv = $h->set_err($err, $errstr, $state, $method, $rv); + +Set the C, C, and C values for the handle. +This method is typically only used by DBI drivers and DBI subclasses. + +If the L attribute holds a reference to a subroutine +it is called first. The subroutine can alter the $err, $errstr, $state, +and $method values. See L for full details. +If the subroutine returns a true value then the handle C, +C, and C values are not altered and set_err() returns +an empty list (it normally returns $rv which defaults to undef, see below). + +Setting C to a I value indicates an error and will trigger +the normal DBI error handling mechanisms, such as C and +C, if they are enabled, when execution returns from +the DBI back to the application. + +Setting C to C<""> indicates an 'information' state, and setting +it to C<"0"> indicates a 'warning' state. Setting C to C +also sets C to undef, and C to C<"">, irrespective +of the values of the $errstr and $state parameters. + +The $method parameter provides an alternate method name for the +C/C/C error string instead of +the fairly unhelpful 'C'. + +The C method normally returns undef. The $rv parameter +provides an alternate return value. + +Some special rules apply if the C or C +values for the handle are I set... + +If C is true then: "C< [err was %s now %s]>" is appended if $err is +true and C is already true and the new err value differs from the original +one. Similarly "C< [state was %s now %s]>" is appended if $state is true and C is +already true and the new state value differs from the original one. Finally +"C<\n>" and the new $errstr are appended if $errstr differs from the existing +errstr value. Obviously the C<%s>'s above are replaced by the corresponding values. + +The handle C value is set to $err if: $err is true; or handle +C value is undef; or $err is defined and the length is greater +than the handle C length. The effect is that an 'information' +state only overrides undef; a 'warning' overrides undef or 'information', +and an 'error' state overrides anything. + +The handle C value is set to $state if $state is true and +the handle C value was set (by the rules above). + +Support for warning and information states was added in DBI 1.41. + +=head3 C + + $h->trace($trace_settings); + $h->trace($trace_settings, $trace_filename); + $trace_settings = $h->trace; + +The trace() method is used to alter the trace settings for a handle +(and any future children of that handle). It can also be used to +change where the trace output is sent. + +There's a similar method, Ctrace>, which sets the global +default trace settings. + +See the L section for full details about the DBI's powerful +tracing facilities. + +=head3 C + + $h->trace_msg($message_text); + $h->trace_msg($message_text, $min_level); + +Writes C<$message_text> to the trace file if the trace level is +greater than or equal to $min_level (which defaults to 1). +Can also be called as Ctrace_msg($msg)>. + +See L for more details. + +=head3 C + + $h->func(@func_arguments, $func_name) or die ...; + +The C method can be used to call private non-standard and +non-portable methods implemented by the driver. Note that the function +name is given as the I argument. + +It's also important to note that the func() method does not clear +a previous error ($DBI::err etc.) and it does not trigger automatic +error detection (RaiseError etc.) so you must check the return +status and/or $h->err to detect errors. + +(This method is not directly related to calling stored procedures. +Calling stored procedures is currently not defined by the DBI. +Some drivers, such as DBD::Oracle, support it in non-portable ways. +See driver documentation for more details.) + +See also install_method() in L for how you can avoid needing to +use func() and gain direct access to driver-private methods. + +=head3 C + + $is_implemented = $h->can($method_name); + +Returns true if $method_name is implemented by the driver or a +default method is provided by the DBI. +It returns false where a driver hasn't implemented a method and the +default method is provided by the DBI is just an empty stub. + +=head3 C + + $trace_settings_integer = $h->parse_trace_flags($trace_settings); + +Parses a string containing trace settings and returns the corresponding +integer value used internally by the DBI and drivers. + +The $trace_settings argument is a string containing a trace level +between 0 and 15 and/or trace flag names separated by vertical bar +("C<|>") or comma ("C<,>") characters. For example: C<"SQL|3|foo">. + +It uses the parse_trace_flag() method, described below, to process +the individual trace flag names. + +The parse_trace_flags() method was added in DBI 1.42. + +=head3 C + + $bit_flag = $h->parse_trace_flag($trace_flag_name); + +Returns the bit flag corresponding to the trace flag name in +$trace_flag_name. Drivers are expected to override this method and +check if $trace_flag_name is a driver specific trace flags and, if +not, then call the DBI's default parse_trace_flag(). + +The parse_trace_flag() method was added in DBI 1.42. + +=head3 C + + $hash_ref = $h->private_attribute_info(); + +Returns a reference to a hash whose keys are the names of driver-private +handle attributes available for the kind of handle (driver, database, statement) +that the method was called on. + +For example, the return value when called with a DBD::Sybase $dbh could look like this: + + { + syb_dynamic_supported => undef, + syb_oc_version => undef, + syb_server_version => undef, + syb_server_version_string => undef, + } + +and when called with a DBD::Sybase $sth they could look like this: + + { + syb_types => undef, + syb_proc_status => undef, + syb_result_type => undef, + } + +The values should be undef. Meanings may be assigned to particular values in future. + +=head3 C + + $rc = $h1->swap_inner_handle( $h2 ); + $rc = $h1->swap_inner_handle( $h2, $allow_reparent ); + +Brain transplants for handles. You don't need to know about this +unless you want to become a handle surgeon. + +A DBI handle is a reference to a tied hash. A tied hash has an +I hash that actually holds the contents. The swap_inner_handle() +method swaps the inner hashes between two handles. The $h1 and $h2 +handles still point to the same tied hashes, but what those hashes +are tied to has been swapped. In effect $h1 I $h2 and +vice-versa. This is powerful stuff, expect problems. Use with care. + +As a small safety measure, the two handles, $h1 and $h2, have to +share the same parent unless $allow_reparent is true. + +The swap_inner_handle() method was added in DBI 1.44. + +Here's a quick kind of 'diagram' as a worked example to help think about what's +happening: + + Original state: + dbh1o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh2o -> dbh2i + + swap_inner_handle dbh1o with dbh2o: + dbh2o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh1o -> dbh2i + + create new sth from dbh1o: + dbh2o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh1o -> dbh2i + sthBo -> sthBi(dbh2i) + + swap_inner_handle sthAo with sthBo: + dbh2o -> dbh1i + sthBo -> sthAi(dbh1i) + dbh1o -> dbh2i + sthAo -> sthBi(dbh2i) + +=head3 C + + $h->visit_child_handles( $coderef ); + $h->visit_child_handles( $coderef, $info ); + +Where $coderef is a reference to a subroutine and $info is an arbitrary value +which, if undefined, defaults to a reference to an empty hash. Returns $info. + +For each child handle of $h, if any, $coderef is invoked as: + + $coderef->($child_handle, $info); + +If the execution of $coderef returns a true value then C +is called on that child handle and passed the returned value as $info. + +For example: + + # count database connections with names (DSN) matching a pattern + my $connections = 0; + $dbh->{Driver}->visit_child_handles(sub { + my ($h, $info) = @_; + ++$connections if $h->{Name} =~ /foo/; + return 0; # don't visit kids + }) + +See also L. + +=head1 ATTRIBUTES COMMON TO ALL HANDLES + +These attributes are common to all types of DBI handles. + +Some attributes are inherited by child handles. That is, the value +of an inherited attribute in a newly created statement handle is the +same as the value in the parent database handle. Changes to attributes +in the new statement handle do not affect the parent database handle +and changes to the database handle do not affect existing statement +handles, only future ones. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver specific attributes (which all have names +starting with a lowercase letter). + +Example: + + $h->{AttributeName} = ...; # set/write + ... = $h->{AttributeName}; # get/read + +=head3 C + +Type: boolean, inherited + +The C attribute enables useful warnings for certain bad +practices. It is enabled by default and should only be disabled in +rare circumstances. Since warnings are generated using the Perl +C function, they can be intercepted using the Perl C<$SIG{__WARN__}> +hook. + +The C attribute is not related to the C attribute. + +=head3 C + +Type: boolean, read-only + +The C attribute is true if the handle object is "active". This is rarely used in +applications. The exact meaning of active is somewhat vague at the +moment. For a database handle it typically means that the handle is +connected to a database (C<$dbh-Edisconnect> sets C off). For +a statement handle it typically means that the handle is a C statements that +either cannot be prepared in advance (due to a limitation of the +driver) or do not need to be executed repeatedly. It should not +be used for C". Drivers using any approach +like this should issue a warning if C is true because +it is generally unsafe - another process may have modified the table +between your insert and the select. For situations where you know +it is safe, such as when you have locked the table, you can silence +the warning by passing C => 0 in \%attr. + +B<*> If no insert has been performed yet, or the last insert failed, +then the value is implementation defined. + +Given all the caveats above, it's clear that this method must be +used with care. + +The C method was added in DBI 1.38. + +=head3 C + + @row_ary = $dbh->selectrow_array($statement); + @row_ary = $dbh->selectrow_array($statement, \%attr); + @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. If called in a list context, it +returns the first row of data from the statement. The C<$statement> +parameter can be a previously prepared statement handle, in which case +the C is skipped. + +If any method fails, and L is not set, C +will return an empty list. + +If called in a scalar context for a statement handle that has more +than one column, it is undefined whether the driver will return +the value of the first column or the last. So don't do that. +Also, in a scalar context, an C is returned if there are no +more rows or if an error occurred. That C can't be distinguished +from an C returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C in a scalar context, or just don't do that. + + +=head3 C + + $ary_ref = $dbh->selectrow_arrayref($statement); + $ary_ref = $dbh->selectrow_arrayref($statement, \%attr); + $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns the first row of +data from the statement. The C<$statement> parameter can be a previously +prepared statement handle, in which case the C is skipped. + +If any method fails, and L is not set, C +will return undef. + + +=head3 C + + $hash_ref = $dbh->selectrow_hashref($statement); + $hash_ref = $dbh->selectrow_hashref($statement, \%attr); + $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns the first row of +data from the statement. The C<$statement> parameter can be a previously +prepared statement handle, in which case the C is skipped. + +If any method fails, and L is not set, C +will return undef. + + +=head3 C + + $ary_ref = $dbh->selectall_arrayref($statement); + $ary_ref = $dbh->selectall_arrayref($statement, \%attr); + $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns a reference to an +array containing a reference to an array (or hash, see below) for each row of +data fetched. + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +If L is not set and any method except C +fails then C will return C; if +C fails then it will return with whatever data +has been fetched thus far. You should check C<$sth-Eerr> +afterwards (or use the C attribute) to discover if the data is +complete or was truncated due to an error. + +The L method called by C +supports a $max_rows parameter. You can specify a value for $max_rows +by including a 'C' attribute in \%attr. In which case finish() +is called for you after fetchall_arrayref() returns. + +The L method called by C +also supports a $slice parameter. You can specify a value for $slice by +including a 'C' or 'C' attribute in \%attr. The only +difference between the two is that if C is not defined and +C is an array ref, then the array is assumed to contain column +index values (which count from 1), rather than perl array index values. +In which case the array is copied and each value decremented before +passing to C. + +You may often want to fetch an array of rows where each row is stored as a +hash. That can be done simple using: + + my $emps = $dbh->selectall_arrayref( + "SELECT ename FROM emp ORDER BY ename", + { Slice => {} } + ); + foreach my $emp ( @$emps ) { + print "Employee: $emp->{ename}\n"; + } + +Or, to fetch into an array instead of an array ref: + + @result = @{ $dbh->selectall_arrayref($sql, { Slice => {} }) }; + +See L method for more details. + +=head3 C + + $hash_ref = $dbh->selectall_hashref($statement, $key_field); + $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr); + $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns a reference to a +hash containing one entry, at most, for each row, as returned by fetchall_hashref(). + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +The C<$key_field> parameter defines which column, or columns, are used as keys +in the returned hash. It can either be the name of a single field, or a +reference to an array containing multiple field names. Using multiple names +yields a tree of nested hashes. + +If a row has the same key as an earlier row then it replaces the earlier row. + +If any method except C fails, and L is not set, +C will return C. If C fails and +L is not set, then it will return with whatever data it +has fetched thus far. $DBI::err should be checked to catch that. + +See fetchall_hashref() for more details. + +=head3 C + + $ary_ref = $dbh->selectcol_arrayref($statement); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L, and fetching one +column from all the rows, into a single call. It returns a reference to +an array containing the values of the first column from each row. + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +If any method except C fails, and L is not set, +C will return C. If C fails and +L is not set, then it will return with whatever data it +has fetched thus far. $DBI::err should be checked to catch that. + +The C method defaults to pushing a single column +value (the first) from each row into the result array. However, it can +also push another column, or even multiple columns per row, into the +result array. This behaviour can be specified via a 'C' +attribute which must be a ref to an array containing the column number +or numbers to use. For example: + + # get array of id and name pairs: + my $ary_ref = $dbh->selectcol_arrayref("select id, name from table", { Columns=>[1,2] }); + my %hash = @$ary_ref; # build hash from key-value pairs so $hash{$id} => name + +You can specify a maximum number of rows to fetch by including a +'C' attribute in \%attr. + +=head3 C + + $sth = $dbh->prepare($statement) or die $dbh->errstr; + $sth = $dbh->prepare($statement, \%attr) or die $dbh->errstr; + +Prepares a statement for later execution by the database +engine and returns a reference to a statement handle object. + +The returned statement handle can be used to get attributes of the +statement and invoke the L method. See L. + +Drivers for engines without the concept of preparing a +statement will typically just store the statement in the returned +handle and process it when C<$sth-Eexecute> is called. Such drivers are +unlikely to give much useful information about the +statement, such as C<$sth-E{NUM_OF_FIELDS}>, until after C<$sth-Eexecute> +has been called. Portable applications should take this into account. + +In general, DBI drivers do not parse the contents of the statement +(other than simply counting any L). The statement is +passed directly to the database engine, sometimes known as pass-thru +mode. This has advantages and disadvantages. On the plus side, you can +access all the functionality of the engine being used. On the downside, +you're limited if you're using a simple engine, and you need to take extra care if +writing applications intended to be portable between engines. + +Portable applications should not assume that a new statement can be +prepared and/or executed while still fetching results from a previous +statement. + +Some command-line SQL tools use statement terminators, like a semicolon, +to indicate the end of a statement. Such terminators should not normally +be used with the DBI. + + +=head3 C + + $sth = $dbh->prepare_cached($statement) + $sth = $dbh->prepare_cached($statement, \%attr) + $sth = $dbh->prepare_cached($statement, \%attr, $if_active) + +Like L except that the statement handle returned will be +stored in a hash associated with the C<$dbh>. If another call is made to +C with the same C<$statement> and C<%attr> parameter values, +then the corresponding cached C<$sth> will be returned without contacting the +database server. + +The C<$if_active> parameter lets you adjust the behaviour if an +already cached statement handle is still Active. There are several +alternatives: + +=over 4 + +=item B<0>: A warning will be generated, and finish() will be called on +the statement handle before it is returned. This is the default +behaviour if $if_active is not passed. + +=item B<1>: finish() will be called on the statement handle, but the +warning is suppressed. + +=item B<2>: Disables any checking. + +=item B<3>: The existing active statement handle will be removed from the +cache and a new statement handle prepared and cached in its place. +This is the safest option because it doesn't affect the state of the +old handle, it just removes it from the cache. [Added in DBI 1.40] + +=back + +Here are some examples of C: + + sub insert_hash { + my ($table, $field_values) = @_; + # sort to keep field order, and thus sql, stable for prepare_cached + my @fields = sort keys %$field_values; + my @values = @{$field_values}{@fields}; + my $sql = sprintf "insert into %s (%s) values (%s)", + $table, join(",", @fields), join(",", ("?")x@fields); + my $sth = $dbh->prepare_cached($sql); + return $sth->execute(@values); + } + + sub search_hash { + my ($table, $field_values) = @_; + # sort to keep field order, and thus sql, stable for prepare_cached + my @fields = sort keys %$field_values; + my @values = @{$field_values}{@fields}; + my $qualifier = ""; + $qualifier = "where ".join(" and ", map { "$_=?" } @fields) if @fields; + $sth = $dbh->prepare_cached("SELECT * FROM $table $qualifier"); + return $dbh->selectall_arrayref($sth, {}, @values); + } + +I This caching can be useful in some applications, +but it can also cause problems and should be used with care. Here +is a contrived case where caching would cause a significant problem: + + my $sth = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); + $sth->execute(...); + while (my $data = $sth->fetchrow_hashref) { + + # later, in some other code called within the loop... + my $sth2 = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); + $sth2->execute(...); + while (my $data2 = $sth2->fetchrow_arrayref) { + do_stuff(...); + } + } + +In this example, since both handles are preparing the exact same statement, +C<$sth2> will not be its own statement handle, but a duplicate of C<$sth> +returned from the cache. The results will certainly not be what you expect. +Typically the inner fetch loop will work normally, fetching all +the records and terminating when there are no more, but now that $sth +is the same as $sth2 the outer fetch loop will also terminate. + +You'll know if you run into this problem because prepare_cached() +will generate a warning by default (when $if_active is false). + +The cache used by prepare_cached() is keyed by both the statement +and any attributes so you can also avoid this issue by doing something +like: + + $sth = $dbh->prepare_cached("...", { dbi_dummy => __FILE__.__LINE__ }); + +which will ensure that prepare_cached only returns statements cached +by that line of code in that source file. + +If you'd like the cache to managed intelligently, you can tie the +hashref returned by C to an appropriate caching module, +such as L: + + my $cache; + tie %$cache, 'Tie::Cache::LRU', 500; + $dbh->{CachedKids} = $cache; + +=head3 C + + $rc = $dbh->commit or die $dbh->errstr; + +Commit (make permanent) the most recent series of database changes +if the database supports transactions and AutoCommit is off. + +If C is on, then calling +C will issue a "commit ineffective with AutoCommit" warning. + +See also L in the L section below. + +=head3 C + + $rc = $dbh->rollback or die $dbh->errstr; + +Rollback (undo) the most recent series of uncommitted database +changes if the database supports transactions and AutoCommit is off. + +If C is on, then calling +C will issue a "rollback ineffective with AutoCommit" warning. + +See also L in the L section below. + +=head3 C + + $rc = $dbh->begin_work or die $dbh->errstr; + +Enable transactions (by turning C off) until the next call +to C or C. After the next C or C, +C will automatically be turned on again. + +If C is already off when C is called then +it does nothing except return an error. If the driver does not support +transactions then when C attempts to set C off +the driver will trigger a fatal error. + +See also L in the L section below. + + +=head3 C + + $rc = $dbh->disconnect or warn $dbh->errstr; + +Disconnects the database from the database handle. C is typically only used +before exiting the program. The handle is of little use after disconnecting. + +The transaction behaviour of the C method is, sadly, +undefined. Some database systems (such as Oracle and Ingres) will +automatically commit any outstanding changes, but others (such as +Informix) will rollback any outstanding changes. Applications not +using C should explicitly call C or C before +calling C. + +The database is automatically disconnected by the C method if +still connected when there are no longer any references to the handle. +The C method for each driver should implicitly call C to +undo any uncommitted changes. This is vital behaviour to ensure that +incomplete transactions don't get committed simply because Perl calls +C on every object before exiting. Also, do not rely on the order +of object destruction during "global destruction", as it is undefined. + +Generally, if you want your changes to be committed or rolled back when +you disconnect, then you should explicitly call L or L +before disconnecting. + +If you disconnect from a database while you still have active +statement handles (e.g., SELECT statement handles that may have +more data to fetch), you will get a warning. The warning may indicate +that a fetch loop terminated early, perhaps due to an uncaught error. +To avoid the warning call the C method on the active handles. + + +=head3 C + + $rc = $dbh->ping; + +Attempts to determine, in a reasonably efficient way, if the database +server is still running and the connection to it is still working. +Individual drivers should implement this function in the most suitable +manner for their database engine. + +The current I implementation always returns true without +actually doing anything. Actually, it returns "C<0 but true>" which is +true but zero. That way you can tell if the return value is genuine or +just the default. Drivers should override this method with one that +does the right thing for their type of database. + +Few applications would have direct use for this method. See the specialized +Apache::DBI module for one example usage. + + +=head3 C + + $value = $dbh->get_info( $info_type ); + +Returns information about the implementation, i.e. driver and data +source capabilities, restrictions etc. It returns C for +unknown or unimplemented information types. For example: + + $database_version = $dbh->get_info( 18 ); # SQL_DBMS_VER + $max_select_tables = $dbh->get_info( 106 ); # SQL_MAXIMUM_TABLES_IN_SELECT + +See L for more detailed information +about the information types and their meanings and possible return values. + +The DBI::Const::GetInfoType module exports a %GetInfoType hash that +can be used to map info type names to numbers. For example: + + $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} ); + +The names are a merging of the ANSI and ODBC standards (which differ +in some cases). See L for more details. + +Because some DBI methods make use of get_info(), drivers are strongly +encouraged to support I the following very minimal set +of information types to ensure the DBI itself works properly: + + Type Name Example A Example B + ---- -------------------------- ------------ ---------------- + 17 SQL_DBMS_NAME 'ACCESS' 'Oracle' + 18 SQL_DBMS_VER '03.50.0000' '08.01.0721 ...' + 29 SQL_IDENTIFIER_QUOTE_CHAR '`' '"' + 41 SQL_CATALOG_NAME_SEPARATOR '.' '@' + 114 SQL_CATALOG_LOCATION 1 2 + +=head3 C + + $sth = $dbh->table_info( $catalog, $schema, $table, $type ); + $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch +information about tables and views that exist in the database. + +The arguments $catalog, $schema and $table may accept search patterns +according to the database/driver, for example: $table = '%FOO%'; +Remember that the underscore character ('C<_>') is a search pattern +that means match any character, so 'FOO_%' is the same as 'FOO%' +and 'FOO_BAR%' will match names like 'FOO1BAR'. + +The value of $type is a comma-separated list of one or more types of +tables to be returned in the result set. Each value may optionally be +quoted, e.g.: + + $type = "TABLE"; + $type = "'TABLE','VIEW'"; + +In addition the following special cases may also be supported by some drivers: + +=over 4 + +=item * +If the value of $catalog is '%' and $schema and $table name +are empty strings, the result set contains a list of catalog names. +For example: + + $sth = $dbh->table_info('%', '', ''); + +=item * +If the value of $schema is '%' and $catalog and $table are empty +strings, the result set contains a list of schema names. + +=item * +If the value of $type is '%' and $catalog, $schema, and $table are all +empty strings, the result set contains a list of table types. + +=back + +If your driver doesn't support one or more of the selection filter +parameters then you may get back more than you asked for and can +do the filtering yourself. + +This method can be expensive, and can return a large amount of data. +(For example, small Oracle installation returns over 2000 rows.) +So it's a good idea to use the filters to limit the data as much as possible. + +The statement handle returned has at least the following fields in the +order show below. Other fields, after these, may also be present. + +B: Table catalog identifier. This field is NULL (C) if not +applicable to the data source, which is usually the case. This field +is empty if not applicable to the table. + +B: The name of the schema containing the TABLE_NAME value. +This field is NULL (C) if not applicable to data source, and +empty if not applicable to the table. + +B: Name of the table (or view, synonym, etc). + +B: One of the following: "TABLE", "VIEW", "SYSTEM TABLE", +"GLOBAL TEMPORARY", "LOCAL TEMPORARY", "ALIAS", "SYNONYM" or a type +identifier that is specific to the data +source. + +B: A description of the table. May be NULL (C). + +Note that C might not return records for all tables. +Applications can use any valid table regardless of whether it's +returned by C. + +See also L, L and +L. + +=head3 C + + $sth = $dbh->column_info( $catalog, $schema, $table, $column ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch +information about columns in specified tables. + +The arguments $schema, $table and $column may accept search patterns +according to the database/driver, for example: $table = '%FOO%'; + +Note: The support for the selection criteria is driver specific. If the +driver doesn't support one or more of them then you may get back more +than you asked for and can do the filtering yourself. + +Note: If your driver does not support column_info an undef is +returned. This is distinct from asking for something which does not +exist in a driver which supports column_info as a valid statement +handle to an empty result-set will be returned in this case. + +If the arguments don't match any tables then you'll still get a statement +handle, it'll just return no rows. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. +Note: A driver may provide column metadata not only for base tables, but +also for derived objects like SYNONYMS etc. + +B: The column identifier. + +B: The concise data type code. + +B: A data source dependent data type name. + +B: The column size. +This is the maximum length in characters for character data types, +the number of digits or bits for numeric data types or the length +in the representation of temporal types. +See the relevant specifications for detailed information. + +B: The length in bytes of transferred data. + +B: The total number of significant digits to the right of +the decimal point. + +B: The radix for numeric precision. +The value is 10 or 2 for numeric data types and NULL (C) if not +applicable. + +B: Indicates if a column can accept NULLs. +The following values are defined: + + SQL_NO_NULLS 0 + SQL_NULLABLE 1 + SQL_NULLABLE_UNKNOWN 2 + +B: A description of the column. + +B: The default value of the column, in a format that can be used +directly in an SQL statement. + +Note that this may be an expression and not simply the text used for the +default value in the original CREATE TABLE statement. For example, given: + + col1 char(30) default current_user -- a 'function' + col2 char(30) default 'string' -- a string literal + +where "current_user" is the name of a function, the corresponding C +values would be: + + Database col1 col2 + -------- ---- ---- + Oracle: current_user 'string' + Postgres: "current_user"() 'string'::text + MS SQL: (user_name()) ('string') + +B: The SQL data type. + +B: The subtype code for datetime and interval data types. + +B: The maximum length in bytes of a character or binary +data type column. + +B: The column sequence number (starting with 1). + +B: Indicates if the column can accept NULLs. +Possible values are: 'NO', 'YES' and ''. + +SQL/CLI defines the following additional columns: + + CHAR_SET_CAT + CHAR_SET_SCHEM + CHAR_SET_NAME + COLLATION_CAT + COLLATION_SCHEM + COLLATION_NAME + UDT_CAT + UDT_SCHEM + UDT_NAME + DOMAIN_CAT + DOMAIN_SCHEM + DOMAIN_NAME + SCOPE_CAT + SCOPE_SCHEM + SCOPE_NAME + MAX_CARDINALITY + DTD_IDENTIFIER + IS_SELF_REF + +Drivers capable of supplying any of those values should do so in +the corresponding column and supply undef values for the others. + +Drivers wishing to provide extra database/driver specific information +should do so in extra columns beyond all those listed above, and +use lowercase field names with the driver-specific prefix (i.e., +'ora_...'). Applications accessing such fields should do so by name +and not by column number. + +The result set is ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME +and ORDINAL_POSITION. + +Note: There is some overlap with statement handle attributes (in perl) and +SQLDescribeCol (in ODBC). However, SQLColumns provides more metadata. + +See also L and L. + +=head3 C + + $sth = $dbh->primary_key_info( $catalog, $schema, $table ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch information +about columns that make up the primary key for a table. +The arguments don't accept search patterns (unlike table_info()). + +The statement handle will return one row per column, ordered by +TABLE_CAT, TABLE_SCHEM, TABLE_NAME, and KEY_SEQ. +If there is no primary key then the statement handle will fetch no rows. + +Note: The support for the selection criteria, such as $catalog, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. + +B: The column identifier. + +B: The column sequence number (starting with 1). +Note: This field is named B in SQL/CLI. + +B: The primary key constraint identifier. +This field is NULL (C) if not applicable to the data source. + +See also L and L. + +=head3 C + + @key_column_names = $dbh->primary_key( $catalog, $schema, $table ); + +Simple interface to the primary_key_info() method. Returns a list of +the column names that comprise the primary key of the specified table. +The list is in primary key column sequence order. +If there is no primary key then an empty list is returned. + +=head3 C + + $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table + , $fk_catalog, $fk_schema, $fk_table ); + + $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table + , $fk_catalog, $fk_schema, $fk_table + , \%attr ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch information +about foreign keys in and/or referencing the specified table(s). +The arguments don't accept search patterns (unlike table_info()). + +C<$pk_catalog>, C<$pk_schema>, C<$pk_table> +identify the primary (unique) key table (B). + +C<$fk_catalog>, C<$fk_schema>, C<$fk_table> +identify the foreign key table (B). + +If both B and B are given, the function returns the foreign key, if +any, in table B that refers to the primary (unique) key of table B. +(Note: In SQL/CLI, the result is implementation-defined.) + +If only B is given, then the result set contains the primary key +of that table and all foreign keys that refer to it. + +If only B is given, then the result set contains all foreign keys +in that table and the primary keys to which they refer. +(Note: In SQL/CLI, the result includes unique keys too.) + +For example: + + $sth = $dbh->foreign_key_info( undef, $user, 'master'); + $sth = $dbh->foreign_key_info( undef, undef, undef , undef, $user, 'detail'); + $sth = $dbh->foreign_key_info( undef, $user, 'master', undef, $user, 'detail'); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Note: The support for the selection criteria, such as C<$catalog>, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has the following fields in the order shown below. +Because ODBC never includes unique keys, they define different columns in the +result set than SQL/CLI. SQL/CLI column names are shown in parentheses. + +B: +The primary (unique) key table catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: +The primary (unique) key table schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: +The primary (unique) key table identifier. + +B: +The primary (unique) key column identifier. + +B: +The foreign key table catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: +The foreign key table schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: +The foreign key table identifier. + +B: +The foreign key column identifier. + +B: +The column sequence number (starting with 1). + +B: +The referential action for the UPDATE rule. +The following codes are defined: + + CASCADE 0 + RESTRICT 1 + SET NULL 2 + NO ACTION 3 + SET DEFAULT 4 + +B: +The referential action for the DELETE rule. +The codes are the same as for UPDATE_RULE. + +B: +The foreign key name. + +B: +The primary (unique) key name. + +B: +The deferrability of the foreign key constraint. +The following codes are defined: + + INITIALLY DEFERRED 5 + INITIALLY IMMEDIATE 6 + NOT DEFERRABLE 7 + +B< ( UNIQUE_OR_PRIMARY )>: +This column is necessary if a driver includes all candidate (i.e. primary and +alternate) keys in the result set (as specified by SQL/CLI). +The value of this column is UNIQUE if the foreign key references an alternate +key and PRIMARY if the foreign key references a primary key, or it +may be undefined if the driver doesn't have access to the information. + +See also L and L. + +=head3 C + +B This method is experimental and may change. + + $sth = $dbh->statistics_info( $catalog, $schema, $table, $unique_only, $quick ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch statistical +information about a table and its indexes. + +The arguments don't accept search patterns (unlike L). + +If the boolean argument $unique_only is true, only UNIQUE indexes will be +returned in the result set, otherwise all indexes will be returned. + +If the boolean argument $quick is set, the actual statistical information +columns (CARDINALITY and PAGES) will only be returned if they are readily +available from the server, and might not be current. Some databases may +return stale statistics or no statistics at all with this flag set. + +The statement handle will return at most one row per column name per index, +plus at most one row for the entire table itself, ordered by NON_UNIQUE, TYPE, +INDEX_QUALIFIER, INDEX_NAME, and ORDINAL_POSITION. + +Note: The support for the selection criteria, such as $catalog, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. + +B: Unique index indicator. +Returns 0 for unique indexes, 1 for non-unique indexes + +B: Index qualifier identifier. +The identifier that is used to qualify the index name when doing a +C; NULL (C) is returned if an index qualifier is not +supported by the data source. +If a non-NULL (defined) value is returned in this column, it must be used +to qualify the index name on a C statement; otherwise, +the TABLE_SCHEM should be used to qualify the index name. + +B: The index identifier. + +B: The type of information being returned. Can be any of the +following values: 'table', 'btree', 'clustered', 'content', 'hashed', +or 'other'. + +In the case that this field is 'table', all fields +other than TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TYPE, +CARDINALITY, and PAGES will be NULL (C). + +B: Column sequence number (starting with 1). + +B: The column identifier. + +B: Column sort sequence. +C for Ascending, C for Descending, or NULL (C) if +not supported for this index. + +B: Cardinality of the table or index. +For indexes, this is the number of unique values in the index. +For tables, this is the number of rows in the table. +If not supported, the value will be NULL (C). + +B: Number of storage pages used by this table or index. +If not supported, the value will be NULL (C). + +B: The index filter condition as a string. +If the index is not a filtered index, or it cannot be determined +whether the index is a filtered index, this value is NULL (C). +If the index is a filtered index, but the filter condition +cannot be determined, this value is the empty string C<''>. +Otherwise it will be the literal filter condition as a string, +such as C. + +See also L and L. + +=head3 C + + @names = $dbh->tables( $catalog, $schema, $table, $type ); + @names = $dbh->tables; # deprecated + +Simple interface to table_info(). Returns a list of matching +table names, possibly including a catalog/schema prefix. + +See L for a description of the parameters. + +If C<$dbh-Eget_info(29)> returns true (29 is SQL_IDENTIFIER_QUOTE_CHAR) +then the table names are constructed and quoted by L +to ensure they are usable even if they contain whitespace or reserved +words etc. This means that the table names returned will include +quote characters. + +=head3 C + + $type_info_all = $dbh->type_info_all; + +Returns a reference to an array which holds information about each data +type variant supported by the database and driver. The array and its +contents should be treated as read-only. + +The first item is a reference to an 'index' hash of CE C pairs. +The items following that are references to arrays, one per supported data +type variant. The leading index hash defines the names and order of the +fields within the arrays that follow it. +For example: + + $type_info_all = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, # was PRECISION originally + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE => 10, # was MONEY originally + AUTO_UNIQUE_VALUE => 11, # was AUTO_INCREMENT originally + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + SQL_DATA_TYPE => 15, + SQL_DATETIME_SUB => 16, + NUM_PREC_RADIX => 17, + INTERVAL_PRECISION=> 18, + }, + [ 'VARCHAR', SQL_VARCHAR, + undef, "'","'", undef,0, 1,1,0,0,0,undef,1,255, undef + ], + [ 'INTEGER', SQL_INTEGER, + undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0, 10 + ], + ]; + +More than one row may have the same value in the C +field if there are different ways to spell the type name and/or there +are variants of the type with different attributes (e.g., with and +without C set, with and without C, etc). + +The rows are ordered by C first and then by how closely each +type maps to the corresponding ODBC SQL data type, closest first. + +The meaning of the fields is described in the documentation for +the L method. + +An 'index' hash is provided so you don't need to rely on index +values defined above. However, using DBD::ODBC with some old ODBC +drivers may return older names, shown as comments in the example above. +Another issue with the index hash is that the lettercase of the +keys is not defined. It is usually uppercase, as show here, but +drivers may return names with any lettercase. + +Drivers are also free to return extra driver-specific columns of +information - though it's recommended that they start at column +index 50 to leave room for expansion of the DBI/ODBC specification. + +The type_info_all() method is not normally used directly. +The L method provides a more usable and useful interface +to the data. + +=head3 C + + @type_info = $dbh->type_info($data_type); + +Returns a list of hash references holding information about one or more +variants of $data_type. The list is ordered by C first and +then by how closely each type maps to the corresponding ODBC SQL data +type, closest first. If called in a scalar context then only the first +(best) element is returned. + +If $data_type is undefined or C, then the list will +contain hashes for all data type variants supported by the database and driver. + +If $data_type is an array reference then C returns the +information for the I type in the array that has any matches. + +The keys of the hash follow the same letter case conventions as the +rest of the DBI (see L). The +following uppercase items should always exist, though may be undef: + +=over 4 + +=item TYPE_NAME (string) + +Data type name for use in CREATE TABLE statements etc. + +=item DATA_TYPE (integer) + +SQL data type number. + +=item COLUMN_SIZE (integer) + +For numeric types, this is either the total number of digits (if the +NUM_PREC_RADIX value is 10) or the total number of bits allowed in the +column (if NUM_PREC_RADIX is 2). + +For string types, this is the maximum size of the string in characters. + +For date and interval types, this is the maximum number of characters +needed to display the value. + +=item LITERAL_PREFIX (string) + +Characters used to prefix a literal. A typical prefix is "C<'>" for characters, +or possibly "C<0x>" for binary values passed as hexadecimal. NULL (C) is +returned for data types for which this is not applicable. + + +=item LITERAL_SUFFIX (string) + +Characters used to suffix a literal. Typically "C<'>" for characters. +NULL (C) is returned for data types where this is not applicable. + +=item CREATE_PARAMS (string) + +Parameter names for data type definition. For example, C for a +C would be "C" if the DECIMAL type should be +declared as CIC<)> where I and I +are integer values. For a C it would be "C". +NULL (C) is returned for data types for which this is not applicable. + +=item NULLABLE (integer) + +Indicates whether the data type accepts a NULL value: +C<0> or an empty string = no, C<1> = yes, C<2> = unknown. + +=item CASE_SENSITIVE (boolean) + +Indicates whether the data type is case sensitive in collations and +comparisons. + +=item SEARCHABLE (integer) + +Indicates how the data type can be used in a WHERE clause, as +follows: + + 0 - Cannot be used in a WHERE clause + 1 - Only with a LIKE predicate + 2 - All comparison operators except LIKE + 3 - Can be used in a WHERE clause with any comparison operator + +=item UNSIGNED_ATTRIBUTE (boolean) + +Indicates whether the data type is unsigned. NULL (C) is returned +for data types for which this is not applicable. + +=item FIXED_PREC_SCALE (boolean) + +Indicates whether the data type always has the same precision and scale +(such as a money type). NULL (C) is returned for data types +for which +this is not applicable. + +=item AUTO_UNIQUE_VALUE (boolean) + +Indicates whether a column of this data type is automatically set to a +unique value whenever a new row is inserted. NULL (C) is returned +for data types for which this is not applicable. + +=item LOCAL_TYPE_NAME (string) + +Localized version of the C for use in dialog with users. +NULL (C) is returned if a localized name is not available (in which +case C should be used). + +=item MINIMUM_SCALE (integer) + +The minimum scale of the data type. If a data type has a fixed scale, +then C holds the same value. NULL (C) is returned for +data types for which this is not applicable. + +=item MAXIMUM_SCALE (integer) + +The maximum scale of the data type. If a data type has a fixed scale, +then C holds the same value. NULL (C) is returned for +data types for which this is not applicable. + +=item SQL_DATA_TYPE (integer) + +This column is the same as the C column, except for interval +and datetime data types. For interval and datetime data types, the +C field will return C or C, and the +C field below will return the subcode for the specific +interval or datetime data type. If this field is NULL, then the driver +does not support or report on interval or datetime subtypes. + +=item SQL_DATETIME_SUB (integer) + +For interval or datetime data types, where the C +field above is C or C, this field will +hold the I for the specific interval or datetime data type. +Otherwise it will be NULL (C). + +Although not mentioned explicitly in the standards, it seems there +is a simple relationship between these values: + + DATA_TYPE == (10 * SQL_DATA_TYPE) + SQL_DATETIME_SUB + +=item NUM_PREC_RADIX (integer) + +The radix value of the data type. For approximate numeric types, +C +contains the value 2 and C holds the number of bits. For +exact numeric types, C contains the value 10 and C holds +the number of decimal digits. NULL (C) is returned either for data types +for which this is not applicable or if the driver cannot report this information. + +=item INTERVAL_PRECISION (integer) + +The interval leading precision for interval types. NULL is returned +either for data types for which this is not applicable or if the driver +cannot report this information. + +=back + +For example, to find the type name for the fields in a select statement +you can do: + + @names = map { scalar $dbh->type_info($_)->{TYPE_NAME} } @{ $sth->{TYPE} } + +Since DBI and ODBC drivers vary in how they map their types into the +ISO standard types you may need to search for more than one type. +Here's an example looking for a usable type to store a date: + + $my_date_type = $dbh->type_info( [ SQL_DATE, SQL_TIMESTAMP ] ); + +Similarly, to more reliably find a type to store small integers, you could +use a list starting with C, C, C, etc. + +See also L. + + +=head3 C + + $sql = $dbh->quote($value); + $sql = $dbh->quote($value, $data_type); + +Quote a string literal for use as a literal value in an SQL statement, +by escaping any special characters (such as quotation marks) +contained within the string and adding the required type of outer +quotation marks. + + $sql = sprintf "SELECT foo FROM bar WHERE baz = %s", + $dbh->quote("Don't"); + +For most database types, at least those that conform to SQL standards, quote +would return C<'Don''t'> (including the outer quotation marks). For others it +may return something like C<'Don\'t'> + +An undefined C<$value> value will be returned as the string C (without +single quotation marks) to match how NULLs are represented in SQL. + +If C<$data_type> is supplied, it is used to try to determine the required +quoting behaviour by using the information returned by L. +As a special case, the standard numeric types are optimized to return +C<$value> without calling C. + +Quote will probably I be able to deal with all possible input +(such as binary data or data containing newlines), and is not related in +any way with escaping or quoting shell meta-characters. + +It is valid for the quote() method to return an SQL expression that +evaluates to the desired string. For example: + + $quoted = $dbh->quote("one\ntwo\0three") + +may return something like: + + CONCAT('one', CHAR(12), 'two', CHAR(0), 'three') + +The quote() method should I be used with L. + +=head3 C + + $sql = $dbh->quote_identifier( $name ); + $sql = $dbh->quote_identifier( $catalog, $schema, $table, \%attr ); + +Quote an identifier (table name etc.) for use in an SQL statement, +by escaping any special characters (such as double quotation marks) +it contains and adding the required type of outer quotation marks. + +Undefined names are ignored and the remainder are quoted and then +joined together, typically with a dot (C<.>) character. For example: + + $id = $dbh->quote_identifier( undef, 'Her schema', 'My table' ); + +would, for most database types, return C<"Her schema"."My table"> +(including all the double quotation marks). + +If three names are supplied then the first is assumed to be a +catalog name and special rules may be applied based on what L +returns for SQL_CATALOG_NAME_SEPARATOR (41) and SQL_CATALOG_LOCATION (114). +For example, for Oracle: + + $id = $dbh->quote_identifier( 'link', 'schema', 'table' ); + +would return C<"schema"."table"@"link">. + +=head3 C + + $imp_data = $dbh->take_imp_data; + +Leaves the $dbh in an almost dead, zombie-like, state and returns +a binary string of raw implementation data from the driver which +describes the current database connection. Effectively it detaches +the underlying database API connection data from the DBI handle. +After calling take_imp_data(), all other methods except C +will generate a warning and return undef. + +Why would you want to do this? You don't, forget I even mentioned it. +Unless, that is, you're implementing something advanced like a +multi-threaded connection pool. See L. + +The returned $imp_data can be passed as a C attribute +to a later connect() call, even in a separate thread in the same +process, where the driver can use it to 'adopt' the existing +connection that the implementation data was taken from. + +Some things to keep in mind... + +B<*> the $imp_data holds the only reference to the underlying +database API connection data. That connection is still 'live' and +won't be cleaned up properly unless the $imp_data is used to create +a new $dbh which is then allowed to disconnect() normally. + +B<*> using the same $imp_data to create more than one other new +$dbh at a time may well lead to unpleasant problems. Don't do that. + +Any child statement handles are effectively destroyed when take_imp_data() is +called. + +The C method was added in DBI 1.36 but wasn't useful till 1.49. + + +=head2 Database Handle Attributes + +This section describes attributes specific to database handles. + +Changes to these database handle attributes do not affect any other +existing or future database handles. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver-specific attributes (which all have names +starting with a lowercase letter). + +Example: + + $h->{AutoCommit} = ...; # set/write + ... = $h->{AutoCommit}; # get/read + +=head3 C + +Type: boolean + +If true, then database changes cannot be rolled-back (undone). If false, +then database changes automatically occur within a "transaction", which +must either be committed or rolled back using the C or C +methods. + +Drivers should always default to C mode (an unfortunate +choice largely forced on the DBI by ODBC and JDBC conventions.) + +Attempting to set C to an unsupported value is a fatal error. +This is an important feature of the DBI. Applications that need +full transaction behaviour can set C<$dbh-E{AutoCommit} = 0> (or +set C to 0 via L) +without having to check that the value was assigned successfully. + +For the purposes of this description, we can divide databases into three +categories: + + Databases which don't support transactions at all. + Databases in which a transaction is always active. + Databases in which a transaction must be explicitly started (C<'BEGIN WORK'>). + +B<* Databases which don't support transactions at all> + +For these databases, attempting to turn C off is a fatal error. +C and C both issue warnings about being ineffective while +C is in effect. + +B<* Databases in which a transaction is always active> + +These are typically mainstream commercial relational databases with +"ANSI standard" transaction behaviour. +If C is off, then changes to the database won't have any +lasting effect unless L is called (but see also +L). If L is called then any changes since the +last commit are undone. + +If C is on, then the effect is the same as if the DBI +called C automatically after every successful database +operation. So calling C or C explicitly while +C is on would be ineffective because the changes would +have already been committed. + +Changing C from off to on will trigger a L. + +For databases which don't support a specific auto-commit mode, the +driver has to commit each statement automatically using an explicit +C after it completes successfully (and roll it back using an +explicit C if it fails). The error information reported to the +application will correspond to the statement which was executed, unless +it succeeded and the commit or rollback failed. + +B<* Databases in which a transaction must be explicitly started> + +For these databases, the intention is to have them act like databases in +which a transaction is always active (as described above). + +To do this, the driver will automatically begin an explicit transaction +when C is turned off, or after a L or +L (or when the application issues the next database +operation after one of those events). + +In this way, the application does not have to treat these databases +as a special case. + +See L, L and L for other important +notes about transactions. + + +=head3 C + +Type: handle + +Holds the handle of the parent driver. The only recommended use for this +is to find the name of the driver using: + + $dbh->{Driver}->{Name} + + +=head3 C + +Type: string + +Holds the "name" of the database. Usually (and recommended to be) the +same as the "C" string used to connect to the database, +but with the leading "C" removed. + + +=head3 C + +Type: string, read-only + +Returns the statement string passed to the most recent L or +L method called in this database handle, even if that method +failed. This is especially useful where C is enabled and +the exception handler checks $@ and sees that a 'prepare' method call +failed. + + +=head3 C + +Type: integer + +A hint to the driver indicating the size of the local row cache that the +application would like the driver to use for future C + 1 - Disable the local row cache + >1 - Cache this many rows + <0 - Cache as many rows that will fit into this much memory for each C statement, C returns the number of rows +affected, if known. If no rows were affected, then C returns +"C<0E0>", which Perl will treat as 0 but will regard as true. Note that it +is I an error for no rows to be affected by a statement. If the +number of rows affected is not known, then C returns -1. + +For C statement by checking if +C<$sth-E{NUM_OF_FIELDS}> is greater than zero after calling C. + +If any arguments are given, then C will effectively call +L for each value before executing the statement. Values +bound in this way are usually treated as C types unless +the driver can determine the correct type (which is rare), or unless +C (or C) has already been used to +specify the type. + +Note that passing C an empty array is the same as passing no arguments +at all, which will execute the statement with previously bound values. +That's probably not what you want. + +If execute() is called on a statement handle that's still active +($sth->{Active} is true) then it should effectively call finish() +to tidy up the previous execution results before starting this new +execution. + +=head3 C + + $tuples = $sth->execute_array(\%attr) or die $sth->errstr; + $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; + + ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr; + ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; + +Execute the prepared statement once for each parameter tuple +(group of values) provided either in the @bind_values, or by prior +calls to L, or via a reference passed in \%attr. + +When called in scalar context the execute_array() method returns the +number of tuples executed, or C if an error occurred. Like +execute(), a successful execute_array() always returns true regardless +of the number of tuples executed, even if it's zero. If there were any +errors the ArrayTupleStatus array can be used to discover which tuples +failed and with what errors. + +When called in list context the execute_array() method returns two scalars; +$tuples is the same as calling execute_array() in scalar context and $rows is +the number of rows affected for each tuple, if available or +-1 if the driver cannot determine this. NOTE, some drivers cannot determine +the number of rows affected per tuple but can provide the number of rows +affected for the batch. +If you are doing an update operation the returned rows affected may not be what +you expect if, for instance, one or more of the tuples affected the same row +multiple times. Some drivers may not yet support list context, in which case +$rows will be undef, or may not be able to provide the number of rows affected +when performing this batch operation, in which case $rows will be -1. + +Bind values for the tuples to be executed may be supplied row-wise +by an C attribute, or else column-wise in the +C<@bind_values> argument, or else column-wise by prior calls to +L. + +Where column-wise binding is used (via the C<@bind_values> argument +or calls to bind_param_array()) the maximum number of elements in +any one of the bound value arrays determines the number of tuples +executed. Placeholders with fewer values in their parameter arrays +are treated as if padded with undef (NULL) values. + +If a scalar value is bound, instead of an array reference, it is +treated as a I length array with all elements having the +same value. It does not influence the number of tuples executed, +so if all bound arrays have zero elements then zero tuples will +be executed. If I bound values are scalars then one tuple +will be executed, making execute_array() act just like execute(). + +The C attribute can be used to specify a reference +to a subroutine that will be called to provide the bind values for +each tuple execution. The subroutine should return an reference to +an array which contains the appropriate number of bind values, or +return an undef if there is no more data to execute. + +As a convenience, the C attribute can also be +used to specify a statement handle. In which case the fetchrow_arrayref() +method will be called on the given statement handle in order to +provide the bind values for each tuple execution. + +The values specified via bind_param_array() or the @bind_values +parameter may be either scalars, or arrayrefs. If any C<@bind_values> +are given, then C will effectively call L +for each value before executing the statement. Values bound in +this way are usually treated as C types unless the +driver can determine the correct type (which is rare), or unless +C, C, C, or +C has already been used to specify the type. +See L for details. + +The C attribute can be used to specify a +reference to an array which will receive the execute status of each +executed parameter tuple. Note the C attribute was +mandatory until DBI 1.38. + +For tuples which are successfully executed, the element at the same +ordinal position in the status array is the resulting rowcount (or -1 +if unknown). +If the execution of a tuple causes an error, then the corresponding +status array element will be set to a reference to an array containing +L, L and L set by the failed execution. + +If B tuple execution returns an error, C will +return C. In that case, the application should inspect the +status array to determine which parameter tuples failed. +Some databases may not continue executing tuples beyond the first +failure. In this case the status array will either hold fewer +elements, or the elements beyond the failure will be undef. + +If all parameter tuples are successfully executed, C +returns the number tuples executed. If no tuples were executed, +then execute_array() returns "C<0E0>", just like execute() does, +which Perl will treat as 0 but will regard as true. + +For example: + + $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name) VALUES (?, ?)"); + my $tuples = $sth->execute_array( + { ArrayTupleStatus => \my @tuple_status }, + \@first_names, + \@last_names, + ); + if ($tuples) { + print "Successfully inserted $tuples records\n"; + } + else { + for my $tuple (0..@last_names-1) { + my $status = $tuple_status[$tuple]; + $status = [0, "Skipped"] unless defined $status; + next unless ref $status; + printf "Failed to insert (%s, %s): %s\n", + $first_names[$tuple], $last_names[$tuple], $status->[1]; + } + } + +Support for data returning statements such as SELECT is driver-specific +and subject to change. At present, the default implementation +provided by DBI only supports non-data returning statements. + +Transaction semantics when using array binding are driver and +database specific. If C is on, the default DBI +implementation will cause each parameter tuple to be individually +committed (or rolled back in the event of an error). If C +is off, the application is responsible for explicitly committing +the entire set of bound parameter tuples. Note that different +drivers and databases may have different behaviours when some +parameter tuples cause failures. In some cases, the driver or +database may automatically rollback the effect of all prior parameter +tuples that succeeded in the transaction; other drivers or databases +may retain the effect of prior successfully executed parameter +tuples. Be sure to check your driver and database for its specific +behaviour. + +Note that, in general, performance will usually be better with +C turned off, and using explicit C after each +C call. + +The C method was added in DBI 1.22, and ArrayTupleFetch +was added in 1.36. + +=head3 C + + $tuples = $sth->execute_for_fetch($fetch_tuple_sub); + $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); + + ($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 +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. + +The execute_for_fetch() method calls $fetch_tuple_sub, without any +parameters, until it returns a false value. Each tuple returned is +used to provide bind values for an $sth->execute(@$tuple) call. + +In scalar context execute_for_fetch() returns C if there were any +errors and the number of tuples executed otherwise. Like execute() and +execute_array() a zero is returned as "0E0" so execute_for_fetch() is +only false on error. If there were any errors the @tuple_status array +can be used to discover which tuples failed and with what errors. + +When called in list context execute_for_fetch() returns two scalars; +$tuples is the same as calling execute_for_fetch() in scalar context and $rows is +the sum of the number of rows affected for each tuple, if available or -1 +if the driver cannot determine this. +If you are doing an update operation the returned rows affected may not be what +you expect if, for instance, one or more of the tuples affected the same row +multiple times. Some drivers may not yet support list context, in which case +$rows will be undef, or may not be able to provide the number of rows affected +when performing this batch operation, in which case $rows will be -1. + +If \@tuple_status is passed then the execute_for_fetch method uses +it to return status information. The tuple_status array holds one +element per tuple. If the corresponding execute() did not fail then +the element holds the return value from execute(), which is typically +a row count. If the execute() did fail then the element holds a +reference to an array containing ($sth->err, $sth->errstr, $sth->state). + +If the driver detects an error that it knows means no further tuples can be +executed then it may return, with an error status, even though $fetch_tuple_sub +may still have more tuples to be executed. + +Although each tuple returned by $fetch_tuple_sub is effectively used +to call $sth->execute(@$tuple_array_ref) the exact timing may vary. +Drivers are free to accumulate sets of tuples to pass to the +database server in bulk group operations for more efficient execution. +However, the $fetch_tuple_sub is specifically allowed to return +the same array reference each time (which is what fetchrow_arrayref() +usually does). + +For example: + + my $sel = $dbh1->prepare("select foo, bar from table1"); + $sel->execute; + + my $ins = $dbh2->prepare("insert into table2 (foo, bar) values (?,?)"); + my $fetch_tuple_sub = sub { $sel->fetchrow_arrayref }; + + my @tuple_status; + $rc = $ins->execute_for_fetch($fetch_tuple_sub, \@tuple_status); + my @errors = grep { ref $_ } @tuple_status; + +Similarly, if you already have an array containing the data rows +to be processed you'd use a subroutine to shift off and return +each array ref in turn: + + $ins->execute_for_fetch( sub { shift @array_of_arrays }, \@tuple_status); + +The C method was added in DBI 1.38. + + +=head3 C + + $ary_ref = $sth->fetchrow_arrayref; + $ary_ref = $sth->fetch; # alias + +Fetches the next row of data and returns a reference to an array +holding the field values. Null fields are returned as C +values in the array. +This is the fastest way to fetch data, particularly if used with +C<$sth-Ebind_columns>. + +If there are no more rows or if an error occurs, then C +returns an C. You should check C<$sth-Eerr> afterwards (or use the +C attribute) to discover if the C returned was due to an +error. + +Note that the same array reference is returned for each fetch, so don't +store the reference and then use it after a later fetch. Also, the +elements of the array are also reused for each row, so take care if you +want to take a reference to an element. See also L. + +=head3 C + + @ary = $sth->fetchrow_array; + +An alternative to C. Fetches the next row of data +and returns it as a list containing the field values. Null fields +are returned as C values in the list. + +If there are no more rows or if an error occurs, then C +returns an empty list. You should check C<$sth-Eerr> afterwards (or use +the C attribute) to discover if the empty list returned was +due to an error. + +If called in a scalar context for a statement handle that has more +than one column, it is undefined whether the driver will return +the value of the first column or the last. So don't do that. +Also, in a scalar context, an C is returned if there are no +more rows or if an error occurred. That C can't be distinguished +from an C returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C in a scalar context. + +=head3 C + + $hash_ref = $sth->fetchrow_hashref; + $hash_ref = $sth->fetchrow_hashref($name); + +An alternative to C. Fetches the next row of data +and returns it as a reference to a hash containing field name and field +value pairs. Null fields are returned as C values in the hash. + +If there are no more rows or if an error occurs, then C +returns an C. You should check C<$sth-Eerr> afterwards (or use the +C attribute) to discover if the C returned was due to an +error. + +The optional C<$name> parameter specifies the name of the statement handle +attribute. For historical reasons it defaults to "C", however using +either "C" or "C" is recommended for portability. + +The keys of the hash are the same names returned by C<$sth-E{$name}>. If +more than one field has the same name, there will only be one entry in the +returned hash for those fields, so statements like "C" +or "C statement, the driver will +automatically call C for you. So you should I call it explicitly +I when you know that you've not fetched all the data from a statement +handle I the handle won't be destroyed soon. + +The most common example is when you only want to fetch just one row, +but in that case the C methods are usually better anyway. + +Consider a query like: + + SELECT foo FROM table WHERE bar=? ORDER BY baz + +on a very large table. When executed, the database server will have to use +temporary buffer space to store the sorted rows. If, after executing +the handle and selecting just a few rows, the handle won't be re-executed for +some time and won't be destroyed, the C method can be used to tell +the server that the buffer space can be freed. + +Calling C resets the L attribute for the statement. It +may also make some statement handle attributes (such as C and C) +unavailable if they have not already been accessed (and thus cached). + +The C method does not affect the transaction status of the +database connection. It has nothing to do with transactions. It's mostly an +internal "housekeeping" method that is rarely needed. +See also L and the L attribute. + +The C method should have been called C. + + +=head3 C + + $rv = $sth->rows; + +Returns the number of rows affected by the last row affecting command, +or -1 if the number of rows is not known or not available. + +Generally, you can only rely on a row count after a I-C statement. + +For C statements is not +recommended. + +One alternative method to get a row count for a C statement. Column numbers count up from 1. +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 L 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 +to be automatically updated simply because it now refers to the same +memory location as the corresponding column value. This makes using +bound variables very efficient. +Binding a tied variable doesn't work, currently. + +The L method +performs a similar, but opposite, function for input variables. + +B + +The C<\%attr> parameter can be used to hint at the data type +formatting the column should have. For example, you can use: + + $sth->bind_col(1, undef, { TYPE => SQL_DATETIME }); + +to specify that you'd like the column (which presumably is some +kind of datetime type) to be returned in the standard format for +SQL_DATETIME, which is 'YYYY-MM-DD HH:MM:SS', rather than the +native formatting the database would normally use. + +There's no $var_to_bind in that example to emphasize the point +that bind_col() works on the underlying column and not just +a particular bound variable. + +As a short-cut for the common case, the data type can be passed +directly, in place of the C<\%attr> hash reference. This example is +equivalent to the one above: + + $sth->bind_col(1, undef, SQL_DATETIME); + +The C value indicates the standard (non-driver-specific) type for +this parameter. To specify the driver-specific type, the driver may +support a driver-specific attribute, such as C<{ ora_type =E 97 }>. + +The SQL_DATETIME and other related constants can be imported using + + use DBI qw(:sql_types); + +See L for more information. + +Few drivers support specifying a data type via a C call +(most will simply ignore the data type). Fewer still allow the data +type to be altered once set. + +The TYPE attribute for bind_col() was first specified in DBI 1.41. + +From DBI 1.611, drivers can use the C attribute to attempt to +cast the bound scalar to a perl type which more closely matches +C. At present DBI supports C, C and +C. See L for details of how types are +cast. + +B + +The C<\%attr> parameter may also contain the following attributes: + +=over + +=item C + +If a C attribute is passed to bind_col, then the driver will +attempt to change the bound perl scalar to match the type more +closely. If the bound value cannot be cast to the requested C +then by default it is left untouched and no error is generated. If you +specify C as 1 and the cast fails, this will generate +an error. + +This attribute was first added in DBI 1.611. When 1.611 was released +few drivers actually supported this attribute but DBD::Oracle and +DBD::ODBC should from versions 1.24. + +=item C + +When the C attribute is passed to L and the driver +successfully casts the bound perl scalar to a non-string type +then if C is set to 1, the string portion of the +scalar will be discarded. By default, C is not set. + +This attribute was first added in DBI 1.611. When 1.611 was released +few drivers actually supported this attribute but DBD::Oracle and +DBD::ODBC should from versions 1.24. + +=back + + +=head3 C + + $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); + +Calls L for each column of the C statement. If it doesn't then C will +bind the elements given, up to the number of columns, and then return an error. + +For maximum portability between drivers, bind_columns() should be called +after execute() and not before. + +For example: + + $dbh->{RaiseError} = 1; # do this, or check every call for errors + $sth = $dbh->prepare(q{ SELECT region, sales FROM sales_by_region }); + $sth->execute; + my ($region, $sales); + + # Bind Perl variables to columns: + $rv = $sth->bind_columns(\$region, \$sales); + + # you can also use Perl's \(...) syntax (see perlref docs): + # $sth->bind_columns(\($region, $sales)); + + # Column binding is the most efficient way to fetch data + while ($sth->fetch) { + print "$region: $sales\n"; + } + +For compatibility with old scripts, the first parameter will be +ignored if it is C or a hash reference. + +Here's a more fancy example that binds columns to the values I +a hash (thanks to H.Merijn Brand): + + $sth->execute; + my %row; + $sth->bind_columns( \( @row{ @{$sth->{NAME_lc} } } )); + while ($sth->fetch) { + print "$row{region}: $row{sales}\n"; + } + + +=head3 C + + $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); + +Fetches all the rows from C<$sth>, calls C for each row, and +prints the results to C<$fh> (defaults to C) separated by C<$lsep> +(default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35. + +This method is designed as a handy utility for prototyping and +testing queries. Since it uses L to +format and edit the string for reading by humans, it is not recommended +for data transfer applications. + + +=head2 Statement Handle Attributes + +This section describes attributes specific to statement handles. Most +of these attributes are read-only. + +Changes to these statement handle attributes do not affect any other +existing or future statement handles. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver specific attributes (which all have names +starting with a lowercase letter). + +Example: + + ... = $h->{NUM_OF_FIELDS}; # get/read + +Some drivers cannot provide valid values for some or all of these +attributes until after C<$sth-Eexecute> has been successfully +called. Typically the attribute will be C in these situations. + +Some attributes, like NAME, are not appropriate to some types of +statement, like SELECT. Typically the attribute will be C +in these situations. + +For drivers which support stored procedures and multiple result sets +(see L) these attributes relate to the I result set. + +See also L to learn more about the effect it +may have on some attributes. + +=head3 C + +Type: integer, read-only + +Number of fields (columns) in the data the prepared statement may return. +Statements that don't return rows of data, like C and C +set C to 0 (though it may be undef in some drivers). + + +=head3 C + +Type: integer, read-only + +The number of parameters (placeholders) in the prepared statement. +See SUBSTITUTION VARIABLES below for more details. + + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of field names for each column. The +names may contain spaces but should not be truncated or have any +trailing space. Note that the names have the letter case (upper, lower +or mixed) as returned by the driver being used. Portable applications +should use L or L. + + print "First column name: $sth->{NAME}->[0]\n"; + +Also note that the name returned for (aggregate) functions like C +or C is determined by the database server and not by C or +the C backend. + +=head3 C + +Type: array-ref, read-only + +Like L but always returns lowercase names. + +=head3 C + +Type: array-ref, read-only + +Like L but always returns uppercase names. + +=head3 C + +Type: hash-ref, read-only + +=head3 C + +Type: hash-ref, read-only + +=head3 C + +Type: hash-ref, read-only + +The C, C, and C attributes +return column name information as a reference to a hash. + +The keys of the hash are the names of the columns. The letter case of +the keys corresponds to the letter case returned by the C, +C, and C attributes respectively (as described above). + +The value of each hash entry is the perl index number of the +corresponding column (counting from 0). For example: + + $sth = $dbh->prepare("select Id, Name from table"); + $sth->execute; + @row = $sth->fetchrow_array; + print "Name $row[ $sth->{NAME_lc_hash}{name} ]\n"; + + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each +column. The value indicates the data type of the corresponding column. + +The values correspond to the international standards (ANSI X3.135 +and ISO/IEC 9075) which, in general terms, means ODBC. Driver-specific +types that don't exactly match standard types should generally return +the same values as an ODBC driver supplied by the makers of the +database. That might include private type numbers in ranges the vendor +has officially registered with the ISO working group: + + ftp://sqlstandards.org/SC32/SQL_Registry/ + +Where there's no vendor-supplied ODBC driver to be compatible with, +the DBI driver can use type numbers in the range that is now +officially reserved for use by the DBI: -9999 to -9000. + +All possible values for C should have at least one entry in the +output of the C method (see L). + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each column. + +For numeric columns, the value is the maximum number of digits +(without considering a sign character or decimal point). Note that +the "display size" for floating point types (REAL, FLOAT, DOUBLE) +can be up to 7 characters greater than the precision (for the +sign + decimal point + the letter E + a sign + 2 or 3 digits). + +For any character type column the value is the OCTET_LENGTH, +in other words the number of bytes, not characters. + +(More recent standards refer to this as COLUMN_SIZE but we stick +with PRECISION for backwards compatibility.) + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each column. +NULL (C) values indicate columns where scale is not applicable. + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array indicating the possibility of each +column returning a null. Possible values are C<0> +(or an empty string) = no, C<1> = yes, C<2> = unknown. + + print "First column may return NULL\n" if $sth->{NULLABLE}->[0]; + + +=head3 C + +Type: string, read-only + +Returns the name of the cursor associated with the statement handle, if +available. If not available or if the database driver does not support the +C<"where current of ..."> SQL syntax, then it returns C. + + +=head3 C + +Type: dbh, read-only + +Returns the parent $dbh of the statement handle. + + +=head3 C + +Type: string, read-only + +Returns the statement string passed to the L method. + + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the values currently bound +to placeholders. The keys of the hash are the 'names' of the +placeholders, typically integers starting at 1. Returns undef if +not supported by the driver. + +See L for an example of how this is used. + +* Keys: + +If the driver supports C but no values have been bound +yet then the driver should return a hash with placeholders names +in the keys but all the values undef, but some drivers may return +a ref to an empty hash because they can't pre-determine the names. + +It is possible that the keys in the hash returned by C +are not exactly the same as those implied by the prepared statement. +For example, DBD::Oracle translates 'C' placeholders into 'C<:pN>' +where N is a sequence number starting at 1. + +* Values: + +It is possible that the values in the hash returned by C +are not I the same as those passed to bind_param() or execute(). +The driver may have slightly modified values in some way based on the +TYPE the value was bound with. For example a floating point value +bound as an SQL_INTEGER type may be returned as an integer. +The values returned by C can be passed to another +bind_param() method with the same TYPE and will be seen by the +database as the same value. See also L below. + +The C attribute was added in DBI 1.28. + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the type information +currently bound to placeholders. +Returns undef if not supported by the driver. + +* Keys: + +See L above. + +* Values: + +The hash values are hashrefs of type information in the same form as that +passed to the various bind_param() methods (See L for the format +and values). + +It is possible that the values in the hash returned by C +are not exactly the same as those passed to bind_param() or execute(). +Param attributes specified using the abbreviated form, like this: + + $sth->bind_param(1, SQL_INTEGER); + +are returned in the expanded form, as if called like this: + + $sth->bind_param(1, { TYPE => SQL_INTEGER }); + +The driver may have modified the type information in some way based +on the bound values, other hints provided by the prepare()'d +SQL statement, or alternate type mappings required by the driver or target +database system. The driver may also add private keys (with names beginning +with the drivers reserved prefix, e.g., odbc_xxx). + +* Example: + +The keys and values in the returned hash can be passed to the various +bind_param() methods to effectively reproduce a previous param binding. +For example: + + # assuming $sth1 is a previously prepared statement handle + my $sth2 = $dbh->prepare( $sth1->{Statement} ); + my $ParamValues = $sth1->{ParamValues} || {}; + my $ParamTypes = $sth1->{ParamTypes} || {}; + $sth2->bind_param($_, $ParamValues->{$_} $ParamTypes->{$_}) + for keys %{ {%$ParamValues, %$ParamTypes} }; + $sth2->execute(); + +The C attribute was added in DBI 1.49. Implementation +is the responsibility of individual drivers; the DBI layer default +implementation simply returns undef. + + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the values currently bound to +placeholders with L or L. The +keys of the hash are the 'names' of the placeholders, typically +integers starting at 1. Returns undef if not supported by the driver +or no arrays of parameters are bound. + +Each key value is an array reference containing a list of the bound +parameters for that column. + +For example: + + $sth = $dbh->prepare("INSERT INTO staff (id, name) values (?,?)"); + $sth->execute_array({},[1,2], ['fred','dave']); + if ($sth->{ParamArrays}) { + foreach $param (keys %{$sth->{ParamArrays}}) { + printf "Parameters for %s : %s\n", $param, + join(",", @{$sth->{ParamArrays}->{$param}}); + } + } + +It is possible that the values in the hash returned by C +are not I the same as those passed to L or +L. The driver may have slightly modified values in some +way based on the TYPE the value was bound with. For example a floating +point value bound as an SQL_INTEGER type may be returned as an +integer. + +It is also possible that the keys in the hash returned by +C are not exactly the same as those implied by the +prepared statement. For example, DBD::Oracle translates 'C' +placeholders into 'C<:pN>' where N is a sequence number starting at 1. + +=head3 C + +Type: integer, read-only + +If the driver supports a local row cache for C statement handle that's a child +of the same database handle. A typical way round this is to connect the +the database twice and use one connection for C statement (unlike other data +types), some special handling is required. + +In this situation, the value of the C<$h-E{LongReadLen}> +attribute is used to determine how much buffer space to allocate +when fetching such fields. The C<$h-E{LongTruncOk}> attribute +is used to determine how to behave if a fetched value can't fit +into the buffer. + +See the description of L for more information. + +When trying to insert long or binary values, placeholders should be used +since there are often limits on the maximum size of an C +statement and the L method generally can't cope with binary +data. See L. + + +=head2 Simple Examples + +Here's a complete example program to select and fetch some data: + + my $data_source = "dbi::DriverName:db_name"; + my $dbh = DBI->connect($data_source, $user, $password) + or die "Can't connect to $data_source: $DBI::errstr"; + + my $sth = $dbh->prepare( q{ + SELECT name, phone + FROM mytelbook + }) or die "Can't prepare statement: $DBI::errstr"; + + my $rc = $sth->execute + or die "Can't execute statement: $DBI::errstr"; + + print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n"; + print "Field names: @{ $sth->{NAME} }\n"; + + while (($name, $phone) = $sth->fetchrow_array) { + print "$name: $phone\n"; + } + # check for problems which may have terminated the fetch early + die $sth->errstr if $sth->err; + + $dbh->disconnect; + +Here's a complete example program to insert some data from a file. +(This example uses C to avoid needing to check each call). + + my $dbh = DBI->connect("dbi:DriverName:db_name", $user, $password, { + RaiseError => 1, AutoCommit => 0 + }); + + my $sth = $dbh->prepare( q{ + INSERT INTO table (name, phone) VALUES (?, ?) + }); + + open FH, ") { + chomp; + my ($name, $phone) = split /,/; + $sth->execute($name, $phone); + } + close FH; + + $dbh->commit; + $dbh->disconnect; + +Here's how to convert fetched NULLs (undefined values) into empty strings: + + while($row = $sth->fetchrow_arrayref) { + # this is a fast and simple way to deal with nulls: + foreach (@$row) { $_ = '' unless defined } + print "@$row\n"; + } + +The C style quoting used in these examples avoids clashing with +quotes that may be used in the SQL statement. Use the double-quote like +C operator if you want to interpolate variables into the string. +See L for more details. + +=head2 Threads and Thread Safety + +Perl 5.7 and later support a new threading model called iThreads. +(The old "5.005 style" threads are not supported by the DBI.) + +In the iThreads model each thread has it's own copy of the perl +interpreter. When a new thread is created the original perl +interpreter is 'cloned' to create a new copy for the new thread. + +If the DBI and drivers are loaded and handles created before the +thread is created then it will get a cloned copy of the DBI, the +drivers and the handles. + +However, the internal pointer data within the handles will refer +to the DBI and drivers in the original interpreter. Using those +handles in the new interpreter thread is not safe, so the DBI detects +this and croaks on any method call using handles that don't belong +to the current thread (except for DESTROY). + +Because of this (possibly temporary) restriction, newly created +threads must make their own connections to the database. Handles +can't be shared across threads. + +But BEWARE, some underlying database APIs (the code the DBD driver +uses to talk to the database, often supplied by the database vendor) +are not thread safe. If it's not thread safe, then allowing more +than one thread to enter the code at the same time may cause +subtle/serious problems. In some cases allowing more than +one thread to enter the code, even if I at the same time, +can cause problems. You have been warned. + +Using DBI with perl threads is not yet recommended for production +environments. For more information see +L + +Note: There is a bug in perl 5.8.2 when configured with threads +and debugging enabled (bug #24463) which causes a DBI test to fail. + +=head2 Signal Handling and Canceling Operations + +[The following only applies to systems with unix-like signal handling. +I'd welcome additions for other systems, especially Windows.] + +The first thing to say is that signal handling in Perl versions less +than 5.8 is I safe. There is always a small risk of Perl +crashing and/or core dumping when, or after, handling a signal +because the signal could arrive and be handled while internal data +structures are being changed. If the signal handling code +used those same internal data structures it could cause all manner +of subtle and not-so-subtle problems. The risk was reduced with +5.4.4 but was still present in all perls up through 5.8.0. + +Beginning in perl 5.8.0 perl implements 'safe' signal handling if +your system has the POSIX sigaction() routine. Now when a signal +is delivered perl just makes a note of it but does I run the +%SIG handler. The handling is 'deferred' until a 'safe' moment. + +Although this change made signal handling safe, it also lead to +a problem with signals being deferred for longer than you'd like. +If a signal arrived while executing a system call, such as waiting +for data on a network connection, the signal is noted and then the +system call that was executing returns with an EINTR error code +to indicate that it was interrupted. All fine so far. + +The problem comes when the code that made the system call sees the +EINTR code and decides it's going to call it again. Perl doesn't +do that, but database code sometimes does. If that happens then the +signal handler doesn't get called until later. Maybe much later. + +Fortunately there are ways around this which we'll discuss below. +Unfortunately they make signals unsafe again. + +The two most common uses of signals in relation to the DBI are for +canceling operations when the user types Ctrl-C (interrupt), and for +implementing a timeout using C and C<$SIG{ALRM}>. + +=over 4 + +=item Cancel + +The DBI provides a C method for statement handles. The +C method should abort the current operation and is designed +to be called from a signal handler. For example: + + $SIG{INT} = sub { $sth->cancel }; + +However, few drivers implement this (the DBI provides a default +method that just returns C) and, even if implemented, there +is still a possibility that the statement handle, and even the +parent database handle, will not be usable afterwards. + +If C returns true, then it has successfully +invoked the database engine's own cancel function. If it returns false, +then C failed. If it returns C, then the database +driver does not have cancel implemented - very few do. + +=item Timeout + +The traditional way to implement a timeout is to set C<$SIG{ALRM}> +to refer to some code that will be executed when an ALRM signal +arrives and then to call alarm($seconds) to schedule an ALRM signal +to be delivered $seconds in the future. For example: + + eval { + local $SIG{ALRM} = sub { die "TIMEOUT\n" }; # N.B. \n required + eval { + alarm($seconds); + ... code to execute with timeout here (which may die) ... + }; + # outer eval catches alarm that might fire JUST before this alarm(0) + alarm(0); # cancel alarm (if code ran fast) + die "$@" if $@; + }; + if ( $@ eq "TIMEOUT\n" ) { ... } + elsif ($@) { ... } # some other error + +The first (outer) eval is used to avoid the unlikely but possible +chance that the "code to execute" dies and the alarm fires before it +is cancelled. Without the outer eval, if this happened your program +will die if you have no ALRM handler or a non-local alarm handler +will be called. + +Unfortunately, as described above, this won't always work as expected, +depending on your perl version and the underlying database code. + +With Oracle for instance (DBD::Oracle), if the system which hosts +the database is down the DBI->connect() call will hang for several +minutes before returning an error. + +=back + +The solution on these systems is to use the C +routine to gain low level access to how the signal handler is installed. + +The code would look something like this (for the DBD-Oracle connect()): + + use POSIX qw(:signal_h); + + my $mask = POSIX::SigSet->new( SIGALRM ); # signals to mask in the handler + my $action = POSIX::SigAction->new( + sub { die "connect timeout\n" }, # the handler code ref + $mask, + # not using (perl 5.8.2 and later) 'safe' switch or sa_flags + ); + my $oldaction = POSIX::SigAction->new(); + sigaction( SIGALRM, $action, $oldaction ); + my $dbh; + eval { + eval { + alarm(5); # seconds before time out + $dbh = DBI->connect("dbi:Oracle:$dsn" ... ); + }; + alarm(0); # cancel alarm (if connect worked fast) + die "$@\n" if $@; # connect died + }; + sigaction( SIGALRM, $oldaction ); # restore original signal handler + if ( $@ ) { + if ($@ eq "connect timeout\n") {...} + else { # connect died } + } + +See previous example for the reasoning around the double eval. + +Similar techniques can be used for canceling statement execution. + +Unfortunately, this solution is somewhat messy, and it does I work with +perl versions less than perl 5.8 where C appears to be broken. + +For a cleaner implementation that works across perl versions, see Lincoln Baxter's +Sys::SigAction module at L. +The documentation for Sys::SigAction includes an longer discussion +of this problem, and a DBD::Oracle test script. + +Be sure to read all the signal handling sections of the L manual. + +And finally, two more points to keep firmly in mind. Firstly, +remember that what we've done here is essentially revert to old +style I handling of these signals. So do as little as +possible in the handler. Ideally just die(). Secondly, the handles +in use at the time the signal is handled may not be safe to use +afterwards. + + +=head2 Subclassing the DBI + +DBI can be subclassed and extended just like any other object +oriented module. Before we talk about how to do that, it's important +to be clear about the various DBI classes and how they work together. + +By default C<$dbh = DBI-Econnect(...)> returns a $dbh blessed +into the C class. And the C<$dbh-Eprepare> method +returns an $sth blessed into the C class (actually it +simply changes the last four characters of the calling handle class +to be C<::st>). + +The leading 'C' is known as the 'root class' and the extra +'C<::db>' or 'C<::st>' are the 'handle type suffixes'. If you want +to subclass the DBI you'll need to put your overriding methods into +the appropriate classes. For example, if you want to use a root class +of C and override the do(), prepare() and execute() methods, +then your do() and prepare() methods should be in the C +class and the execute() method should be in the C class. + +To setup the inheritance hierarchy the @ISA variable in C +should include C and the @ISA variable in C +should include C. The C root class itself isn't +currently used for anything visible and so, apart from setting @ISA +to include C, it can be left empty. + +So, having put your overriding methods into the right classes, and +setup the inheritance hierarchy, how do you get the DBI to use them? +You have two choices, either a static method call using the name +of your subclass: + + $dbh = MySubDBI->connect(...); + +or specifying a C attribute: + + $dbh = DBI->connect(..., { RootClass => 'MySubDBI' }); + +If both forms are used then the attribute takes precedence. + +The only differences between the two are that using an explicit +RootClass attribute will a) make the DBI automatically attempt to load +a module by that name if the class doesn't exist, and b) won't call +your MySubDBI::connect() method, if you have one. + +When subclassing is being used then, after a successful new +connect, the DBI->connect method automatically calls: + + $dbh->connected($dsn, $user, $pass, \%attr); + +The default method does nothing. The call is made just to simplify +any post-connection setup that your subclass may want to perform. +The parameters are the same as passed to DBI->connect. +If your subclass supplies a connected method, it should be part of the +MySubDBI::db package. + +One more thing to note: you must let the DBI do the handle creation. If you +want to override the connect() method in your *::dr class then it must still +call SUPER::connect to get a $dbh to work with. Similarly, an overridden +prepare() method in *::db must still call SUPER::prepare to get a $sth. +If you try to create your own handles using bless() then you'll find the DBI +will reject them with an "is not a DBI handle (has no magic)" error. + +Here's a brief example of a DBI subclass. A more thorough example +can be found in F in the DBI distribution. + + package MySubDBI; + + use strict; + + use DBI; + use vars qw(@ISA); + @ISA = qw(DBI); + + package MySubDBI::db; + use vars qw(@ISA); + @ISA = qw(DBI::db); + + sub prepare { + my ($dbh, @args) = @_; + my $sth = $dbh->SUPER::prepare(@args) + or return; + $sth->{private_mysubdbi_info} = { foo => 'bar' }; + return $sth; + } + + package MySubDBI::st; + use vars qw(@ISA); + @ISA = qw(DBI::st); + + sub fetch { + my ($sth, @args) = @_; + my $row = $sth->SUPER::fetch(@args) + or return; + do_something_magical_with_row_data($row) + or return $sth->set_err(1234, "The magic failed", undef, "fetch"); + return $row; + } + +When calling a SUPER::method that returns a handle, be careful to +check the return value before trying to do other things with it in +your overridden method. This is especially important if you want to +set a hash attribute on the handle, as Perl's autovivification will +bite you by (in)conveniently creating an unblessed hashref, which your +method will then return with usually baffling results later on like +the error "dbih_getcom handle HASH(0xa4451a8) is not a DBI handle (has +no magic". It's best to check right after the call and return undef +immediately on error, just like DBI would and just like the example +above. + +If your method needs to record an error it should call the set_err() +method with the error code and error string, as shown in the example +above. The error code and error string will be recorded in the +handle and available via C<$h-Eerr> and C<$DBI::errstr> etc. +The set_err() method always returns an undef or empty list as +appropriate. Since your method should nearly always return an undef +or empty list as soon as an error is detected it's handy to simply +return what set_err() returns, as shown in the example above. + +If the handle has C, C, or C +etc. set then the set_err() method will honour them. This means +that if C is set then set_err() won't return in the +normal way but will 'throw an exception' that can be caught with +an C block. + +You can stash private data into DBI handles +via C<$h-E{private_..._*}>. See the entry under L for info and important caveats. + + +=head1 TRACING + +The DBI has a powerful tracing mechanism built in. It enables you +to see what's going on 'behind the scenes', both within the DBI and +the drivers you're using. + +=head2 Trace Settings + +Which details are written to the trace output is controlled by a +combination of a I, an integer from 0 to 15, and a set +of I that are either on or off. Together these are known +as the I and are stored together in a single integer. +For normal use you only need to set the trace level, and generally +only to a value between 1 and 4. + +Each handle has it's own trace settings, and so does the DBI. +When you call a method the DBI merges the handles settings into its +own for the duration of the call: the trace flags of the handle are +OR'd into the trace flags of the DBI, and if the handle has a higher +trace level then the DBI trace level is raised to match it. +The previous DBI trace settings are restored when the called method +returns. + +=head2 Trace Levels + +Trace I are as follows: + + 0 - Trace disabled. + 1 - Trace top-level DBI method calls returning with results or errors. + 2 - As above, adding tracing of top-level method entry with parameters. + 3 - As above, adding some high-level information from the driver + and some internal information from the DBI. + 4 - As above, adding more detailed information from the driver. + This is the first level to trace all the rows being fetched. + 5 to 15 - As above but with more and more internal information. + +Trace level 1 is best for a simple overview of what's happening. +Trace levels 2 thru 4 a good choice for general purpose tracing. +Levels 5 and above are best reserved for investigating a specific +problem, when you need to see "inside" the driver and DBI. + +The trace output is detailed and typically very useful. Much of the +trace output is formatted using the L function, so strings +in the trace output may be edited and truncated by that function. + +=head2 Trace Flags + +Trace I are used to enable tracing of specific activities +within the DBI and drivers. The DBI defines some trace flags and +drivers can define others. DBI trace flag names begin with a capital +letter and driver specific names begin with a lowercase letter, as +usual. + +Currently the DBI only defines two trace flags: + + ALL - turn on all DBI and driver flags (not recommended) + SQL - trace SQL statements executed + (not yet implemented in DBI but implemented in some DBDs) + CON - trace connection process + ENC - trace encoding (unicode translations etc) + (not yet implemented in DBI but implemented in some DBDs) + DBD - trace only DBD messages + (not implemented by all DBDs yet) + TXN - trace transactions + (not implemented in all DBDs yet) + +The L and L methods are used +to convert trace flag names into the corresponding integer bit flags. + +=head2 Enabling Trace + +The C<$h-Etrace> method sets the trace settings for a handle +and Ctrace> does the same for the DBI. + +In addition to the L method, you can enable the same trace +information, and direct the output to a file, by setting the +C environment variable before starting Perl. +See L for more information. + +Finally, you can set, or get, the trace settings for a handle using +the C attribute. + +All of those methods use parse_trace_flags() and so allow you set +both the trace level and multiple trace flags by using a string +containing the trace level and/or flag names separated by vertical +bar ("C<|>") or comma ("C<,>") characters. For example: + + local $h->{TraceLevel} = "3|SQL|foo"; + +=head2 Trace Output + +Initially trace output is written to C. Both the +C<$h-Etrace> and Ctrace> methods take an optional +$trace_file parameter, which may be either the name of a file to be +opened by DBI in append mode, or a reference to an existing writable +(possibly layered) filehandle. If $trace_file is a filename, +and can be opened in append mode, or $trace_file is a writable +filehandle, then I trace output (currently including that from +other handles) is redirected to that file. A warning is generated +if $trace_file can't be opened or is not writable. + +Further calls to trace() without $trace_file do not alter where +the trace output is sent. If $trace_file is undefined, then +trace output is sent to C and, if the prior trace was opened with +$trace_file as a filename, the previous trace file is closed; if $trace_file was +a filehandle, the filehandle is B closed. + +B: If $trace_file is specified as a filehandle, the filehandle +should not be closed until all DBI operations are completed, or the +application has reset the trace file via another call to +C that changes the trace file. + +=head2 Tracing to Layered Filehandles + +B: + +=over 4 + +=item * +Tied filehandles are not currently supported, as +tie operations are not available to the PerlIO +methods used by the DBI. + +=item * +PerlIO layer support requires Perl version 5.8 or higher. + +=back + +As of version 5.8, Perl provides the ability to layer various +"disciplines" on an open filehandle via the L module. + +A simple example of using PerlIO layers is to use a scalar as the output: + + my $scalar = ''; + open( my $fh, "+>:scalar", \$scalar ); + $dbh->trace( 2, $fh ); + +Now all trace output is simply appended to $scalar. + +A more complex application of tracing to a layered filehandle is the +use of a custom layer (IL I). Consider an application with the +following logger module: + + package MyFancyLogger; + + sub new + { + my $self = {}; + my $fh; + open $fh, '>', 'fancylog.log'; + $self->{_fh} = $fh; + $self->{_buf} = ''; + return bless $self, shift; + } + + sub log + { + my $self = shift; + return unless exists $self->{_fh}; + my $fh = $self->{_fh}; + $self->{_buf} .= shift; + # + # DBI feeds us pieces at a time, so accumulate a complete line + # before outputing + # + print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and + $self->{_buf} = '' + if $self->{_buf}=~tr/\n//; + } + + sub close { + my $self = shift; + return unless exists $self->{_fh}; + my $fh = $self->{_fh}; + print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and + $self->{_buf} = '' + if $self->{_buf}; + close $fh; + delete $self->{_fh}; + } + + 1; + +To redirect DBI traces to this logger requires creating +a package for the layer: + + package PerlIO::via::MyFancyLogLayer; + + sub PUSHED + { + my ($class,$mode,$fh) = @_; + my $logger; + return bless \$logger,$class; + } + + sub OPEN { + my ($self, $path, $mode, $fh) = @_; + # + # $path is actually our logger object + # + $$self = $path; + return 1; + } + + sub WRITE + { + my ($self, $buf, $fh) = @_; + $$self->log($buf); + return length($buf); + } + + sub CLOSE { + my $self = shift; + $$self->close(); + return 0; + } + + 1; + + +The application can then cause DBI traces to be routed to the +logger using + + use PerlIO::via::MyFancyLogLayer; + + open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new(); + + $dbh->trace('SQL', $fh); + +Now all trace output will be processed by MyFancyLogger's +log() method. + +=head2 Trace Content + +Many of the values embedded in trace output are formatted using the neat() +utility function. This means they may be quoted, sanitized, and possibly +truncated if longer than C<$DBI::neat_maxlen>. See L for more details. + +=head2 Tracing Tips + +You can add tracing to your own application code using the L method. + +It can sometimes be handy to compare trace files from two different runs of the +same script. However using a tool like C on the original log output +doesn't work well because the trace file is full of object addresses that may +differ on each run. + +The DBI includes a handy utility called dbilogstrip that can be used to +'normalize' the log content. It can be used as a filter like this: + + DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log + DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log + diff -u dbitrace1.log dbitrace2.log + +See L for more information. + +=head1 DBI ENVIRONMENT VARIABLES + +The DBI module recognizes a number of environment variables, but most of +them should not be used most of the time. +It is better to be explicit about what you are doing to avoid the need +for environment variables, especially in a web serving system where web +servers are stingy about which environment variables are available. + +=head2 DBI_DSN + +The DBI_DSN environment variable is used by DBI->connect if you do not +specify a data source when you issue the connect. +It should have a format such as "dbi:Driver:databasename". + +=head2 DBI_DRIVER + +The DBI_DRIVER environment variable is used to fill in the database +driver name in DBI->connect if the data source string starts "dbi::" +(thereby omitting the driver). +If DBI_DSN omits the driver name, DBI_DRIVER can fill the gap. + +=head2 DBI_AUTOPROXY + +The DBI_AUTOPROXY environment variable takes a string value that starts +"dbi:Proxy:" and is typically followed by "hostname=...;port=...". +It is used to alter the behaviour of DBI->connect. +For full details, see DBI::Proxy documentation. + +=head2 DBI_USER + +The DBI_USER environment variable takes a string value that is used as +the user name if the DBI->connect call is given undef (as distinct from +an empty string) as the username argument. +Be wary of the security implications of using this. + +=head2 DBI_PASS + +The DBI_PASS environment variable takes a string value that is used as +the password if the DBI->connect call is given undef (as distinct from +an empty string) as the password argument. +Be extra wary of the security implications of using this. + +=head2 DBI_DBNAME (obsolete) + +The DBI_DBNAME environment variable takes a string value that is used only when the +obsolescent style of DBI->connect (with driver name as fourth parameter) is used, and +when no value is provided for the first (database name) argument. + +=head2 DBI_TRACE + +The DBI_TRACE environment variable specifies the global default +trace settings for the DBI at startup. Can also be used to direct +trace output to a file. When the DBI is loaded it does: + + DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; + +So if C contains an "C<=>" character then what follows +it is used as the name of the file to append the trace to. + +output appended to that file. If the name begins with a number +followed by an equal sign (C<=>), then the number and the equal sign are +stripped off from the name, and the number is used to set the trace +level. For example: + + DBI_TRACE=1=dbitrace.log perl your_test_script.pl + +On Unix-like systems using a Bourne-like shell, you can do this easily +on the command line: + + DBI_TRACE=2 perl your_test_script.pl + +See L for more information. + +=head2 PERL_DBI_DEBUG (obsolete) + +An old variable that should no longer be used; equivalent to DBI_TRACE. + +=head2 DBI_PROFILE + +The DBI_PROFILE environment variable can be used to enable profiling +of DBI method calls. See L for more information. + +=head2 DBI_PUREPERL + +The DBI_PUREPERL environment variable can be used to enable the +use of DBI::PurePerl. See L for more information. + +=head1 WARNING AND ERROR MESSAGES + +=head2 Fatal Errors + +=over 4 + +=item Can't call method "prepare" without a package or object reference + +The C<$dbh> handle you're using to call C is probably undefined because +the preceding C failed. You should always check the return status of +DBI methods, or use the L attribute. + +=item Can't call method "execute" without a package or object reference + +The C<$sth> handle you're using to call C is probably undefined because +the preceding C failed. You should always check the return status of +DBI methods, or use the L attribute. + +=item DBI/DBD internal version mismatch + +The DBD driver module was built with a different version of DBI than +the one currently being used. You should rebuild the DBD module under +the current version of DBI. + +(Some rare platforms require "static linking". On those platforms, there +may be an old DBI or DBD driver version actually embedded in the Perl +executable being used.) + +=item DBD driver has not implemented the AutoCommit attribute + +The DBD driver implementation is incomplete. Consult the author. + +=item Can't [sg]et %s->{%s}: unrecognised attribute + +You attempted to set or get an unknown attribute of a handle. Make +sure you have spelled the attribute name correctly; case is significant +(e.g., "Autocommit" is not the same as "AutoCommit"). + +=back + +=head1 Pure-Perl DBI + +A pure-perl emulation of the DBI is included in the distribution +for people using pure-perl drivers who, for whatever reason, can't +install the compiled DBI. See L. + +=head1 SEE ALSO + +=head2 Driver and Database Documentation + +Refer to the documentation for the DBD driver that you are using. + +Refer to the SQL Language Reference Manual for the database engine that you are using. + +=head2 ODBC and SQL/CLI Standards Reference Information + +More detailed information about the semantics of certain DBI methods +that are based on ODBC and SQL/CLI standards is available on-line +via microsoft.com, for ODBC, and www.jtc1sc32.org for the SQL/CLI +standard: + + DBI method ODBC function SQL/CLI Working Draft + ---------- ------------- --------------------- + column_info SQLColumns Page 124 + foreign_key_info SQLForeignKeys Page 163 + get_info SQLGetInfo Page 214 + primary_key_info SQLPrimaryKeys Page 254 + table_info SQLTables Page 294 + type_info SQLGetTypeInfo Page 239 + statistics_info SQLStatistics + +To find documentation on the ODBC function you can use +the MSDN search facility at: + + http://msdn.microsoft.com/Search + +and search for something like C<"SQLColumns returns">. + +And for SQL/CLI standard information on SQLColumns you'd read page 124 of +the (very large) SQL/CLI Working Draft available from: + + http://jtc1sc32.org/doc/N0701-0750/32N0744T.pdf + +=head2 Standards Reference Information + +A hyperlinked, browsable version of the BNF syntax for SQL92 (plus +Oracle 7 SQL and PL/SQL) is available here: + + http://cui.unige.ch/db-research/Enseignement/analyseinfo/SQL92/BNFindex.html + +A BNF syntax for SQL3 is available here: + + http://www.sqlstandards.org/SC32/WG3/Progression_Documents/Informal_working_drafts/iso-9075-2-1999.bnf + +The following links provide further useful information about SQL. +Some of these are rather dated now but may still be useful. + + http://www.jcc.com/SQLPages/jccs_sql.htm + http://www.contrib.andrew.cmu.edu/~shadow/sql.html + http://www.altavista.com/query?q=sql+tutorial + + +=head2 Books and Articles + +Programming the Perl DBI, by Alligator Descartes and Tim Bunce. +L + +Programming Perl 3rd Ed. by Larry Wall, Tom Christiansen & Jon Orwant. +L + +Learning Perl by Randal Schwartz. +L + +Details of many other books related to perl can be found at L + +=head2 Perl Modules + +Index of DBI related modules available from CPAN: + + http://search.cpan.org/search?mode=module&query=DBIx%3A%3A + http://search.cpan.org/search?mode=doc&query=DBI + +For a good comparison of RDBMS-OO mappers and some OO-RDBMS mappers +(including Class::DBI, Alzabo, and DBIx::RecordSet in the former +category and Tangram and SPOPS in the latter) see the Perl +Object-Oriented Persistence project pages at: + + http://poop.sourceforge.net + +A similar page for Java toolkits can be found at: + + http://c2.com/cgi-bin/wiki?ObjectRelationalToolComparison + +=head2 Mailing List + +The I mailing list is the primary means of communication among +users of the DBI and its related modules. For details send email to: + + dbi-users-help@perl.org + +There are typically between 700 and 900 messages per month. You have +to subscribe in order to be able to post. However you can opt for a +'post-only' subscription. + +Mailing list archives (of variable quality) are held at: + + http://groups.google.com/groups?group=perl.dbi.users + http://www.xray.mpe.mpg.de/mailing-lists/dbi/ + http://www.mail-archive.com/dbi-users%40perl.org/ + +=head2 Assorted Related WWW Links + +The DBI "Home Page": + + http://dbi.perl.org/ + +Other DBI related links: + + http://tegan.deltanet.com/~phlip/DBUIdoc.html + http://dc.pm.org/perl_db.html + 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://www.perlmonks.org/?node=DBI%20recipes + http://www.perlmonks.org/?node=Speeding%20up%20the%20DBI + +Other database related links: + + http://www.jcc.com/sql_stnd.html + http://cuiwww.unige.ch/OSG/info/FreeDB/FreeDB.home.html + http://www.connectionstrings.com/ + +Security, especially the "SQL Injection" attack: + + http://www.ngssoftware.com/research/papers.html + http://www.ngssoftware.com/papers/advanced_sql_injection.pdf + http://www.ngssoftware.com/papers/more_advanced_sql_injection.pdf + http://www.esecurityplanet.com/trends/article.php/2243461 + http://www.spidynamics.com/papers/SQLInjectionWhitePaper.pdf + http://www.imperva.com/application_defense_center/white_papers/blind_sql_server_injection.html + http://online.securityfocus.com/infocus/1644 + +Commercial and Data Warehouse Links + + http://www.dwinfocenter.org + http://www.datawarehouse.com + http://www.datamining.org + http://www.olapcouncil.org + http://www.idwa.org + http://www.knowledgecenters.org/dwcenter.asp + +Recommended Perl Programming Links + + http://language.perl.com/style/ + + +=head2 FAQ + +See L + +=head1 AUTHORS + +DBI by Tim Bunce, L + +This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others. +Perl by Larry Wall and the C. + +=head1 COPYRIGHT + +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 +License or the Artistic License, as specified in the Perl 5.10.0 README file. + +=head1 SUPPORT / WARRANTY + +The DBI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND. + +=head2 Support + +My consulting company, Data Plan Services, offers annual and +multi-annual support contracts for the DBI. These provide sustained +support for DBI development, and sustained value for you in return. +Contact me for details. + +=head2 Sponsor Enhancements + +The DBI Roadmap is available at L + +If your company would benefit from a specific new DBI feature, +please consider sponsoring its development. Work is performed +rapidly, and usually on a fixed-price payment-on-delivery basis. +Contact me for details. + +Using such targeted financing allows you to contribute to DBI +development, and rapidly get something specific and valuable in return. + +=head1 ACKNOWLEDGEMENTS + +I would like to acknowledge the valuable contributions of the many +people I have worked with on the DBI project, especially in the early +years (1992-1994). In no particular order: Kevin Stock, Buzz Moschetti, +Kurt Andersen, Ted Lemon, William Hails, Garth Kennedy, Michael Peppler, +Neil S. Briscoe, Jeff Urlwin, David J. Hughes, Jeff Stander, +Forrest D Whitcher, Larry Wall, Jeff Fried, Roy Johnson, Paul Hudson, +Georg Rehfeld, Steve Sizemore, Ron Pool, Jon Meek, Tom Christiansen, +Steve Baumgarten, Randal Schwartz, and a whole lot more. + +Then, of course, there are the poor souls who have struggled through +untold and undocumented obstacles to actually implement DBI drivers. +Among their ranks are Jochen Wiedmann, Alligator Descartes, Jonathan +Leffler, Jeff Urlwin, Michael Peppler, Henrik Tougaard, Edwin Pratomo, +Davide Migliavacca, Jan Pazdziora, Peter Haworth, Edmund Mergl, Steve +Williams, Thomas Lowery, and Phlip Plumlee. Without them, the DBI would +not be the practical reality it is today. I'm also especially grateful +to Alligator Descartes for starting work on the first edition of the +"Programming the Perl DBI" book and letting me jump on board. + +The DBI and DBD::Oracle were originally developed while I was Technical +Director (CTO) of Ingeneering in the UK (L) (formerly known as the +Paul Ingram Group). So I'd especially like to thank Paul for his generosity +and vision in supporting this work for many years. + +A couple of specific DBI features have been sponsored by enlightened companies: + +The development of the swap_inner_handle() method was sponsored by BizRate.com (L) + +The development of DBD::Gofer and related modules was sponsored by +Shopzilla.com (L), where I currently work. + + +=head1 CONTRIBUTING + +As you can see above, many people have contributed to the DBI and +drivers in many ways over many years. + +If you'd like to help then see L +and L + +If you'd like the DBI to do something new or different then a good way +to make that happen is to do it yourself and send me a patch to the +source code that shows the changes. (But read "Speak before you patch" +below.) + +=head2 Browsing the source code repository + +Use http://svn.perl.org/modules/dbi/trunk (basic) +or http://svn.perl.org/viewcvs/modules/ (more useful) + +=head2 How to create a patch using Subversion + +The DBI source code is maintained using Subversion (a replacement +for CVS, see L). To access the source +you'll need to install a Subversion client. Then, to get the source +code, do: + + svn checkout http://svn.perl.org/modules/dbi/trunk + +If it prompts for a username and password use your perl.org account +if you have one, else just 'guest' and 'guest'. The source code will +be in a new subdirectory called C. + +To keep informed about changes to the source you can send an empty email +to svn-commit-modules-dbi-subscribe@perl.org after which you'll get an email +with the change log message and diff of each change checked-in to the source. + +After making your changes you can generate a patch file, but before +you do, make sure your source is still up to date using: + + svn update + +If you get any conflicts reported you'll need to fix them first. +Then generate the patch file from within the C directory using: + + svn diff > foo.patch + +Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org. + +=head2 How to create a patch without Subversion + +Unpack a fresh copy of the distribution: + + tar xfz DBI-1.40.tar.gz + +Rename the newly created top level directory: + + mv DBI-1.40 DBI-1.40.your_foo + +Edit the contents of DBI-1.40.your_foo/* till it does what you want. + +Test your changes and then remove all temporary files: + + make test && make distclean + +Go back to the directory you originally unpacked the distribution: + + cd .. + +Unpack I copy of the original distribution you started with: + + tar xfz DBI-1.40.tar.gz + +Then create a patch file by performing a recursive C on the two +top level directories: + + diff -r -u DBI-1.40 DBI-1.40.your_foo > DBI-1.40.your_foo.patch + +=head2 Speak before you patch + +For anything non-trivial or possibly controversial it's a good idea +to discuss (on dbi-dev@perl.org) the changes you propose before +actually spending time working on them. Otherwise you run the risk +of them being rejected because they don't fit into some larger plans +you may not be aware of. + +=head1 TRANSLATIONS + +A German translation of this manual (possibly slightly out of date) is +available, thanks to O'Reilly, at: + + http://www.oreilly.de/catalog/perldbiger/ + +Some other translations: + + http://cronopio.net/perl/ - Spanish + http://member.nifty.ne.jp/hippo2000/dbimemo.htm - Japanese + + +=head1 TRAINING + +References to DBI related training resources. No recommendation implied. + + http://www.treepax.co.uk/ + http://www.keller.com/dbweb/ + +(If you offer professional DBI related training services, +please send me your details so I can add them here.) + +=head1 OTHER RELATED WORK AND PERL MODULES + +=over 4 + +=item Apache::DBI by E.Mergl@bawue.de + +To be used with the Apache daemon together with an embedded Perl +interpreter like C. Establishes a database connection which +remains open for the lifetime of the HTTP daemon. This way the CGI +connect and disconnect for every database access becomes superfluous. + +=item SQL Parser + +See also the L module, SQL parser and engine. + +=back + +=cut + +# LocalWords: DBI diff --git a/DBI.xs b/DBI.xs new file mode 100644 index 0000000..514007a --- /dev/null +++ b/DBI.xs @@ -0,0 +1,5560 @@ +/* vim: ts=8:sw=4:expandtab + * + * $Id: DBI.xs 15304 2012-05-14 08:17:22Z mjevans $ + * + * 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 + +#include "DBIXS.h" /* DBI public interface for DBD's written in C */ + +# if (defined(_WIN32) && (! defined(HAS_GETTIMEOFDAY))) +#include +# endif + +/* 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() */ + +#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 +#ifdef HAS_SETLINEBUF +#define PerlIO_setlinebuf(f) setlinebuf(f) +#else +#ifndef USE_PERLIO +#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0) +#endif +#endif +#endif + +#ifndef CopFILEGV +# define CopFILEGV(cop) cop->cop_filegv +# define CopLINE(cop) cop->cop_line +# define CopSTASH(cop) cop->cop_stash +# define CopSTASHPV(cop) (CopSTASH(cop) ? HvNAME(CopSTASH(cop)) : Nullch) +#endif +#ifndef PERL_GET_THX +#define PERL_GET_THX ((void*)0) +#endif +#ifndef PerlProc_getpid +#define PerlProc_getpid() getpid() +extern Pid_t getpid (void); +#endif +#ifndef aTHXo_ +#define aTHXo_ +#endif + +#if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION == 0)) +#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)); +static void dbih_clearcom _((imp_xxh_t *imp_xxh)); +static int dbih_logmsg _((imp_xxh_t *imp_xxh, const char *fmt, ...)); +static SV *dbih_make_com _((SV *parent_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV *copy)); +static SV *dbih_make_fdsv _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)); +static AV *dbih_get_fbav _((imp_sth_t *imp_sth)); +static SV *dbih_event _((SV *h, const char *name, SV*, SV*)); +static int dbih_set_attr_k _((SV *h, SV *keysv, int dbikey, SV *valuesv)); +static SV *dbih_get_attr_k _((SV *h, SV *keysv, int dbikey)); +static int dbih_sth_bind_col _((SV *sth, SV *col, SV *ref, SV *attribs)); + +static int set_err_char _((SV *h, imp_xxh_t *imp_xxh, const char *err_c, IV err_i, const char *errstr, const char *state, const char *method)); +static int set_err_sv _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)); +static int quote_type _((int sql_type, int p, int s, int *base_type, void *v)); +static int sql_type_cast_svpv _((pTHX_ SV *sv, int sql_type, U32 flags, void *v)); +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); +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; + U8 maxargs; + IV hidearg; + /* method_trace controls tracing of method calls in the dispatcher: + - if the current trace flags include a trace flag in method_trace + then set trace_level to min(2,trace_level) for duration of the call. + - else, if trace_level < (method_trace & DBIc_TRACE_LEVEL_MASK) + then don't trace the call + */ + 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 */ +#define IMA_HAS_USAGE 0x00000001 /* check parameter usage */ +#define IMA_FUNC_REDIRECT 0x00000002 /* is $h->func(..., "method") */ +#define IMA_KEEP_ERR 0x00000004 /* don't reset err & errstr */ +#define IMA_KEEP_ERR_SUB 0x00000008 /* '' if in a nested call */ +#define IMA_NO_TAINT_IN 0x00000010 /* don't check for tainted args */ +#define IMA_NO_TAINT_OUT 0x00000020 /* don't taint results */ +#define IMA_COPY_UP_STMT 0x00000040 /* copy sth Statement to dbh */ +#define IMA_END_WORK 0x00000080 /* method is commit or rollback */ +#define IMA_STUB 0x00000100 /* donothing eg $dbh->connected */ +#define IMA_CLEAR_STMT 0x00000200 /* clear Statement before call */ +#define IMA_UNRELATED_TO_STMT 0x00000400 /* profile as empty Statement */ +#define IMA_NOT_FOUND_OKAY 0x00000800 /* no error if not found */ +#define IMA_EXECUTE 0x00001000 /* do/execute: DBIcf_Executed */ +#define IMA_SHOW_ERR_STMT 0x00002000 /* dbh meth relates to Statement*/ +#define IMA_HIDE_ERR_PARAMVALUES 0x00004000 /* ParamValues are not relevant */ +#define IMA_IS_FACTORY 0x00008000 /* new h ie connect and prepare */ +#define IMA_CLEAR_CACHED_KIDS 0x00010000 /* clear CachedKids before call */ + +#define DBIc_STATE_adjust(imp_xxh, state) \ + (SvOK(state) /* SQLSTATE is implemented by driver */ \ + ? (strEQ(SvPV_nolen(state),"00000") ? &PL_sv_no : sv_mortalcopy(state))\ + : (SvTRUE(DBIc_ERR(imp_xxh)) \ + ? sv_2mortal(newSVpv("S1000",5)) /* General error */ \ + : &PL_sv_no) /* Success ("00000") */ \ + ) + +#define DBI_LAST_HANDLE g_dbi_last_h /* special fake inner handle */ +#define DBI_IS_LAST_HANDLE(h) ((DBI_LAST_HANDLE) == SvRV(h)) +#define DBI_SET_LAST_HANDLE(h) ((DBI_LAST_HANDLE) = SvRV(h)) +#define DBI_UNSET_LAST_HANDLE ((DBI_LAST_HANDLE) = &PL_sv_undef) +#define DBI_LAST_HANDLE_OK ((DBI_LAST_HANDLE) != &PL_sv_undef) + +#define DBIS_TRACE_LEVEL (DBIS->debug & DBIc_TRACE_LEVEL_MASK) +#define DBIS_TRACE_FLAGS (DBIS->debug) /* includes level */ + +#ifdef PERL_LONG_MAX +#define MAX_LongReadLen PERL_LONG_MAX +#else +#define MAX_LongReadLen 2147483647L +#endif + +#ifdef DBI_USE_THREADS +static char *dbi_build_opt = "-ithread"; +#else +static char *dbi_build_opt = "-nothread"; +#endif + +/* 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)); + + (void)param; /* avoid 'unused variable' warning */ + 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 --- */ +/* 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; /* maybe better moved into dbistate_t? */ + dbistate_t* dbi_state; +} my_cxt_t; + +START_MY_CXT + +#undef DBIS +#define DBIS (MY_CXT.dbi_state) + +#define g_dbi_last_h (MY_CXT.dbi_last_h) + +/* 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); +} + + +/* --- */ + +static void * +malloc_using_sv(STRLEN len) +{ + dTHX; + SV *sv = newSV(len); + void *p = SvPVX(sv); + memzero(p, len); + return p; +} + +static char * +savepv_using_sv(char *str) +{ + char *buf = malloc_using_sv(strlen(str)); + strcpy(buf, str); + return buf; +} + + +/* --- support functions for concat_hash_sorted --- */ + +typedef struct str_uv_sort_pair_st { + char *key; + UV numeric; +} str_uv_sort_pair_t; + +static int +_cmp_number(const void *val1, const void *val2) +{ + UV first = ((str_uv_sort_pair_t *)val1)->numeric; + UV second = ((str_uv_sort_pair_t *)val2)->numeric; + + if (first > second) + return 1; + if (first < second) + return -1; + /* only likely to reach here if numeric sort forced for non-numeric keys */ + /* fallback to comparing the key strings */ + return strcmp( + ((str_uv_sort_pair_t *)val1)->key, + ((str_uv_sort_pair_t *)val2)->key + ); +} + +static int +_cmp_str (const void *val1, const void *val2) +{ + return strcmp( *(char **)val1, *(char **)val2); +} + +static char ** +_sort_hash_keys (HV *hash, int num_sort, STRLEN *total_length) +{ + dTHX; + I32 hv_len, key_len; + HE *entry; + char **keys; + unsigned int idx = 0; + STRLEN tot_len = 0; + bool has_non_numerics = 0; + str_uv_sort_pair_t *numbers; + + hv_len = hv_iterinit(hash); + if (!hv_len) + return 0; + + Newz(0, keys, hv_len, char *); + Newz(0, numbers, hv_len, str_uv_sort_pair_t); + + while ((entry = hv_iternext(hash))) { + *(keys+idx) = hv_iterkey(entry, &key_len); + tot_len += key_len; + + if (grok_number(*(keys+idx), key_len, &(numbers+idx)->numeric) != IS_NUMBER_IN_UV) { + has_non_numerics = 1; + (numbers+idx)->numeric = 0; + } + + (numbers+idx)->key = *(keys+idx); + ++idx; + } + + if (total_length) + *total_length = tot_len; + + if (num_sort < 0) + num_sort = (has_non_numerics) ? 0 : 1; + + if (!num_sort) { + qsort(keys, hv_len, sizeof(char*), _cmp_str); + } + else { + qsort(numbers, hv_len, sizeof(str_uv_sort_pair_t), _cmp_number); + for (idx = 0; idx < hv_len; ++idx) + *(keys+idx) = (numbers+idx)->key; + } + + Safefree(numbers); + return keys; +} + + +static SV * +_join_hash_sorted(HV *hash, char *kv_sep, STRLEN kv_sep_len, char *pair_sep, STRLEN pair_sep_len, int use_neat, int num_sort) +{ + dTHX; + I32 hv_len; + STRLEN total_len = 0; + char **keys; + unsigned int i = 0; + SV *return_sv; + + keys = _sort_hash_keys(hash, num_sort, &total_len); + if (!keys) + return newSVpv("", 0); + + if (!kv_sep_len) + kv_sep_len = strlen(kv_sep); + if (!pair_sep_len) + pair_sep_len = strlen(pair_sep); + + hv_len = hv_iterinit(hash); + /* total_len += Separators + quotes + term null */ + total_len += kv_sep_len*hv_len + pair_sep_len*hv_len+2*hv_len+1; + return_sv = newSV(total_len); + sv_setpv(return_sv, ""); /* quell undef warnings */ + + for (i=0; icheck_version = check_version; + DBIS->version = DBISTATE_VERSION; + DBIS->size = sizeof(*DBIS); + DBIS->xs_version = DBIXS_VERSION; + + DBIS->logmsg = dbih_logmsg; + DBIS->logfp = PerlIO_stderr(); + DBIS->debug = (parent_dbis) ? parent_dbis->debug + : SvIV(get_sv("DBI::dbi_debug",0x5)); + DBIS->neatsvpvlen = (parent_dbis) ? parent_dbis->neatsvpvlen + : get_sv("DBI::neat_maxlen", GV_ADDMULTI); +#ifdef DBI_USE_THREADS + DBIS->thr_owner = PERL_GET_THX; +#endif + + /* store some function pointers so DBD's can call our functions */ + DBIS->getcom = dbih_getcom; + DBIS->clearcom = dbih_clearcom; + DBIS->event = dbih_event; + DBIS->set_attr_k = dbih_set_attr_k; + DBIS->get_attr_k = dbih_get_attr_k; + DBIS->get_fbav = dbih_get_fbav; + DBIS->make_fdsv = dbih_make_fdsv; + DBIS->neat_svpv = neatsvpv; + DBIS->bind_as_num = quote_type; /* XXX deprecated */ + DBIS->hash = dbi_hash; + DBIS->set_err_sv = set_err_sv; + DBIS->set_err_char= set_err_char; + DBIS->bind_col = dbih_sth_bind_col; + DBIS->sql_type_cast_svpv = sql_type_cast_svpv; + + + /* Remember the last handle used. BEWARE! Sneaky stuff here! */ + /* We want a handle reference but we don't want to increment */ + /* the handle's reference count and we don't want perl to try */ + /* to destroy it during global destruction. Take care! */ + DBI_UNSET_LAST_HANDLE; /* ensure setup the correct way */ + + /* trick to avoid 'possible typo' warnings */ + gv_fetchpv("DBI::state", GV_ADDMULTI, SVt_PV); + gv_fetchpv("DBI::err", GV_ADDMULTI, SVt_PV); + 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")); +} + + +/* ----------------------------------------------------------------- */ +/* Utility functions */ + + +static char * +dbih_htype_name(int htype) +{ + switch(htype) { + case DBIt_DR: return "dr"; + case DBIt_DB: return "db"; + case DBIt_ST: return "st"; + case DBIt_FD: return "fd"; + default: return "??"; + } +} + + +char * +neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging only */ +{ + dTHX; + dMY_CXT; + STRLEN len; + SV *nsv = Nullsv; + SV *infosv = Nullsv; + char *v, *quote; + + /* We take care not to alter the supplied sv in any way at all. */ + /* (but if it is SvGMAGICAL we have to call mg_get and that can */ + /* have side effects, especially as it may be called twice overall.) */ + + if (!sv) + return "Null!"; /* should never happen */ + + /* try to do the right thing with magical values */ + if (SvMAGICAL(sv)) { + if (DBIS_TRACE_LEVEL >= 5) { /* add magic details to help debugging */ + MAGIC* mg; + infosv = sv_2mortal(newSVpv(" (magic-",0)); + if (SvSMAGICAL(sv)) sv_catpvn(infosv,"s",1); + if (SvGMAGICAL(sv)) sv_catpvn(infosv,"g",1); + if (SvRMAGICAL(sv)) sv_catpvn(infosv,"r",1); + sv_catpvn(infosv,":",1); + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) + sv_catpvn(infosv, &mg->mg_type, 1); + sv_catpvn(infosv, ")", 1); + } + if (SvGMAGICAL(sv)) + mg_get(sv); /* trigger magic to FETCH the value */ + } + + if (!SvOK(sv)) { + if (SvTYPE(sv) >= SVt_PVAV) + return (char *)sv_reftype(sv,0); /* raw AV/HV etc, not via a ref */ + if (!infosv) + return "undef"; + sv_insert(infosv, 0,0, "undef",5); + return SvPVX(infosv); + } + + if (SvNIOK(sv)) { /* is a numeric value - so no surrounding quotes */ + if (SvPOK(sv)) { /* already has string version of the value, so use it */ + v = SvPV(sv,len); + if (len == 0) { v="''"; len=2; } /* catch &sv_no style special case */ + if (!infosv) + return v; + sv_insert(infosv, 0,0, v, len); + return SvPVX(infosv); + } + /* we don't use SvPV here since we don't want to alter sv in _any_ way */ + if (SvUOK(sv)) + nsv = newSVpvf("%"UVuf, SvUVX(sv)); + else if (SvIOK(sv)) + nsv = newSVpvf("%"IVdf, SvIVX(sv)); + else nsv = newSVpvf("%"NVgf, SvNVX(sv)); + if (infosv) + sv_catsv(nsv, infosv); + return SvPVX(sv_2mortal(nsv)); + } + + nsv = sv_newmortal(); + sv_upgrade(nsv, SVt_PV); + + if (SvROK(sv)) { + if (!SvAMAGIC(sv)) /* (un-amagic'd) refs get no special treatment */ + v = SvPV(sv,len); + else { + /* handle Overload magic refs */ + (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); + } + sv_setpvn(nsv, v, len); + if (infosv) + sv_catsv(nsv, infosv); + return SvPV(nsv, len); + } + + if (SvPOK(sv)) /* usual simple string case */ + v = SvPV(sv,len); + else /* handles all else via sv_2pv() */ + v = SvPV(sv,len); /* XXX how does this relate to SvGMAGIC? */ + + /* for strings we limit the length and translate codes */ + if (maxlen == 0) + maxlen = SvIV(DBIS->neatsvpvlen); + if (maxlen < 6) /* handle daft values */ + maxlen = 6; + maxlen -= 2; /* account for quotes */ + + quote = (SvUTF8(sv)) ? "\"" : "'"; + if (len > maxlen) { + SvGROW(nsv, (1+maxlen+1+1)); + sv_setpvn(nsv, quote, 1); + sv_catpvn(nsv, v, maxlen-3); /* account for three dots */ + sv_catpvn(nsv, "...", 3); + } else { + SvGROW(nsv, (1+len+1+1)); + sv_setpvn(nsv, quote, 1); + sv_catpvn(nsv, v, len); + } + sv_catpvn(nsv, quote, 1); + if (infosv) + sv_catsv(nsv, infosv); + v = SvPV(nsv, len); + if (!SvUTF8(sv)) { + while(len-- > 0) { /* cleanup string (map control chars to ascii etc) */ + const char c = v[len] & 0x7F; /* ignore top bit for multinational chars */ + if (!isPRINT(c) && !isSPACE(c)) + v[len] = '.'; + } + } + return v; +} + + +static int +set_err_char(SV *h, imp_xxh_t *imp_xxh, const char *err_c, IV err_i, const char *errstr, const char *state, const char *method) +{ + dTHX; + char err_buf[28]; + SV *err_sv, *errstr_sv, *state_sv, *method_sv; + if (!err_c) { + sprintf(err_buf, "%ld", (long)err_i); + err_c = &err_buf[0]; + } + err_sv = (strEQ(err_c,"1")) ? &PL_sv_yes : sv_2mortal(newSVpvn(err_c, strlen(err_c))); + errstr_sv = sv_2mortal(newSVpvn(errstr, strlen(errstr))); + state_sv = (state && *state) ? sv_2mortal(newSVpvn(state, strlen(state))) : &PL_sv_undef; + method_sv = (method && *method) ? sv_2mortal(newSVpvn(method, strlen(method))) : &PL_sv_undef; + return set_err_sv(h, imp_xxh, err_sv, errstr_sv, state_sv, method_sv); +} + +static int +set_err_sv(SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method) +{ + dTHX; + SV *h_err; + SV *h_errstr; + SV *h_state; + SV **hook_svp; + int err_changed = 0; + + if ( DBIc_has(imp_xxh, DBIcf_HandleSetErr) + && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleSetErr",12,0)) + && hook_svp + && ((void)(SvGMAGICAL(*hook_svp) && mg_get(*hook_svp)), SvOK(*hook_svp)) + ) { + dSP; + IV items; + SV *response_sv; + if (SvREADONLY(err)) err = sv_mortalcopy(err); + if (SvREADONLY(errstr)) errstr = sv_mortalcopy(errstr); + if (SvREADONLY(state)) state = sv_mortalcopy(state); + if (SvREADONLY(method)) method = sv_mortalcopy(method); + if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," -> HandleSetErr(%s, err=%s, errstr=%s, state=%s, %s)\n", + neatsvpv(h,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0), + neatsvpv(method,0) + ); + PUSHMARK(SP); + XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh)))); + XPUSHs(err); + XPUSHs(errstr); + XPUSHs(state); + XPUSHs(method); + PUTBACK; + items = call_sv(*hook_svp, G_SCALAR); + SPAGAIN; + response_sv = (items) ? POPs : &PL_sv_undef; + PUTBACK; + if (DBIc_TRACE_LEVEL(imp_xxh) >= 1) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," <- HandleSetErr= %s (err=%s, errstr=%s, state=%s, %s)\n", + neatsvpv(response_sv,0), neatsvpv(err,0), neatsvpv(errstr,0), neatsvpv(state,0), + neatsvpv(method,0) + ); + if (SvTRUE(response_sv)) /* handler says it has handled it, so... */ + return 0; + } + + if (!SvOK(err)) { /* clear err / errstr / state */ + DBIh_CLEAR_ERROR(imp_xxh); + return 1; + } + + /* fetch these after calling HandleSetErr */ + h_err = DBIc_ERR(imp_xxh); + h_errstr = DBIc_ERRSTR(imp_xxh); + h_state = DBIc_STATE(imp_xxh); + + if (SvTRUE(h_errstr)) { + /* append current err, if any, to errstr if it's going to change */ + if (SvTRUE(h_err) && SvTRUE(err) && strNE(SvPV_nolen(h_err), SvPV_nolen(err))) + sv_catpvf(h_errstr, " [err was %s now %s]", SvPV_nolen(h_err), SvPV_nolen(err)); + if (SvTRUE(h_state) && SvTRUE(state) && strNE(SvPV_nolen(h_state), SvPV_nolen(state))) + sv_catpvf(h_errstr, " [state was %s now %s]", SvPV_nolen(h_state), SvPV_nolen(state)); + if (strNE(SvPV_nolen(h_errstr), SvPV_nolen(errstr))) { + sv_catpvn(h_errstr, "\n", 1); + sv_catsv(h_errstr, errstr); + } + } + else + sv_setsv(h_errstr, errstr); + + /* SvTRUE(err) > "0" > "" > undef */ + if (SvTRUE(err) /* new error: so assign */ + || !SvOK(h_err) /* no existing warn/info: so assign */ + /* new warn ("0" len 1) > info ("" len 0): so assign */ + || (SvOK(err) && strlen(SvPV_nolen(err)) > strlen(SvPV_nolen(h_err))) + ) { + sv_setsv(h_err, err); + err_changed = 1; + if (SvTRUE(h_err)) /* new error */ + ++DBIc_ErrCount(imp_xxh); + } + + if (err_changed) { + if (SvTRUE(state)) { + if (strlen(SvPV_nolen(state)) != 5) { + warn("set_err: state (%s) is not a 5 character string, using 'S1000' instead", neatsvpv(state,0)); + sv_setpv(h_state, "S1000"); + } + else + sv_setsv(h_state, state); + } + else + (void)SvOK_off(h_state); /* see DBIc_STATE_adjust */ + } + + return 1; +} + + +static char * +mkvname(pTHX_ HV *stash, const char *item, int uplevel) /* construct a variable name */ +{ + SV *sv = sv_newmortal(); + sv_setpv(sv, HvNAME(stash)); + if(uplevel) { + while(SvCUR(sv) && *SvEND(sv)!=':') + --SvCUR(sv); + if (SvCUR(sv)) + --SvCUR(sv); + } + sv_catpv(sv, "::"); + sv_catpv(sv, item); + return SvPV_nolen(sv); +} + +/* 32 bit magic FNV-0 and FNV-1 prime */ +#define FNV_32_PRIME ((UV)0x01000193) + +static I32 +dbi_hash(const char *key, long type) +{ + if (type == 0) { + STRLEN klen = strlen(key); + U32 hash = 0; + while (klen--) + hash = hash * 33 + *key++; + hash &= 0x7FFFFFFF; /* limit to 31 bits */ + hash |= 0x40000000; /* set bit 31 */ + return -(I32)hash; /* return negative int */ + } + else if (type == 1) { /* Fowler/Noll/Vo hash */ + /* see http://www.isthe.com/chongo/tech/comp/fnv/ */ + U32 hash = 0x811c9dc5; + const unsigned char *s = (unsigned char *)key; /* unsigned string */ + while (*s) { + /* multiply by the 32 bit FNV magic prime mod 2^32 */ + hash *= FNV_32_PRIME; + /* xor the bottom with the current octet */ + hash ^= (U32)*s++; + } + return hash; + } + croak("DBI::hash(%ld): invalid type", type); + return 0; /* NOT REACHED */ +} + + +static int +dbih_logmsg(imp_xxh_t *imp_xxh, const char *fmt, ...) +{ + dTHX; + va_list args; +#ifdef I_STDARG + va_start(args, fmt); +#else + va_start(args); +#endif + (void) PerlIO_vprintf(DBIc_DBISTATE(imp_xxh)->logfp, fmt, args); + va_end(args); + (void)imp_xxh; + return 1; +} + +static void +close_trace_file(pTHX) +{ + dMY_CXT; + if (DBILOGFP == PerlIO_stderr() || DBILOGFP == PerlIO_stdout()) + return; + + if (DBIS->logfp_ref == NULL) + PerlIO_close(DBILOGFP); + else { + /* DAA dec refcount and discard */ + SvREFCNT_dec(DBIS->logfp_ref); + DBIS->logfp_ref = NULL; + } +} + +static int +set_trace_file(SV *file) +{ + dTHX; + dMY_CXT; + const char *filename; + PerlIO *fp = Nullfp; + IO *io; + + if (!file) /* no arg == no change */ + return 0; + + /* DAA check for a filehandle */ + if (SvROK(file)) { + io = sv_2io(file); + if (!io || !(fp = IoOFP(io))) { + warn("DBI trace filehandle is not valid"); + return 0; + } + close_trace_file(aTHX); + SvREFCNT_inc(io); + DBIS->logfp_ref = io; + } + else if (isGV_with_GP(file)) { + io = GvIO(file); + if (!io || !(fp = IoOFP(io))) { + warn("DBI trace filehandle from GLOB is not valid"); + return 0; + } + close_trace_file(aTHX); + SvREFCNT_inc(io); + DBIS->logfp_ref = io; + } + else { + filename = (SvOK(file)) ? SvPV_nolen(file) : Nullch; + /* undef arg == reset back to stderr */ + if (!filename || strEQ(filename,"STDERR") + || strEQ(filename,"*main::STDERR")) { + close_trace_file(aTHX); + DBILOGFP = PerlIO_stderr(); + return 1; + } + if (strEQ(filename,"STDOUT")) { + close_trace_file(aTHX); + DBILOGFP = PerlIO_stdout(); + return 1; + } + fp = PerlIO_open(filename, "a+"); + if (fp == Nullfp) { + warn("Can't open trace file %s: %s", filename, Strerror(errno)); + return 0; + } + close_trace_file(aTHX); + } + DBILOGFP = fp; + /* if this line causes your compiler or linker to choke */ + /* then just comment it out, it's not essential. */ + PerlIO_setlinebuf(fp); /* force line buffered output */ + return 1; +} + +static IV +parse_trace_flags(SV *h, SV *level_sv, IV old_level) +{ + dTHX; + IV level; + if (!level_sv || !SvOK(level_sv)) + level = old_level; /* undef: no change */ + else + if (SvTRUE(level_sv)) { + if (looks_like_number(level_sv)) + level = SvIV(level_sv); /* number: number */ + else { /* string: parse it */ + dSP; + PUSHMARK(sp); + XPUSHs(h); + XPUSHs(level_sv); + PUTBACK; + if (call_method("parse_trace_flags", G_SCALAR) != 1) + croak("panic: parse_trace_flags");/* should never happen */ + SPAGAIN; + level = POPi; + PUTBACK; + } + } + else /* defined but false: 0 */ + level = 0; + return level; +} + + +static int +set_trace(SV *h, SV *level_sv, SV *file) +{ + dTHX; + D_imp_xxh(h); + 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 */ + if ((level & DBIc_TRACE_LEVEL_MASK) > 0) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh), + " %s trace level set to 0x%lx/%ld (DBI @ 0x%lx/%ld) in DBI %s%s (pid %d)\n", + neatsvpv(h,0), + (long)(level & DBIc_TRACE_FLAGS_MASK), + (long)(level & DBIc_TRACE_LEVEL_MASK), + (long)DBIc_TRACE_FLAGS(imp_xxh), (long)DBIc_TRACE_LEVEL(imp_xxh), + XS_VERSION, dbi_build_opt, (int)PerlProc_getpid()); + if (!PL_dowarn) + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," Note: perl is running without the recommended perl -w option\n"); + PerlIO_flush(DBIc_LOGPIO(imp_xxh)); + } + sv_setiv(DBIc_DEBUG(imp_xxh), level); + } + return RETVAL; +} + + +static SV * +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 */ + MAGIC *mg; + SV *ohv; /* outer HV after derefing the RV */ + SV *hrv; /* dbi inner handle RV-to-HV */ + + /* enable a raw HV (not ref-to-HV) to be passed in, eg DBIc_MY_H */ + ohv = SvROK(orv) ? SvRV(orv) : orv; + + if (!ohv || SvTYPE(ohv) != SVt_PVHV) { + if (!what) + return NULL; + 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)"); + croak("%s handle %s is not a DBI handle", what, neatsvpv(orv,0)); + } + if (!SvMAGICAL(ohv)) { + if (!what) + return NULL; + sv_dump(orv); + croak("%s handle %s is not a DBI handle (has no magic)", + what, neatsvpv(orv,0)); + } + + if ( (mg=mg_find(ohv,'P')) == NULL) { /* hash tie magic */ + /* not tied, maybe it's already an inner handle... */ + if (mg_find(ohv, DBI_MAGIC) == NULL) { + if (!what) + return NULL; + sv_dump(orv); + croak("%s handle %s is not a valid DBI handle", + what, neatsvpv(orv,0)); + } + hrv = orv; /* was already a DBI handle inner hash */ + } + else { + hrv = mg->mg_obj; /* inner hash of tie */ + } + + return hrv; +} + + + +/* -------------------------------------------------------------------- */ +/* Functions to manage a DBI handle (magic and attributes etc). */ + +static imp_xxh_t * +dbih_getcom(SV *hrv) /* used by drivers via DBIS func ptr */ +{ + 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. */ +{ + 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 { + 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 */ + /* has magic and that DBI_MAGIC, if present, will be the first. */ + if (SvRMAGICAL(sv) && (mg=SvMAGIC(sv))->mg_type == DBI_MAGIC) { + /* nothing to do here */ + } + else { + /* Validate handle (convert outer to inner if required) */ + hrv = dbih_inner(aTHX_ hrv, "dbih_getcom"); + mg = mg_find(SvRV(hrv), DBI_MAGIC); + } + if (mgp) /* let caller pickup magic struct for this handle */ + *mgp = mg; + + return (imp_xxh_t *) mg->mg_ptr; +} + + +static SV * +dbih_setup_attrib(pTHX_ SV *h, imp_xxh_t *imp_xxh, char *attrib, SV *parent, int read_only, int optional) +{ + STRLEN len = strlen(attrib); + SV **asvp; + + asvp = hv_fetch((HV*)SvRV(h), attrib, len, !optional); + /* we assume that we won't have any existing 'undef' attributes here */ + /* (or, alternately, we take undef to mean 'copy from parent') */ + if (!(asvp && SvOK(*asvp))) { /* attribute doesn't already exists (the common case) */ + SV **psvp; + if ((!parent || !SvROK(parent)) && !optional) { + croak("dbih_setup_attrib(%s): %s not set and no parent supplied", + neatsvpv(h,0), attrib); + } + psvp = hv_fetch((HV*)SvRV(parent), attrib, len, 0); + if (psvp) { + if (!asvp) + asvp = hv_fetch((HV*)SvRV(h), attrib, len, 1); + sv_setsv(*asvp, *psvp); /* copy attribute from parent to handle */ + } + else { + if (!optional) + croak("dbih_setup_attrib(%s): %s not set and not in parent", + neatsvpv(h,0), attrib); + } + } + if (DBIc_TRACE_LEVEL(imp_xxh) >= 5) { + PerlIO *logfp = DBIc_LOGPIO(imp_xxh); + PerlIO_printf(logfp," dbih_setup_attrib(%s, %s, %s)", + neatsvpv(h,0), attrib, neatsvpv(parent,0)); + if (!asvp) + PerlIO_printf(logfp," undef (not defined)\n"); + else + if (SvOK(*asvp)) + PerlIO_printf(logfp," %s (already defined)\n", neatsvpv(*asvp,0)); + else PerlIO_printf(logfp," %s (copied from parent)\n", neatsvpv(*asvp,0)); + } + if (read_only && asvp) + SvREADONLY_on(*asvp); + return asvp ? *asvp : &PL_sv_undef; +} + + +static SV * +dbih_make_fdsv(SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name) +{ + dTHX; + D_imp_sth(sth); + const STRLEN cn_len = strlen(col_name); + imp_fdh_t *imp_fdh; + SV *fdsv; + if (imp_size < sizeof(imp_fdh_t) || cn_len<10 || strNE("::fd",&col_name[cn_len-4])) + 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(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); + imp_fdh->com.col_name = ((char*)imp_fdh) + imp_size; + strcpy(imp_fdh->com.col_name, col_name); + return fdsv; +} + + +static SV * +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; + static const char *errmsg = "Can't make DBI com handle for %s: %s"; + HV *imp_stash; + SV *dbih_imp_sv; + imp_xxh_t *imp; + int trace_level; + (void)extra; /* unused arg */ + + if ( (imp_stash = gv_stashpv(imp_class, FALSE)) == NULL) + croak(errmsg, imp_class, "unknown package"); + + if (imp_size == 0) { + /* get size of structure to allocate for common and imp specific data */ + const char *imp_size_name = mkvname(aTHX_ imp_stash, "imp_data_size", 0); + imp_size = SvIV(get_sv(imp_size_name, 0x05)); + if (imp_size == 0) { + imp_size = sizeof(imp_sth_t); + if (sizeof(imp_dbh_t) > imp_size) + imp_size = sizeof(imp_dbh_t); + if (sizeof(imp_drh_t) > imp_size) + imp_size = sizeof(imp_drh_t); + imp_size += 4; + } + } + + 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; + /* validate the supplied dbi_imp_data looks reasonable, */ + if (SvCUR(imp_templ) != imp_size) + croak("Can't use dbi_imp_data of wrong size (%ld not %ld)", + (long)SvCUR(imp_templ), (long)imp_size); + + /* copy the whole template */ + dbih_imp_sv = newSVsv(imp_templ); + imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv); + + /* sanity checks on the supplied imp_data */ + if (DBIc_TYPE(imp) != ((p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 :1) ) + croak("Can't use dbi_imp_data from different type of handle"); + if (!DBIc_has(imp, DBIcf_IMPSET)) + croak("Can't use dbi_imp_data that not from a setup handle"); + + /* copy flags, zero out our imp_xxh struct, restore some flags */ + imp_templ_flags = DBIc_FLAGS(imp); + switch ( (p_imp_xxh) ? DBIc_TYPE(p_imp_xxh)+1 : DBIt_DR ) { + case DBIt_DR: memzero((char*)imp, sizeof(imp_drh_t)); break; + case DBIt_DB: memzero((char*)imp, sizeof(imp_dbh_t)); break; + case DBIt_ST: memzero((char*)imp, sizeof(imp_sth_t)); break; + default: croak("dbih_make_com dbi_imp_data bad h type"); + } + /* Only pass on DBIcf_IMPSET to indicate to driver that the imp */ + /* structure has been copied and it doesn't need to reconnect. */ + /* Similarly DBIcf_ACTIVE is also passed along but isn't key. */ + DBIc_FLAGS(imp) = imp_templ_flags & (DBIcf_IMPSET|DBIcf_ACTIVE); + } + else { + dbih_imp_sv = newSV(imp_size); /* is grown to at least imp_size+1 */ + imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv); + memzero((char*)imp, imp_size); + /* set up SV with SvCUR set ready for take_imp_data */ + SvCUR_set(dbih_imp_sv, imp_size); + *SvEND(dbih_imp_sv) = '\0'; + } + + 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 */ + DBIc_PARENT_H(imp) = &PL_sv_undef; + DBIc_PARENT_COM(imp) = NULL; + DBIc_TYPE(imp) = DBIt_DR; + DBIc_on(imp,DBIcf_WARN /* set only here, children inherit */ + |DBIcf_ACTIVE /* drivers are 'Active' by default */ + |DBIcf_AutoCommit /* advisory, driver must manage this */ + ); + DBIc_set(imp, DBIcf_PrintWarn, PL_dowarn); /* set if warnings enabled */ + } + else { + DBIc_PARENT_H(imp) = (SV*)SvREFCNT_inc(p_h); /* ensure it lives */ + DBIc_PARENT_COM(imp) = p_imp_xxh; /* shortcut for speed */ + DBIc_TYPE(imp) = DBIc_TYPE(p_imp_xxh) + 1; + /* inherit some flags from parent and carry forward some from template */ + DBIc_FLAGS(imp) = (DBIc_FLAGS(p_imp_xxh) & ~DBIcf_INHERITMASK) + | (DBIc_FLAGS(imp) & (DBIcf_IMPSET|DBIcf_ACTIVE)); + ++DBIc_KIDS(p_imp_xxh); + } +#ifdef DBI_USE_THREADS + DBIc_THR_USER(imp) = PERL_GET_THX ; +#endif + + if (DBIc_TYPE(imp) == DBIt_ST) { + imp_sth_t *imp_sth = (imp_sth_t*)imp; + DBIc_ROW_COUNT(imp_sth) = -1; + } + + DBIc_COMSET_on(imp); /* common data now set up */ + + /* The implementor should DBIc_IMPSET_on(imp) when setting up */ + /* any private data which will need clearing/freeing later. */ + + return dbih_imp_sv; +} + + +static void +dbih_setup_handle(pTHX_ SV *orv, char *imp_class, SV *parent, SV *imp_datasv) +{ + SV *h; + char *errmsg = "Can't setup DBI handle of %s to %s: %s"; + SV *dbih_imp_sv; + SV *dbih_imp_rv; + SV *dbi_imp_data = Nullsv; + SV **svp; + char imp_mem_name[300]; + 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) */ + 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 (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"); + + strcpy(imp_mem_name, imp_class); + strcat(imp_mem_name, "_mem"); + if ( (imp_mem_stash = gv_stashpv(imp_mem_name, FALSE)) == NULL) + croak(errmsg, neatsvpv(orv,0), imp_mem_name, "unknown _mem package"); + + if ((svp = hv_fetch((HV*)SvRV(h), "dbi_imp_data", 12, 0))) { + dbi_imp_data = *svp; + if (SvGMAGICAL(dbi_imp_data)) /* call FETCH via magic */ + mg_get(dbi_imp_data); + } + + DBI_LOCK; + + dbih_imp_sv = dbih_make_com(parent, parent_imp, imp_class, 0, 0, dbi_imp_data); + imp = (imp_xxh_t*)(void*)SvPVX(dbih_imp_sv); + + dbih_imp_rv = newRV_inc(dbih_imp_sv); /* just needed for sv_bless */ + sv_bless(dbih_imp_rv, imp_mem_stash); + sv_free(dbih_imp_rv); + + DBIc_MY_H(imp) = (HV*)SvRV(orv); /* take _copy_ of pointer, not new ref */ + DBIc_IMP_DATA(imp) = (imp_datasv) ? newSVsv(imp_datasv) : &PL_sv_undef; + _imp2com(imp, std.pid) = (U32)PerlProc_getpid(); + + if (DBIc_TYPE(imp) <= DBIt_ST) { + SV **tmp_svp; + /* Copy some attributes from parent if not defined locally and */ + /* also take address of attributes for speed of direct access. */ + /* parent is null for drh, in which case h must hold the values */ +#define COPY_PARENT(name,ro,opt) SvREFCNT_inc(dbih_setup_attrib(aTHX_ h,imp,(name),parent,ro,opt)) +#define DBIc_ATTR(imp, f) _imp2com(imp, attr.f) + /* XXX we should validate that these are the right type (refs etc) */ + DBIc_ATTR(imp, Err) = COPY_PARENT("Err",1,0); /* scalar ref */ + DBIc_ATTR(imp, State) = COPY_PARENT("State",1,0); /* scalar ref */ + DBIc_ATTR(imp, Errstr) = COPY_PARENT("Errstr",1,0); /* scalar ref */ + DBIc_ATTR(imp, TraceLevel)=COPY_PARENT("TraceLevel",0,0);/* scalar (int)*/ + DBIc_ATTR(imp, FetchHashKeyName) = COPY_PARENT("FetchHashKeyName",0,0); /* scalar ref */ + + if (parent) { + dbih_setup_attrib(aTHX_ h,imp,"HandleSetErr",parent,0,1); + dbih_setup_attrib(aTHX_ h,imp,"HandleError",parent,0,1); + dbih_setup_attrib(aTHX_ h,imp,"ReadOnly",parent,0,1); + dbih_setup_attrib(aTHX_ h,imp,"Profile",parent,0,1); + + /* setup Callbacks from parents' ChildCallbacks */ + if (DBIc_has(parent_imp, DBIcf_Callbacks) + && (tmp_svp = hv_fetch((HV*)SvRV(parent), "Callbacks", 9, 0)) + && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV + && (tmp_svp = hv_fetch((HV*)SvRV(*tmp_svp), "ChildCallbacks", 14, 0)) + && SvROK(*tmp_svp) && SvTYPE(SvRV(*tmp_svp)) == SVt_PVHV + ) { + /* XXX mirrors behaviour of dbih_set_attr_k() of Callbacks */ + (void)hv_store((HV*)SvRV(h), "Callbacks", 9, newRV_inc(SvRV(*tmp_svp)), 0); + DBIc_set(imp, DBIcf_Callbacks, 1); + } + + DBIc_LongReadLen(imp) = DBIc_LongReadLen(parent_imp); +#ifdef sv_rvweaken + if (1) { + AV *av; + /* add weakref to new (outer) handle into parents ChildHandles array */ + tmp_svp = hv_fetch((HV*)SvRV(parent), "ChildHandles", 12, 1); + if (!SvROK(*tmp_svp)) { + SV *ChildHandles_rvav = newRV_noinc((SV*)newAV()); + sv_setsv(*tmp_svp, ChildHandles_rvav); + sv_free(ChildHandles_rvav); + } + av = (AV*)SvRV(*tmp_svp); + av_push(av, (SV*)sv_rvweaken(newRV_inc((SV*)SvRV(orv)))); + if (av_len(av) % 120 == 0) { + /* time to do some housekeeping to remove dead handles */ + I32 i = av_len(av); /* 0 = 1 element */ + while (i-- >= 0) { + SV *sv = av_shift(av); + if (SvOK(sv)) + av_push(av, sv); + else + sv_free(sv); /* keep it leak-free by Doru Petrescu pdoru.dbi@from.ro */ + } + } + } +#endif + } + else { + DBIc_LongReadLen(imp) = DBIc_LongReadLen_init; + } + + switch (DBIc_TYPE(imp)) { + case DBIt_DB: + /* cache _inner_ handle, but also see quick_FETCH */ + (void)hv_store((HV*)SvRV(h), "Driver", 6, newRV_inc(SvRV(parent)), 0); + (void)hv_fetch((HV*)SvRV(h), "Statement", 9, 1); /* store writable undef */ + break; + case DBIt_ST: + DBIc_NUM_FIELDS((imp_sth_t*)imp) = -1; + /* cache _inner_ handle, but also see quick_FETCH */ + (void)hv_store((HV*)SvRV(h), "Database", 8, newRV_inc(SvRV(parent)), 0); + /* copy (alias) Statement from the sth up into the dbh */ + tmp_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 1); + (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(*tmp_svp), 0); + break; + } + } + + /* Use DBI magic on inner handle to carry handle attributes */ + /* 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 + * DBD::Oracle (and possibly other drivers) check for a valid handle + * using (SvMAGIC(SvRV(h)))->mg_type == 'P'). That doesn't work now + * because the weakref magic is inserted ahead of the tie magic. + * So here we swap the tie and weakref magic so the tie comes first. + */ + MAGIC *tie_mg = mg_find(SvRV(orv),'P'); + MAGIC *first = SvMAGIC(SvRV(orv)); + if (tie_mg && first->mg_moremagic == tie_mg && !tie_mg->mg_moremagic) { + MAGIC *next = tie_mg->mg_moremagic; + SvMAGIC(SvRV(orv)) = tie_mg; + tie_mg->mg_moremagic = first; + first->mg_moremagic = next; + } + } + + DBI_UNLOCK; +} + + +static void +dbih_dumphandle(pTHX_ SV *h, const char *msg, int level) +{ + D_imp_xxh(h); + if (level >= 9) { + sv_dump(h); + } + dbih_dumpcom(aTHX_ imp_xxh, msg, level); +} + +static int +dbih_dumpcom(pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level) +{ + dMY_CXT; + SV *flags = sv_2mortal(newSVpv("",0)); + SV *inner; + static const char pad[] = " "; + if (!msg) + msg = "dbih_dumpcom"; + PerlIO_printf(DBILOGFP," %s (%sh 0x%lx, com 0x%lx, imp %s):\n", + msg, dbih_htype_name(DBIc_TYPE(imp_xxh)), + (long)DBIc_MY_H(imp_xxh), (long)imp_xxh, + (PL_dirty) ? "global destruction" : HvNAME(DBIc_IMP_STASH(imp_xxh))); + if (DBIc_COMSET(imp_xxh)) sv_catpv(flags,"COMSET "); + if (DBIc_IMPSET(imp_xxh)) sv_catpv(flags,"IMPSET "); + if (DBIc_ACTIVE(imp_xxh)) sv_catpv(flags,"Active "); + if (DBIc_WARN(imp_xxh)) sv_catpv(flags,"Warn "); + if (DBIc_COMPAT(imp_xxh)) sv_catpv(flags,"CompatMode "); + if (DBIc_is(imp_xxh, DBIcf_ChopBlanks)) sv_catpv(flags,"ChopBlanks "); + if (DBIc_is(imp_xxh, DBIcf_HandleSetErr)) sv_catpv(flags,"HandleSetErr "); + if (DBIc_is(imp_xxh, DBIcf_HandleError)) sv_catpv(flags,"HandleError "); + if (DBIc_is(imp_xxh, DBIcf_RaiseError)) sv_catpv(flags,"RaiseError "); + if (DBIc_is(imp_xxh, DBIcf_PrintError)) sv_catpv(flags,"PrintError "); + if (DBIc_is(imp_xxh, DBIcf_PrintWarn)) sv_catpv(flags,"PrintWarn "); + if (DBIc_is(imp_xxh, DBIcf_ShowErrorStatement)) sv_catpv(flags,"ShowErrorStatement "); + if (DBIc_is(imp_xxh, DBIcf_AutoCommit)) sv_catpv(flags,"AutoCommit "); + if (DBIc_is(imp_xxh, DBIcf_BegunWork)) sv_catpv(flags,"BegunWork "); + if (DBIc_is(imp_xxh, DBIcf_LongTruncOk)) sv_catpv(flags,"LongTruncOk "); + if (DBIc_is(imp_xxh, DBIcf_MultiThread)) sv_catpv(flags,"MultiThread "); + if (DBIc_is(imp_xxh, DBIcf_TaintIn)) sv_catpv(flags,"TaintIn "); + if (DBIc_is(imp_xxh, DBIcf_TaintOut)) sv_catpv(flags,"TaintOut "); + if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile "); + if (DBIc_is(imp_xxh, DBIcf_Callbacks)) sv_catpv(flags,"Callbacks "); + PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad, (long)DBIc_FLAGS(imp_xxh), SvPV_nolen(flags)); + if (SvOK(DBIc_ERR(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s ERR %s\n", pad, neatsvpv((SV*)DBIc_ERR(imp_xxh),0)); + if (SvOK(DBIc_ERR(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s ERRSTR %s\n", pad, neatsvpv((SV*)DBIc_ERRSTR(imp_xxh),0)); + PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad, neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0)); + PerlIO_printf(DBILOGFP,"%s KIDS %ld (%ld Active)\n", pad, + (long)DBIc_KIDS(imp_xxh), (long)DBIc_ACTIVE_KIDS(imp_xxh)); + if (DBIc_IMP_DATA(imp_xxh) && SvOK(DBIc_IMP_DATA(imp_xxh))) + PerlIO_printf(DBILOGFP,"%s IMP_DATA %s\n", pad, neatsvpv(DBIc_IMP_DATA(imp_xxh),0)); + if (DBIc_LongReadLen(imp_xxh) != DBIc_LongReadLen_init) + PerlIO_printf(DBILOGFP,"%s LongReadLen %ld\n", pad, (long)DBIc_LongReadLen(imp_xxh)); + + if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + const imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh; + PerlIO_printf(DBILOGFP,"%s NUM_OF_FIELDS %d\n", pad, DBIc_NUM_FIELDS(imp_sth)); + PerlIO_printf(DBILOGFP,"%s NUM_OF_PARAMS %d\n", pad, DBIc_NUM_PARAMS(imp_sth)); + } + inner = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_xxh), msg); + if (!inner || !SvROK(inner)) + return 1; + if (DBIc_TYPE(imp_xxh) <= DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(inner), "CachedKids", 10, 0); + if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(*svp); + PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(hv)); + } + } + if (level > 0) { + SV* value; + char *key; + I32 keylen; + PerlIO_printf(DBILOGFP,"%s cached attributes:\n", pad); + while ( (value = hv_iternextsv((HV*)SvRV(inner), &key, &keylen)) ) { + PerlIO_printf(DBILOGFP,"%s '%s' => %s\n", pad, key, neatsvpv(value,0)); + } + } + else if (DBIc_TYPE(imp_xxh) == DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(inner), "Name", 4, 0); + if (svp && SvOK(*svp)) + PerlIO_printf(DBILOGFP,"%s Name %s\n", pad, neatsvpv(*svp,0)); + } + else if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + SV **svp = hv_fetch((HV*)SvRV(inner), "Statement", 9, 0); + if (svp && SvOK(*svp)) + PerlIO_printf(DBILOGFP,"%s Statement %s\n", pad, neatsvpv(*svp,0)); + } + return 1; +} + + +static void +dbih_clearcom(imp_xxh_t *imp_xxh) +{ + dTHX; + dTHR; + int dump = FALSE; + int debug = DBIc_TRACE_LEVEL(imp_xxh); + int auto_dump = (debug >= 6); + imp_xxh_t * const parent_xxh = DBIc_PARENT_COM(imp_xxh); + /* Note that we're very much on our own here. DBIc_MY_H(imp_xxh) almost */ + /* certainly points to memory which has been freed. Don't use it! */ + + /* --- pre-clearing sanity checks --- */ + +#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(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(DBIc_LOGPIO(imp_xxh)); + } + return; + } +#endif + + if (!DBIc_COMSET(imp_xxh)) { /* should never happen */ + dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom: DBI handle already cleared", 0); + return; + } + + if (auto_dump) + dbih_dumpcom(aTHX_ imp_xxh,"DESTROY (dbih_clearcom)", 0); + + if (!PL_dirty) { + + if (DBIc_ACTIVE(imp_xxh)) { /* bad news, potentially */ + /* warn for sth, warn for dbh only if it has active sth or isn't AutoCommit */ + if (DBIc_TYPE(imp_xxh) >= DBIt_ST + || (DBIc_ACTIVE_KIDS(imp_xxh) || !DBIc_has(imp_xxh, DBIcf_AutoCommit)) + ) { + warn("DBI %s handle 0x%lx cleared whilst still active", + dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh)); + dump = TRUE; + } + } + + /* check that the implementor has done its own housekeeping */ + if (DBIc_IMPSET(imp_xxh)) { + warn("DBI %s handle 0x%lx has uncleared implementors data", + dbih_htype_name(DBIc_TYPE(imp_xxh)), (unsigned long)DBIc_MY_H(imp_xxh)); + dump = TRUE; + } + + if (DBIc_KIDS(imp_xxh)) { + warn("DBI %s handle 0x%lx has %d uncleared child handles", + dbih_htype_name(DBIc_TYPE(imp_xxh)), + (unsigned long)DBIc_MY_H(imp_xxh), (int)DBIc_KIDS(imp_xxh)); + dump = TRUE; + } + } + + if (dump && !auto_dump) /* else was already dumped above */ + dbih_dumpcom(aTHX_ imp_xxh, "dbih_clearcom", 0); + + /* --- pre-clearing adjustments --- */ + + if (!PL_dirty) { + if (parent_xxh) { + if (DBIc_ACTIVE(imp_xxh)) /* see also DBIc_ACTIVE_off */ + --DBIc_ACTIVE_KIDS(parent_xxh); + --DBIc_KIDS(parent_xxh); + } + } + + /* --- clear fields (may invoke object destructors) --- */ + + if (DBIc_TYPE(imp_xxh) == DBIt_ST) { + imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh; + sv_free((SV*)DBIc_FIELDS_AV(imp_sth)); + } + + sv_free(DBIc_IMP_DATA(imp_xxh)); /* do this first */ + if (DBIc_TYPE(imp_xxh) <= DBIt_ST) { /* DBIt_FD doesn't have attr */ + sv_free(_imp2com(imp_xxh, attr.TraceLevel)); + sv_free(_imp2com(imp_xxh, attr.State)); + sv_free(_imp2com(imp_xxh, attr.Err)); + sv_free(_imp2com(imp_xxh, attr.Errstr)); + sv_free(_imp2com(imp_xxh, attr.FetchHashKeyName)); + } + + + sv_free((SV*)DBIc_PARENT_H(imp_xxh)); /* do this last */ + + DBIc_COMSET_off(imp_xxh); + + if (debug >= 4) + 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)); +} + + +/* --- Functions for handling field buffer arrays --- */ + +static AV * +dbih_setup_fbav(imp_sth_t *imp_sth) +{ + /* Usually called to setup the row buffer for new sth. + * Also called if the value of NUM_OF_FIELDS is altered, + * in which case it adjusts the row buffer to match NUM_OF_FIELDS. + */ + dTHX; + I32 i = DBIc_NUM_FIELDS(imp_sth); + AV *av = DBIc_FIELDS_AV(imp_sth); + + if (i < 0) + i = 0; + + if (av) { + if (av_len(av)+1 == i) /* is existing array the right size? */ + return av; + /* we need to adjust the size of the array */ + if (DBIc_TRACE_LEVEL(imp_sth) >= 2) + 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(DBIc_LOGPIO(imp_sth)," dbih_setup_fbav alloc for %ld fields\n", (long)i); + av = newAV(); + DBIc_FIELDS_AV(imp_sth) = av; + + /* row_count will need to be manually reset by the driver if the */ + /* sth is re-executed (since this code won't get rerun) */ + DBIc_ROW_COUNT(imp_sth) = 0; + } + + /* load array with writeable SV's. Do this backwards so */ + /* the array only gets extended once. */ + while(i--) /* field 1 stored at index 0 */ + av_store(av, i, newSV(0)); + if (DBIc_TRACE_LEVEL(imp_sth) >= 6) + 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; +} + + +static AV * +dbih_get_fbav(imp_sth_t *imp_sth) +{ + AV *av; + + if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav) { + av = dbih_setup_fbav(imp_sth); + } + else { + dTHX; + int i = av_len(av) + 1; + if (i != DBIc_NUM_FIELDS(imp_sth)) { + /*SV *sth = dbih_inner(aTHX_ (SV*)DBIc_MY_H(imp_sth), "_get_fbav");*/ + /* warn via PrintWarn */ + set_err_char(SvRV(DBIc_MY_H(imp_sth)), (imp_xxh_t*)imp_sth, + "0", 0, "Number of row fields inconsistent with NUM_OF_FIELDS (driver bug)", "", "_get_fbav"); + /* + DBIc_NUM_FIELDS(imp_sth) = i; + hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD); + */ + } + /* don't let SvUTF8 flag persist from one row to the next */ + /* (only affects drivers that use sv_setpv, but most XS do) */ + /* XXX turn into option later (force on/force off/ignore) */ + while(i--) /* field 1 stored at index 0 */ + SvUTF8_off(AvARRAY(av)[i]); + } + + if (DBIc_is(imp_sth, DBIcf_TaintOut)) { + dTHX; + dTHR; + TAINT; /* affects sv_setsv()'s called within same perl statement */ + } + + /* XXX fancy stuff to happen here later (re scrolling etc) */ + ++DBIc_ROW_COUNT(imp_sth); + return av; +} + + +static int +dbih_sth_bind_col(SV *sth, SV *col, SV *ref, SV *attribs) +{ + dTHX; + 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 */ + croak("Statement has no result columns to bind%s", + DBIc_ACTIVE(imp_sth) + ? "" : " (perhaps you need to call execute first)"); + } + + if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav) + av = dbih_setup_fbav(imp_sth); + + if (DBIc_TRACE_LEVEL(imp_sth) >= 5) + 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) + croak("bind_col: column %d is not a valid column (1..%d)", + idx, fields); + + if (!SvOK(ref) && SvREADONLY(ref)) { /* binding to literal undef */ + /* presumably the call is just setting the TYPE or other atribs */ + /* but this default method ignores attribs, so we just return */ + return 1; + } + + /* Write this as > SVt_PVMG because in 5.8.x the next type */ + /* is SVt_PVBM, whereas in 5.9.x it's SVt_PVGV. */ + if (!SvROK(ref) || SvTYPE(SvRV(ref)) > SVt_PVMG) /* XXX LV */ + croak("Can't %s->bind_col(%s, %s,...), need a reference to a scalar", + neatsvpv(sth,0), neatsvpv(col,0), neatsvpv(ref,0)); + + /* use supplied scalar as storage for this column */ + SvREADONLY_off(av); + av_store(av, idx-1, SvREFCNT_inc(SvRV(ref)) ); + SvREADONLY_on(av); + return 1; +} + + +static int +quote_type(int sql_type, int p, int s, int *t, void *v) +{ + /* Returns true if type should be bound as a number else */ + /* false implying that binding as a string should be okay. */ + /* The true value is either SQL_INTEGER or SQL_DOUBLE which */ + /* can be used as a hint if desired. */ + (void)p; + (void)s; + (void)t; + (void)v; + /* looks like it's never been used, and doesn't make much sense anyway */ + warn("Use of DBI internal bind_as_num/quote_type function is deprecated"); + switch(sql_type) { + case SQL_INTEGER: + case SQL_SMALLINT: + case SQL_TINYINT: + case SQL_BIGINT: + return 0; + case SQL_FLOAT: + case SQL_REAL: + case SQL_DOUBLE: + return 0; + case SQL_NUMERIC: + case SQL_DECIMAL: + return 0; /* bind as string to attempt to retain precision */ + } + return 1; +} + + +/* Convert a simple string representation of a value into a more specific + * perl type based on an sql_type value. + * The semantics of SQL standard TYPE values are interpreted _very_ loosely + * on the basis of "be liberal in what you accept and let's throw in some + * extra semantics while we're here" :) + * Returns: + * -2: sql_type isn't handled, value unchanged + * -1: sv is undef, value unchanged + * 0: sv couldn't be cast cleanly and DBIstcf_STRICT was used + * 1: sv couldn't be cast cleanly and DBIstcf_STRICT was not used + * 2: sv was cast ok + */ + +int +sql_type_cast_svpv(pTHX_ SV *sv, int sql_type, U32 flags, void *v) +{ + int cast_ok = 0; + int grok_flags; + UV uv; + + /* do nothing for undef (NULL) or non-string values */ + if (!sv || !SvOK(sv)) + return -1; + + switch(sql_type) { + + default: + return -2; /* not a recognised SQL TYPE, value unchanged */ + + case SQL_INTEGER: + /* sv_2iv is liberal, may return SvIV, SvUV, or SvNV */ + sv_2iv(sv); + /* SvNOK will be set if value is out of range for IV/UV. + * SvIOK should be set but won't if sv is not numeric (in which + * case perl would have warn'd already if -w or warnings are in effect) + */ + cast_ok = (SvIOK(sv) && !SvNOK(sv)); + break; + + case SQL_DOUBLE: + sv_2nv(sv); + /* SvNOK should be set but won't if sv is not numeric (in which + * case perl would have warn'd already if -w or warnings are in effect) + */ + cast_ok = SvNOK(sv); + break; + + /* caller would like IV else UV else NV */ + /* else no error and sv is untouched */ + case SQL_NUMERIC: + /* based on the code in perl's toke.c */ + uv = 0; + grok_flags = grok_number(SvPVX(sv), SvCUR(sv), &uv); + cast_ok = 1; + if (grok_flags == IS_NUMBER_IN_UV) { /* +ve int */ + if (uv <= IV_MAX) /* prefer IV over UV */ + sv_2iv(sv); + else sv_2uv(sv); + } + else if (grok_flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG) + && uv <= IV_MAX + ) { + sv_2iv(sv); + } + else if (grok_flags) { /* is numeric */ + sv_2nv(sv); + } + else + cast_ok = 0; + break; + +#if 0 /* XXX future possibilities */ + case SQL_BIGINT: /* use Math::BigInt if too large for IV/UV */ +#endif + } + + if (cast_ok) { + + if (flags & DBIstcf_DISCARD_STRING + && SvNIOK(sv) /* we set a numeric value */ + && SvPVX(sv) /* we have a buffer to discard */ + ) { + SvOOK_off(sv); + if (SvLEN(sv)) + Safefree(SvPVX(sv)); + SvPOK_off(sv); + SvPV_set(sv, NULL); + SvLEN_set(sv, 0); + SvCUR_set(sv, 0); + } + } + + if (cast_ok) + return 2; + else if (flags & DBIstcf_STRICT) + return 0; + else return 1; +} + + + +/* --- Generic Handle Attributes (for all handle types) --- */ + +static int +dbih_set_attr_k(SV *h, SV *keysv, int dbikey, SV *valuesv) +{ + dTHX; + dTHR; + D_imp_xxh(h); + STRLEN keylen; + const char *key = SvPV(keysv, keylen); + const int htype = DBIc_TYPE(imp_xxh); + int on = (SvTRUE(valuesv)); + int internal = 1; /* DBIh_IN_PERL_DBD(imp_xxh); -- for DBD's in perl */ + int cacheit = 0; + (void)dbikey; + + if (DBIc_TRACE_LEVEL(imp_xxh) >= 3) + 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")) { + if (on) { + D_imp_sth(h); + DBIc_ACTIVE_on(imp_xxh); + /* for pure-perl drivers on second and subsequent */ + /* execute()'s, else row count keeps rising. */ + if (htype==DBIt_ST && DBIc_FIELDS_AV(imp_sth)) + DBIc_ROW_COUNT(imp_sth) = 0; + } + else { + DBIc_ACTIVE_off(imp_xxh); + } + } + else if (strEQ(key, "FetchHashKeyName")) { + if (htype >= DBIt_ST) + croak("Can't set FetchHashKeyName for a statement handle, set in parent before prepare()"); + cacheit = 1; /* just save it */ + } + else if (strEQ(key, "CompatMode")) { + (on) ? DBIc_COMPAT_on(imp_xxh) : DBIc_COMPAT_off(imp_xxh); + } + else if (strEQ(key, "Warn")) { + (on) ? DBIc_WARN_on(imp_xxh) : DBIc_WARN_off(imp_xxh); + } + else if (strEQ(key, "AutoInactiveDestroy")) { + (on) ? DBIc_AIADESTROY_on(imp_xxh) : DBIc_AIADESTROY_off(imp_xxh); + } + else if (strEQ(key, "InactiveDestroy")) { + (on) ? DBIc_IADESTROY_on(imp_xxh) : DBIc_IADESTROY_off(imp_xxh); + } + else if (strEQ(key, "RootClass")) { + cacheit = 1; /* just save it */ + } + else if (strEQ(key, "RowCacheSize")) { + cacheit = 0; /* ignore it */ + } + else if (strEQ(key, "Executed")) { + DBIc_set(imp_xxh, DBIcf_Executed, on); + } + else if (strEQ(key, "ChopBlanks")) { + DBIc_set(imp_xxh, DBIcf_ChopBlanks, on); + } + else if (strEQ(key, "ErrCount")) { + DBIc_ErrCount(imp_xxh) = SvUV(valuesv); + } + else if (strEQ(key, "LongReadLen")) { + if (SvNV(valuesv) < 0 || SvNV(valuesv) > MAX_LongReadLen) + croak("Can't set LongReadLen < 0 or > %ld",MAX_LongReadLen); + DBIc_LongReadLen(imp_xxh) = SvIV(valuesv); + cacheit = 1; /* save it for clone */ + } + else if (strEQ(key, "LongTruncOk")) { + DBIc_set(imp_xxh,DBIcf_LongTruncOk, on); + } + else if (strEQ(key, "RaiseError")) { + DBIc_set(imp_xxh,DBIcf_RaiseError, on); + } + else if (strEQ(key, "PrintError")) { + DBIc_set(imp_xxh,DBIcf_PrintError, on); + } + else if (strEQ(key, "PrintWarn")) { + DBIc_set(imp_xxh,DBIcf_PrintWarn, on); + } + else if (strEQ(key, "HandleError")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) { + croak("Can't set %s to '%s'", "HandleError", neatsvpv(valuesv,0)); + } + DBIc_set(imp_xxh,DBIcf_HandleError, on); + cacheit = 1; /* child copy setup by dbih_setup_handle() */ + } + else if (strEQ(key, "HandleSetErr")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) { + croak("Can't set %s to '%s'","HandleSetErr",neatsvpv(valuesv,0)); + } + DBIc_set(imp_xxh,DBIcf_HandleSetErr, on); + cacheit = 1; /* child copy setup by dbih_setup_handle() */ + } + else if (strEQ(key, "ChildHandles")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVAV)) ) { + croak("Can't set %s to '%s'", "ChildHandles", neatsvpv(valuesv,0)); + } + cacheit = 1; /* just save it in the hash */ + } + else if (strEQ(key, "Profile")) { + static const char profile_class[] = "DBI::Profile"; + if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) { + /* not a hash ref so use DBI::Profile to work out what to do */ + dTHR; + dSP; + I32 returns; + TAINT_NOT; /* the require is presumed innocent till proven guilty */ + perl_require_pv("DBI/Profile.pm"); + if (SvTRUE(ERRSV)) { + warn("Can't load %s: %s", profile_class, SvPV_nolen(ERRSV)); + valuesv = &PL_sv_undef; + } + else { + PUSHMARK(SP); + XPUSHs(sv_2mortal(newSVpv(profile_class,0))); + XPUSHs(valuesv); + PUTBACK; + returns = call_method("_auto_new", G_SCALAR); + if (returns != 1) + croak("%s _auto_new", profile_class); + SPAGAIN; + valuesv = POPs; + PUTBACK; + } + on = SvTRUE(valuesv); /* in case it returns undef */ + } + if (on && !sv_isobject(valuesv)) { + /* not blessed already - so default to DBI::Profile */ + HV *stash; + perl_require_pv(profile_class); + stash = gv_stashpv(profile_class, GV_ADDWARN); + sv_bless(valuesv, stash); + } + DBIc_set(imp_xxh,DBIcf_Profile, on); + cacheit = 1; /* child copy setup by dbih_setup_handle() */ + } + else if (strEQ(key, "ShowErrorStatement")) { + DBIc_set(imp_xxh,DBIcf_ShowErrorStatement, on); + } + else if (strEQ(key, "MultiThread") && internal) { + /* here to allow pure-perl drivers to set MultiThread */ + DBIc_set(imp_xxh,DBIcf_MultiThread, on); + if (on && DBIc_WARN(imp_xxh)) { + warn("MultiThread support not yet implemented in DBI"); + } + } + else if (strEQ(key, "Taint")) { + /* 'Taint' is a shortcut for both in and out mode */ + DBIc_set(imp_xxh,DBIcf_TaintIn|DBIcf_TaintOut, on); + } + else if (strEQ(key, "TaintIn")) { + DBIc_set(imp_xxh,DBIcf_TaintIn, on); + } + else if (strEQ(key, "TaintOut")) { + DBIc_set(imp_xxh,DBIcf_TaintOut, on); + } + else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids") + /* only allow hash refs */ + && SvROK(valuesv) && SvTYPE(SvRV(valuesv))==SVt_PVHV + ) { + cacheit = 1; + } + else if (keylen==9 && strEQ(key, "Callbacks")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) + croak("Can't set Callbacks to '%s'",neatsvpv(valuesv,0)); + /* see also dbih_setup_handle for ChildCallbacks handling */ + DBIc_set(imp_xxh, DBIcf_Callbacks, on); + cacheit = 1; + } + else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "AutoCommit")) { + /* driver should have intercepted this and either handled it */ + /* or set valuesv to either the 'magic' on or off value. */ + if (SvIV(valuesv) != -900 && SvIV(valuesv) != -901) + croak("DBD driver has not implemented the AutoCommit attribute"); + DBIc_set(imp_xxh,DBIcf_AutoCommit, (SvIV(valuesv)==-901)); + } + else if (htype==DBIt_DB && keylen==9 && strEQ(key, "BegunWork")) { + DBIc_set(imp_xxh,DBIcf_BegunWork, on); + } + else if (keylen==10 && strEQ(key, "TraceLevel")) { + set_trace(h, valuesv, Nullsv); + } + else if (keylen==9 && strEQ(key, "TraceFile")) { /* XXX undocumented and readonly */ + set_trace_file(valuesv); + } + else if (htype==DBIt_ST && strEQ(key, "NUM_OF_FIELDS")) { + D_imp_sth(h); + int new_num_fields = (SvOK(valuesv)) ? SvIV(valuesv) : -1; + DBIc_NUM_FIELDS(imp_sth) = new_num_fields; + if (DBIc_FIELDS_AV(imp_sth)) { /* modify existing fbav */ + dbih_setup_fbav(imp_sth); + } + cacheit = 1; + } + else if (htype==DBIt_ST && strEQ(key, "NUM_OF_PARAMS")) { + D_imp_sth(h); + DBIc_NUM_PARAMS(imp_sth) = SvIV(valuesv); + cacheit = 1; + } + /* these are here due to clone() needing to set attribs through a public api */ + else if (htype<=DBIt_DB && (strEQ(key, "Name") + || strEQ(key,"ImplementorClass") + || strEQ(key,"ReadOnly") + || strEQ(key,"Statement") + || strEQ(key,"Username") + /* these are here for backwards histerical raisons */ + || strEQ(key,"USER") || strEQ(key,"CURRENT_USER") + ) ) { + cacheit = 1; + } + else { /* XXX should really be an event ? */ + if (isUPPER(*key)) { + char *msg = "Can't set %s->{%s}: unrecognised attribute name or invalid value%s"; + char *hint = ""; + if (strEQ(key, "NUM_FIELDS")) + hint = ", perhaps you meant NUM_OF_FIELDS"; + warn(msg, neatsvpv(h,0), key, hint); + return FALSE; /* don't store it */ + } + /* Allow private_* attributes to be stored in the cache. */ + /* This is designed to make life easier for people subclassing */ + /* 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(DBIc_LOGPIO(imp_xxh),"$h->{%s}=%s ignored for invalid driver-specific attribute\n", + neatsvpv(keysv,0), neatsvpv(valuesv,0)); + } + return FALSE; + } + cacheit = 1; + } + if (cacheit) { + (void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0); + } + return TRUE; +} + + +static SV * +dbih_get_attr_k(SV *h, SV *keysv, int dbikey) +{ + dTHX; + dTHR; + D_imp_xxh(h); + STRLEN keylen; + char *key = SvPV(keysv, keylen); + int htype = DBIc_TYPE(imp_xxh); + SV *valuesv = Nullsv; + int cacheit = FALSE; + char *p; + int i; + SV *sv; + SV **svp; + (void)dbikey; + + /* DBI quick_FETCH will service some requests (e.g., cached values) */ + + if (htype == DBIt_ST) { + switch (*key) { + + case 'D': + if (keylen==8 && strEQ(key, "Database")) { + D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh); + valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh)); + cacheit = FALSE; /* else creates ref loop */ + } + break; + + case 'N': + if (keylen==8 && strEQ(key, "NULLABLE")) { + valuesv = &PL_sv_undef; + break; + } + + if (keylen==4 && strEQ(key, "NAME")) { + valuesv = &PL_sv_undef; + break; + } + + /* deal with: NAME_(uc|lc), NAME_hash, NAME_(uc|lc)_hash */ + if ((keylen==7 || keylen==9 || keylen==12) + && strnEQ(key, "NAME_", 5) + && ( (keylen==9 && strEQ(key, "NAME_hash")) + || ((key[5]=='u' || key[5]=='l') && key[6] == 'c' + && (!key[7] || strnEQ(&key[7], "_hash", 5))) + ) + ) { + D_imp_sth(h); + valuesv = &PL_sv_undef; + + /* fetch from tied outer handle to trigger FETCH magic */ + svp = hv_fetch((HV*)DBIc_MY_H(imp_sth), "NAME",4, FALSE); + sv = (svp) ? *svp : &PL_sv_undef; + if (SvGMAGICAL(sv)) /* call FETCH via magic */ + mg_get(sv); + + if (SvROK(sv)) { + AV *name_av = (AV*)SvRV(sv); + char *name; + int upcase = (key[5] == 'u'); + AV *av = Nullav; + HV *hv = Nullhv; + int num_fields_mismatch = 0; + + if (strEQ(&key[strlen(key)-5], "_hash")) + hv = newHV(); + else av = newAV(); + i = DBIc_NUM_FIELDS(imp_sth); + + /* catch invalid NUM_FIELDS */ + if (i != AvFILL(name_av)+1) { + /* flag as mismatch, except for "-1 and empty" case */ + if ( ! (i == -1 && 0 == AvFILL(name_av)+1) ) + num_fields_mismatch = 1; + i = AvFILL(name_av)+1; /* limit for safe iteration over array */ + } + + if (DBIc_TRACE_LEVEL(imp_sth) >= 10 || (num_fields_mismatch && DBIc_WARN(imp_xxh))) { + 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)" : ""); + } + + while (--i >= 0) { + sv = newSVsv(AvARRAY(name_av)[i]); + name = SvPV_nolen(sv); + if (key[5] != 'h') { /* "NAME_hash" */ + for (p = name; p && *p; ++p) { +#ifdef toUPPER_LC + *p = (upcase) ? toUPPER_LC(*p) : toLOWER_LC(*p); +#else + *p = (upcase) ? toUPPER(*p) : toLOWER(*p); +#endif + } + } + if (av) + av_store(av, i, sv); + else { + (void)hv_store(hv, name, SvCUR(sv), newSViv(i), 0); + sv_free(sv); + } + } + valuesv = newRV_noinc( (av ? (SV*)av : (SV*)hv) ); + cacheit = TRUE; /* can't change */ + } + } + else if (keylen==13 && strEQ(key, "NUM_OF_FIELDS")) { + D_imp_sth(h); + IV num_fields = DBIc_NUM_FIELDS(imp_sth); + valuesv = (num_fields < 0) ? &PL_sv_undef : newSViv(num_fields); + if (num_fields > 0) + cacheit = TRUE; /* can't change once set (XXX except for multiple result sets) */ + } + else if (keylen==13 && strEQ(key, "NUM_OF_PARAMS")) { + D_imp_sth(h); + valuesv = newSViv(DBIc_NUM_PARAMS(imp_sth)); + cacheit = TRUE; /* can't change */ + } + break; + + case 'P': + if (strEQ(key, "PRECISION")) + valuesv = &PL_sv_undef; + else if (strEQ(key, "ParamValues")) + valuesv = &PL_sv_undef; + else if (strEQ(key, "ParamTypes")) + valuesv = &PL_sv_undef; + break; + + case 'R': + if (strEQ(key, "RowsInCache")) + valuesv = &PL_sv_undef; + break; + + case 'S': + if (strEQ(key, "SCALE")) + valuesv = &PL_sv_undef; + break; + + case 'T': + if (strEQ(key, "TYPE")) + valuesv = &PL_sv_undef; + break; + } + + } + else + if (htype == DBIt_DB) { + /* this is here but is, sadly, not called because + * not-preloading them into the handle attrib cache caused + * wierdness in t/proxy.t that I never got to the bottom + * of. One day maybe. */ + if (keylen==6 && strEQ(key, "Driver")) { + D_imp_from_child(imp_dbh, imp_dbh_t, imp_xxh); + valuesv = newRV_inc((SV*)DBIc_MY_H(imp_dbh)); + cacheit = FALSE; /* else creates ref loop */ + } + } + + if (valuesv == Nullsv && htype <= DBIt_DB) { + if (keylen==10 && strEQ(key, "AutoCommit")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit)); + } + } + + if (valuesv == Nullsv) { + switch (*key) { + case 'A': + if (keylen==6 && strEQ(key, "Active")) { + valuesv = boolSV(DBIc_ACTIVE(imp_xxh)); + } + else if (keylen==10 && strEQ(key, "ActiveKids")) { + valuesv = newSViv(DBIc_ACTIVE_KIDS(imp_xxh)); + } + else if (strEQ(key, "AutoInactiveDestroy")) { + valuesv = boolSV(DBIc_AIADESTROY(imp_xxh)); + } + break; + + case 'B': + if (keylen==9 && strEQ(key, "BegunWork")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_BegunWork)); + } + break; + + case 'C': + if (strEQ(key, "ChildHandles")) { + svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE); + /* if something has been stored then return it. + * otherwise return a dummy empty array if weakrefs are + * available, else an undef to indicate that they're not */ + if (svp) { + valuesv = newSVsv(*svp); + } else { +#ifdef sv_rvweaken + valuesv = newRV_noinc((SV*)newAV()); +#else + valuesv = &PL_sv_undef; +#endif + } + } + else if (strEQ(key, "ChopBlanks")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ChopBlanks)); + } + else if (strEQ(key, "CachedKids")) { + valuesv = &PL_sv_undef; + } + else if (strEQ(key, "CompatMode")) { + valuesv = boolSV(DBIc_COMPAT(imp_xxh)); + } + break; + + case 'E': + if (strEQ(key, "Executed")) { + valuesv = boolSV(DBIc_is(imp_xxh, DBIcf_Executed)); + } + else if (strEQ(key, "ErrCount")) { + valuesv = newSVuv(DBIc_ErrCount(imp_xxh)); + } + break; + + case 'I': + if (strEQ(key, "InactiveDestroy")) { + valuesv = boolSV(DBIc_IADESTROY(imp_xxh)); + } + break; + + case 'K': + if (keylen==4 && strEQ(key, "Kids")) { + valuesv = newSViv(DBIc_KIDS(imp_xxh)); + } + break; + + case 'L': + if (keylen==11 && strEQ(key, "LongReadLen")) { + valuesv = newSVnv((NV)DBIc_LongReadLen(imp_xxh)); + } + else if (keylen==11 && strEQ(key, "LongTruncOk")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_LongTruncOk)); + } + break; + + case 'M': + if (keylen==10 && strEQ(key, "MultiThread")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_MultiThread)); + } + break; + + case 'P': + if (keylen==10 && strEQ(key, "PrintError")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintError)); + } + else if (keylen==9 && strEQ(key, "PrintWarn")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintWarn)); + } + break; + + case 'R': + if (keylen==10 && strEQ(key, "RaiseError")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_RaiseError)); + } + else if (keylen==12 && strEQ(key, "RowCacheSize")) { + valuesv = &PL_sv_undef; + } + break; + + case 'S': + if (keylen==18 && strEQ(key, "ShowErrorStatement")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ShowErrorStatement)); + } + break; + + case 'T': + if (keylen==4 && strEQ(key, "Type")) { + char *type = dbih_htype_name(htype); + valuesv = newSVpv(type,0); + cacheit = TRUE; /* can't change */ + } + else if (keylen==10 && strEQ(key, "TraceLevel")) { + valuesv = newSViv( DBIc_DEBUGIV(imp_xxh) ); + } + else if (keylen==5 && strEQ(key, "Taint")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn) && + DBIc_has(imp_xxh,DBIcf_TaintOut)); + } + else if (keylen==7 && strEQ(key, "TaintIn")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn)); + } + else if (keylen==8 && strEQ(key, "TaintOut")) { + valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintOut)); + } + break; + + case 'W': + if (keylen==4 && strEQ(key, "Warn")) { + valuesv = boolSV(DBIc_WARN(imp_xxh)); + } + break; + } + } + + /* finally check the actual hash */ + if (valuesv == Nullsv) { + valuesv = &PL_sv_undef; + cacheit = 0; + svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE); + if (svp) + valuesv = newSVsv(*svp); /* take copy to mortalize */ + else /* warn unless it's known attribute name */ + if ( !( (*key=='H' && strEQ(key, "HandleError")) + || (*key=='H' && strEQ(key, "HandleSetErr")) + || (*key=='S' && strEQ(key, "Statement")) + || (*key=='P' && strEQ(key, "ParamArrays")) + || (*key=='P' && strEQ(key, "ParamValues")) + || (*key=='P' && strEQ(key, "Profile")) + || (*key=='R' && strEQ(key, "ReadOnly")) + || (*key=='C' && strEQ(key, "CursorName")) + || (*key=='C' && strEQ(key, "Callbacks")) + || (*key=='U' && strEQ(key, "Username")) + || !isUPPER(*key) /* dbd_*, private_* etc */ + )) + warn("Can't get %s->{%s}: unrecognised attribute name",neatsvpv(h,0),key); + } + + if (cacheit) { + (void)hv_store((HV*)SvRV(h), key, keylen, newSVsv(valuesv), 0); + } + if (DBIc_TRACE_LEVEL(imp_xxh) >= 3) + 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 */ + return sv_2mortal(valuesv); +} + + + +/* -------------------------------------------------------------------- */ +/* Functions implementing Error and Event Handling. */ + + +static SV * +dbih_event(SV *hrv, const char *evtype, SV *a1, SV *a2) +{ + dTHX; + /* We arrive here via DBIh_EVENT* macros (see DBIXS.h) called from */ + /* DBD driver C code OR $h->event() method (in DBD::_::common) */ + /* XXX VERY OLD INTERFACE/CONCEPT MAY GO SOON */ + /* OR MAY EVOLVE INTO A WAY TO HANDLE 'SUCCESS_WITH_INFO'/'WARNINGS' from db */ + (void)hrv; + (void)evtype; + (void)a1; + (void)a2; + return &PL_sv_undef; +} + + +/* ----------------------------------------------------------------- */ + + +STATIC I32 +dbi_dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock) +{ + dTHX; + I32 i; + register PERL_CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + case CXt_SUB: +#ifdef CXt_FORMAT + case CXt_FORMAT: +#endif + DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); + return i; + } + } + return i; +} + + +static COP * +dbi_caller_cop() +{ + dTHX; + register I32 cxix; + register PERL_CONTEXT *cx; + register PERL_CONTEXT *ccstack = cxstack; + PERL_SI *top_si = PL_curstackinfo; + char *stashname; + + for ( cxix = dbi_dopoptosub_at(ccstack, cxstack_ix) ;; cxix = dbi_dopoptosub_at(ccstack, cxix - 1)) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = dbi_dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) { + break; + } + if (PL_DBsub && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + continue; + cx = &ccstack[cxix]; + stashname = CopSTASHPV(cx->blk_oldcop); + if (!stashname) + continue; + if (!(stashname[0] == 'D' && stashname[1] == 'B' + && strchr("DI", stashname[2]) + && (!stashname[3] || (stashname[3] == ':' && stashname[4] == ':')))) + { + return cx->blk_oldcop; + } + cxix = dbi_dopoptosub_at(ccstack, cxix - 1); + } + return NULL; +} + +static void +dbi_caller_string(SV *buf, COP *cop, char *prefix, int show_line, int show_path) +{ + dTHX; + STRLEN len; + long line = CopLINE(cop); + char *file = SvPV(GvSV(CopFILEGV(cop)), len); + if (!show_path) { + char *sep; + if ( (sep=strrchr(file,'/')) || (sep=strrchr(file,'\\'))) + file = sep+1; + } + if (show_line) { + sv_catpvf(buf, "%s%s line %ld", (prefix) ? prefix : "", file, line); + } + else { + sv_catpvf(buf, "%s%s", (prefix) ? prefix : "", file); + } +} + +static char * +log_where(SV *buf, int append, char *prefix, char *suffix, int show_line, int show_caller, int show_path) +{ + dTHX; + dTHR; + if (!buf) + buf = sv_2mortal(newSVpv("",0)); + else if (!append) + sv_setpv(buf,""); + if (CopLINE(PL_curcop)) { + COP *cop; + dbi_caller_string(buf, PL_curcop, prefix, show_line, show_path); + if (show_caller && (cop = dbi_caller_cop())) { + SV *via = sv_2mortal(newSVpv("",0)); + dbi_caller_string(via, cop, prefix, show_line, show_path); + sv_catpvf(buf, " via %s", SvPV_nolen(via)); + } + } + if (PL_dirty) + sv_catpvf(buf, " during global destruction"); + if (suffix) + sv_catpv(buf, suffix); + return SvPVX(buf); +} + + +static void +clear_cached_kids(pTHX_ SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int trace_level) +{ + if (DBIc_TYPE(imp_xxh) <= DBIt_DB) { + SV **svp = hv_fetch((HV*)SvRV(h), "CachedKids", 10, 0); + if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(*svp); + if (HvKEYS(hv)) { + if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level) + trace_level = DBIc_TRACE_LEVEL(imp_xxh); + if (trace_level >= 2) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh)," >> %s %s clearing %d CachedKids\n", + meth_name, neatsvpv(h,0), (int)HvKEYS(hv)); + 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 */ + hv_clear(hv); + } + } + } +} + + +static NV +dbi_time() { +# ifdef HAS_GETTIMEOFDAY +# ifdef PERL_IMPLICIT_SYS + dTHX; +# endif + struct timeval when; + gettimeofday(&when, (struct timezone *) 0); + return when.tv_sec + (when.tv_usec / 1000000.0); +# else /* per-second is almost useless */ +# ifdef _WIN32 /* use _ftime() on Win32 (MS Visual C++ 6.0) */ +# if defined(__BORLANDC__) +# define _timeb timeb +# define _ftime ftime +# endif + struct _timeb when; + _ftime( &when ); + return when.time + (when.millitm / 1000.0); +# else + return time(NULL); +# endif +# endif +} + + +static SV * +_profile_next_node(SV *node, const char *name) +{ + /* step one level down profile Data tree and auto-vivify if required */ + dTHX; + SV *orig_node = node; + if (SvROK(node)) + node = SvRV(node); + if (SvTYPE(node) != SVt_PVHV) { + HV *hv = newHV(); + if (SvOK(node)) { + char *key = "(demoted)"; + warn("Profile data element %s replaced with new hash ref (for %s) and original value stored with key '%s'", + neatsvpv(orig_node,0), name, key); + (void)hv_store(hv, key, strlen(key), SvREFCNT_inc(orig_node), 0); + } + sv_setsv(node, newRV_noinc((SV*)hv)); + node = (SV*)hv; + } + node = *hv_fetch((HV*)node, name, strlen(name), 1); + return node; +} + + +static SV* +dbi_profile(SV *h, imp_xxh_t *imp_xxh, SV *statement_sv, SV *method, NV t1, NV t2) +{ +#define DBIprof_MAX_PATH_ELEM 100 +#define DBIprof_COUNT 0 +#define DBIprof_TOTAL_TIME 1 +#define DBIprof_FIRST_TIME 2 +#define DBIprof_MIN_TIME 3 +#define DBIprof_MAX_TIME 4 +#define DBIprof_FIRST_CALLED 5 +#define DBIprof_LAST_CALLED 6 +#define DBIprof_max_index 6 + dTHX; + NV ti = t2 - t1; + int src_idx = 0; + HV *dbh_outer_hv = NULL; + HV *dbh_inner_hv = NULL; + char *statement_pv; + char *method_pv; + SV *profile; + SV *tmp; + SV *dest_node; + AV *av; + HV *h_hv; + + const int call_depth = DBIc_CALL_DEPTH(imp_xxh); + const int parent_call_depth = DBIc_PARENT_COM(imp_xxh) ? DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) : 0; + /* Only count calls originating from the application code */ + if (call_depth > 1 || parent_call_depth > 0) + return &PL_sv_undef; + + if (!DBIc_has(imp_xxh, DBIcf_Profile)) + return &PL_sv_undef; + + method_pv = (SvTYPE(method)==SVt_PVCV) ? GvNAME(CvGV(method)) + : isGV(method) ? GvNAME(method) + : SvOK(method) ? SvPV_nolen(method) + : ""; + + /* we don't profile DESTROY during global destruction */ + if (PL_dirty && instr(method_pv, "DESTROY")) + return &PL_sv_undef; + + h_hv = (HV*)SvRV(dbih_inner(aTHX_ h, "dbi_profile")); + + profile = *hv_fetch(h_hv, "Profile", 7, 1); + if (profile && SvMAGICAL(profile)) + mg_get(profile); /* FETCH */ + if (!profile || !SvROK(profile)) { + DBIc_set(imp_xxh, DBIcf_Profile, 0); /* disable */ + if (SvOK(profile) && !PL_dirty) + warn("Profile attribute isn't a hash ref (%s,%ld)", neatsvpv(profile,0), (long)SvTYPE(profile)); + return &PL_sv_undef; + } + + /* statement_sv: undef = use $h->{Statement}, "" (&sv_no) = use empty string */ + + if (!SvOK(statement_sv)) { + SV **psv = hv_fetch(h_hv, "Statement", 9, 0); + statement_sv = (psv && SvOK(*psv)) ? *psv : &PL_sv_no; + } + statement_pv = SvPV_nolen(statement_sv); + + if (DBIc_TRACE_LEVEL(imp_xxh) >= 4) + PerlIO_printf(DBIc_LOGPIO(imp_xxh), " dbi_profile +%" NVff "s %s %s\n", + ti, method_pv, neatsvpv(statement_sv,0)); + + dest_node = _profile_next_node(profile, "Data"); + + tmp = *hv_fetch((HV*)SvRV(profile), "Path", 4, 1); + if (SvROK(tmp) && SvTYPE(SvRV(tmp))==SVt_PVAV) { + int len; + av = (AV*)SvRV(tmp); + len = av_len(av); /* -1=empty, 0=one element */ + + while ( src_idx <= len ) { + SV *pathsv = AvARRAY(av)[src_idx++]; + + if (SvROK(pathsv) && SvTYPE(SvRV(pathsv))==SVt_PVCV) { + /* call sub, use returned list of values as path */ + /* returning a ref to undef vetos this profile data */ + dSP; + I32 ax; + SV *code_sv = SvRV(pathsv); + I32 items; + I32 item_idx; + EXTEND(SP, 4); + PUSHMARK(SP); + PUSHs(h); /* push inner handle, then others params */ + PUSHs( sv_2mortal(newSVpv(method_pv,0))); + PUTBACK; + SAVE_DEFSV; /* local($_) = $statement */ + DEFSV = statement_sv; + items = call_sv(code_sv, G_ARRAY); + SPAGAIN; + SP -= items ; + ax = (SP - PL_stack_base) + 1 ; + for (item_idx=0; item_idx < items; ++item_idx) { + SV *item_sv = ST(item_idx); + if (SvROK(item_sv)) { + if (!SvOK(SvRV(item_sv))) + items = -2; /* flag that we're rejecting this profile data */ + else /* other refs reserved */ + warn("Ignored ref returned by code ref in Profile Path"); + break; + } + dest_node = _profile_next_node(dest_node, SvPV_nolen(item_sv)); + } + PUTBACK; + if (items == -2) /* this profile data was vetoed */ + return &PL_sv_undef; + } + else if (SvROK(pathsv)) { + /* only meant for refs to scalars currently */ + const char *p = SvPV_nolen(SvRV(pathsv)); + dest_node = _profile_next_node(dest_node, p); + } + else if (SvOK(pathsv)) { + STRLEN len; + const char *p = SvPV(pathsv,len); + if (p[0] == '!') { /* special cases */ + if (p[1] == 'S' && strEQ(p, "!Statement")) { + dest_node = _profile_next_node(dest_node, statement_pv); + } + else if (p[1] == 'M' && strEQ(p, "!MethodName")) { + dest_node = _profile_next_node(dest_node, method_pv); + } + else if (p[1] == 'M' && strEQ(p, "!MethodClass")) { + if (SvTYPE(method) == SVt_PVCV) { + p = SvPV_nolen((SV*)CvGV(method)); + } + else if (isGV(method)) { + /* just using SvPV_nolen(method) sometimes causes an error: */ + /* "Can't coerce GLOB to string" so we use gv_efullname() */ + SV *tmpsv = sv_2mortal(newSVpv("",0)); +#if (PERL_VERSION < 6) + gv_efullname(tmpsv, (GV*)method); +#else + gv_efullname4(tmpsv, (GV*)method, "", TRUE); +#endif + p = SvPV_nolen(tmpsv); + if (*p == '*') ++p; /* skip past leading '*' glob sigil */ + } + else { + p = method_pv; + } + dest_node = _profile_next_node(dest_node, p); + } + else if (p[1] == 'F' && strEQ(p, "!File")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 0, 0)); + } + else if (p[1] == 'F' && strEQ(p, "!File2")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 0, 1, 0)); + } + else if (p[1] == 'C' && strEQ(p, "!Caller")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 0, 0)); + } + else if (p[1] == 'C' && strEQ(p, "!Caller2")) { + dest_node = _profile_next_node(dest_node, log_where(0, 0, "", "", 1, 1, 0)); + } + else if (p[1] == 'T' && (strEQ(p, "!Time") || strnEQ(p, "!Time~", 6))) { + char timebuf[20]; + int factor = 1; + if (p[5] == '~') { + factor = atoi(&p[6]); + if (factor == 0) /* sanity check to avoid div by zero error */ + factor = 3600; + } + sprintf(timebuf, "%ld", ((long)(dbi_time()/factor))*factor); + dest_node = _profile_next_node(dest_node, timebuf); + } + else { + warn("Unknown ! element in DBI::Profile Path: %s", p); + dest_node = _profile_next_node(dest_node, p); + } + } + else if (p[0] == '{' && p[len-1] == '}') { /* treat as name of dbh attribute to use */ + SV **attr_svp; + if (!dbh_inner_hv) { /* cache dbh handles the first time we need them */ + imp_dbh_t *imp_dbh = (DBIc_TYPE(imp_xxh) <= DBIt_DB) ? (imp_dbh_t*)imp_xxh : (imp_dbh_t*)DBIc_PARENT_COM(imp_xxh); + dbh_outer_hv = DBIc_MY_H(imp_dbh); + if (SvTYPE(dbh_outer_hv) != SVt_PVHV) + return &PL_sv_undef; /* presumably global destruction - bail */ + dbh_inner_hv = (HV*)SvRV(dbih_inner(aTHX_ (SV*)dbh_outer_hv, "profile")); + if (SvTYPE(dbh_inner_hv) != SVt_PVHV) + return &PL_sv_undef; /* presumably global destruction - bail */ + } + /* fetch from inner first, then outer if key doesn't exist */ + /* (yes, this is an evil premature optimization) */ + p += 1; len -= 2; /* ignore the braces */ + if ((attr_svp = hv_fetch(dbh_inner_hv, p, len, 0)) == NULL) { + /* try outer (tied) hash - for things like AutoCommit */ + /* (will always return something even for unknowns) */ + if ((attr_svp = hv_fetch(dbh_outer_hv, p, len, 0))) { + if (SvGMAGICAL(*attr_svp)) + mg_get(*attr_svp); /* FETCH */ + } + } + if (!attr_svp) + p -= 1; /* unignore the braces */ + else if (!SvOK(*attr_svp)) + p = ""; + else if (!SvTRUE(*attr_svp) && SvPOK(*attr_svp) && SvNIOK(*attr_svp)) + p = "0"; /* catch &sv_no style special case */ + else + p = SvPV_nolen(*attr_svp); + dest_node = _profile_next_node(dest_node, p); + } + else { + dest_node = _profile_next_node(dest_node, p); + } + } + /* else undef, so ignore */ + } + } + else { /* a bad Path value is treated as a Path of just Statement */ + dest_node = _profile_next_node(dest_node, statement_pv); + } + + + if (!SvOK(dest_node)) { + av = newAV(); + sv_setsv(dest_node, newRV_noinc((SV*)av)); + av_store(av, DBIprof_COUNT, newSViv(1)); + av_store(av, DBIprof_TOTAL_TIME, newSVnv(ti)); + av_store(av, DBIprof_FIRST_TIME, newSVnv(ti)); + av_store(av, DBIprof_MIN_TIME, newSVnv(ti)); + av_store(av, DBIprof_MAX_TIME, newSVnv(ti)); + av_store(av, DBIprof_FIRST_CALLED, newSVnv(t1)); + av_store(av, DBIprof_LAST_CALLED, newSVnv(t1)); + } + else { + tmp = dest_node; + if (SvROK(tmp)) + tmp = SvRV(tmp); + if (SvTYPE(tmp) != SVt_PVAV) + croak("Invalid Profile data leaf element: %s (type %ld)", + neatsvpv(tmp,0), (long)SvTYPE(tmp)); + av = (AV*)tmp; + sv_inc( *av_fetch(av, DBIprof_COUNT, 1)); + tmp = *av_fetch(av, DBIprof_TOTAL_TIME, 1); + sv_setnv(tmp, SvNV(tmp) + ti); + tmp = *av_fetch(av, DBIprof_MIN_TIME, 1); + if (ti < SvNV(tmp)) sv_setnv(tmp, ti); + tmp = *av_fetch(av, DBIprof_MAX_TIME, 1); + if (ti > SvNV(tmp)) sv_setnv(tmp, ti); + sv_setnv( *av_fetch(av, DBIprof_LAST_CALLED, 1), t1); + } + return dest_node; /* use with caution - copy first, ie sv_mortalcopy() */ +} + + +static void +dbi_profile_merge_nodes(SV *dest, SV *increment) +{ + dTHX; + AV *d_av, *i_av; + SV *tmp; + SV *tmp2; + NV i_nv; + int i_is_earlier; + + if (!SvROK(dest) || SvTYPE(SvRV(dest)) != SVt_PVAV) + croak("dbi_profile_merge_nodes(%s, ...) requires array ref", neatsvpv(dest,0)); + d_av = (AV*)SvRV(dest); + + if (av_len(d_av) < DBIprof_max_index) { + int idx; + av_extend(d_av, DBIprof_max_index); + for(idx=0; idx<=DBIprof_max_index; ++idx) { + tmp = *av_fetch(d_av, idx, 1); + if (!SvOK(tmp) && idx != DBIprof_MIN_TIME && idx != DBIprof_FIRST_CALLED) + sv_setnv(tmp, 0.0); /* leave 'min' values as undef */ + } + } + + if (!SvOK(increment)) + return; + + if (SvROK(increment) && SvTYPE(SvRV(increment)) == SVt_PVHV) { + HV *hv = (HV*)SvRV(increment); + char *key; + I32 keylen = 0; + hv_iterinit(hv); + while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) { + dbi_profile_merge_nodes(dest, tmp); + }; + return; + } + + if (!SvROK(increment) || SvTYPE(SvRV(increment)) != SVt_PVAV) + croak("dbi_profile_merge_nodes: increment %s not an array or hash ref", neatsvpv(increment,0)); + i_av = (AV*)SvRV(increment); + + tmp = *av_fetch(d_av, DBIprof_COUNT, 1); + tmp2 = *av_fetch(i_av, DBIprof_COUNT, 1); + if (SvIOK(tmp) && SvIOK(tmp2)) + sv_setiv( tmp, SvIV(tmp) + SvIV(tmp2) ); + else + sv_setnv( tmp, SvNV(tmp) + SvNV(tmp2) ); + + tmp = *av_fetch(d_av, DBIprof_TOTAL_TIME, 1); + sv_setnv( tmp, SvNV(tmp) + SvNV( *av_fetch(i_av, DBIprof_TOTAL_TIME, 1)) ); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_MIN_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_MIN_TIME, 1); + if (!SvOK(tmp) || i_nv < SvNV(tmp)) sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_MAX_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_MAX_TIME, 1); + if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_CALLED, 1)); + tmp = *av_fetch(d_av, DBIprof_FIRST_CALLED, 1); + i_is_earlier = (!SvOK(tmp) || i_nv < SvNV(tmp)); + if (i_is_earlier) + sv_setnv(tmp, i_nv); + + i_nv = SvNV(*av_fetch(i_av, DBIprof_FIRST_TIME, 1)); + tmp = *av_fetch(d_av, DBIprof_FIRST_TIME, 1); + if (i_is_earlier || !SvOK(tmp)) { + /* If the increment has an earlier DBIprof_FIRST_CALLED + then we set the DBIprof_FIRST_TIME from the increment */ + sv_setnv(tmp, i_nv); + } + + i_nv = SvNV(*av_fetch(i_av, DBIprof_LAST_CALLED, 1)); + tmp = *av_fetch(d_av, DBIprof_LAST_CALLED, 1); + if (i_nv > SvNV(tmp)) sv_setnv(tmp, i_nv); +} + + +/* ----------------------------------------------------------------- */ +/* --- The DBI dispatcher. The heart of the perl DBI. --- */ + +XS(XS_DBI_dispatch); /* prototype to pass -Wmissing-prototypes */ +XS(XS_DBI_dispatch) +{ + dXSARGS; + dMY_CXT; + + SV *h = ST(0); /* the DBI handle we are working with */ + SV *st1 = ST(1); /* used in debugging */ + SV *st2 = ST(2); /* used in debugging */ + SV *orig_h = h; + SV *err_sv; + SV **tmp_svp; + SV **hook_svp = 0; + MAGIC *mg; + int gimme = GIMME; + I32 trace_flags = DBIS->debug; /* local copy may change during dispatch */ + I32 trace_level = (trace_flags & DBIc_TRACE_LEVEL_MASK); + int is_DESTROY; + meth_types meth_type; + int is_unrelated_to_Statement = 0; + int keep_error = FALSE; + UV ErrCount = UV_MAX; + int i, outitems; + 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)); + 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)", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0), + (long)SvREFCNT(h), (SvROK(h) ? (long)SvREFCNT(SvRV(h)) : (long)-1), + (long)items, (int)gimme, (long)ima_flags, (long)PerlProc_getpid()); + PerlIO_puts(logfp, log_where(0, 0, " at ","\n", 1, (trace_level >= 3), (trace_level >= 4))); + PerlIO_flush(logfp); + } + + if ( ( (is_DESTROY=(meth_type == methtype_DESTROY))) ) { + /* note that croak()'s won't propagate, only append to $@ */ + keep_error = TRUE; + } + + /* If h is a tied hash ref, switch to the inner ref 'behind' the tie. + This means *all* DBI methods work with the inner (non-tied) ref. + This makes it much easier for methods to access the real hash + 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=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, + "%c <> %s for %s ignored (inner handle gone)\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0)); + XSRETURN(0); + } + /* Distinguish DESTROY of tie (outer) from DESTROY of inner ref */ + /* This may one day be used to manually destroy extra internal */ + /* refs if the application ceases to use the handle. */ + if (is_DESTROY) { + imp_xxh = DBIh_COM(mg->mg_obj); +#ifdef DBI_USE_THREADS + if (imp_xxh && DBIc_THR_USER(imp_xxh) != my_perl) { + goto is_DESTROY_wrong_thread; + } +#endif + if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB) + clear_cached_kids(aTHX_ mg->mg_obj, imp_xxh, meth_name, trace_level); + /* XXX might be better to move this down to after call_depth has been + * incremented and then also SvREFCNT_dec(mg->mg_obj) to force an immediate + * DESTROY of the inner handle if there are no other refs to it. + * That way the inner DESTROY is properly flagged as a nested call, + * and the outer DESTROY gets profiled more accurately, and callbacks work. + */ + if (trace_level >= 3) { + PerlIO_printf(DBILOGFP, + "%c <> DESTROY(%s) ignored for outer handle (inner %s has ref cnt %ld)\n", + (PL_dirty?'!':' '), neatsvpv(h,0), neatsvpv(mg->mg_obj,0), + (long)SvREFCNT(SvRV(mg->mg_obj)) + ); + } + /* for now we ignore it since it'll be followed soon by */ + /* a destroy of the inner hash and that'll do the real work */ + + /* However, we must at least modify DBIc_MY_H() as that is */ + /* pointing (without a refcnt inc) to the scalar that is */ + /* being destroyed, so it'll contain random values later. */ + if (imp_xxh) + DBIc_MY_H(imp_xxh) = (HV*)SvRV(mg->mg_obj); /* inner (untied) HV */ + + XSRETURN(0); + } + h = mg->mg_obj; /* switch h to inner ref */ + ST(0) = h; /* switch handle on stack to inner ref */ + } + + imp_xxh = dbih_getcom2(aTHX_ h, 0); /* get common Internal Handle Attributes */ + if (!imp_xxh) { + 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); + if (gv && isGV(gv)) + rv = sv_2mortal(newRV_inc((SV*)GvCV(gv))); + if (trace_level >= 1) { + PerlIO_printf(DBILOGFP," <- %s(%s) = %p\n", meth_name, can_meth, neatsvpv(rv,0)); + } + ST(0) = rv; + XSRETURN(1); + } + if (trace_level) + PerlIO_printf(DBILOGFP, "%c <> %s for %s ignored (no imp_data)\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(h,0)); + if (!is_DESTROY) + warn("Can't call %s method on handle %s%s", meth_name, neatsvpv(h,0), + SvROK(h) ? " after take_imp_data()" : " (not a reference)"); + XSRETURN(0); + } + + if (DBIc_has(imp_xxh,DBIcf_Profile)) { + profile_t1 = dbi_time(); /* just get start time here */ + } + + if ((i = DBIc_DEBUGIV(imp_xxh))) { /* merge handle into global */ + I32 h_trace_level = (i & DBIc_TRACE_LEVEL_MASK); + if ( h_trace_level > trace_level ) + trace_level = h_trace_level; + trace_flags = (trace_flags & ~DBIc_TRACE_LEVEL_MASK) + | ( i & ~DBIc_TRACE_LEVEL_MASK) + | trace_level; + } + +#ifdef DBI_USE_THREADS +{ + PerlInterpreter * h_perl; + is_DESTROY_wrong_thread: + h_perl = DBIc_THR_USER(imp_xxh) ; + if (h_perl != my_perl) { + /* XXX could call a 'handle clone' method here?, for dbh's at least */ + if (is_DESTROY) { + if (trace_level >= 3) { + PerlIO_printf(DBILOGFP," DESTROY ignored because DBI %sh handle (%s) is owned by thread %p not current thread %p\n", + dbih_htype_name(DBIc_TYPE(imp_xxh)), HvNAME(DBIc_IMP_STASH(imp_xxh)), + (void*)DBIc_THR_USER(imp_xxh), (void*)my_perl) ; + PerlIO_flush(DBILOGFP); + } + XSRETURN(0); /* don't DESTROY handle, if it is not our's !*/ + } + croak("%s %s failed: handle %d is owned by thread %lx not current thread %lx (%s)", + HvNAME(DBIc_IMP_STASH(imp_xxh)), meth_name, DBIc_TYPE(imp_xxh), + (unsigned long)h_perl, (unsigned long)my_perl, + "handles can't be shared between threads and your driver may need a CLONE method added"); + } +} +#endif + + /* Check method call against Internal Method Attributes */ + 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_type == methtype_can) { + const char *can_meth = SvPV_nolen(st1); + SV *dbi_msv = Nullsv; + /* find handle implementors method (GV or CV) */ + if ( (imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), can_meth, FALSE)) ) { + /* return DBI's CV, not the implementors CV (else we'd bypass dispatch) */ + /* and anyway, we may have hit a private method not part of the DBI */ + GV *gv = gv_fetchmethod_autoload(SvSTASH(SvRV(orig_h)), can_meth, FALSE); + if (gv && isGV(gv)) + dbi_msv = (SV*)GvCV(gv); + } + if (trace_level >= 1) { + PerlIO *logfp = DBILOGFP; + PerlIO_printf(logfp," <- %s(%s) = %p (%s %p)\n", meth_name, can_meth, (void*)dbi_msv, + (imp_msv && isGV(imp_msv)) ? HvNAME(GvSTASH(imp_msv)) : "?", (void*)imp_msv); + } + ST(0) = (dbi_msv) ? sv_2mortal(newRV_inc(dbi_msv)) : &PL_sv_undef; + XSRETURN(1); + } + XSRETURN(0); + } + if (ima_flags & IMA_FUNC_REDIRECT) { + /* XXX this doesn't redispatch, nor consider the IMA of the new method */ + SV *meth_name_sv = POPs; + PUTBACK; + --items; + if (!SvPOK(meth_name_sv) || SvNIOK(meth_name_sv)) + 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; + if (ima_flags & IMA_KEEP_ERR_SUB + && DBIc_PARENT_COM(imp_xxh) && DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) > 0) + keep_error = TRUE; + if (ima_flags & IMA_CLEAR_STMT) { + /* don't use SvOK_off: dbh's Statement may be ref to sth's */ + (void)hv_store((HV*)SvRV(h), "Statement", 9, &PL_sv_undef, 0); + } + if (ima_flags & IMA_CLEAR_CACHED_KIDS) + clear_cached_kids(aTHX_ h, imp_xxh, meth_name, trace_flags); + + } + + if (ima_flags & IMA_HAS_USAGE) { + const char *err = NULL; + char msg[200]; + + if (ima->minargs && (items < ima->minargs + || (ima->maxargs>0 && items > ima->maxargs))) { + sprintf(msg, + "DBI %s: invalid number of arguments: got handle + %ld, expected handle + between %d and %d\n", + meth_name, (long)items-1, (int)ima->minargs-1, (int)ima->maxargs-1); + err = msg; + } + /* arg type checking could be added here later */ + if (err) { + croak("%sUsage: %s->%s(%s)", err, "$h", meth_name, + (ima->usage_msg) ? ima->usage_msg : "...?"); + } + } + } + + is_unrelated_to_Statement = ( (DBIc_TYPE(imp_xxh) == DBIt_ST) ? 0 + : (DBIc_TYPE(imp_xxh) == DBIt_DR) ? 1 + : (ima_flags & IMA_UNRELATED_TO_STMT) ); + + if (PL_tainting && items > 1 /* method call has args */ + && DBIc_is(imp_xxh, DBIcf_TaintIn) /* taint checks requested */ + && !(ima_flags & IMA_NO_TAINT_IN) + ) { + for(i=1; i < items; ++i) { + if (SvTAINTED(ST(i))) { + char buf[100]; + sprintf(buf,"parameter %d of %s->%s method call", + i, SvPV_nolen(h), meth_name); + PL_tainted = 1; /* needed for TAINT_PROPER to work */ + TAINT_PROPER(buf); /* die's */ + } + } + } + + /* record this inner handle for use by DBI::var::FETCH */ + if (is_DESTROY) { + + 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 + ) { + /* copy err/errstr/state values to $DBI::err etc still work */ + sv_setsv(DBIc_ERR(parent_imp), DBIc_ERR(imp_xxh)); + sv_setsv(DBIc_ERRSTR(parent_imp), DBIc_ERRSTR(imp_xxh)); + sv_setsv(DBIc_STATE(parent_imp), DBIc_STATE(imp_xxh)); + } + } + + if (DBIc_AIADESTROY(imp_xxh)) { /* wants ineffective destroy after fork */ + if ((U32)PerlProc_getpid() != _imp2com(imp_xxh, std.pid)) + DBIc_set(imp_xxh, DBIcf_IADESTROY, 1); + } + if (DBIc_IADESTROY(imp_xxh)) { /* wants ineffective destroy */ + DBIc_ACTIVE_off(imp_xxh); + } + call_depth = 0; + } + else { + DBI_SET_LAST_HANDLE(h); + SAVEINT(DBIc_CALL_DEPTH(imp_xxh)); + call_depth = ++DBIc_CALL_DEPTH(imp_xxh); + + if (ima_flags & IMA_COPY_UP_STMT) { /* execute() */ + SV *parent = DBIc_PARENT_H(imp_xxh); + SV *tmp_sv = *hv_fetch((HV*)SvRV(h), "Statement", 9, 1); + /* XXX sv_copy() if Profiling? */ + (void)hv_store((HV*)SvRV(parent), "Statement", 9, SvREFCNT_inc(tmp_sv), 0); + } + } + + 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_type != methtype_set_err) { + SV *err_sv; + if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) { + PerlIO *logfp = DBILOGFP; + PerlIO_printf(logfp, " !! %s: %s CLEARED by call to %s method\n", + SvTRUE(err_sv) ? "ERROR" : strlen(SvPV_nolen(err_sv)) ? "warn" : "info", + neatsvpv(DBIc_ERR(imp_xxh),0), meth_name); + } + DBIh_CLEAR_ERROR(imp_xxh); + } + else { /* we check for change in ErrCount during call */ + ErrCount = DBIc_ErrCount(imp_xxh); + } + + if (DBIc_has(imp_xxh,DBIcf_Callbacks) + && (tmp_svp = hv_fetch((HV*)SvRV(h), "Callbacks", 9, 0)) + && ( (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), meth_name, strlen(meth_name), 0)) + /* the "*" fallback callback only applies to non-nested calls + * and also doesn't apply to the 'set_err' or DESTROY methods. + * Nor during global destruction. + * Other restrictions may be added over time. + * It's an undocumented hack. + */ + || (!is_nested_call && !PL_dirty && meth_type != methtype_set_err && + meth_type != methtype_DESTROY && + (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0)) + ) + ) + && SvROK(*hook_svp) + ) { + SV *orig_defsv; + SV *code = SvRV(*hook_svp); + I32 skip_dispatch = 0; + if (trace_level) + PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0)); + + /* we don't use ENTER,SAVETMPS & FREETMPS,LEAVE because we may need mortal + * results to live long enough to be returned to our caller + */ + /* we want to localize $_ for the callback but can't just do that alone + * because we're not using SAVETMPS & FREETMPS, so we have to get sneaky. + * We still localize, so we're safe from the callback dieing, + * but after the callback we manually restore the original $_. + */ + orig_defsv = DEFSV; /* remember the current $_ */ + SAVE_DEFSV; /* local($_) = $method_name */ + DEFSV = sv_2mortal(newSVpv(meth_name,0)); + + EXTEND(SP, items+1); + PUSHMARK(SP); + PUSHs(h); /* push inner handle, then others params */ + for (i=1; i < items; ++i) { /* start at 1 to skip handle */ + PUSHs( ST(i) ); + } + PUTBACK; + outitems = call_sv(code, G_ARRAY); /* call the callback code */ + SPAGAIN; + + /* The callback code can undef $_ to indicate to skip dispatch */ + skip_dispatch = !SvOK(DEFSV); + /* put $_ back now, but with an incremented ref count to compensate + * for the ref count decrement that will happen when we exit the scope. + */ + DEFSV = SvREFCNT_inc(orig_defsv); + + if (trace_level) + PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s\n", + (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), + skip_dispatch ? ", actual method will not be called" : "" + ); + if (skip_dispatch) { /* XXX experimental */ + int ix = outitems; + /* copy the new items down to the destination list */ + while (ix-- > 0) { + if(0)warn("\tcopy down %d: %s overwriting %s\n", ix, SvPV_nolen(TOPs), SvPV_nolen(ST(ix)) ); + ST(ix) = POPs; + } + imp_msv = *hook_svp; /* for trace and profile */ + goto post_dispatch; + } + else { + if (outitems != 0) + die("Callback for %s returned %d values but must not return any (temporary restriction in current version)", + meth_name, (int)outitems); + /* POP's and PUTBACK? to clear stack */ + } + } + + /* set Executed after Callbacks so it's not set if callback elects to skip the method */ + if (ima_flags & IMA_EXECUTE) { + imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh); + DBIc_on(imp_xxh, DBIcf_Executed); + if (parent) + DBIc_on(parent, DBIcf_Executed); + } + + /* The "quick_FETCH" logic... */ + /* Shortcut for fetching attributes to bypass method call overheads */ + if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) { + STRLEN kl; + const char *key = SvPV(st1, kl); + SV **attr_svp; + if (*key != '_' && (attr_svp=hv_fetch((HV*)SvRV(h), key, kl, 0))) { + qsv = *attr_svp; + /* disable FETCH from cache for special attributes */ + if (SvROK(qsv) && SvTYPE(SvRV(qsv))==SVt_PVHV && *key=='D' && + ( (kl==6 && DBIc_TYPE(imp_xxh)==DBIt_DB && strEQ(key,"Driver")) + || (kl==8 && DBIc_TYPE(imp_xxh)==DBIt_ST && strEQ(key,"Database")) ) + ) { + qsv = Nullsv; + } + /* disable profiling of FETCH of Profile data */ + 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; + } + } + + { + CV *meth_cv; +#ifdef DBI_save_hv_fetch_ent + HE save_mh; + if (meth_type == methtype_FETCH) + save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */ +#endif + + if (trace_flags) { + SAVEI32(DBIS->debug); /* fall back to orig value later */ + DBIS->debug = trace_flags; /* make new value global (for now) */ + if (ima) { + /* enabling trace via flags takes precedence over disabling due to min level */ + if ((trace_flags & DBIc_TRACE_FLAGS_MASK) & (ima->method_trace & DBIc_TRACE_FLAGS_MASK)) + trace_level = (trace_level < 2) ? 2 : trace_level; /* min */ + else + if (trace_level < (DBIc_TRACE_LEVEL_MASK & ima->method_trace)) + trace_level = 0; /* silence dispatch log for this method */ + } + } + + 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)) { + imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), "func", FALSE); + if (imp_msv) { + /* driver does have func method so undo the earlier 'func' stack changes */ + PUSHs(sv_2mortal(newSVpv(meth_name,0))); + PUTBACK; + ++items; + meth_name = "func"; + meth_type = methtype_ordinary; + } + } + + if (trace_level >= (is_nested_call ? 4 : 2)) { + PerlIO *logfp = DBILOGFP; + /* Full pkg method name (or just meth_name for ANON CODE) */ + const char *imp_meth_name = (imp_msv && isGV(imp_msv)) ? GvNAME(imp_msv) : meth_name; + HV *imp_stash = DBIc_IMP_STASH(imp_xxh); + PerlIO_printf(logfp, "%c -> %s ", + call_depth>1 ? '0'+call_depth-1 : (PL_dirty?'!':' '), imp_meth_name); + if (imp_meth_name[0] == 'A' && strEQ(imp_meth_name,"AUTOLOAD")) + PerlIO_printf(logfp, "\"%s\" ", meth_name); + if (imp_msv && isGV(imp_msv) && GvSTASH(imp_msv) != imp_stash) + PerlIO_printf(logfp, "in %s ", HvNAME(GvSTASH(imp_msv))); + PerlIO_printf(logfp, "for %s (%s", HvNAME(imp_stash), + SvPV_nolen(orig_h)); + if (h != orig_h) /* show inner handle to aid tracing */ + PerlIO_printf(logfp, "~0x%lx", (long)SvRV(h)); + else PerlIO_printf(logfp, "~INNER"); + for(i=1; ihidearg) ? "****" : neatsvpv(ST(i),0)); + } +#ifdef DBI_USE_THREADS + PerlIO_printf(logfp, ") thr#%p\n", (void*)DBIc_THR_USER(imp_xxh)); +#else + PerlIO_printf(logfp, ")\n"); +#endif + PerlIO_flush(logfp); + } + + if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) { + if (PL_dirty || is_DESTROY) { + outitems = 0; + goto post_dispatch; + } + if (ima_flags & IMA_NOT_FOUND_OKAY) { + outitems = 0; + goto post_dispatch; + } + croak("Can't locate DBI object method \"%s\" via package \"%s\"", + meth_name, HvNAME(DBIc_IMP_STASH(imp_xxh))); + } + + PUSHMARK(mark); /* mark arguments again so we can pass them on */ + + /* Note: the handle on the stack is still an object blessed into a + * DBI::* class and not the DBD::*::* class whose method is being + * invoked. This is correct and should be largely transparent. + */ + + /* SHORT-CUT ALERT! */ + 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 based on a small section of pp_entersub(). + */ + (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code directly */ + + if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */ + 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 + ax - 1); + } + + } + else { + /* sv_dump(imp_msv); */ + outitems = call_sv((SV*)meth_cv, + (is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) ); + } + + XSprePUSH; /* reset SP to base of stack frame */ + +#ifdef DBI_save_hv_fetch_ent + if (meth_type == methtype_FETCH) + PL_hv_fetch_ent_mh = save_mh; /* see start of block */ +#endif + } + + post_dispatch: + + if (is_DESTROY && DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */ + SV *lhp = DBIc_PARENT_H(imp_xxh); + if (lhp && SvROK(lhp)) { + DBI_SET_LAST_HANDLE(lhp); + } + else { + DBI_UNSET_LAST_HANDLE; + } + } + + /* if we didn't clear err before the call, check if ErrCount has gone up */ + /* if so, we turn off keep_error so error is acted on */ + if (keep_error && DBIc_ErrCount(imp_xxh) > ErrCount) + keep_error = 0; + + err_sv = DBIc_ERR(imp_xxh); + + if (trace_level >= (is_nested_call ? 3 : 1)) { + PerlIO *logfp = DBILOGFP; + 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 */ + goto skip_meth_return_trace; + } + if (SvOK(err_sv)) { + PerlIO_printf(logfp, " %s %s %s %s (err#%ld)\n", (keep_error) ? " " : "!!", + SvTRUE(err_sv) ? "ERROR:" : strlen(SvPV_nolen(err_sv)) ? "warn:" : "info:", + neatsvpv(err_sv,0), neatsvpv(DBIc_ERRSTR(imp_xxh),0), (long)DBIc_ErrCount(imp_xxh)); + } + PerlIO_printf(logfp,"%c%c <%c %s", + (call_depth > 1) ? '0'+call_depth-1 : (PL_dirty?'!':' '), + (DBIc_is(imp_xxh, DBIcf_TaintIn|DBIcf_TaintOut)) ? 'T' : ' ', + (qsv) ? '>' : '-', + meth_name); + if (trace_level==1 && (items>=2||is_DESTROY)) { /* make level 1 more useful */ + /* we only have the first two parameters available here */ + if (is_DESTROY) /* show handle as first arg to DESTROY */ + /* want to show outer handle so trace makes sense */ + /* but outer handle has been destroyed so we fake it */ + PerlIO_printf(logfp,"(%s=HASH(0x%p)", HvNAME(SvSTASH(SvRV(orig_h))), (void*)DBIc_MY_H(imp_xxh)); + else + PerlIO_printf(logfp,"(%s", neatsvpv(st1,0)); + if (items >= 3) + PerlIO_printf(logfp,", %s", neatsvpv(st2,0)); + PerlIO_printf(logfp,"%s)", (items > 3) ? ", ..." : ""); + } + + if (gimme & G_ARRAY) + PerlIO_printf(logfp,"= ("); + else PerlIO_printf(logfp,"="); + for(i=0; i < outitems; ++i) { + SV *s = ST(i); + if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVAV) { + AV *av = (AV*)SvRV(s); + int avi; + int avi_last = SvIV(DBIS->neatsvpvlen) / 10; + if (avi_last < 39) + avi_last = 39; + PerlIO_printf(logfp, " ["); + for (avi=0; avi <= AvFILL(av); ++avi) { + PerlIO_printf(logfp, " %s", neatsvpv(AvARRAY(av)[avi],0)); + if (avi >= avi_last && AvFILL(av) - avi > 1) { + PerlIO_printf(logfp, " ... %ld others skipped", AvFILL(av) - avi); + break; + } + } + PerlIO_printf(logfp, " ]"); + } + else { + PerlIO_printf(logfp, " %s", neatsvpv(s,0)); + if ( SvROK(s) && SvTYPE(SvRV(s))==SVt_PVHV && !SvOBJECT(SvRV(s)) ) + PerlIO_printf(logfp, "%ldkeys", (long)HvKEYS(SvRV(s))); + } + } + if (gimme & G_ARRAY) { + PerlIO_printf(logfp," ) [%d items]", outitems); + } + if (is_fetch && row_count) { + PerlIO_printf(logfp," row%d", row_count); + } + if (qsv) /* flag as quick and peek at the first arg (still on the stack) */ + PerlIO_printf(logfp," (%s from cache)", neatsvpv(st1,0)); + else if (!imp_msv) + PerlIO_printf(logfp," (not implemented)"); + /* XXX add flag to show pid here? */ + /* add file and line number information */ + PerlIO_puts(logfp, log_where(0, 0, " at ", "\n", 1, (trace_level >= 3), (trace_level >= 4))); + skip_meth_return_trace: + PerlIO_flush(logfp); + } + + if (ima_flags & IMA_END_WORK) { /* commit() or rollback() */ + /* XXX does not consider if the method call actually worked or not */ + DBIc_off(imp_xxh, DBIcf_Executed); + + if (DBIc_has(imp_xxh, DBIcf_BegunWork)) { + DBIc_off(imp_xxh, DBIcf_BegunWork); + if (!DBIc_has(imp_xxh, DBIcf_AutoCommit)) { + /* We only get here if the driver hasn't implemented their own code */ + /* for begin_work, or has but hasn't correctly turned AutoCommit */ + /* back on in their commit or rollback code. So we have to do it. */ + /* This is bad because it'll probably trigger a spurious commit() */ + /* and may mess up the error handling below for the commit/rollback */ + PUSHMARK(SP); + XPUSHs(h); + XPUSHs(sv_2mortal(newSVpv("AutoCommit",0))); + XPUSHs(&PL_sv_yes); + PUTBACK; + call_method("STORE", G_DISCARD); + SPAGAIN; + } + } + } + + if (PL_tainting + && DBIc_is(imp_xxh, DBIcf_TaintOut) /* taint checks requested */ + /* XXX this would taint *everything* being returned from *any* */ + /* method that doesn't have IMA_NO_TAINT_OUT set. */ + /* DISABLED: just tainting fetched data in get_fbav seems ok */ + && 0/* XXX disabled*/ /* !(ima_flags & IMA_NO_TAINT_OUT) */ + ) { + dTHR; + TAINT; /* affects sv_setsv()'s within same perl statement */ + for(i=0; i < outitems; ++i) { + I32 avi; + char *p; + SV *s; + SV *agg = ST(i); + if ( !SvROK(agg) ) + continue; + agg = SvRV(agg); +#define DBI_OUT_TAINTABLE(s) (!SvREADONLY(s) && !SvTAINTED(s)) + switch (SvTYPE(agg)) { + case SVt_PVAV: + for(avi=0; avi <= AvFILL((AV*)agg); ++avi) { + s = AvARRAY((AV*)agg)[avi]; + if (DBI_OUT_TAINTABLE(s)) + SvTAINTED_on(s); + } + break; + case SVt_PVHV: + hv_iterinit((HV*)agg); + while( (s = hv_iternextsv((HV*)agg, &p, &avi)) ) { + if (DBI_OUT_TAINTABLE(s)) + SvTAINTED_on(s); + } + break; + default: + if (DBIc_WARN(imp_xxh)) { + PerlIO_printf(DBILOGFP,"Don't know how to taint contents of returned %s (type %d)\n", + neatsvpv(agg,0), (int)SvTYPE(agg)); + } + } + } + } + + /* if method returned a new handle, and that handle has an error on it + * then copy the error up into the parent handle + */ + if (ima_flags & IMA_IS_FACTORY && SvROK(ST(0))) { + SV *h_new = ST(0); + D_impdata(imp_xxh_new, imp_xxh_t, h_new); + if (SvOK(DBIc_ERR(imp_xxh_new))) { + set_err_sv(h, imp_xxh, DBIc_ERR(imp_xxh_new), DBIc_ERRSTR(imp_xxh_new), DBIc_STATE(imp_xxh_new), &PL_sv_no); + } + } + + if ( !keep_error /* is a new err/warn/info */ + && !is_nested_call /* skip nested (internal) calls */ + && ( + /* is an error and has RaiseError|PrintError|HandleError set */ + (SvTRUE(err_sv) && DBIc_has(imp_xxh, DBIcf_RaiseError|DBIcf_PrintError|DBIcf_HandleError)) + /* is a warn (not info) and has PrintWarn set */ + || ( SvOK(err_sv) && strlen(SvPV_nolen(err_sv)) && DBIc_has(imp_xxh, DBIcf_PrintWarn)) + ) + ) { + SV *msg; + SV **statement_svp = NULL; + const int is_warning = (!SvTRUE(err_sv) && strlen(SvPV_nolen(err_sv))==1); + const char *err_meth_name = meth_name; + char intro[200]; + + 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); + } + + /* XXX change to vsprintf into sv directly */ + sprintf(intro,"%s %s %s: ", HvNAME(DBIc_IMP_STASH(imp_xxh)), err_meth_name, + SvTRUE(err_sv) ? "failed" : is_warning ? "warning" : "information"); + msg = sv_2mortal(newSVpv(intro,0)); + if (SvOK(DBIc_ERRSTR(imp_xxh))) + sv_catsv(msg, DBIc_ERRSTR(imp_xxh)); + else + sv_catpvf(msg, "(err=%s, errstr=undef, state=%s)", + neatsvpv(DBIc_ERR(imp_xxh),0), neatsvpv(DBIc_STATE(imp_xxh),0) ); + + if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement) + && !is_unrelated_to_Statement + && (DBIc_TYPE(imp_xxh) == DBIt_ST || ima_flags & IMA_SHOW_ERR_STMT) + && (statement_svp = hv_fetch((HV*)SvRV(h), "Statement", 9, 0)) + && statement_svp && SvOK(*statement_svp) + ) { + SV **svp = 0; + sv_catpv(msg, " [for Statement \""); + sv_catsv(msg, *statement_svp); + + /* fetch from tied outer handle to trigger FETCH magic */ + /* could add DBIcf_ShowErrorParams (default to on?) */ + if (!(ima_flags & IMA_HIDE_ERR_PARAMVALUES)) { + svp = hv_fetch((HV*)DBIc_MY_H(imp_xxh),"ParamValues",11,FALSE); + if (svp && SvMAGICAL(*svp)) + mg_get(*svp); /* XXX may recurse, may croak. could use eval */ + } + if (svp && SvRV(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV && HvKEYS(SvRV(*svp))>0 ) { + SV *param_values_sv = sv_2mortal(_join_hash_sorted((HV*)SvRV(*svp), "=",1, ", ",2, 1, -1)); + sv_catpv(msg, "\" with ParamValues: "); + sv_catsv(msg, param_values_sv); + sv_catpvn(msg, "]", 1); + } + else { + sv_catpv(msg, "\"]"); + } + } + + if (0) { + COP *cop = dbi_caller_cop(); + if (cop && (CopLINE(cop) != CopLINE(PL_curcop) || CopFILEGV(cop) != CopFILEGV(PL_curcop))) { + dbi_caller_string(msg, cop, " called via ", 1, 0); + } + } + + hook_svp = NULL; + if ( SvTRUE(err_sv) + && DBIc_has(imp_xxh, DBIcf_HandleError) + && (hook_svp = hv_fetch((HV*)SvRV(h),"HandleError",11,0)) + && hook_svp && SvOK(*hook_svp) + ) { + dSP; + PerlIO *logfp = DBILOGFP; + IV items; + SV *status; + SV *result; /* point to result SV that's pointed to by the stack */ + if (outitems) { + result = *(sp-outitems+1); + if (SvREADONLY(result)) { + *(sp-outitems+1) = result = sv_2mortal(newSVsv(result)); + } + } + else { + result = sv_newmortal(); + } + if (trace_level) + PerlIO_printf(logfp," -> HandleError on %s via %s%s%s%s\n", + neatsvpv(h,0), neatsvpv(*hook_svp,0), + (!outitems ? "" : " ("), + (!outitems ? "" : neatsvpv(result ,0)), + (!outitems ? "" : ")") + ); + PUSHMARK(SP); + XPUSHs(msg); + XPUSHs(sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh)))); + XPUSHs( result ); + PUTBACK; + items = call_sv(*hook_svp, G_SCALAR); + SPAGAIN; + status = (items) ? POPs : &PL_sv_undef; + PUTBACK; + if (trace_level) + PerlIO_printf(logfp," <- HandleError= %s%s%s%s\n", + neatsvpv(status,0), + (!outitems ? "" : " ("), + (!outitems ? "" : neatsvpv(result,0)), + (!outitems ? "" : ")") + ); + if (!SvTRUE(status)) /* handler says it didn't handle it, so... */ + hook_svp = 0; /* pretend we didn't have a handler... */ + } + + if (profile_t1) { /* see also dbi_profile() call a few lines below */ + SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef; + dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv, + profile_t1, dbi_time()); + } + if (is_warning) { + if (DBIc_has(imp_xxh, DBIcf_PrintWarn)) + warn("%s", SvPV_nolen(msg)); + } + else if (!hook_svp && SvTRUE(err_sv)) { + if (DBIc_has(imp_xxh, DBIcf_PrintError)) + warn("%s", SvPV_nolen(msg)); + if (DBIc_has(imp_xxh, DBIcf_RaiseError)) + croak("%s", SvPV_nolen(msg)); + } + } + else if (profile_t1) { /* see also dbi_profile() call a few lines above */ + SV *statement_sv = (is_unrelated_to_Statement) ? &PL_sv_no : &PL_sv_undef; + dbi_profile(h, imp_xxh, statement_sv, imp_msv ? imp_msv : (SV*)cv, + profile_t1, dbi_time()); + } + XSRETURN(outitems); +} + + + +/* -------------------------------------------------------------------- */ + +/* comment and placeholder styles to accept and return */ + +#define DBIpp_cm_cs 0x000001 /* C style */ +#define DBIpp_cm_hs 0x000002 /* # */ +#define DBIpp_cm_dd 0x000004 /* -- */ +#define DBIpp_cm_br 0x000008 /* {} */ +#define DBIpp_cm_dw 0x000010 /* '-- ' dash dash whitespace */ +#define DBIpp_cm_XX 0x00001F /* any of the above */ + +#define DBIpp_ph_qm 0x000100 /* ? */ +#define DBIpp_ph_cn 0x000200 /* :1 */ +#define DBIpp_ph_cs 0x000400 /* :name */ +#define DBIpp_ph_sp 0x000800 /* %s (as return only, not accept) */ +#define DBIpp_ph_XX 0x000F00 /* any of the above */ + +#define DBIpp_st_qq 0x010000 /* '' char escape */ +#define DBIpp_st_bs 0x020000 /* \ char escape */ +#define DBIpp_st_XX 0x030000 /* any of the above */ + +#define DBIpp_L_BRACE '{' +#define DBIpp_R_BRACE '}' +#define PS_accept(flag) DBIbf_has(ps_accept,(flag)) +#define PS_return(flag) DBIbf_has(ps_return,(flag)) + +SV * +preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo) +{ + dTHX; + D_imp_xxh(dbh); +/* + The idea here is that ps_accept defines which constructs to + recognize (accept) as valid in the source string (other + constructs are ignored), and ps_return defines which + constructs are valid to return in the result string. + + If a construct that is valid in the input is also valid in the + output then it's simply copied. If it's not valid in the output + then it's editied into one of the valid forms (ideally the most + 'standard' and/or information preserving one). + + For example, if ps_accept includes '--' style comments but + ps_return doesn't, but ps_return does include '#' style + comments then any '--' style comments would be rewritten as '#' + style comments. + + Similarly for placeholders. DBD::Oracle, for example, would say + '?', ':1' and ':name' are all acceptable input, but only + ':name' should be returned. + + (There's a tricky issue with the '--' comment style because it can + clash with valid syntax, i.e., "... set foo=foo--1 ..." so it + would be *bad* to misinterpret that as the start of a comment. + Perhaps we need a DBIpp_cm_dw (for dash-dash-whitespace) style + to allow for that.) + + Also, we'll only support DBIpp_cm_br as an input style. And + even then, only with reluctance. We may (need to) drop it when + we add support for odbc escape sequences. +*/ + int idx = 1; + + char in_quote = '\0'; + char in_comment = '\0'; + char rt_comment = '\0'; + char *dest, *start; + const char *src; + const char *style = "", *laststyle = '\0'; + SV *new_stmt_sv; + + (void)foo; + + if (!(ps_return | DBIpp_ph_XX)) { /* no return ph type specified */ + ps_return |= ps_accept | DBIpp_ph_XX; /* so copy from ps_accept */ + } + + /* XXX this allocation strategy won't work when we get to more advanced stuff */ + new_stmt_sv = newSV(strlen(statement) * 3); + sv_setpv(new_stmt_sv,""); + src = statement; + dest = SvPVX(new_stmt_sv); + + while( *src ) + { + if (*src == '%' && PS_return(DBIpp_ph_sp)) + *dest++ = '%'; + + if (in_comment) + { + if ( (in_comment == '-' && (*src == '\n' || *(src+1) == '\0')) + || (in_comment == '#' && (*src == '\n' || *(src+1) == '\0')) + || (in_comment == DBIpp_L_BRACE && *src == DBIpp_R_BRACE) /* XXX nesting? */ + || (in_comment == '/' && *src == '*' && *(src+1) == '/') + ) { + switch (rt_comment) { + case '/': *dest++ = '*'; *dest++ = '/'; break; + case '-': *dest++ = '\n'; break; + case '#': *dest++ = '\n'; break; + case DBIpp_L_BRACE: *dest++ = DBIpp_R_BRACE; break; + case '\0': /* ensure deleting a comment doesn't join two tokens */ + if (in_comment=='/' || in_comment==DBIpp_L_BRACE) + *dest++ = ' '; /* ('-' and '#' styles use the newline) */ + break; + } + if (in_comment == '/') + src++; + src += (*src != '\n' || *(dest-1)=='\n') ? 1 : 0; + in_comment = '\0'; + rt_comment = '\0'; + } + else + if (rt_comment) + *dest++ = *src++; + else + src++; /* delete (don't copy) the comment */ + continue; + } + + if (in_quote) + { + if (*src == in_quote) { + in_quote = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments */ + if (*src == '-' && *(src+1) == '-' && + (PS_accept(DBIpp_cm_dd) || (*(src+2) == ' ' && PS_accept(DBIpp_cm_dw))) + ) + { + in_comment = *src; + src += 2; /* skip past 2nd char of double char delimiters */ + if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw) && *src!=' ') + *dest++ = ' '; /* insert needed white space */ + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == '/' && *(src+1) == '*' && PS_accept(DBIpp_cm_cs)) + { + in_comment = *src; + src += 2; /* skip past 2nd char of double char delimiters */ + if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == '#' && PS_accept(DBIpp_cm_hs)) + { + in_comment = *src; + src++; + if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + continue; + } + else if (*src == DBIpp_L_BRACE && PS_accept(DBIpp_cm_br)) + { + in_comment = *src; + src++; + if (PS_return(DBIpp_cm_br)) { + *dest++ = rt_comment = DBIpp_L_BRACE; + } + else if (PS_return(DBIpp_cm_dd) || PS_return(DBIpp_cm_dw)) { + *dest++ = rt_comment = '-'; + *dest++ = '-'; + if (PS_return(DBIpp_cm_dw)) *dest++ = ' '; + } + else if (PS_return(DBIpp_cm_cs)) { + *dest++ = rt_comment = '/'; + *dest++ = '*'; + } + else if (PS_return(DBIpp_cm_hs)) { + *dest++ = rt_comment = '#'; + } + continue; + } + + if ( !(*src==':' && (PS_accept(DBIpp_ph_cn) || PS_accept(DBIpp_ph_cs))) + && !(*src=='?' && PS_accept(DBIpp_ph_qm)) + ){ + if (*src == '\'' || *src == '"') + in_quote = *src; + *dest++ = *src++; + continue; + } + + /* only here for : or ? outside of a comment or literal */ + + start = dest; /* save name inc colon */ + *dest++ = *src++; /* copy and move past first char */ + + if (*start == '?') /* X/Open Standard */ + { + style = "?"; + + if (PS_return(DBIpp_ph_qm)) + ; + else if (PS_return(DBIpp_ph_cn)) { /* '?' -> ':p1' (etc) */ + sprintf(start,":p%d", idx++); + dest = start+strlen(start); + } + else if (PS_return(DBIpp_ph_sp)) { /* '?' -> '%s' */ + *start = '%'; + *dest++ = 's'; + } + } + else if (isDIGIT(*src)) { /* :1 */ + const int pln = atoi(src); + style = ":1"; + + if (PS_return(DBIpp_ph_cn)) { /* ':1'->':p1' */ + idx = pln; + *dest++ = 'p'; + while(isDIGIT(*src)) + *dest++ = *src++; + } + else if (PS_return(DBIpp_ph_qm) /* ':1' -> '?' */ + || PS_return(DBIpp_ph_sp) /* ':1' -> '%s' */ + ) { + PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s"); + dest = start + strlen(start); + if (pln != idx) { + char buf[99]; + sprintf(buf, "preparse found placeholder :%d out of sequence, expected :%d", pln, idx); + set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse"); + return &PL_sv_undef; + } + while(isDIGIT(*src)) src++; + idx++; + } + } + else if (isALNUM(*src)) /* :name */ + { + style = ":name"; + + if (PS_return(DBIpp_ph_cs)) { + ; + } + else if (PS_return(DBIpp_ph_qm) /* ':name' -> '?' */ + || PS_return(DBIpp_ph_sp) /* ':name' -> '%s' */ + ) { + PS_return(DBIpp_ph_qm) ? sprintf(start,"?") : sprintf(start,"%%s"); + dest = start + strlen(start); + while (isALNUM(*src)) /* consume name, includes '_' */ + src++; + } + } + /* perhaps ':=' PL/SQL construct */ + else { continue; } + + *dest = '\0'; /* handy for debugging */ + + if (laststyle && style != laststyle) { + char buf[99]; + sprintf(buf, "preparse found mixed placeholder styles (%s / %s)", style, laststyle); + set_err_char(dbh, imp_xxh, "1", 1, buf, 0, "preparse"); + return &PL_sv_undef; + } + laststyle = style; + } + *dest = '\0'; + + /* warn about probable parsing errors, but continue anyway (returning processed string) */ + switch (in_quote) + { + case '\'': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated single-quoted string", 0, "preparse"); + break; + case '\"': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated double-quoted string", 0, "preparse"); + break; + } + switch (in_comment) + { + case DBIpp_L_BRACE: + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed {...} comment", 0, "preparse"); + break; + case '/': + set_err_char(dbh, imp_xxh, "1", 1, "preparse found unterminated bracketed C-style comment", 0, "preparse"); + break; + } + + SvCUR_set(new_stmt_sv, strlen(SvPVX(new_stmt_sv))); + *SvEND(new_stmt_sv) = '\0'; + return new_stmt_sv; +} + + +/* -------------------------------------------------------------------- */ +/* The DBI Perl interface (via XS) starts here. Currently these are */ +/* all internal support functions. Note install_method and see DBI.pm */ + +MODULE = DBI PACKAGE = DBI + +REQUIRE: 1.929 +PROTOTYPES: DISABLE + + +BOOT: + { + MY_CXT_INIT; + (void)MY_CXT; /* avoid 'unused variable' warning */ + } + (void)cv; + (void)items; /* avoid 'unused variable' warning */ + 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 +constant() + PROTOTYPE: + ALIAS: + SQL_ALL_TYPES = SQL_ALL_TYPES + SQL_ARRAY = SQL_ARRAY + SQL_ARRAY_LOCATOR = SQL_ARRAY_LOCATOR + SQL_BIGINT = SQL_BIGINT + SQL_BINARY = SQL_BINARY + SQL_BIT = SQL_BIT + SQL_BLOB = SQL_BLOB + SQL_BLOB_LOCATOR = SQL_BLOB_LOCATOR + SQL_BOOLEAN = SQL_BOOLEAN + SQL_CHAR = SQL_CHAR + SQL_CLOB = SQL_CLOB + SQL_CLOB_LOCATOR = SQL_CLOB_LOCATOR + SQL_DATE = SQL_DATE + SQL_DATETIME = SQL_DATETIME + SQL_DECIMAL = SQL_DECIMAL + SQL_DOUBLE = SQL_DOUBLE + SQL_FLOAT = SQL_FLOAT + SQL_GUID = SQL_GUID + SQL_INTEGER = SQL_INTEGER + SQL_INTERVAL = SQL_INTERVAL + SQL_INTERVAL_DAY = SQL_INTERVAL_DAY + SQL_INTERVAL_DAY_TO_HOUR = SQL_INTERVAL_DAY_TO_HOUR + SQL_INTERVAL_DAY_TO_MINUTE = SQL_INTERVAL_DAY_TO_MINUTE + SQL_INTERVAL_DAY_TO_SECOND = SQL_INTERVAL_DAY_TO_SECOND + SQL_INTERVAL_HOUR = SQL_INTERVAL_HOUR + SQL_INTERVAL_HOUR_TO_MINUTE = SQL_INTERVAL_HOUR_TO_MINUTE + SQL_INTERVAL_HOUR_TO_SECOND = SQL_INTERVAL_HOUR_TO_SECOND + SQL_INTERVAL_MINUTE = SQL_INTERVAL_MINUTE + SQL_INTERVAL_MINUTE_TO_SECOND = SQL_INTERVAL_MINUTE_TO_SECOND + SQL_INTERVAL_MONTH = SQL_INTERVAL_MONTH + SQL_INTERVAL_SECOND = SQL_INTERVAL_SECOND + SQL_INTERVAL_YEAR = SQL_INTERVAL_YEAR + SQL_INTERVAL_YEAR_TO_MONTH = SQL_INTERVAL_YEAR_TO_MONTH + SQL_LONGVARBINARY = SQL_LONGVARBINARY + SQL_LONGVARCHAR = SQL_LONGVARCHAR + SQL_MULTISET = SQL_MULTISET + SQL_MULTISET_LOCATOR = SQL_MULTISET_LOCATOR + SQL_NUMERIC = SQL_NUMERIC + SQL_REAL = SQL_REAL + SQL_REF = SQL_REF + SQL_ROW = SQL_ROW + SQL_SMALLINT = SQL_SMALLINT + SQL_TIME = SQL_TIME + SQL_TIMESTAMP = SQL_TIMESTAMP + SQL_TINYINT = SQL_TINYINT + SQL_TYPE_DATE = SQL_TYPE_DATE + SQL_TYPE_TIME = SQL_TYPE_TIME + SQL_TYPE_TIMESTAMP = SQL_TYPE_TIMESTAMP + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE = SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + SQL_TYPE_TIME_WITH_TIMEZONE = SQL_TYPE_TIME_WITH_TIMEZONE + SQL_UDT = SQL_UDT + SQL_UDT_LOCATOR = SQL_UDT_LOCATOR + SQL_UNKNOWN_TYPE = SQL_UNKNOWN_TYPE + SQL_VARBINARY = SQL_VARBINARY + SQL_VARCHAR = SQL_VARCHAR + SQL_WCHAR = SQL_WCHAR + SQL_WLONGVARCHAR = SQL_WLONGVARCHAR + SQL_WVARCHAR = SQL_WVARCHAR + SQL_CURSOR_FORWARD_ONLY = SQL_CURSOR_FORWARD_ONLY + SQL_CURSOR_KEYSET_DRIVEN = SQL_CURSOR_KEYSET_DRIVEN + SQL_CURSOR_DYNAMIC = SQL_CURSOR_DYNAMIC + SQL_CURSOR_STATIC = SQL_CURSOR_STATIC + SQL_CURSOR_TYPE_DEFAULT = SQL_CURSOR_TYPE_DEFAULT + DBIpp_cm_cs = DBIpp_cm_cs + DBIpp_cm_hs = DBIpp_cm_hs + DBIpp_cm_dd = DBIpp_cm_dd + DBIpp_cm_dw = DBIpp_cm_dw + DBIpp_cm_br = DBIpp_cm_br + DBIpp_cm_XX = DBIpp_cm_XX + DBIpp_ph_qm = DBIpp_ph_qm + DBIpp_ph_cn = DBIpp_ph_cn + DBIpp_ph_cs = DBIpp_ph_cs + DBIpp_ph_sp = DBIpp_ph_sp + DBIpp_ph_XX = DBIpp_ph_XX + DBIpp_st_qq = DBIpp_st_qq + DBIpp_st_bs = DBIpp_st_bs + DBIpp_st_XX = DBIpp_st_XX + DBIstcf_DISCARD_STRING = DBIstcf_DISCARD_STRING + DBIstcf_STRICT = DBIstcf_STRICT + DBIf_TRACE_SQL = DBIf_TRACE_SQL + DBIf_TRACE_CON = DBIf_TRACE_CON + DBIf_TRACE_ENC = DBIf_TRACE_ENC + DBIf_TRACE_DBD = DBIf_TRACE_DBD + DBIf_TRACE_TXN = DBIf_TRACE_TXN + CODE: + RETVAL = ix; + OUTPUT: + RETVAL + + +void +_clone_dbis() + CODE: + dMY_CXT; + dbistate_t * parent_dbis = DBIS; + + (void)cv; + { + MY_CXT_CLONE; + } + dbi_bootinit(parent_dbis); + + +void +_new_handle(class, parent, attr_ref, imp_datasv, imp_class) + SV * class + SV * parent + SV * attr_ref + SV * imp_datasv + SV * imp_class + PPCODE: + dMY_CXT; + HV *outer; + SV *outer_ref; + HV *class_stash = gv_stashsv(class, GV_ADDWARN); + + 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 */ + } + + (void)hv_store((HV*)SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class), 0); + + /* make attr into inner handle by blessing it into class */ + sv_bless(attr_ref, class_stash); + /* tie new outer hash to inner handle */ + outer = newHV(); /* create new hash to be outer handle */ + outer_ref = newRV_noinc((SV*)outer); + /* make outer hash into a handle by blessing it into class */ + sv_bless(outer_ref, class_stash); + /* tie outer handle to inner handle */ + sv_magic((SV*)outer, attr_ref, PERL_MAGIC_tied, Nullch, 0); + + dbih_setup_handle(aTHX_ outer_ref, SvPV_nolen(imp_class), parent, SvOK(imp_datasv) ? imp_datasv : Nullsv); + + /* return outer handle, plus inner handle if not in scalar context */ + sv_2mortal(outer_ref); + EXTEND(SP, 2); + PUSHs(outer_ref); + if (GIMME != G_SCALAR) { + PUSHs(attr_ref); + } + + +void +_setup_handle(sv, imp_class, parent, imp_datasv) + SV * sv + char * imp_class + SV * parent + SV * imp_datasv + CODE: + (void)cv; + dbih_setup_handle(aTHX_ sv, imp_class, parent, SvOK(imp_datasv) ? imp_datasv : Nullsv); + ST(0) = &PL_sv_undef; + + +void +_get_imp_data(sv) + SV * sv + CODE: + D_imp_xxh(sv); + (void)cv; + ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh)); /* okay if NULL */ + + +void +_handles(sv) + SV * sv + PPCODE: + /* return the outer and inner handle for any given handle */ + D_imp_xxh(sv); + SV *ih = sv_mortalcopy( dbih_inner(aTHX_ sv, "_handles") ); + SV *oh = sv_2mortal(newRV_inc((SV*)DBIc_MY_H(imp_xxh))); /* XXX dangerous */ + (void)cv; + EXTEND(SP, 2); + PUSHs(oh); /* returns outer handle then inner */ + PUSHs(ih); + + +void +neat(sv, maxlen=0) + SV * sv + U32 maxlen + CODE: + ST(0) = sv_2mortal(newSVpv(neatsvpv(sv, maxlen), 0)); + (void)cv; + + +I32 +hash(key, type=0) + const char *key + long type + CODE: + (void)cv; + RETVAL = dbi_hash(key, type); + OUTPUT: + RETVAL + +void +looks_like_number(...) + PPCODE: + int i; + EXTEND(SP, items); + (void)cv; + for(i=0; i < items ; ++i) { + SV *sv = ST(i); + if (!SvOK(sv) || (SvPOK(sv) && SvCUR(sv)==0)) + PUSHs(&PL_sv_undef); + else if ( looks_like_number(sv) ) + PUSHs(&PL_sv_yes); + else + PUSHs(&PL_sv_no); + } + + +void +_install_method(dbi_class, meth_name, file, attribs=Nullsv) + const char * dbi_class + char * meth_name + char * file + SV * attribs + CODE: + { + 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; + MAGIC *mg; + (void)dbi_class; + + if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */ + croak("install_method %s: invalid class", meth_name); + + 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 */ + if (SvTYPE(SvRV(attribs)) != SVt_PVHV) + croak("install_method %s: bad attribs", meth_name); + + 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); + + if (trace_msg) { + if (ima->flags) sv_catpvf(trace_msg, ", flags 0x%04x", (unsigned)ima->flags); + if (ima->method_trace)sv_catpvf(trace_msg, ", T 0x%08lx", (unsigned long)ima->method_trace); + if (ima->hidearg) sv_catpvf(trace_msg, ", H %u", (unsigned)ima->hidearg); + } + if ( (svp=DBD_ATTRIB_GET_SVP(attribs, "U",1)) != NULL) { + AV *av = (AV*)SvRV(*svp); + ima->minargs = (U8)SvIV(*av_fetch(av, 0, 1)); + ima->maxargs = (U8)SvIV(*av_fetch(av, 1, 1)); + svp = av_fetch(av, 2, 0); + ima->usage_msg = (svp) ? savepv_using_sv(SvPV_nolen(*svp)) : ""; + ima->flags |= IMA_HAS_USAGE; + if (trace_msg && DBIS_TRACE_LEVEL >= 11) + sv_catpvf(trace_msg, ",\n usage: min %d, max %d, '%s'", + ima->minargs, ima->maxargs, ima->usage_msg); + } + } + 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; + } + + +int +trace(class, level_sv=&PL_sv_undef, file=Nullsv) + SV * class + SV * level_sv + SV * file + ALIAS: + _debug_dispatch = 1 + CODE: + { + dMY_CXT; + IV level; + if (!DBIS) { + ix=ix; /* avoid 'unused variable' warnings */ + croak("DBI not initialised"); + } + /* Return old/current value. No change if new value not given. */ + RETVAL = (DBIS) ? DBIS->debug : 0; + level = parse_trace_flags(class, level_sv, RETVAL); + if (level) /* call before or after altering DBI trace level */ + set_trace_file(file); + if (level != RETVAL) { + if ((level & DBIc_TRACE_LEVEL_MASK) > 0) { + PerlIO_printf(DBILOGFP," DBI %s%s default trace level set to 0x%lx/%ld (pid %d pi %p) at %s\n", + XS_VERSION, dbi_build_opt, + (long)(level & DBIc_TRACE_FLAGS_MASK), + (long)(level & DBIc_TRACE_LEVEL_MASK), + (int)PerlProc_getpid(), +#ifdef MULTIPLICITY + (void *)my_perl, +#else + (void*)NULL, +#endif + log_where(Nullsv, 0, "", "", 1, 1, 0) + ); + if (!PL_dowarn) + PerlIO_printf(DBILOGFP," Note: perl is running without the recommended perl -w option\n"); + PerlIO_flush(DBILOGFP); + } + DBIS->debug = level; + sv_setiv(get_sv("DBI::dbi_debug",0x5), level); + } + if (!level) /* call before or after altering DBI trace level */ + set_trace_file(file); + } + OUTPUT: + RETVAL + + + +void +dump_handle(sv, msg="DBI::dump_handle", level=0) + SV * sv + const char *msg + int level + CODE: + (void)cv; + dbih_dumphandle(aTHX_ sv, msg, level); + + + +void +_svdump(sv) + SV * sv + CODE: + { + dMY_CXT; + (void)cv; + PerlIO_printf(DBILOGFP, "DBI::_svdump(%s)", neatsvpv(sv,0)); +#ifdef DEBUGGING + sv_dump(sv); +#endif + } + + +NV +dbi_time() + + +void +dbi_profile(h, statement, method, t1, t2) + SV *h + SV *statement + SV *method + NV t1 + NV t2 + CODE: + SV *leaf = &PL_sv_undef; + (void)cv; /* avoid unused var warnings */ + if (SvROK(method)) + method = SvRV(method); + if (dbih_inner(aTHX_ h, NULL)) { /* is a DBI handle */ + D_imp_xxh(h); + leaf = dbi_profile(h, imp_xxh, statement, method, t1, t2); + } + else if (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV) { + /* iterate over values %$h */ + HV *hv = (HV*)SvRV(h); + SV *tmp; + char *key; + I32 keylen = 0; + hv_iterinit(hv); + while ( (tmp = hv_iternextsv(hv, &key, &keylen)) != NULL ) { + if (SvOK(tmp)) { + D_imp_xxh(tmp); + leaf = dbi_profile(tmp, imp_xxh, statement, method, t1, t2); + } + }; + } + else { + croak("dbi_profile(%s,...) invalid handle argument", neatsvpv(h,0)); + } + if (GIMME_V == G_VOID) + ST(0) = &PL_sv_undef; /* skip sv_mortalcopy if not needed */ + else + ST(0) = sv_mortalcopy(leaf); + + + +SV * +dbi_profile_merge_nodes(dest, ...) + SV * dest + ALIAS: + dbi_profile_merge = 1 + CODE: + { + 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; + RETVAL = 0; + } + else { + /* items==2 for dest + 1 arg, ST(0) is dest, ST(1) is first arg */ + while (--items >= 1) { + SV *thingy = ST(items); + dbi_profile_merge_nodes(dest, thingy); + } + RETVAL = newSVsv(*av_fetch((AV*)SvRV(dest), DBIprof_TOTAL_TIME, 1)); + } + } + OUTPUT: + RETVAL + + +SV * +_concat_hash_sorted(hash_sv, kv_sep_sv, pair_sep_sv, use_neat_sv, num_sort_sv) + SV *hash_sv + SV *kv_sep_sv + SV *pair_sep_sv + SV *use_neat_sv + SV *num_sort_sv + PREINIT: + char *kv_sep, *pair_sep; + STRLEN kv_sep_len, pair_sep_len; + CODE: + if (!SvOK(hash_sv)) + XSRETURN_UNDEF; + if (!SvROK(hash_sv) || SvTYPE(SvRV(hash_sv))!=SVt_PVHV) + croak("hash is not a hash reference"); + + kv_sep = SvPV(kv_sep_sv, kv_sep_len); + pair_sep = SvPV(pair_sep_sv, pair_sep_len); + + RETVAL = _join_hash_sorted( (HV*)SvRV(hash_sv), + kv_sep, kv_sep_len, + pair_sep, pair_sep_len, + /* use_neat should be undef, 0 or 1, may allow sprintf format strings later */ + (SvOK(use_neat_sv)) ? SvIV(use_neat_sv) : 0, + (SvOK(num_sort_sv)) ? SvIV(num_sort_sv) : -1 + ); + OUTPUT: + RETVAL + + +int +sql_type_cast(sv, sql_type, flags=0) + SV * sv + int sql_type + U32 flags + CODE: + RETVAL = sql_type_cast_svpv(aTHX_ sv, sql_type, flags, 0); + OUTPUT: + RETVAL + + + +MODULE = DBI PACKAGE = DBI::var + +void +FETCH(sv) + SV * sv + CODE: + 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 */ + imp_xxh_t *imp_xxh = (DBI_LAST_HANDLE_OK) ? DBIh_COM(DBI_LAST_HANDLE) : NULL; + int trace_level = (imp_xxh ? DBIc_TRACE_LEVEL(imp_xxh) : DBIS_TRACE_LEVEL); + NV profile_t1 = 0.0; + + if (imp_xxh && DBIc_has(imp_xxh,DBIcf_Profile)) + profile_t1 = dbi_time(); + + if (trace_level >= 2) { + PerlIO_printf(DBILOGFP," -> $DBI::%s (%c) FETCH from lasth=%s\n", meth, type, + (imp_xxh) ? neatsvpv(DBI_LAST_HANDLE,0): "none"); + } + + if (type == '!') { /* special case for $DBI::lasth */ + /* Currently we can only return the INNER handle. */ + /* This handle should only be used for true/false tests */ + ST(0) = (imp_xxh) ? sv_2mortal(newRV_inc(DBI_LAST_HANDLE)) : &PL_sv_undef; + } + else if ( !imp_xxh ) { + if (trace_level) + warn("Can't read $DBI::%s, last handle unknown or destroyed", meth); + ST(0) = &PL_sv_undef; + } + else if (type == '*') { /* special case for $DBI::err, see also err method */ + SV *errsv = DBIc_ERR(imp_xxh); + ST(0) = sv_mortalcopy(errsv); + } + else if (type == '"') { /* special case for $DBI::state */ + SV *state = DBIc_STATE(imp_xxh); + ST(0) = DBIc_STATE_adjust(imp_xxh, state); + } + else if (type == '$') { /* lookup scalar variable in implementors stash */ + const char *vname = mkvname(aTHX_ DBIc_IMP_STASH(imp_xxh), meth, 0); + SV *vsv = get_sv(vname, 1); + ST(0) = sv_mortalcopy(vsv); + } + else { + /* default to method call via stash of implementor of DBI_LAST_HANDLE */ + GV *imp_gv; + HV *imp_stash = DBIc_IMP_STASH(imp_xxh); +#ifdef DBI_save_hv_fetch_ent + HE save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */ +#endif + profile_t1 = 0.0; /* profile this via dispatch only (else we'll double count) */ + if (trace_level >= 3) + PerlIO_printf(DBILOGFP," >> %s::%s\n", HvNAME(imp_stash), meth); + ST(0) = sv_2mortal(newRV_inc(DBI_LAST_HANDLE)); + if ((imp_gv = gv_fetchmethod(imp_stash,meth)) == NULL) { + croak("Can't locate $DBI::%s object method \"%s\" via package \"%s\"", + meth, meth, HvNAME(imp_stash)); + } + PUSHMARK(mark); /* reset mark (implies one arg as we were called with one arg?) */ + call_sv((SV*)GvCV(imp_gv), GIMME); + SPAGAIN; +#ifdef DBI_save_hv_fetch_ent + PL_hv_fetch_ent_mh = save_mh; +#endif + } + if (trace_level) + PerlIO_printf(DBILOGFP," <- $DBI::%s= %s\n", meth, neatsvpv(ST(0),0)); + if (profile_t1) { + SV *h = sv_2mortal(newRV_inc(DBI_LAST_HANDLE)); + dbi_profile(h, imp_xxh, &PL_sv_undef, (SV*)cv, profile_t1, dbi_time()); + } + + +MODULE = DBI PACKAGE = DBD::_::dr + +void +dbixs_revision(h) + SV * h + CODE: + PERL_UNUSED_VAR(h); + ST(0) = sv_2mortal(newSViv(DBIXS_REVISION)); + + +MODULE = DBI PACKAGE = DBD::_::db + +void +connected(...) + CODE: + /* defined here just to avoid AUTOLOAD */ + (void)cv; + (void)items; + ST(0) = &PL_sv_undef; + + +SV * +preparse(dbh, statement, ps_accept, ps_return, foo=Nullch) + SV * dbh + char * statement + IV ps_accept + IV ps_return + void *foo + + +void +take_imp_data(h) + SV * h + PREINIT: + /* take_imp_data currently in DBD::_::db not DBD::_::common, so for dbh's only */ + D_imp_xxh(h); + MAGIC *mg; + SV *imp_xxh_sv; + SV **tmp_svp; + CODE: + (void)cv; /* unused */ + /* + * 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 + * leaving it as an empty shell - brain dead. All method calls on it fail. + * + * The imp_xxh_t structure that's removed and returned is a plain scalar + * (containing binary data). It can be passed to a new DBI->connect call + * in order to have the new $dbh use the same 'connection' as the original + * handle. In this way a multi-threaded connection pool can be implemented. + * + * If the drivers imp_xxh_t structure contains SV*'s, or other interpreter + * specific items, they should be freed by the drivers own take_imp_data() + * method before it then calls SUPER::take_imp_data() to finalize removal + * of the imp_xxh_t structure. + * + * The driver needs to view the take_imp_data method as being nearly the + * same as disconnect+DESTROY only not actually calling the database API to + * disconnect. All that needs to remain valid in the imp_xxh_t structure + * is the underlying database API connection data. Everything else should + * in a 'clean' state such that if the drivers own DESTROY method was + * called it would be able to properly handle the contents of the + * structure. This is important in case a new handle created using this + * imp_data, possibly in a new thread, might end up being DESTROY'd before + * the driver has had a chance to 're-setup' the data. See dbih_setup_handle() + * + * All the above relates to the 'typical use case' for a compiled driver. + * For a pure-perl driver using a socket pair, for example, the drivers + * take_imp_data method might just return a string containing the fileno() + * values of the sockets (without calling this SUPER::take_imp_data() code). + * The key point is that the take_imp_data() method returns an opaque buffer + * containing whatever the driver would need to reuse the same underlying + * 'connection to the database' in a new handle. + * + * In all cases, care should be taken that driver attributes (such as + * AutoCommit) match the state of the underlying connection. + */ + + if (!DBIc_ACTIVE(imp_xxh)) {/* sanity check, may be relaxed later */ + set_err_char(h, imp_xxh, "1", 1, "Can't take_imp_data from handle that's not Active", 0, "take_imp_data"); + XSRETURN(0); + } + + /* Ideally there should be no child statement handles existing when + * take_imp_data is called because when those statement handles are + * destroyed they may need to interact with the 'zombie' parent dbh. + * So we do our best to neautralize them (finish & rebless) + */ + if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) { + AV *av = (AV*)SvRV(*tmp_svp); + HV *zombie_stash = gv_stashpv("DBI::zombie", GV_ADDWARN); + I32 kidslots; + for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) { + SV **hp = av_fetch(av, kidslots, FALSE); + if (hp && SvROK(*hp) && SvMAGICAL(SvRV(*hp))) { + PUSHMARK(sp); + XPUSHs(*hp); + PUTBACK; + call_method("finish", G_SCALAR|G_DISCARD); + SPAGAIN; + PUTBACK; + sv_unmagic(SvRV(*hp), 'P'); /* untie */ + sv_bless(*hp, zombie_stash); /* neutralise */ + } + } + } + /* The above measures may not be sufficient if weakrefs aren't available + * or something has a reference to the inner-handle of an sth. + * We'll require no Active kids, but just warn about others. + */ + if (DBIc_ACTIVE_KIDS(imp_xxh)) { + set_err_char(h, imp_xxh, "1", 1, "Can't take_imp_data from handle while it still has Active kids", 0, "take_imp_data"); + XSRETURN(0); + } + if (DBIc_KIDS(imp_xxh)) + warn("take_imp_data from handle while it still has kids"); + + /* it may be better here to return a copy and poison the original + * rather than detatching and returning the original + */ + + /* --- perform the surgery */ + 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 */ + DBIc_ACTIVE_off(imp_xxh); /* silence warning from dbih_clearcom */ + DBIc_IMPSET_off(imp_xxh); /* silence warning from dbih_clearcom */ + dbih_clearcom(imp_xxh); /* free SVs like DBD::_mem::common::DESTROY */ + SvOBJECT_off(imp_xxh_sv); /* no longer needs DESTROY via dbih_clearcom */ + /* restore flags to mark fact imp data holds active connection */ + /* (don't use magical DBIc_ACTIVE_on here) */ + DBIc_FLAGS(imp_xxh) |= DBIcf_IMPSET | DBIcf_ACTIVE; + /* --- tidy up the raw PV for life as a more normal string */ + SvPOK_on(imp_xxh_sv); /* SvCUR & SvEND were set at creation */ + /* --- return the actual imp_xxh_sv on the stack */ + ST(0) = imp_xxh_sv; + + + +MODULE = DBI PACKAGE = DBD::_::st + +void +_get_fbav(sth) + SV * sth + CODE: + D_imp_sth(sth); + AV *av = dbih_get_fbav(imp_sth); + (void)cv; + ST(0) = sv_2mortal(newRV_inc((SV*)av)); + +void +_set_fbav(sth, src_rv) + SV * sth + SV * src_rv + CODE: + D_imp_sth(sth); + int i; + AV *src_av; + AV *dst_av = dbih_get_fbav(imp_sth); + int dst_fields = AvFILL(dst_av)+1; + int src_fields; + (void)cv; + + if (!SvROK(src_rv) || SvTYPE(SvRV(src_rv)) != SVt_PVAV) + croak("_set_fbav(%s): not an array ref", neatsvpv(src_rv,0)); + src_av = (AV*)SvRV(src_rv); + src_fields = AvFILL(src_av)+1; + if (src_fields != dst_fields) { + warn("_set_fbav(%s): array has %d elements, the statement handle row buffer has %d (and NUM_OF_FIELDS is %d)", + neatsvpv(src_rv,0), src_fields, dst_fields, DBIc_NUM_FIELDS(imp_sth)); + SvREADONLY_off(dst_av); + if (src_fields < dst_fields) { + /* shrink the array - sadly this looses column bindings for the lost columns */ + av_fill(dst_av, src_fields-1); + dst_fields = src_fields; + } + else { + av_fill(dst_av, src_fields-1); + /* av_fill pads with immutable undefs which we need to change */ + for(i=dst_fields-1; i < src_fields; ++i) { + sv_setsv(AvARRAY(dst_av)[i], newSV(0)); + } + } + SvREADONLY_on(dst_av); + } + for(i=0; i < dst_fields; ++i) { /* copy over the row */ + /* If we're given the values, then taint them if required */ + if (DBIc_is(imp_sth, DBIcf_TaintOut)) + SvTAINT(AvARRAY(src_av)[i]); + sv_setsv(AvARRAY(dst_av)[i], AvARRAY(src_av)[i]); + } + ST(0) = sv_2mortal(newRV_inc((SV*)dst_av)); + + +void +bind_col(sth, col, ref, attribs=Nullsv) + SV * sth + SV * col + SV * ref + SV * attribs + CODE: + DBD_ATTRIBS_CHECK("bind_col", sth, attribs); + ST(0) = boolSV(dbih_sth_bind_col(sth, col, ref, attribs)); + (void)cv; + + +void +fetchrow_array(sth) + SV * sth + ALIAS: + fetchrow = 1 + PPCODE: + SV *retsv; + if (CvDEPTH(cv) == 99) { + ix = ix; /* avoid 'unused variable' warning' */ + croak("Deep recursion, probably fetchrow-fetch-fetchrow loop"); + } + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + if (call_method("fetch", G_SCALAR) != 1) + croak("panic: DBI fetch"); /* should never happen */ + SPAGAIN; + retsv = POPs; + PUTBACK; + if (SvROK(retsv) && SvTYPE(SvRV(retsv)) == SVt_PVAV) { + D_imp_sth(sth); + int num_fields, i; + AV *bound_av; + AV *av = (AV*)SvRV(retsv); + num_fields = AvFILL(av)+1; + EXTEND(sp, num_fields+1); + + /* We now check for bind_col() having been called but fetch */ + /* not returning the fields_svav array. Probably because the */ + /* driver is implemented in perl. XXX This logic may change later. */ + bound_av = DBIc_FIELDS_AV(imp_sth); /* bind_col() called ? */ + if (bound_av && av != bound_av) { + /* 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(DBIc_LOGPIO(imp_sth), + "fetchrow: updating fbav 0x%lx from 0x%lx\n", + (long)bound_av, (long)av); + } + for(i=0; i < num_fields; ++i) { /* copy over the row */ + sv_setsv(AvARRAY(bound_av)[i], AvARRAY(av)[i]); + } + } + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(av)[i]); + } + } + + +SV * +fetchrow_hashref(sth, keyattrib=Nullch) + SV * sth + const char *keyattrib + PREINIT: + SV *rowavr; + SV *ka_rv; + D_imp_sth(sth); + CODE: + (void)cv; + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + if (!keyattrib || !*keyattrib) { + SV *kn = DBIc_FetchHashKeyName(imp_sth); + if (kn && SvOK(kn)) + keyattrib = SvPVX(kn); + else + keyattrib = "NAME"; + } + ka_rv = *hv_fetch((HV*)DBIc_MY_H(imp_sth), keyattrib,strlen(keyattrib), TRUE); + /* we copy to invoke FETCH magic, and we do that before fetch() so if tainting */ + /* then the taint triggered by the fetch won't then apply to the fetched name */ + ka_rv = newSVsv(ka_rv); + if (call_method("fetch", G_SCALAR) != 1) + croak("panic: DBI fetch"); /* should never happen */ + SPAGAIN; + rowavr = POPs; + PUTBACK; + /* have we got an array ref in rowavr */ + if (SvROK(rowavr) && SvTYPE(SvRV(rowavr)) == SVt_PVAV) { + int i; + AV *rowav = (AV*)SvRV(rowavr); + const int num_fields = AvFILL(rowav)+1; + HV *hv; + AV *ka_av; + if (!(SvROK(ka_rv) && SvTYPE(SvRV(ka_rv))==SVt_PVAV)) { + sv_setiv(DBIc_ERR(imp_sth), 1); + sv_setpvf(DBIc_ERRSTR(imp_sth), + "Can't use attribute '%s' because it doesn't contain a reference to an array (%s)", + keyattrib, neatsvpv(ka_rv,0)); + XSRETURN_UNDEF; + } + ka_av = (AV*)SvRV(ka_rv); + hv = newHV(); + for (i=0; i < num_fields; ++i) { /* honor the original order as sent by the database */ + SV **field_name_svp = av_fetch(ka_av, i, 1); + (void)hv_store_ent(hv, *field_name_svp, newSVsv((SV*)(AvARRAY(rowav)[i])), 0); + } + RETVAL = newRV_inc((SV*)hv); + SvREFCNT_dec(hv); /* since newRV incremented it */ + } + else { + RETVAL = &PL_sv_undef; +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 4)) + RETVAL = newSV(0); /* mutable undef for 5.004_04 */ +#endif + } + SvREFCNT_dec(ka_rv); /* since we created it */ + OUTPUT: + RETVAL + + +void +fetch(sth) + SV * sth + ALIAS: + fetchrow_arrayref = 1 + CODE: + int num_fields; + if (CvDEPTH(cv) == 99) { + (void)ix; /* avoid 'unused variable' warning' */ + croak("Deep recursion. Probably fetch-fetchrow-fetch loop."); + } + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + num_fields = call_method("fetchrow", G_ARRAY); /* XXX change the name later */ + SPAGAIN; + if (num_fields == 0) { + ST(0) = &PL_sv_undef; + } else { + D_imp_sth(sth); + AV *av = dbih_get_fbav(imp_sth); + if (num_fields != AvFILL(av)+1) + croak("fetchrow returned %d fields, expected %d", + num_fields, (int)AvFILL(av)+1); + SPAGAIN; + while(--num_fields >= 0) + sv_setsv(AvARRAY(av)[num_fields], POPs); + PUTBACK; + ST(0) = sv_2mortal(newRV_inc((SV*)av)); + } + + +void +rows(sth) + SV * sth + CODE: + D_imp_sth(sth); + const IV rows = DBIc_ROW_COUNT(imp_sth); + ST(0) = sv_2mortal(newSViv(rows)); + (void)cv; + + +void +finish(sth) + SV * sth + CODE: + D_imp_sth(sth); + DBIc_ACTIVE_off(imp_sth); + ST(0) = &PL_sv_yes; + (void)cv; + + +void +DESTROY(sth) + SV * sth + PPCODE: + /* keep in sync with DESTROY in Driver.xst */ + D_imp_sth(sth); + ST(0) = &PL_sv_yes; + /* we don't test IMPSET here because this code applies to pure-perl drivers */ + if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */ + DBIc_ACTIVE_off(imp_sth); + if (DBIc_TRACE_LEVEL(imp_sth)) + PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth)); + } + if (DBIc_ACTIVE(imp_sth)) { + D_imp_dbh_from_sth; + if (!PL_dirty && DBIc_ACTIVE(imp_dbh)) { + dSP; + PUSHMARK(sp); + XPUSHs(sth); + PUTBACK; + call_method("finish", G_SCALAR); + SPAGAIN; + PUTBACK; + } + else { + DBIc_ACTIVE_off(imp_sth); + } + } + + +MODULE = DBI PACKAGE = DBI::st + +void +TIEHASH(class, inner_ref) + SV * class + SV * inner_ref + CODE: + HV *stash = gv_stashsv(class, GV_ADDWARN); /* a new hash is supplied to us, we just need to bless and apply tie magic */ + sv_bless(inner_ref, stash); + ST(0) = inner_ref; + +MODULE = DBI PACKAGE = DBD::_::common + + +void +DESTROY(h) + SV * h + CODE: + /* DESTROY defined here just to avoid AUTOLOAD */ + (void)cv; + (void)h; + ST(0) = &PL_sv_undef; + + +void +STORE(h, keysv, valuesv) + SV * h + SV * keysv + SV * valuesv + CODE: + ST(0) = &PL_sv_yes; + if (!dbih_set_attr_k(h, keysv, 0, valuesv)) + ST(0) = &PL_sv_no; + (void)cv; + + +void +FETCH(h, keysv) + SV * h + SV * keysv + CODE: + ST(0) = dbih_get_attr_k(h, keysv, 0); + (void)cv; + + +void +private_data(h) + SV * h + CODE: + D_imp_xxh(h); + (void)cv; + ST(0) = sv_mortalcopy(DBIc_IMP_DATA(imp_xxh)); + + +void +err(h) + SV * h + CODE: + D_imp_xxh(h); + SV *errsv = DBIc_ERR(imp_xxh); + (void)cv; + ST(0) = sv_mortalcopy(errsv); + +void +state(h) + SV * h + CODE: + D_imp_xxh(h); + SV *state = DBIc_STATE(imp_xxh); + (void)cv; + ST(0) = DBIc_STATE_adjust(imp_xxh, state); + +void +errstr(h) + SV * h + CODE: + D_imp_xxh(h); + SV *errstr = DBIc_ERRSTR(imp_xxh); + SV *err; + /* If there's no errstr but there is an err then use err */ + (void)cv; + if (!SvTRUE(errstr) && (err=DBIc_ERR(imp_xxh)) && SvTRUE(err)) + errstr = err; + ST(0) = sv_mortalcopy(errstr); + + +void +set_err(h, err, errstr=&PL_sv_no, state=&PL_sv_undef, method=&PL_sv_undef, result=Nullsv) + SV * h + SV * err + SV * errstr + SV * state + SV * method + SV * result + PPCODE: + { + D_imp_xxh(h); + SV **sem_svp; + (void)cv; + + if (DBIc_has(imp_xxh, DBIcf_HandleSetErr) && SvREADONLY(method)) + method = sv_mortalcopy(method); /* HandleSetErr may want to change it */ + + if (!set_err_sv(h, imp_xxh, err, errstr, state, method)) { + /* set_err was canceled by HandleSetErr, */ + /* don't set "dbi_set_err_method", return an empty list */ + } + else { + /* store provided method name so handler code can find it */ + sem_svp = hv_fetch((HV*)SvRV(h), "dbi_set_err_method", 18, 1); + if (SvOK(method)) { + sv_setpv(*sem_svp, SvPV_nolen(method)); + } + else + (void)SvOK_off(*sem_svp); + EXTEND(SP, 1); + PUSHs( result ? result : &PL_sv_undef ); + } + /* We don't check RaiseError and call die here because that must be */ + /* done by returning through dispatch and letting the DBI handle it */ + } + + +int +trace(h, level=&PL_sv_undef, file=Nullsv) + SV *h + SV *level + SV *file + ALIAS: + debug = 1 + CODE: + RETVAL = set_trace(h, level, file); + (void)cv; /* Unused variables */ + (void)ix; + OUTPUT: + RETVAL + + +void +trace_msg(sv, msg, this_trace=1) + SV *sv + const char *msg + int this_trace + PREINIT: + int current_trace; + PerlIO *pio; + CODE: + { + dMY_CXT; + (void)cv; + if (SvROK(sv)) { + D_imp_xxh(sv); + current_trace = DBIc_TRACE_LEVEL(imp_xxh); + pio = DBIc_LOGPIO(imp_xxh); + } + else { /* called as a static method */ + current_trace = DBIS_TRACE_FLAGS; + pio = DBILOGFP; + } + if (DBIc_TRACE_MATCHES(this_trace, current_trace)) { + PerlIO_puts(pio, msg); + ST(0) = &PL_sv_yes; + } + else { + ST(0) = &PL_sv_no; + } + } + + +void +rows(h) + SV * h + CODE: + /* fallback esp for $DBI::rows after $drh was last used */ + ST(0) = sv_2mortal(newSViv(-1)); + (void)h; + (void)cv; + + +void +swap_inner_handle(rh1, rh2, allow_reparent=0) + SV * rh1 + SV * rh2 + IV allow_reparent + CODE: + { + D_impdata(imp_xxh1, imp_xxh_t, rh1); + D_impdata(imp_xxh2, imp_xxh_t, rh2); + SV *h1i = dbih_inner(aTHX_ rh1, "swap_inner_handle"); + SV *h2i = dbih_inner(aTHX_ rh2, "swap_inner_handle"); + SV *h1 = (rh1 == h1i) ? (SV*)DBIc_MY_H(imp_xxh1) : SvRV(rh1); + SV *h2 = (rh2 == h2i) ? (SV*)DBIc_MY_H(imp_xxh2) : SvRV(rh2); + (void)cv; + + if (DBIc_TYPE(imp_xxh1) != DBIc_TYPE(imp_xxh2)) { + char buf[99]; + sprintf(buf, "Can't swap_inner_handle between %sh and %sh", + dbih_htype_name(DBIc_TYPE(imp_xxh1)), dbih_htype_name(DBIc_TYPE(imp_xxh2))); + DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, buf, Nullch, Nullch); + XSRETURN_NO; + } + if (!allow_reparent && DBIc_PARENT_COM(imp_xxh1) != DBIc_PARENT_COM(imp_xxh2)) { + DBIh_SET_ERR_CHAR(rh1, imp_xxh1, "1", 1, + "Can't swap_inner_handle with handle from different parent", + Nullch, Nullch); + XSRETURN_NO; + } + + SvREFCNT_inc(h1i); + SvREFCNT_inc(h2i); + + sv_unmagic(h1, 'P'); /* untie(%$h1) */ + sv_unmagic(h2, 'P'); /* untie(%$h2) */ + + sv_magic(h1, h2i, 'P', Nullch, 0); /* tie %$h1, $h2i */ + DBIc_MY_H(imp_xxh2) = (HV*)h1; + + sv_magic(h2, h1i, 'P', Nullch, 0); /* tie %$h2, $h1i */ + DBIc_MY_H(imp_xxh1) = (HV*)h2; + + SvREFCNT_dec(h1i); + SvREFCNT_dec(h2i); + + ST(0) = &PL_sv_yes; + } + + +MODULE = DBI PACKAGE = DBD::_mem::common + +void +DESTROY(imp_xxh_rv) + SV * imp_xxh_rv + CODE: + /* ignore 'cast increases required alignment' warning */ + imp_xxh_t *imp_xxh = (imp_xxh_t*)SvPVX(SvRV(imp_xxh_rv)); + DBIc_DBISTATE(imp_xxh)->clearcom(imp_xxh); + (void)cv; + +# end diff --git a/DBIXS.h b/DBIXS.h new file mode 100644 index 0000000..f1a3963 --- /dev/null +++ b/DBIXS.h @@ -0,0 +1,573 @@ +/* vim: ts=8:sw=4:expandtab + * + * $Id: DBIXS.h 15268 2012-04-18 11:34:59Z timbo $ + * + * Copyright (c) 1994-2010 Tim Bunce Ireland + * + * See COPYRIGHT section in DBI.pm for usage and distribution rights. + */ + +/* DBI Interface Definitions for DBD Modules */ + +#ifndef DBIXS_VERSION /* prevent multiple inclusion */ + +#ifndef DBIS +#define DBIS dbis /* default name for dbistate_t variable */ +#endif + +/* Here for backwards compat. PERL_POLLUTE was removed in perl 5.13.3 */ +#define PERL_POLLUTE + +/* first pull in the standard Perl header files for extensions */ +#include +#include +#include + +#ifdef debug /* causes problems with DBIS->debug */ +#undef debug +#endif + +#ifdef std /* causes problems with STLport */ +#undef std +#endif + +/* define DBIXS_REVISION */ +#include "dbixs_rev.h" + +/* Perl backwards compatibility definitions */ +#include "dbipport.h" + +/* DBI SQL_* type definitions */ +#include "dbi_sql.h" + + +#define DBIXS_VERSION 93 /* superceeded by DBIXS_REVISION */ + +#ifdef NEED_DBIXS_VERSION +#if NEED_DBIXS_VERSION > DBIXS_VERSION +error You_need_to_upgrade_your_DBI_module_before_building_this_driver +#endif +#else +#define NEED_DBIXS_VERSION DBIXS_VERSION +#endif + + +#define DBI_LOCK +#define DBI_UNLOCK + +#ifndef DBI_NO_THREADS +#ifdef USE_ITHREADS +#define DBI_USE_THREADS +#endif /* USE_ITHREADS */ +#endif /* DBI_NO_THREADS */ + + +/* forward struct declarations */ + +typedef struct dbistate_st dbistate_t; +/* implementor needs to define actual struct { dbih_??c_t com; ... }*/ +typedef struct imp_drh_st imp_drh_t; /* driver */ +typedef struct imp_dbh_st imp_dbh_t; /* database */ +typedef struct imp_sth_st imp_sth_t; /* statement */ +typedef struct imp_fdh_st imp_fdh_t; /* field descriptor */ +typedef struct imp_xxh_st imp_xxh_t; /* any (defined below) */ +#define DBI_imp_data_ imp_xxh_t /* friendly for take_imp_data */ + + + +/* --- DBI Handle Common Data Structure (all handles have one) --- */ + +/* Handle types. Code currently assumes child = parent + 1. */ +#define DBIt_DR 1 +#define DBIt_DB 2 +#define DBIt_ST 3 +#define DBIt_FD 4 + +/* component structures */ + +typedef struct dbih_com_std_st { + U32 flags; + int call_depth; /* used by DBI to track nested calls (int) */ + U16 type; /* DBIt_DR, DBIt_DB, DBIt_ST */ + HV *my_h; /* copy of outer handle HV (not refcounted) */ + SV *parent_h; /* parent inner handle (ref to hv) (r.c.inc) */ + imp_xxh_t *parent_com; /* parent com struct shortcut */ + PerlInterpreter * thr_user; /* thread that owns the handle */ + + HV *imp_stash; /* who is the implementor for this handle */ + SV *imp_data; /* optional implementors data (for perl imp's) */ + + I32 kids; /* count of db's for dr's, st's for db's etc */ + I32 active_kids; /* kids which are currently DBIc_ACTIVE */ + U32 pid; /* pid of process that created handle */ + dbistate_t *dbistate; +} dbih_com_std_t; + +typedef struct dbih_com_attr_st { + /* These are copies of the Hash values (ref.cnt.inc'd) */ + /* Many of the hash values are themselves references */ + SV *TraceLevel; + SV *State; /* Standard SQLSTATE, 5 char string */ + SV *Err; /* Native engine error code */ + SV *Errstr; /* Native engine error message */ + UV ErrCount; + U32 LongReadLen; /* auto read length for long/blob types */ + SV *FetchHashKeyName; /* for fetchrow_hashref */ + /* (NEW FIELDS?... DON'T FORGET TO UPDATE dbih_clearcom()!) */ +} dbih_com_attr_t; + + +struct dbih_com_st { /* complete core structure (typedef'd above) */ + dbih_com_std_t std; + dbih_com_attr_t attr; +}; + +/* This 'implementors' type the DBI defines by default as a way to */ +/* refer to the imp_??h data of a handle without considering its type. */ +struct imp_xxh_st { struct dbih_com_st com; }; + +/* Define handle-type specific structures for implementors to include */ +/* at the start of their private structures. */ + +typedef struct { /* -- DRIVER -- */ + dbih_com_std_t std; + dbih_com_attr_t attr; + HV *_old_cached_kids; /* not used, here for binary compat */ +} dbih_drc_t; + +typedef struct { /* -- DATABASE -- */ + dbih_com_std_t std; /* \__ standard structure */ + dbih_com_attr_t attr; /* / plus... (nothing else right now) */ + HV *_old_cached_kids; /* not used, here for binary compat */ +} dbih_dbc_t; + +typedef struct { /* -- STATEMENT -- */ + dbih_com_std_t std; /* \__ standard structure */ + dbih_com_attr_t attr; /* / plus ... */ + + int num_params; /* number of placeholders */ + int num_fields; /* NUM_OF_FIELDS, must be set */ + AV *fields_svav; /* special row buffer (inc bind_cols) */ + IV row_count; /* incremented by get_fbav() */ + + AV *fields_fdav; /* not used yet, may change */ + + I32 spare1; + void *spare2; +} dbih_stc_t; + + +/* XXX THIS STRUCTURE SHOULD NOT BE USED */ +typedef struct { /* -- FIELD DESCRIPTOR -- */ + dbih_com_std_t std; /* standard structure (not fully setup) */ + + /* core attributes (from DescribeCol in ODBC) */ + char *col_name; /* see dbih_make_fdsv */ + I16 col_name_len; + I16 col_sql_type; + I16 col_precision; + I16 col_scale; + I16 col_nullable; + + /* additional attributes (from ColAttributes in ODBC) */ + I32 col_length; + I32 col_disp_size; + + I32 spare1; + void *spare2; +} dbih_fdc_t; + + +#define _imp2com(p,f) ((p)->com.f) /* private */ + +#define DBIc_FLAGS(imp) _imp2com(imp, std.flags) +#define DBIc_TYPE(imp) _imp2com(imp, std.type) +#define DBIc_CALL_DEPTH(imp) _imp2com(imp, std.call_depth) +#define DBIc_MY_H(imp) _imp2com(imp, std.my_h) +#define DBIc_PARENT_H(imp) _imp2com(imp, std.parent_h) +#define DBIc_PARENT_COM(imp) _imp2com(imp, std.parent_com) +#define DBIc_THR_COND(imp) _imp2com(imp, std.thr_cond) +#define DBIc_THR_USER(imp) _imp2com(imp, std.thr_user) +#define DBIc_THR_USER_NONE (0xFFFF) +#define DBIc_IMP_STASH(imp) _imp2com(imp, std.imp_stash) +#define DBIc_IMP_DATA(imp) _imp2com(imp, std.imp_data) +#define DBIc_DBISTATE(imp) _imp2com(imp, std.dbistate) +#define DBIc_LOGPIO(imp) DBIc_DBISTATE(imp)->logfp +#define DBIc_KIDS(imp) _imp2com(imp, std.kids) +#define DBIc_ACTIVE_KIDS(imp) _imp2com(imp, std.active_kids) +#define DBIc_LAST_METHOD(imp) _imp2com(imp, std.last_method) + +/* d = DBD flags, l = DBD level (needs to be shifted down) + * D - DBI flags, r = reserved, L = DBI trace level + * Trace level bit allocation: 0xddlDDDrL */ +#define DBIc_TRACE_LEVEL_MASK 0x0000000F +#define DBIc_TRACE_FLAGS_MASK 0xFF0FFF00 /* includes DBD flag bits for DBIc_TRACE */ +#define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) +#define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) +#define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) +/* DBI defined trace flags */ +#define DBIf_TRACE_SQL 0x00000100 +#define DBIf_TRACE_CON 0x00000200 +#define DBIf_TRACE_ENC 0x00000400 +#define DBIf_TRACE_DBD 0x00000800 +#define DBIf_TRACE_TXN 0x00001000 + +#define DBDc_TRACE_LEVEL_MASK 0x00F00000 +#define DBDc_TRACE_LEVEL_SHIFT 20 +#define DBDc_TRACE_LEVEL(imp) ( (DBIc_TRACE_SETTINGS(imp) & DBDc_TRACE_LEVEL_MASK) >> DBDc_TRACE_LEVEL_SHIFT ) +#define DBDc_TRACE_LEVEL_set(imp, l) ( DBIc_TRACE_SETTINGS(imp) |= (((l) << DBDc_TRACE_LEVEL_SHIFT) & DBDc_TRACE_LEVEL_MASK )) + +/* DBIc_TRACE_MATCHES(this, crnt): true if this 'matches' (is within) crnt + DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) +*/ +#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(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 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)) \ + || (level && DBIc_TRACE_LEVEL(imp) >= level) ) + +#define DBIc_DEBUG(imp) (_imp2com(imp, attr.TraceLevel)) /* deprecated */ +#define DBIc_DEBUGIV(imp) SvIV(DBIc_DEBUG(imp)) /* deprecated */ +#define DBIc_STATE(imp) SvRV(_imp2com(imp, attr.State)) +#define DBIc_ERR(imp) SvRV(_imp2com(imp, attr.Err)) +#define DBIc_ERRSTR(imp) SvRV(_imp2com(imp, attr.Errstr)) +#define DBIc_ErrCount(imp) _imp2com(imp, attr.ErrCount) +#define DBIc_LongReadLen(imp) _imp2com(imp, attr.LongReadLen) +#define DBIc_LongReadLen_init 80 /* may change */ +#define DBIc_FetchHashKeyName(imp) (_imp2com(imp, attr.FetchHashKeyName)) + +/* handle sub-type specific fields */ +/* dbh & drh */ +#define DBIc_CACHED_KIDS(imp) Nullhv /* no longer used, here for src compat */ +/* sth */ +#define DBIc_NUM_FIELDS(imp) _imp2com(imp, num_fields) +#define DBIc_NUM_PARAMS(imp) _imp2com(imp, num_params) +#define DBIc_NUM_PARAMS_AT_EXECUTE -9 /* see Driver.xst */ +#define DBIc_ROW_COUNT(imp) _imp2com(imp, row_count) +#define DBIc_FIELDS_AV(imp) _imp2com(imp, fields_svav) +#define DBIc_FDESC_AV(imp) _imp2com(imp, fields_fdav) +#define DBIc_FDESC(imp, i) ((imp_fdh_t*)(void*)SvPVX(AvARRAY(DBIc_FDESC_AV(imp))[i])) + +/* XXX --- DO NOT CHANGE THESE VALUES AS THEY ARE COMPILED INTO DRIVERS --- XXX */ +#define DBIcf_COMSET 0x000001 /* needs to be clear'd before free'd */ +#define DBIcf_IMPSET 0x000002 /* has implementor data to be clear'd */ +#define DBIcf_ACTIVE 0x000004 /* needs finish/disconnect before clear */ +#define DBIcf_IADESTROY 0x000008 /* do DBIc_ACTIVE_off before DESTROY */ +#define DBIcf_WARN 0x000010 /* warn about poor practice etc */ +#define DBIcf_COMPAT 0x000020 /* compat/emulation mode (eg oraperl) */ +#define DBIcf_ChopBlanks 0x000040 /* rtrim spaces from fetch char columns */ +#define DBIcf_RaiseError 0x000080 /* throw exception (croak) on error */ +#define DBIcf_PrintError 0x000100 /* warn() on error */ +#define DBIcf_AutoCommit 0x000200 /* dbh only. used by drivers */ +#define DBIcf_LongTruncOk 0x000400 /* truncation to LongReadLen is okay */ +#define DBIcf_MultiThread 0x000800 /* allow multiple threads to enter */ +#define DBIcf_HandleSetErr 0x001000 /* has coderef HandleSetErr attribute */ +#define DBIcf_ShowErrorStatement 0x002000 /* include Statement in error */ +#define DBIcf_BegunWork 0x004000 /* between begin_work & commit/rollback */ +#define DBIcf_HandleError 0x008000 /* has coderef in HandleError attribute */ +#define DBIcf_Profile 0x010000 /* profile activity on this handle */ +#define DBIcf_TaintIn 0x020000 /* check inputs for taintedness */ +#define DBIcf_TaintOut 0x040000 /* taint outgoing data */ +#define DBIcf_Executed 0x080000 /* do/execute called since commit/rollb */ +#define DBIcf_PrintWarn 0x100000 /* warn() on warning (err="0") */ +#define DBIcf_Callbacks 0x200000 /* has Callbacks attribute hash */ +#define DBIcf_AIADESTROY 0x400000 /* auto DBIcf_IADESTROY if pid changes */ +/* NOTE: new flags may require clone() to be updated */ + +#define DBIcf_INHERITMASK /* what NOT to pass on to children */ \ + (U32)( DBIcf_COMSET | DBIcf_IMPSET | DBIcf_ACTIVE | DBIcf_IADESTROY \ + | DBIcf_AutoCommit | DBIcf_BegunWork | DBIcf_Executed | DBIcf_Callbacks ) + +/* general purpose bit setting and testing macros */ +#define DBIbf_is( bitset,flag) ((bitset) & (flag)) +#define DBIbf_has(bitset,flag) DBIbf_is(bitset, flag) /* alias for _is */ +#define DBIbf_on( bitset,flag) ((bitset) |= (flag)) +#define DBIbf_off(bitset,flag) ((bitset) &= ~(flag)) +#define DBIbf_set(bitset,flag,on) ((on) ? DBIbf_on(bitset, flag) : DBIbf_off(bitset,flag)) + +/* as above, but specifically for DBIc_FLAGS imp flags (except ACTIVE) */ +#define DBIc_is(imp, flag) DBIbf_is( DBIc_FLAGS(imp), flag) +#define DBIc_has(imp,flag) DBIc_is(imp, flag) /* alias for DBIc_is */ +#define DBIc_on(imp, flag) DBIbf_on( DBIc_FLAGS(imp), flag) +#define DBIc_off(imp,flag) DBIbf_off(DBIc_FLAGS(imp), flag) +#define DBIc_set(imp,flag,on) DBIbf_set(DBIc_FLAGS(imp), flag, on) + +#define DBIc_COMSET(imp) DBIc_is(imp, DBIcf_COMSET) +#define DBIc_COMSET_on(imp) DBIc_on(imp, DBIcf_COMSET) +#define DBIc_COMSET_off(imp) DBIc_off(imp,DBIcf_COMSET) + +#define DBIc_IMPSET(imp) DBIc_is(imp, DBIcf_IMPSET) +#define DBIc_IMPSET_on(imp) DBIc_on(imp, DBIcf_IMPSET) +#define DBIc_IMPSET_off(imp) DBIc_off(imp,DBIcf_IMPSET) + +#define DBIc_ACTIVE(imp) (DBIc_FLAGS(imp) & DBIcf_ACTIVE) +#define DBIc_ACTIVE_on(imp) /* adjust parent's active kid count */ \ + do { \ + imp_xxh_t *ph_com = DBIc_PARENT_COM(imp); \ + if (!DBIc_ACTIVE(imp) && ph_com && !PL_dirty \ + && ++DBIc_ACTIVE_KIDS(ph_com) > DBIc_KIDS(ph_com)) \ + croak("panic: DBI active kids (%ld) > kids (%ld)", \ + (long)DBIc_ACTIVE_KIDS(ph_com), \ + (long)DBIc_KIDS(ph_com)); \ + DBIc_FLAGS(imp) |= DBIcf_ACTIVE; \ + } while(0) +#define DBIc_ACTIVE_off(imp) /* adjust parent's active kid count */ \ + do { \ + imp_xxh_t *ph_com = DBIc_PARENT_COM(imp); \ + if (DBIc_ACTIVE(imp) && ph_com && !PL_dirty \ + && (--DBIc_ACTIVE_KIDS(ph_com) > DBIc_KIDS(ph_com) \ + || DBIc_ACTIVE_KIDS(ph_com) < 0) ) \ + croak("panic: DBI active kids (%ld) < 0 or > kids (%ld)", \ + (long)DBIc_ACTIVE_KIDS(ph_com), \ + (long)DBIc_KIDS(ph_com)); \ + DBIc_FLAGS(imp) &= ~DBIcf_ACTIVE; \ + } while(0) + +#define DBIc_IADESTROY(imp) (DBIc_FLAGS(imp) & DBIcf_IADESTROY) +#define DBIc_IADESTROY_on(imp) (DBIc_FLAGS(imp) |= DBIcf_IADESTROY) +#define DBIc_IADESTROY_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_IADESTROY) + +#define DBIc_AIADESTROY(imp) (DBIc_FLAGS(imp) & DBIcf_AIADESTROY) +#define DBIc_AIADESTROY_on(imp) (DBIc_FLAGS(imp) |= DBIcf_AIADESTROY) +#define DBIc_AIADESTROY_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_AIADESTROY) + +#define DBIc_WARN(imp) (DBIc_FLAGS(imp) & DBIcf_WARN) +#define DBIc_WARN_on(imp) (DBIc_FLAGS(imp) |= DBIcf_WARN) +#define DBIc_WARN_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_WARN) + +#define DBIc_COMPAT(imp) (DBIc_FLAGS(imp) & DBIcf_COMPAT) +#define DBIc_COMPAT_on(imp) (DBIc_FLAGS(imp) |= DBIcf_COMPAT) +#define DBIc_COMPAT_off(imp) (DBIc_FLAGS(imp) &= ~DBIcf_COMPAT) + + +#ifdef IN_DBI_XS /* get Handle Common Data Structure */ +#define DBIh_COM(h) (dbih_getcom2(aTHX_ h, 0)) +#else +#define DBIh_COM(h) (DBIS->getcom(h)) +#define neatsvpv(sv,len) (DBIS->neat_svpv(sv,len)) +#endif + +/* --- For sql_type_cast_svpv() --- */ + +#define DBIstcf_DISCARD_STRING 0x0001 +#define DBIstcf_STRICT 0x0002 + +/* --- Implementors Private Data Support --- */ + +#define D_impdata(name,type,h) type *name = (type*)(DBIh_COM(h)) +#define D_imp_drh(h) D_impdata(imp_drh, imp_drh_t, h) +#define D_imp_dbh(h) D_impdata(imp_dbh, imp_dbh_t, h) +#define D_imp_sth(h) D_impdata(imp_sth, imp_sth_t, h) +#define D_imp_xxh(h) D_impdata(imp_xxh, imp_xxh_t, h) + +#define D_imp_from_child(name,type,child) \ + type *name = (type*)(DBIc_PARENT_COM(child)) +#define D_imp_drh_from_dbh D_imp_from_child(imp_drh, imp_drh_t, imp_dbh) +#define D_imp_dbh_from_sth D_imp_from_child(imp_dbh, imp_dbh_t, imp_sth) + +#define DBI_IMP_SIZE(n,s) sv_setiv(get_sv((n), GV_ADDMULTI), (s)) /* XXX */ + + + +/* --- Event Support (VERY LIABLE TO CHANGE) --- */ + +#define DBIh_EVENTx(h,t,a1,a2) /* deprecated XXX */ &PL_sv_no +#define DBIh_EVENT0(h,t) DBIh_EVENTx((h), (t), &PL_sv_undef, &PL_sv_undef) +#define DBIh_EVENT1(h,t, a1) DBIh_EVENTx((h), (t), (a1), &PL_sv_undef) +#define DBIh_EVENT2(h,t, a1,a2) DBIh_EVENTx((h), (t), (a1), (a2)) + +#define ERROR_event "ERROR" +#define WARN_event "WARN" +#define MSG_event "MESSAGE" +#define DBEVENT_event "DBEVENT" +#define UNKNOWN_event "UNKNOWN" + +#define DBIh_SET_ERR_SV(h,i, err, errstr, state, method) \ + (DBIc_DBISTATE(i)->set_err_sv(h,i, err, errstr, state, method)) +#define DBIh_SET_ERR_CHAR(h,i, err_c, err_i, errstr, state, method) \ + (DBIc_DBISTATE(i)->set_err_char(h,i, err_c, err_i, errstr, state, method)) + + +/* --- Handy Macros --- */ + +#define DBIh_CLEAR_ERROR(imp_xxh) (void)( \ + (void)SvOK_off(DBIc_ERR(imp_xxh)), \ + (void)SvOK_off(DBIc_ERRSTR(imp_xxh)), \ + (void)SvOK_off(DBIc_STATE(imp_xxh)) \ + ) + + +/* --- DBI State Structure --- */ + +struct dbistate_st { + +/* DBISTATE_VERSION is checked at runtime via DBISTATE_INIT and check_version. + * It should be incremented on incompatible changes to dbistate_t structure. + * Additional function pointers being assigned from spare padding, where the + * size of the structure doesn't change, doesn't require an increment. + * Incrementing forces all XS drivers to need to be recompiled. + * (See also DBIXS_REVISION as a driver source compatibility tool.) + */ +#define DBISTATE_VERSION 94 /* ++ on incompatible dbistate_t changes */ + + /* this must be the first member in structure */ + void (*check_version) _((const char *name, + int dbis_cv, int dbis_cs, int need_dbixs_cv, + int drc_s, int dbc_s, int stc_s, int fdc_s)); + + /* version and size are used to check for DBI/DBD version mis-match */ + U16 version; /* version of this structure */ + U16 size; + U16 xs_version; /* version of the overall DBIXS / DBD interface */ + U16 spare_pad; + + I32 debug; + PerlIO *logfp; + + /* pointers to DBI functions which the DBD's will want to use */ + char * (*neat_svpv) _((SV *sv, STRLEN maxlen)); + imp_xxh_t * (*getcom) _((SV *h)); /* see DBIh_COM macro */ + void (*clearcom) _((imp_xxh_t *imp_xxh)); + SV * (*event) _((SV *h, const char *name, SV*, SV*)); + int (*set_attr_k) _((SV *h, SV *keysv, int dbikey, SV *valuesv)); + SV * (*get_attr_k) _((SV *h, SV *keysv, int dbikey)); + AV * (*get_fbav) _((imp_sth_t *imp_sth)); + SV * (*make_fdsv) _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)); + int (*bind_as_num) _((int sql_type, int p, int s, int *t, void *v)); /* XXX deprecated */ + I32 (*hash) _((const char *string, long i)); + SV * (*preparse) _((SV *sth, char *statement, IV ps_return, IV ps_accept, void *foo)); + + SV *neatsvpvlen; /* only show dbgpvlen chars when debugging pv's */ + + PerlInterpreter * thr_owner; /* thread that owns this dbistate */ + + int (*logmsg) _((imp_xxh_t *imp_xxh, const char *fmt, ...)); + int (*set_err_sv) _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)); + int (*set_err_char) _((SV *h, imp_xxh_t *imp_xxh, const char *err, IV err_i, const char *errstr, const char *state, const char *method)); + int (*bind_col) _((SV *sth, SV *col, SV *ref, SV *attribs)); + + IO *logfp_ref; /* keep ptr to filehandle for refcounting */ + + int (*sql_type_cast_svpv) _((pTHX_ SV *sv, int sql_type, U32 flags, void *v)); + + /* WARNING: Only add new structure members here, and reduce pad2 to keep */ + /* the memory footprint exactly the same */ + void *pad2[3]; +}; + +/* macros for backwards compatibility */ +#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 DBILOGFP (DBIS->logfp) +#ifdef IN_DBI_XS +#define DBILOGMSG (dbih_logmsg) +#else +#define DBILOGMSG (DBIS->logmsg) +#endif + +/* --- perl object (ActiveState) / multiplicity hooks and hoops --- */ +/* note that USE_ITHREADS implies MULTIPLICITY */ + +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 _DBISTATE_DECLARE_COMMON +# define _DBISTATE_INIT_DBIS +# undef 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; \ + _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 \ + if (DBIS == NULL) \ + 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) \ + ); \ +} + + +/* --- Assorted Utility Macros --- */ + +#define DBD_ATTRIB_OK(attribs) /* is this a usable attrib value */ \ + (attribs && SvROK(attribs) && SvTYPE(SvRV(attribs))==SVt_PVHV) + +/* If attribs value supplied then croak if it's not a hash ref. */ +/* Also map undef to Null. Should always be called to pre-process the */ +/* attribs value. One day we may add some extra magic in here. */ +#define DBD_ATTRIBS_CHECK(func, h, attribs) \ + if ((attribs) && SvOK(attribs)) { \ + if (!SvROK(attribs) || SvTYPE(SvRV(attribs))!=SVt_PVHV) \ + croak("%s->%s(...): attribute parameter '%s' is not a hash ref", \ + SvPV_nolen(h), func, SvPV_nolen(attribs)); \ + } else (attribs) = Nullsv + +#define DBD_ATTRIB_GET_SVP(attribs, key,klen) \ + (DBD_ATTRIB_OK(attribs) \ + ? hv_fetch((HV*)SvRV(attribs), key,klen, 0) \ + : (SV **)Nullsv) + +#define DBD_ATTRIB_GET_IV(attribs, key,klen, svp, var) \ + if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \ + var = SvIV(*svp) + +#define DBD_ATTRIB_GET_UV(attribs, key,klen, svp, var) \ + if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \ + var = SvUV(*svp) + +#define DBD_ATTRIB_GET_BOOL(attribs, key,klen, svp, var) \ + if ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \ + var = SvTRUE(*svp) + +#define DBD_ATTRIB_TRUE(attribs, key,klen, svp) \ + ( ((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \ + ? SvTRUE(*svp) : 0 ) + +#define DBD_ATTRIB_GET_PV(attribs, key,klen, svp, dflt) \ + (((svp=DBD_ATTRIB_GET_SVP(attribs, key,klen)) != NULL) \ + ? SvPV_nolen(*svp) : (dflt)) + +#define DBD_ATTRIB_DELETE(attribs, key, klen) \ + hv_delete((HV*)SvRV(attribs), key, klen, G_DISCARD) + +#endif /* DBIXS_VERSION */ +/* end of DBIXS.h */ diff --git a/Driver.xst b/Driver.xst new file mode 100644 index 0000000..455549d --- /dev/null +++ b/Driver.xst @@ -0,0 +1,778 @@ +# $Id: Driver.xst 14772 2011-03-25 21:45:26Z mjevans $ +# Copyright (c) 1997-2002 Tim Bunce Ireland +# Copyright (c) 2002 Jonathan Leffler +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + +#include "Driver_xst.h" + + +MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~ + +REQUIRE: 1.929 +PROTOTYPES: DISABLE + +BOOT: + items = 0; /* avoid 'unused variable' warning */ + DBISTATE_INIT; + /* XXX this interface will change: */ + DBI_IMP_SIZE("DBD::~DRIVER~::dr::imp_data_size", sizeof(imp_drh_t)); + DBI_IMP_SIZE("DBD::~DRIVER~::db::imp_data_size", sizeof(imp_dbh_t)); + DBI_IMP_SIZE("DBD::~DRIVER~::st::imp_data_size", sizeof(imp_sth_t)); + dbd_init(DBIS); + + +# ------------------------------------------------------------ +# driver level interface +# ------------------------------------------------------------ +MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::dr + + +void +dbixs_revision(...) + PPCODE: + ST(0) = sv_2mortal(newSViv(DBIXS_REVISION)); + + +#ifdef dbd_discon_all + +# disconnect_all renamed and ALIAS'd to avoid length clash on VMS :-( +void +discon_all_(drh) + SV * drh + ALIAS: + disconnect_all = 1 + CODE: + D_imp_drh(drh); + if (0) ix = ix; /* avoid unused variable warning */ + ST(0) = dbd_discon_all(drh, imp_drh) ? &PL_sv_yes : &PL_sv_no; + +#endif /* dbd_discon_all */ + + +#ifdef dbd_dr_data_sources + +void +data_sources(drh, attr = Nullsv) + SV *drh + SV *attr + PPCODE: + { + D_imp_drh(drh); + AV *av = dbd_dr_data_sources(drh, imp_drh, attr); + if (av) { + int i; + int n = AvFILL(av)+1; + EXTEND(sp, n); + for (i = 0; i < n; ++i) { + PUSHs(AvARRAY(av)[i]); + } + } + } + +#endif + + +# ------------------------------------------------------------ +# database level interface +# ------------------------------------------------------------ +MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::db + + +void +_login(dbh, dbname, username, password, attribs=Nullsv) + SV * dbh + SV * dbname + SV * username + SV * password + SV * attribs + CODE: + { + D_imp_dbh(dbh); +#if !defined(dbd_db_login6_sv) + STRLEN lna; + char *u = (SvOK(username)) ? SvPV(username,lna) : ""; + char *p = (SvOK(password)) ? SvPV(password,lna) : ""; +#endif +#ifdef dbd_db_login6_sv + ST(0) = dbd_db_login6_sv(dbh, imp_dbh, dbname, username, password, attribs) ? &PL_sv_yes : &PL_sv_no; +#elif defined(dbd_db_login6) + ST(0) = dbd_db_login6(dbh, imp_dbh, SvPV_nolen(dbname), u, p, attribs) ? &PL_sv_yes : &PL_sv_no; +#else + ST(0) = dbd_db_login( dbh, imp_dbh, SvPV_nolen(dbname), u, p) ? &PL_sv_yes : &PL_sv_no; +#endif + } + + +void +selectall_arrayref(...) + PREINIT: + SV *sth; + SV **maxrows_svp; + SV **tmp_svp; + SV *attr = &PL_sv_undef; + imp_sth_t *imp_sth; + CODE: + if (items > 2) { + attr = ST(2); + if (SvROK(attr) && + (DBD_ATTRIB_TRUE(attr,"Slice",5,tmp_svp) || DBD_ATTRIB_TRUE(attr,"Columns",7,tmp_svp)) + ) { + /* fallback to perl implementation */ + SV *tmp =dbixst_bounce_method("DBD::~DRIVER~::db::SUPER::selectall_arrayref", items); + SPAGAIN; + ST(0) = tmp; + XSRETURN(1); + } + } + /* --- prepare --- */ + if (SvROK(ST(1))) { + MAGIC *mg; + sth = ST(1); + /* switch to inner handle if not already */ + if ( (mg = mg_find(SvRV(sth),'P')) ) + sth = mg->mg_obj; + } + else { + sth = dbixst_bounce_method("prepare", 3); + SPAGAIN; SP -= items; /* because stack might have been realloc'd */ + if (!SvROK(sth)) + XSRETURN_UNDEF; + /* switch to inner handle */ + sth = mg_find(SvRV(sth),'P')->mg_obj; + } + imp_sth = (imp_sth_t*)(DBIh_COM(sth)); + /* --- bind_param --- */ + if (items > 3) { /* need to bind params before execute */ + if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2) ) { + XSRETURN_UNDEF; + } + } + /* --- execute --- */ + DBIc_ROW_COUNT(imp_sth) = 0; + if ( dbd_st_execute(sth, imp_sth) <= -2 ) { /* -2 == error */ + XSRETURN_UNDEF; + } + /* --- fetchall --- */ + maxrows_svp = DBD_ATTRIB_GET_SVP(attr, "MaxRows", 7); + ST(0) = dbdxst_fetchall_arrayref(sth, &PL_sv_undef, (maxrows_svp) ? *maxrows_svp : &PL_sv_undef); + + +void +selectrow_arrayref(...) + ALIAS: + selectrow_array = 1 + PREINIT: + int is_selectrow_array = (ix == 1); + imp_sth_t *imp_sth; + SV *sth; + AV *row_av; + PPCODE: + if (SvROK(ST(1))) { + MAGIC *mg; + sth = ST(1); + /* switch to inner handle if not already */ + if ( (mg = mg_find(SvRV(sth),'P')) ) + sth = mg->mg_obj; + } + else { + /* --- prepare --- */ + sth = dbixst_bounce_method("prepare", 3); + SPAGAIN; SP -= items; /* because stack might have been realloc'd */ + if (!SvROK(sth)) { + if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; } + } + /* switch to inner handle */ + sth = mg_find(SvRV(sth),'P')->mg_obj; + } + imp_sth = (imp_sth_t*)(DBIh_COM(sth)); + /* --- bind_param --- */ + if (items > 3) { /* need to bind params before execute */ + if (!dbdxst_bind_params(sth, imp_sth, items-2, ax+2) ) { + if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; } + } + } + /* --- execute --- */ + DBIc_ROW_COUNT(imp_sth) = 0; + if ( dbd_st_execute(sth, imp_sth) <= -2 ) { /* -2 == error */ + if (is_selectrow_array) { XSRETURN_EMPTY; } else { XSRETURN_UNDEF; } + } + /* --- fetchrow_arrayref --- */ + row_av = dbd_st_fetch(sth, imp_sth); + if (!row_av) { + if (GIMME == G_SCALAR) + PUSHs(&PL_sv_undef); + } + else if (is_selectrow_array) { + int i; + int num_fields = AvFILL(row_av)+1; + if (GIMME == G_SCALAR) + num_fields = 1; /* return just first field */ + EXTEND(sp, num_fields); + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(row_av)[i]); + } + } + else { + PUSHs( sv_2mortal(newRV((SV *)row_av)) ); + } + /* --- finish --- */ +#ifdef dbd_st_finish3 + dbd_st_finish3(sth, imp_sth, 0); +#else + dbd_st_finish(sth, imp_sth); +#endif + + +#ifdef dbd_db_do4 /* deebeedee-deebee-doo, deebee-doobee-dah? */ + +void +do(dbh, statement, params = Nullsv) + SV * dbh + char * statement + SV * params + CODE: + { + D_imp_dbh(dbh); + IV retval; + retval = dbd_db_do4(dbh, imp_dbh, statement, params); + /* remember that dbd_db_do4 must return <= -2 for error */ + if (retval == 0) /* ok with no rows affected */ + XST_mPV(0, "0E0"); /* (true but zero) */ + else if (retval < -1) /* -1 == unknown number of rows */ + XST_mUNDEF(0); /* <= -2 means error */ + else + XST_mIV(0, retval); /* typically 1, rowcount or -1 */ + } + +#endif + + +#ifdef dbd_db_last_insert_id + +void +last_insert_id(dbh, catalog, schema, table, field, attr=Nullsv) + SV * dbh + SV * catalog + SV * schema + SV * table + SV * field + SV * attr + CODE: + { + D_imp_dbh(dbh); + ST(0) = dbd_db_last_insert_id(dbh, imp_dbh, catalog, schema, table, field, attr); + } + +#endif + + +void +commit(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) + warn("commit ineffective with AutoCommit enabled"); + ST(0) = dbd_db_commit(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; + + +void +rollback(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if (DBIc_has(imp_dbh,DBIcf_AutoCommit) && DBIc_WARN(imp_dbh)) + warn("rollback ineffective with AutoCommit enabled"); + ST(0) = dbd_db_rollback(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; + + +void +disconnect(dbh) + SV * dbh + CODE: + D_imp_dbh(dbh); + if ( !DBIc_ACTIVE(imp_dbh) ) { + XSRETURN_YES; + } + /* Check for disconnect() being called whilst refs to cursors */ + /* still exists. This possibly needs some more thought. */ + if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !PL_dirty) { + STRLEN lna; + char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s"; + warn("%s->disconnect invalidates %d active statement handle%s %s", + SvPV(dbh,lna), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural, + "(either destroy statement handles or call finish on them before disconnecting)"); + } + ST(0) = dbd_db_disconnect(dbh, imp_dbh) ? &PL_sv_yes : &PL_sv_no; + DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */ + + +void +STORE(dbh, keysv, valuesv) + SV * dbh + SV * keysv + SV * valuesv + CODE: + D_imp_dbh(dbh); + if (SvGMAGICAL(valuesv)) + mg_get(valuesv); + ST(0) = &PL_sv_yes; + if (!dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv)) + if (!DBIc_DBISTATE(imp_dbh)->set_attr(dbh, keysv, valuesv)) + ST(0) = &PL_sv_no; + + +void +FETCH(dbh, keysv) + SV * dbh + SV * keysv + CODE: + D_imp_dbh(dbh); + SV *valuesv = dbd_db_FETCH_attrib(dbh, imp_dbh, keysv); + if (!valuesv) + valuesv = DBIc_DBISTATE(imp_dbh)->get_attr(dbh, keysv); + ST(0) = valuesv; /* dbd_db_FETCH_attrib did sv_2mortal */ + + +void +DESTROY(dbh) + SV * dbh + PPCODE: + /* keep in sync with default DESTROY in DBI.xs */ + D_imp_dbh(dbh); + ST(0) = &PL_sv_yes; + if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */ + STRLEN lna; + if (DBIc_WARN(imp_dbh) && !PL_dirty && DBIc_DBISTATE(imp_dbh)->debug >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_dbh), + " DESTROY for %s ignored - handle not initialised\n", + SvPV(dbh,lna)); + } + else { + if (DBIc_IADESTROY(imp_dbh)) { /* wants ineffective destroy */ + DBIc_ACTIVE_off(imp_dbh); + if (DBIc_DBISTATE(imp_dbh)->debug) + PerlIO_printf(DBIc_LOGPIO(imp_dbh), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(dbh)); + } + if (DBIc_ACTIVE(imp_dbh)) { + if (!DBIc_has(imp_dbh,DBIcf_AutoCommit)) { + /* Application is using transactions and hasn't explicitly disconnected. + Some databases will automatically commit on graceful disconnect. + Since we're about to gracefully disconnect as part of the DESTROY + we want to be sure we're not about to implicitly commit changes + that are incomplete and should be rolled back. (The DESTROY may + be due to a RaiseError, for example.) So we rollback here. + This will be harmless if the application has issued a commit, + XXX Could add an attribute flag to indicate that the driver + doesn't have this problem. Patches welcome. + */ + if (DBIc_WARN(imp_dbh) /* only warn if likely to be useful... */ + && DBIc_is(imp_dbh, DBIcf_Executed) /* has not just called commit/rollback */ + /* && !DBIc_is(imp_dbh, DBIcf_ReadOnly) -- is not read only */ + && (!PL_dirty || DBIc_DBISTATE(imp_dbh)->debug >= 3) + ) { + warn("Issuing rollback() due to DESTROY without explicit disconnect() of %s handle %s", + SvPV_nolen(*hv_fetch((HV*)SvRV(dbh), "ImplementorClass", 16, 1)), + SvPV_nolen(*hv_fetch((HV*)SvRV(dbh), "Name", 4, 1)) + ); + } + dbd_db_rollback(dbh, imp_dbh); /* ROLLBACK! */ + } + dbd_db_disconnect(dbh, imp_dbh); + DBIc_ACTIVE_off(imp_dbh); /* ensure it's off, regardless */ + } + dbd_db_destroy(dbh, imp_dbh); + } + + +#ifdef dbd_take_imp_data + +void +take_imp_data(h) + SV * h + CODE: + D_imp_xxh(h); + /* dbd_take_imp_data() returns &sv_no (or other defined but false value) + * to indicate "preparations complete, now call SUPER::take_imp_data" for me. + * Anything else is returned to the caller via sv_2mortal(sv), typically that + * would be &sv_undef for error or an SV holding the imp_data. + */ + SV *sv = dbd_take_imp_data(h, imp_xxh, NULL); + if (SvOK(sv) && !SvTRUE(sv)) { + SV *tmp = dbixst_bounce_method("DBD::~DRIVER~::db::SUPER::take_imp_data", items); + SPAGAIN; + ST(0) = tmp; + } else { + ST(0) = sv_2mortal(sv); + } + +#endif + +#ifdef dbd_db_data_sources + +void +data_sources(dbh, attr = Nullsv) + SV *dbh + SV *attr + PPCODE: + { + D_imp_dbh(dbh); + AV *av = dbd_db_data_sources(dbh, imp_dbh, attr); + if (av) { + int i; + int n = AvFILL(av)+1; + EXTEND(sp, n); + for (i = 0; i < n; ++i) { + PUSHs(AvARRAY(av)[i]); + } + } + } + +#endif + +# -- end of DBD::~DRIVER~::db + +# ------------------------------------------------------------ +# statement interface +# ------------------------------------------------------------ +MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~::st + + +void +_prepare(sth, statement, attribs=Nullsv) + SV * sth + SV * statement + SV * attribs + CODE: + { + D_imp_sth(sth); + DBD_ATTRIBS_CHECK("_prepare", sth, attribs); +#ifdef dbd_st_prepare_sv + ST(0) = dbd_st_prepare_sv(sth, imp_sth, statement, attribs) ? &PL_sv_yes : &PL_sv_no; +#else + ST(0) = dbd_st_prepare(sth, imp_sth, SvPV_nolen(statement), attribs) ? &PL_sv_yes : &PL_sv_no; +#endif + } + + +#ifdef dbd_st_rows + +void +rows(sth) + SV * sth + CODE: + D_imp_sth(sth); + XST_mIV(0, dbd_st_rows(sth, imp_sth)); + +#endif /* dbd_st_rows */ + + +#ifdef dbd_st_bind_col + +void +bind_col(sth, col, ref, attribs=Nullsv) + SV * sth + SV * col + SV * ref + SV * attribs + CODE: + { + IV sql_type = 0; + D_imp_sth(sth); + if (SvGMAGICAL(ref)) + mg_get(ref); + if (attribs) { + if (SvNIOK(attribs)) { + sql_type = SvIV(attribs); + attribs = Nullsv; + } + else { + SV **svp; + DBD_ATTRIBS_CHECK("bind_col", sth, attribs); + /* XXX we should perhaps complain if TYPE is not SvNIOK */ + DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type); + } + } + switch(dbd_st_bind_col(sth, imp_sth, col, ref, sql_type, attribs)) { + case 2: ST(0) = &PL_sv_yes; /* job done completely */ + break; + case 1: /* fallback to DBI default */ + ST(0) = (DBIc_DBISTATE(imp_sth)->bind_col(sth, col, ref, attribs)) + ? &PL_sv_yes : &PL_sv_no; + break; + default: ST(0) = &PL_sv_no; /* dbd_st_bind_col has called set_err */ + break; + } + } + +#endif /* dbd_st_bind_col */ + +void +bind_param(sth, param, value, attribs=Nullsv) + SV * sth + SV * param + SV * value + SV * attribs + CODE: + { + IV sql_type = 0; + D_imp_sth(sth); + if (SvGMAGICAL(value)) + mg_get(value); + if (attribs) { + if (SvNIOK(attribs)) { + sql_type = SvIV(attribs); + attribs = Nullsv; + } + else { + SV **svp; + DBD_ATTRIBS_CHECK("bind_param", sth, attribs); + /* XXX we should perhaps complain if TYPE is not SvNIOK */ + DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type); + } + } + ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, FALSE, 0) + ? &PL_sv_yes : &PL_sv_no; + } + + +void +bind_param_inout(sth, param, value_ref, maxlen, attribs=Nullsv) + SV * sth + SV * param + SV * value_ref + IV maxlen + SV * attribs + CODE: + { + IV sql_type = 0; + D_imp_sth(sth); + SV *value; + if (!SvROK(value_ref) || SvTYPE(SvRV(value_ref)) > SVt_PVMG) + croak("bind_param_inout needs a reference to a scalar value"); + value = SvRV(value_ref); + if (SvREADONLY(value)) + croak("Modification of a read-only value attempted"); + if (SvGMAGICAL(value)) + mg_get(value); + if (attribs) { + if (SvNIOK(attribs)) { + sql_type = SvIV(attribs); + attribs = Nullsv; + } + else { + SV **svp; + DBD_ATTRIBS_CHECK("bind_param", sth, attribs); + DBD_ATTRIB_GET_IV(attribs, "TYPE",4, svp, sql_type); + } + } + ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, TRUE, maxlen) + ? &PL_sv_yes : &PL_sv_no; + } + + +void +execute(sth, ...) + SV * sth + CODE: + D_imp_sth(sth); + int retval; + if (items > 1) { /* need to bind params */ + if (!dbdxst_bind_params(sth, imp_sth, items, ax) ) { + XSRETURN_UNDEF; + } + } + /* XXX this code is duplicated in selectrow_arrayref above */ + if (DBIc_ROW_COUNT(imp_sth) > 0) /* reset for re-execute */ + DBIc_ROW_COUNT(imp_sth) = 0; + retval = dbd_st_execute(sth, imp_sth); + /* remember that dbd_st_execute must return <= -2 for error */ + if (retval == 0) /* ok with no rows affected */ + XST_mPV(0, "0E0"); /* (true but zero) */ + else if (retval < -1) /* -1 == unknown number of rows */ + XST_mUNDEF(0); /* <= -2 means error */ + else + XST_mIV(0, retval); /* typically 1, rowcount or -1 */ + + +#ifdef dbd_st_execute_for_fetch + +void +execute_for_fetch(sth, fetch_tuple_sub, tuple_status = Nullsv) + SV * sth + SV * fetch_tuple_sub + SV * tuple_status + CODE: + { + D_imp_sth(sth); + ST(0) = dbd_st_execute_for_fetch(sth, imp_sth, fetch_tuple_sub, tuple_status); + } + +#endif + + + +void +fetchrow_arrayref(sth) + SV * sth + ALIAS: + fetch = 1 + CODE: + D_imp_sth(sth); + AV *av; + if (0) ix = ix; /* avoid unused variable warning */ + av = dbd_st_fetch(sth, imp_sth); + ST(0) = (av) ? sv_2mortal(newRV((SV *)av)) : &PL_sv_undef; + + +void +fetchrow_array(sth) + SV * sth + ALIAS: + fetchrow = 1 + PPCODE: + D_imp_sth(sth); + AV *av; + av = dbd_st_fetch(sth, imp_sth); + if (av) { + int i; + int num_fields = AvFILL(av)+1; + EXTEND(sp, num_fields); + for(i=0; i < num_fields; ++i) { + PUSHs(AvARRAY(av)[i]); + } + if (0) ix = ix; /* avoid unused variable warning */ + } + + +void +fetchall_arrayref(sth, slice=&PL_sv_undef, batch_row_count=&PL_sv_undef) + SV * sth + SV * slice + SV * batch_row_count + CODE: + if (SvOK(slice)) { /* fallback to perl implementation */ + SV *tmp = dbixst_bounce_method("DBD::~DRIVER~::st::SUPER::fetchall_arrayref", 3); + SPAGAIN; + ST(0) = tmp; + } + else { + ST(0) = dbdxst_fetchall_arrayref(sth, slice, batch_row_count); + } + + +void +finish(sth) + SV * sth + CODE: + D_imp_sth(sth); + D_imp_dbh_from_sth; + if (!DBIc_ACTIVE(imp_sth)) { + /* No active statement to finish */ + XSRETURN_YES; + } + if (!DBIc_ACTIVE(imp_dbh)) { + /* Either an explicit disconnect() or global destruction */ + /* has disconnected us from the database. Finish is meaningless */ + DBIc_ACTIVE_off(imp_sth); + XSRETURN_YES; + } +#ifdef dbd_st_finish3 + ST(0) = dbd_st_finish3(sth, imp_sth, 0) ? &PL_sv_yes : &PL_sv_no; +#else + ST(0) = dbd_st_finish(sth, imp_sth) ? &PL_sv_yes : &PL_sv_no; +#endif + + +void +blob_read(sth, field, offset, len, destrv=Nullsv, destoffset=0) + SV * sth + int field + long offset + long len + SV * destrv + long destoffset + CODE: + { + D_imp_sth(sth); + if (!destrv) + destrv = sv_2mortal(newRV(sv_2mortal(newSV(0)))); + if (dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset)) + ST(0) = SvRV(destrv); + else ST(0) = &PL_sv_undef; + } + + +void +STORE(sth, keysv, valuesv) + SV * sth + SV * keysv + SV * valuesv + CODE: + D_imp_sth(sth); + if (SvGMAGICAL(valuesv)) + mg_get(valuesv); + ST(0) = &PL_sv_yes; + if (!dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv)) + if (!DBIc_DBISTATE(imp_sth)->set_attr(sth, keysv, valuesv)) + ST(0) = &PL_sv_no; + + +# FETCH renamed and ALIAS'd to avoid case clash on VMS :-( +void +FETCH_attrib(sth, keysv) + SV * sth + SV * keysv + ALIAS: + FETCH = 1 + CODE: + D_imp_sth(sth); + SV *valuesv; + if (0) ix = ix; /* avoid unused variable warning */ + valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv); + if (!valuesv) + valuesv = DBIc_DBISTATE(imp_sth)->get_attr(sth, keysv); + ST(0) = valuesv; /* dbd_st_FETCH_attrib did sv_2mortal */ + + +void +DESTROY(sth) + SV * sth + PPCODE: + /* keep in sync with default DESTROY in DBI.xs */ + D_imp_sth(sth); + ST(0) = &PL_sv_yes; + if (!DBIc_IMPSET(imp_sth)) { /* was never fully set up */ + STRLEN lna; + if (DBIc_WARN(imp_sth) && !PL_dirty && DBIc_DBISTATE(imp_sth)->debug >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_sth), + " DESTROY for %s ignored - handle not initialised\n", + SvPV(sth,lna)); + } + else { + if (DBIc_IADESTROY(imp_sth)) { /* wants ineffective destroy */ + DBIc_ACTIVE_off(imp_sth); + if (DBIc_DBISTATE(imp_sth)->debug) + PerlIO_printf(DBIc_LOGPIO(imp_sth), " DESTROY %s skipped due to InactiveDestroy\n", SvPV_nolen(sth)); + } + if (DBIc_ACTIVE(imp_sth)) { + D_imp_dbh_from_sth; + if (!PL_dirty && DBIc_ACTIVE(imp_dbh)) { +#ifdef dbd_st_finish3 + dbd_st_finish3(sth, imp_sth, 1); +#else + dbd_st_finish(sth, imp_sth); +#endif + } + else { + DBIc_ACTIVE_off(imp_sth); + } + } + dbd_st_destroy(sth, imp_sth); + } + +# end of ~DRIVER~.xst +# vim:ts=8:sw=4:et diff --git a/Driver_xst.h b/Driver_xst.h new file mode 100644 index 0000000..0cc79d3 --- /dev/null +++ b/Driver_xst.h @@ -0,0 +1,122 @@ +/* +# $Id: Driver_xst.h 15124 2012-02-03 15:13:41Z timbo $ +# Copyright (c) 2002 Tim Bunce Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. +*/ + + +/* This is really just a workaround for SUPER:: not working right for XS code. + * It would be better if we setup perl's context so SUPER:: did the right thing + * (borrowing the relevant magic from pp_entersub in perl pp_hot.c). + * Then we could just use call_method("SUPER::foo") instead. + * XXX remember to call SPAGAIN in the calling code after calling this! + */ +static SV * +dbixst_bounce_method(char *methname, int params) +{ + dTHX; + /* XXX this 'magic' undoes the dMARK embedded in the dXSARGS of our caller */ + /* so that the dXSARGS below can set things up as they were for our caller */ + void *xxx = PL_markstack_ptr++; + dXSARGS; /* declares sp, ax, mark, items */ + int i; + SV *sv; + int debug = 0; + D_imp_xxh(ST(0)); + 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 */ + } + EXTEND(SP, params); + PUSHMARK(SP); + for (i=0; i < params; ++i) { + sv = (i >= items) ? &PL_sv_undef : ST(i); + PUSHs(sv); + } + PUTBACK; + i = call_method(methname, G_SCALAR); + SPAGAIN; + sv = (i) ? POPs : &PL_sv_undef; + PUTBACK; + if (debug >= 3) + PerlIO_printf(DBIc_LOGPIO(imp_xxh), + " <- %s= %s (trampoline call return)\n", methname, neatsvpv(sv,0)); + return sv; +} + + +static int +dbdxst_bind_params(SV *sth, imp_sth_t *imp_sth, I32 items, I32 ax) +{ + /* Handle binding supplied values to placeholders. */ + /* items = one greater than the number of params */ + /* ax = ax from calling sub, maybe adjusted to match items */ + dTHX; + int i; + SV *idx; + if (items-1 != DBIc_NUM_PARAMS(imp_sth) + && 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)); + DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, "-1", -1, errmsg, Nullch, Nullch); + return 0; + } + idx = sv_2mortal(newSViv(0)); + for(i=1; i < items ; ++i) { + SV* value = ST(i); + if (SvGMAGICAL(value)) + mg_get(value); /* trigger magic to FETCH the value */ + sv_setiv(idx, i); + if (!dbd_bind_ph(sth, imp_sth, idx, value, 0, Nullsv, FALSE, 0)) { + return 0; /* dbd_bind_ph already registered error */ + } + } + return 1; +} + +#ifndef dbd_fetchall_arrayref +static SV * +dbdxst_fetchall_arrayref(SV *sth, SV *slice, SV *batch_row_count) +{ + dTHX; + D_imp_sth(sth); + SV *rows_rvav; + if (SvOK(slice)) { /* should never get here */ + char errmsg[99]; + sprintf(errmsg,"slice param not supported by XS version of fetchall_arrayref"); + DBIh_SET_ERR_CHAR(sth, (imp_xxh_t*)imp_sth, "-1", -1, errmsg, Nullch, Nullch); + return &PL_sv_undef; + } + else { + IV maxrows = SvOK(batch_row_count) ? SvIV(batch_row_count) : -1; + AV *fetched_av; + AV *rows_av = newAV(); + if ( !DBIc_ACTIVE(imp_sth) && maxrows>0 ) { + /* to simplify application logic we return undef without an error */ + /* if we've fetched all the rows and called with a batch_row_count */ + return &PL_sv_undef; + } + av_extend(rows_av, (maxrows>0) ? maxrows : 31); + while ( (maxrows < 0 || maxrows-- > 0) + && (fetched_av = dbd_st_fetch(sth, imp_sth)) + ) { + AV *copy_row_av = av_make(AvFILL(fetched_av)+1, AvARRAY(fetched_av)); + av_push(rows_av, newRV_noinc((SV*)copy_row_av)); + } + rows_rvav = sv_2mortal(newRV_noinc((SV *)rows_av)); + } + return rows_rvav; +} +#endif + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..37b4bcf --- /dev/null +++ b/MANIFEST @@ -0,0 +1,121 @@ +Changes History of significant changes to the DBI +DBI.pm The Database Interface Module Perl code +DBI.xs The Database Interface Module XS code +DBIXS.h The DBI XS public interface for Drivers (DBD::...) +Driver.xst Template driver xs file +Driver_xst.h Template driver xs support code +MANIFEST +Makefile.PL The Makefile generator +Perl.xs Test harness (currently) for Driver.xst +README +TODO_2005.txt Old (but still mostly relevant) occasional random notes about what's missing +TODO_gofer.txt To-do notes related to gofer +dbd_xsh.h Prototypes for standard Driver.xst interface +dbi_sql.h Definitions based on SQL CLI / ODBC (#inc'd by DBIXS.h) +dbipport.h Perl portability macros (from Devel::PPort) +dbilogstrip.PL Utility to normalise DBI logs so they can be compared with diff +dbiprof.PL +dbiproxy.PL Frontend for DBI::ProxyServer +dbivport.h DBI version portability macros (for drivers to copy) +dbixs_rev.h Defines DBIXS_REVISION macro holding DBIXS.h subversion revision number +dbixs_rev.pl Utility to write dbixs_rev.h +ex/perl_dbi_nulls_test.pl A test script for forms of IS NULL qualification in SQL +ex/profile.pl A test script for DBI::Profile +ex/corogofer.pl A test script for DBD::Gofer::Transport::corostream +lib/Bundle/DBI.pm A bundle for automatic installation via CPAN. +lib/DBD/DBM.pm A driver for DBM files (uses DBD::File) +lib/DBD/ExampleP.pm A very simple example Driver module +lib/DBD/File.pm A driver base class for simple drivers +lib/DBD/File/Developers.pod Developer documentation for DBD::File +lib/DBD/File/Roadmap.pod Roadmap for DBD::File and other Pure Perl DBD's +lib/DBD/File/HowTo.pod Guide to write a DBD::File based DBI driver +lib/DBD/Gofer.pm DBD::Gofer 'stateless proxy' driver +lib/DBD/Gofer/Policy/Base.pm +lib/DBD/Gofer/Policy/pedantic.pm Safest and most transparent, but also slowest +lib/DBD/Gofer/Policy/classic.pm Reasonable policy for typical usage +lib/DBD/Gofer/Policy/rush.pm Raw speed, fewest round trips, least transparent +lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport classes +lib/DBD/Gofer/Transport/corostream.pm Async Gofer transport using Coro and AnyEvent +lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes in same process (for testing) +lib/DBD/Gofer/Transport/pipeone.pm DBD::Gofer transport to new subprocess for each request +lib/DBD/Gofer/Transport/stream.pm DBD::Gofer transport for ssh etc +lib/DBD/NullP.pm An empty example Driver module +lib/DBD/Proxy.pm Proxy driver +lib/DBD/Sponge.pm A driver for fake cursors (precached data) +lib/DBI/Const/GetInfo/ANSI.pm GetInfo data based on ANSI standard +lib/DBI/Const/GetInfo/ODBC.pm GetInfo data based on ODBC standard +lib/DBI/Const/GetInfoReturn.pm GetInfo return values plus tools based on standards +lib/DBI/Const/GetInfoType.pm GetInfo type code data based on standards +lib/DBI/DBD.pm Some basic help for people writing DBI drivers +lib/DBI/DBD/Metadata.pm Metadata tools for people writing DBI drivers +lib/DBI/DBD/SqlEngine.pm SQL Engine for drivers without an own +lib/DBI/DBD/SqlEngine/Developers.pod DBI::DBD::SqlEngine API Documentation +lib/DBI/DBD/SqlEngine/HowTo.pod HowTo ... write a DBI::DBD::SqlEngine based driver +lib/DBI/FAQ.pm The DBI FAQ in module form for perldoc +lib/DBI/Gofer/Execute.pm Execution logic for DBD::Gofer server +lib/DBI/Gofer/Request.pm Request object from DBD::Gofer +lib/DBI/Gofer/Response.pm Response object for DBD::Gofer +lib/DBI/Gofer/Serializer/Base.pm +lib/DBI/Gofer/Serializer/DataDumper.pm +lib/DBI/Gofer/Serializer/Storable.pm +lib/DBI/Gofer/Transport/Base.pm Base class for DBD::Gofer server transport classes +lib/DBI/Gofer/Transport/pipeone.pm DBD::Gofer transport for single requests +lib/DBI/Gofer/Transport/stream.pm DBI::Gofer transport for ssh etc +lib/DBI/Profile.pm Manage DBI usage profile data +lib/DBI/ProfileData.pm +lib/DBI/ProfileDumper.pm +lib/DBI/ProfileDumper/Apache.pm +lib/DBI/ProfileSubs.pm +lib/DBI/ProxyServer.pm The proxy drivers server +lib/DBI/PurePerl.pm A DBI.xs emulation in Perl +lib/DBI/SQL/Nano.pm A 'smaller than micro' SQL parser +lib/DBI/Util/_accessor.pm A veryŹcut-down version of Class::Accessor::Fast +lib/DBI/Util/CacheMemory.pm A very cut-down version of Cache::Memory +lib/DBI/W32ODBC.pm An experimental DBI emulation layer for Win32::ODBC +lib/Win32/DBIODBC.pm An experimental Win32::ODBC emulation layer for DBI +t/01basics.t +t/02dbidrv.t +t/03handle.t +t/04mods.t +t/05concathash.t +t/06attrs.t +t/07kids.t +t/08keeperr.t +t/09trace.t +t/10examp.t +t/11fetch.t +t/12quote.t +t/13taint.t +t/14utf8.t +t/15array.t +t/16destroy.t +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 +t/42prof_data.t +t/43prof_env.t +t/48dbi_dbd_sqlengine.t Tests for DBI::DBD::SqlEngine +t/49dbd_file.t DBD::File API and very basic tests +t/50dbm_simple.t simple DBD::DBM tests +t/51dbm_file.t extended DBD::File tests (through DBD::DBM) +t/52dbm_complex.t Complex DBD::DBM tests with SQL::Statement +t/60preparse.t +t/65transact.t +t/70callbacks.t +t/72childhandles.t +t/80proxy.t +t/85gofer.t +t/86gofer_fail.t +t/87gofer_cache.t +t/90sql_type_cast.t +t/lib.pl Utility functions for test scripts +t/pod.t +t/pod-coverage.t +test.pl Assorted informal tests, including tests for memory leaks +typemap +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..4b3b8bb --- /dev/null +++ b/META.json @@ -0,0 +1,67 @@ +{ + "abstract" : "Database independent interface for Perl", + "author" : [ + "Tim Bunce (dbi-users@perl.org)" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "DBI", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "6.48", + "Test::Simple" : "0.90" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "conflicts" : { + "DBD::AnyData" : "0.09", + "DBD::CSV" : "0.29", + "DBD::PO" : "2.10", + "DBD::RAM" : "0.072", + "SQL::Statement" : "1.27" + }, + "recommends" : { + "Clone" : "0.31", + "DB_File" : "0", + "MLDBM" : "0", + "Net::Daemon" : "0", + "RPC::PlServer" : "0.2001", + "SQL::Statement" : "1.28" + }, + "requires" : { + "perl" : "5.008" + } + } + }, + "release_status" : "stable", + "resources" : { + "homepage" : "http://dbi.perl.org/", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "https://svn.perl.org/modules/dbi/trunk/" + }, + "x_MailingList" : "mailto:dbi-dev@perl.org" + }, + "version" : "1.622" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..2b32528 --- /dev/null +++ b/META.yml @@ -0,0 +1,41 @@ +--- +abstract: 'Database independent interface for Perl' +author: + - 'Tim Bunce (dbi-users@perl.org)' +build_requires: + ExtUtils::MakeMaker: 6.48 + Test::Simple: 0.90 +configure_requires: + ExtUtils::MakeMaker: 0 +conflicts: + DBD::AnyData: 0.09 + DBD::CSV: 0.29 + DBD::PO: 2.10 + DBD::RAM: 0.072 + SQL::Statement: 1.27 +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: DBI +no_index: + directory: + - t + - inc +recommends: + Clone: 0.31 + DB_File: 0 + MLDBM: 0 + Net::Daemon: 0 + RPC::PlServer: 0.2001 + SQL::Statement: 1.28 +requires: + perl: 5.008 +resources: + homepage: http://dbi.perl.org/ + license: http://dev.perl.org/licenses/ + repository: https://svn.perl.org/modules/dbi/trunk/ + x_MailingList: mailto:dbi-dev@perl.org +version: 1.622 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..9680e45 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,397 @@ +# -*- perl -*- +# +# $Id: Makefile.PL 15248 2012-03-26 21:47:22Z timbo $ +# +# Copyright (c) 1994-2010 Tim Bunce Ireland +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. + +use 5.008_001; + +use ExtUtils::MakeMaker 5.16, qw(WriteMakefile $Verbose prompt); +use Getopt::Long; +use Config; +use File::Find; +use File::Spec; +use strict; + +use lib 'lib'; # for use DBI::DBD +use DBI::DBD; + +$| = 1; +$^W = 1; +my $os = $^O; +my $osvers = $Config{osvers}; +$osvers =~ s/^\s*(\d+\.\d+).*/$1/; # drop sub-sub-version: 2.5.1 -> 2.5 +my $ext_pl = $^O eq 'VMS' ? '.pl' : ''; +my $is_developer = ((-d ".svn" || -d ".git") && -f "MANIFEST.SKIP"); + +$::opt_v = 0; +$::opt_thread = 1; # thread if we can, use "-nothread" to disable +$::opt_g = 0; +$::opt_g = 1 if $is_developer && $ENV{LOGNAME} && $ENV{LOGNAME} eq 'timbo'; # it's me! (probably) + +GetOptions(qw(v! g! thread!)) + or die "Invalid arguments\n"; + +$::opt_g &&= '-g'; # convert to actual string + + +if (($ENV{LANG}||'') =~ m/utf-?8/i) { + print "\n"; + print "*** Your LANG environment variable is set to '$ENV{LANG}'\n"; + print "*** This may cause problems for some perl installations.\n"; + print "*** If you get test failures, please try again with LANG unset.\n"; + print "*** If that then works, please email dbi-dev\@perl.org with details\n"; + print "*** including the output of 'perl -V'\n"; + print "\n"; + sleep 1; +} + +if ($Config{useithreads}) { + 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} =~ /\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"; + print "of perl threading (now known as '5005 threads'). It is badly flawed\n"; + print "and could never be safe to use in production environments.\n\n"; + print "If you are using multiple threads you are *strongly* encouraged to\n"; + print "upgrade to perl 5.8.2 or later.\n"; + print "If you are not using multiple threads you are *strongly* encouraged to\n"; + print "upgrade to at least 5.6.1 (preferably perl 5.8.2 or later.)\n"; + print "or at the very least rebuild this version with threading disabled.\n"; + print "If you have stick with your current build of perl...\n"; + print "then you also have to stick with DBI 1.28 for safety.\n"; + print "Or if *desparate* you may be able to build this DBI using 'perl Makefile.PL -nothread' but\n"; + print "but but, that will have *no* logic to handle threads because the logic\n"; + print "that was there for 5005 threads has now been removed! You have been warned.\n"; + die "*** ABORTED.\n"; + } + + $::opt_thread = 0; +} + +my %opts = ( + NAME => 'DBI', + AUTHOR => 'Tim Bunce (dbi-users@perl.org)', + VERSION_FROM => 'DBI.pm', + ABSTRACT_FROM => 'DBI.pm', + MIN_PERL_VERSION => '5.008', + BUILD_REQUIRES => { + 'ExtUtils::MakeMaker' => '6.48', + 'Test::Simple' => '0.90', + }, + META_MERGE => { + resources => { + repository => 'https://svn.perl.org/modules/dbi/trunk/', + MailingList => 'mailto:dbi-dev@perl.org', + license => 'http://dev.perl.org/licenses/', + homepage => 'http://dbi.perl.org/', + }, + recommends => { + 'RPC::PlServer' => 0.2001, + 'Net::Daemon' => 0, + 'SQL::Statement' => 1.28, + 'Clone' => 0.31, + 'MLDBM' => 0, + 'DB_File' => 0, + }, + }, + PREREQ_PM => { + ( $^O eq 'MSWin32' ? ( 'File::Spec' => 3.31, ) : () ), + }, + CONFLICTS => { + 'SQL::Statement' => '1.27', + 'DBD::AnyData' => '0.09', + 'DBD::CSV' => '0.29', + 'DBD::RAM' => '0.072', + 'DBD::PO' => '2.10', + }, + LICENSE => 'perl', + EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl", "dbilogstrip$ext_pl" ], + DIR => [ ], + dynamic_lib => { OTHERLDFLAGS => "$::opt_g" }, + clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t dbi__null_test_tmp*" + ." dbiproxy$ext_pl dbiprof$ext_pl dbilogstrip$ext_pl dbiproxy.*log dbitrace.log dbi*.prof ndtest.prt" }, + dist => { + DIST_DEFAULT=> 'clean distcheck disttest tardist', + PREOP => '$(MAKE) -f Makefile.old distdir', + COMPRESS => 'gzip -v9', SUFFIX => 'gz', + }, +); +$opts{CAPI} = 'TRUE' if $Config{archname} =~ /-object\b/i; + +if (my $gccversion = $Config{gccversion}) { # ask gcc to be more pedantic + warn "WARNING: Your GNU C $gccversion compiler is very old. Please upgrade it and rebuild perl.\n" + if $gccversion =~ m/^\D*(1|2\.[1-8])/; + print "Your perl was compiled with gcc (version $Config{gccversion}), okay.\n"; + $gccversion =~ s/[^\d\.]//g; # just a number please + $opts{DEFINE} .= ' -W -Wall -Wpointer-arith -Wbad-function-cast'; + $opts{DEFINE} .= ' -Wno-comment -Wno-sign-compare -Wno-cast-qual'; + $opts{DEFINE} .= ' -Wmissing-noreturn -Wno-unused-parameter' if $gccversion ge "3.0"; + if ($is_developer && $::opt_g) { + $opts{DEFINE} .= ' -DPERL_GCC_PEDANTIC -ansi -pedantic' if $gccversion ge "3.0"; + $opts{DEFINE} .= ' -Wdisabled-optimization -Wformat' if $gccversion ge "3.0"; + $opts{DEFINE} .= ' -Wmissing-prototypes'; + } +} + +$opts{DEFINE} .= ' -DDBI_NO_THREADS' unless $::opt_thread; + +# HP-UX 9 cannot link a non-PIC object file into a shared library. +# Since the # .a libs that Oracle supplies contain non-PIC object +# files, we sadly have to build static on HP-UX 9 :( +if ($os eq 'hpux' and $osvers < 10) { + $opts{LINKTYPE} = 'static'; + print "Warning: Forced to build static not dynamic on $os $osvers.\a\n"; + print "** Note: DBI will be built *into* a NEW perl binary. You MUST use that new perl.\n"; + print " See README and Makefile.PL for more information.\a\n"; +} + +if ($os eq 'MSWin32' && $Config{libs} =~ /\bPerlCRT.lib\b/ + && -f "$Config{archlib}/CORE/PerlCRT.lib") { + # ActiveState Perl needs this; should better be done in MakeMaker, but + # as a temporary workaround it seems ok. + $opts{LIBS} = "-L$Config{archlib}/CORE"; +} + +# Set aside some values for post_initialize() in package MY +my ( $cfg_privlibexp, $cfg_archlibexp, $cfg_sitelibexp, $cfg_sitearchexp, + $cfg_man3direxp ) = + @Config{qw( privlibexp archlibexp sitelibexp sitearchexp man3direxp ) }; +for ( $cfg_privlibexp, $cfg_archlibexp, $cfg_sitelibexp, $cfg_sitearchexp, + $cfg_man3direxp ) { + $_ = '' unless defined $_; +} + +# If working from git-svn, the $Id: Makefile.PL 15248 2012-03-26 21:47:22Z timbo $'s in the mod's should be completed +# before any other action is taken +$is_developer && -d ".git" && -f "git-svn-vsn.pl" and system $^X, "git-svn-vsn.pl"; + +my $conflictMsg = < 1, + create_nano_tests => 1, + create_gap_tests => 1, + }) +); +# WriteMakefile call is last thing executed +# so return value is propagated + + +# ===================================================================== + +package MY; + +sub postamble { +warn <SUPER::const_cccmd(@_); + # If perl Makefile.PL *-g* then switch on debugging + if ($::opt_g) { + s/\s-O\d?\b//; # delete optimise option + s/\s-/ -g -/; # add -g option + } + $_; +} + + +sub post_initialize { + my($self) = shift; + + if ($cfg_privlibexp ne $cfg_sitelibexp) { + # this block could probably be removed now + my %old; + File::Find::find( sub { + local $_ = $File::Find::name; + s:\\:/:g if $os eq 'MSWin32'; + $File::Find::prune = 1, return + if -d $_ && ( $_ eq $cfg_sitelibexp || + $_ eq $cfg_sitearchexp || + $_ eq $cfg_man3direxp ); + ++$old{$_} if m:\bDB(I|D$):; # DBI files, but just DBD dirs + }, $cfg_privlibexp, $cfg_archlibexp ); + if ( %old ) { + warn " +Warning: By default new modules are installed into your 'site_lib' + directories. Since site_lib directories come after the normal library + directories you must delete old DBI files and directories from your + 'privlib' and 'archlib' directories and their auto subdirectories. + +Reinstall DBI and your DBD::* drivers after deleting the old directories. + +Here's a list of probable old files and directories: + + " . join( "\n ", ( sort keys %old ), "\n" ); + } + } + + # install files that DBD's may need + File::Find::find( sub { + + # may be '.' or '[]' depending on File::Find version + $_ = '.' if $^O eq 'VMS' && $_ eq File::Spec->curdir; + + $File::Find::prune = 1, return if -d $_ && '.' ne $_; + $self->{PM}->{$_} = File::Spec->catfile($self->{INST_ARCHAUTODIR}, $_) + if '.h' eq substr( $_, -2 ) || '.xst' eq substr( $_, -4 ); + }, '.' ); + + delete $self->{$_}{"git-svn-vsn.pl"} for qw( PM MAN3PODS ); + + return ''; +} + + +sub post_constants { + my($self) = shift; + + # ensure that Driver.xst and related code gets tested + my $xst = main::dbd_postamble(); + $xst =~ s/\$\(BASEEXT\)/Perl/g; + $xst .= ' +dbixs_rev.h: DBIXS.h Driver_xst.h dbipport.h dbivport.h dbixs_rev.pl + $(PERL) dbixs_rev.pl + +DBI.c: Perl$(OBJ_EXT) + +# make Changes file available as installed pod docs "perldoc DBI::Changes" +inst_libdbi = ' . File::Spec->catdir($self->{INST_LIB}, 'DBI') . ' +changes_pm = ' . File::Spec->catfile($self->{INST_LIB}, 'DBI', 'Changes.pm') . ' +'.q{ + +config :: $(changes_pm) + $(NOECHO) $(NOOP) + +$(changes_pm): Changes + $(MKPATH) $(inst_libdbi) + $(RM_F) $(changes_pm) + $(CP) Changes $(changes_pm) + +ptest: all + prove --blib --jobs 4 --shuffle + +faq: + : checkin any local changes not already checked in before overwriting + svn commit --message "dbi.tiddlyspot.com FAQ update" dbi.tiddlyspot.com.html + wget --ignore-length --output-document=dbi.tiddlyspot.com.html --timestamping http://dbi.tiddlyspot.com/download + svn commit --message "dbi.tiddlyspot.com FAQ update" dbi.tiddlyspot.com.html + +checkkeywords: + $(RM_RF) blib + find . -type f \( -name .svn -prune -o -name \*.pm -o -name \*.PL -o -name \*.pl \) \ + -exec bash -c '[ -z "$$(svn pg svn:keywords {})" ] && echo svn propset svn:keywords \"Id Revision\" {}' \; + +checkpod: + $(RM_RF) blib + find . -type f \( -name .svn -prune -o -name \*.pm -o -name \*.PL -o -name \*.pl \) \ + -exec podchecker {} \; 2>&1 | grep -v 'pod syntax OK' +}; + + return $xst; +} + +# end. diff --git a/Perl.xs b/Perl.xs new file mode 100644 index 0000000..048e9d9 --- /dev/null +++ b/Perl.xs @@ -0,0 +1,54 @@ +/* This is a skeleton driver that only serves as a basic sanity check + that the Driver.xst mechansim doesn't have compile-time errors in it. + vim: ts=8:sw=4:expandtab +*/ + +#define PERL_NO_GET_CONTEXT +#include "DBIXS.h" +#include "dbd_xsh.h" + +#undef DBIh_SET_ERR_CHAR /* to syntax check emulation */ +#include "dbivport.h" + +DBISTATE_DECLARE; + + +struct imp_drh_st { + dbih_drc_t com; /* MUST be first element in structure */ +}; +struct imp_dbh_st { + dbih_dbc_t com; /* MUST be first element in structure */ +}; +struct imp_sth_st { + dbih_stc_t com; /* MUST be first element in structure */ +}; + + + +#define dbd_discon_all(drh, imp_drh) (drh=drh,imp_drh=imp_drh,1) +#define dbd_dr_data_sources(drh, imp_drh, attr) (drh=drh,imp_drh=imp_drh,Nullav) +#define dbd_db_do4(dbh,imp_dbh,p3,p4) (dbh=dbh,imp_dbh=imp_dbh,p3=p3,p4=p4,-2) +#define dbd_db_last_insert_id(dbh, imp_dbh, p3,p4,p5,p6, attr) \ + (dbh=dbh,imp_dbh=imp_dbh,p3=p3,p4=p4,p5=p5,p6=p6,&PL_sv_undef) +#define dbd_take_imp_data(h, imp_xxh, p3) (h=h,imp_xxh=imp_xxh,&PL_sv_undef) +#define dbd_st_execute_for_fetch(sth, imp_sth, p3, p4) \ + (sth=sth,imp_sth=imp_sth,p3=p3,p4=p4,&PL_sv_undef) + +#define dbd_st_bind_col(sth, imp_sth, param, ref, sql_type, attribs) \ + (sth=sth,imp_sth=imp_sth,param=param,ref=ref,sql_type=sql_type,attribs=attribs,1) + +int /* just to test syntax of macros etc */ +dbd_st_rows(SV *h, imp_sth_t *imp_sth) +{ + dTHX; + h = h; /* silence unused var warning */ + DBIh_SET_ERR_CHAR(h, imp_sth, 0, 1, "err msg", "12345", Nullch); + return -1; +} + + +MODULE = DBD::Perl PACKAGE = DBD::Perl + +INCLUDE: Perl.xsi + +# vim:sw=4:ts=8 diff --git a/README b/README new file mode 100644 index 0000000..d6fb465 --- /dev/null +++ b/README @@ -0,0 +1,145 @@ +DBI - The Perl Database Interface by Tim Bunce. + +Copyright (c) 1994-2010 Tim Bunce Ireland. + +See COPYRIGHT section in DBI.pm for usage and distribution rights. + +See GETTING HELP section in DBI.pm for how to get help. + +QUICK START GUIDE: + + The DBI requires one or more 'driver' modules to talk to databases, + but they are not needed to build or install the DBI. + + Check that a DBD::* module exists for the database you wish to use. + + Read the DBI README then Build/test/install the DBI by doing + perl Makefile.PL + make + make test + make install + Then delete the source directory tree since it's no longer needed. + 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. + + Fetch the DBD::* driver module you wish to use and unpack it. + http://search.cpan.org/ (or www.activestate.com if on Windows) + It is often important to read the driver README file carefully. + Generally the build/test/install/delete sequence is the same + as for the DBI module. + + +The DBI.pm file contains the DBI specification and other documentation. +PLEASE READ IT. It'll save you asking questions on the mailing list +which you will be told are already answered in the documentation. + +For more information and to keep informed about progress you can join +the a mailing list via mailto:dbi-users-help@perl.org + +To help you make the best use of the dbi-users mailing list, +and any other lists or forums you may use, I strongly +recommend that you read "How To Ask Questions The Smart Way" +by Eric Raymond: + + http://www.catb.org/~esr/faqs/smart-questions.html + +Much useful information and online archives of the mailing lists can be +found at http://dbi.perl.org/ + +See also http://search.cpan.org/ + + +BEFORE BUILDING, TESTING AND INSTALLING this you will need to: + + Build, test and install a recent version of Perl 5 + It is very important to test it and actually install it! + (You can use "Configure -Dprefix=..." to build a private copy.) + +BUILDING + + perl Makefile.PL + make + make test + make test TEST_VERBOSE=1 (if any of the t/* tests fail) + make install (if the tests look okay) + +The perl you use to execute Makefile.PL should be the first one in your PATH. +If you want to use some installed perl then modify your PATH to match. + +IF YOU HAVE PROBLEMS: + +First, carefully read the notes at the bottom of this file. + +If you can't fix it your self please post details to dbi-users@perl.org. +Please do _not_ send them just to me. Please include: + +1. A complete log of a complete build, e.g.: + + perl Makefile.PL (do a make realclean first) + make + make test + make test TEST_VERBOSE=1 (if any of the t/* tests fail) + +2. The output of perl -V + +3. If you get a core dump, try to include a stack trace from it. + (Try installing the Devel::CoreStack module to get a stack trace.) + If the stack trace mentions XS_DynaLoader_dl_load_file then rerun + make test after setting the environment variable PERL_DL_DEBUG to 2. + +4. If your installation succeeds, but your script does not behave + as you expect, the problem is possibly in your script. Before + sending to dbi-users, try writing a small, easy to use test case + to reproduce your problem. Also, use the DBI->trace method to + trace your database calls. + +Please don't post problems to comp.lang.perl.* or perl5-porters. +This software is supported via the dbi-users mailing list. For more +information and to keep informed about progress you can join the +mailing list via mailto:dbi-users-help@perl.org +(please note that I do not run or manage the mailing list). + +It is important to check that you are using the latest version before +posting. If you're not then I'm very likely to simply say "upgrade to +the latest". You would do yourself a favour by upgrading beforehand. + +Please remember that I'm _very_ busy. Try to help yourself first, +then try to help me help you by following these guidelines carefully. +(Note specifically that I'm unlikely to answer a question that's +answered clearly in the on-line documentation.) + +Regards, +Tim Bunce. + +======================================================================= + +--- +If you get an error like "gcc: command not found" or "cc: command not found" +you need to either install a compiler, or you may be able to install a +precompiled binary of DBI using a package manager (e.g., ppm for ActiveState, +Synaptic for Ubuntu, port for FreeBSD etc) + +--- +If you get compiler errors refering to Perl's own header files +(.../CORE/*.h) or the compiler complains about bad options etc then +there is something wrong with your perl installation. If the compiler complains +of missing files (.../perl.h: error: sys/types.h: No such file) then you may +need to install extra packages for your operating system. + +Generally it's best to use a Perl that was built on the system you are trying +to use and it's also important to use the same compiler that was used to build +the Perl you are using. + +If you installed Perl using a binary distribution, such as ActiveState Perl, +or if Perl came installed with the operating system you use, such as Debian or +Ubuntu, then you may be able to install a precompiled binary of DBI using a +package manager. Check the package manager for your distribution of Perl (e.g. +ppm for ActiveState) or for your operating system (e.g Synaptic for Ubuntu). + +--- +If you get compiler warnings like "value computed is not used" and +"unused variable" you can ignore them. + +End. diff --git a/TODO_2005.txt b/TODO_2005.txt new file mode 100644 index 0000000..8020ae7 --- /dev/null +++ b/TODO_2005.txt @@ -0,0 +1,579 @@ +Change ideas for DBI +==================== + +--- Changes that may impact applications: + +Turning AutoCommit on, such as when { local $dbh->{AutoCommit} = 0; ... } +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). +RISK: May impact code running with taint enabled but not DBI TaintIn/Out +Also consider other changes to TaintIn/TaintOut attribute semantics. + +Alter tables() to default $schema to $dbh->current_schema. +So tables() will default to returning tables in the current schema. +(Should include public synonyms) +RISK: This will impact code requiring tables from multiple schema. +REMEDY: specify $schema parameter ("%" for all?) + +Add $dbh->current_schema (default to $dbh->{Username}) + +Remove old informix fudge in tables() (would only impact people +using very old DBD::Informix versions as it now has it's own). + +Remove "old-style" connect syntax (where driver name is 4th parameter). + +Change undocumented DBI->err and DBI->errstr methods to warn. + +Bundle enhanced DBD::Multiplex +RISK: may break apps using old DBD::Multiplex + +disconnect() implies rollback() unless AutoCommit (Driver.xst + drivers) + +--- Internal Changes + +Move DBI::xx classes to DBI::xx_base and sanction use of DBI::xx +classes for extensions via mixins. + +Increase size of DBIS (dbistate) structure and imp_xxh.com structures +and improve size/version sanity checks. + +Make ShowErrorStatement=>1 the default when handle is created + +Mandate use of dbivport.h and related macros. + +Drivers to alter trace level behaviour (no output at low levels +and use named trace topics). + +Mandate that NUM_OF_FIELDS must be set by execute() and +can't be deferred till $sth->{NUM_OF_FIELDS} or fetch*_*() called. + +Add PERL_NO_GET_CONTEXT for multiplicity/threads? + +Remove DBIS global and related macros. +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. + +Add function pointers for setting fetched field values into DBIS. +IV, UV, NV, PV and SV? +Drivers to use this instead of calling sv_setpv (etc) themselves. +Use internally for set_fbav(). + +Add function pointer to indicate 'all fields set'. +Use for both per-field and per-row OnFetch hooks. + +New reset() method: +$dbh->reset - disconnects + discards all state related to the particular connection +$sth->reset - finish + discards all state related to the particular statement +Effectively think of a handle as having two parts: +attributes related to a particular connection/statement (CachedKids/NUM_OF_PARAMS) +and attribute not-related (AutoCommit/RaiseError). +The reset method resets the first set but not the second. +The reset method would call uncache(). + +Rework handle creation to use methods: +Maybe $h->new_child(\%handle_attr) + dr::connect => + $dbh = $drh->new_child(\%attr); + $dbh->connect(...) - calls $dbh->reset() +& db::prepare => + sub ...::db::prepare { + my ($dbh, $sql, $attr) = @_; + $sth = $dbh->new_child($attr) + my @statements = $dbh->preparse($sql); + $sth->{PendingStatements} = \@statements if @statements > 1; + $sth->prepare( shift @statements ) or return; + return $sth; + } + sub prepare_cached - no change, calls $dbh->prepare. + sub ...::st::prepare { + $sth->reset; + ... + } +Also need to consider $sth->more_results and its need for reset()-like behaviour. + +Need to enable drivers to work with old and new approaches, +which means having both ::db::prepare and ::st::prepare +When a driver is loaded the ::db::prepare() method +will be deleted if a ::st::reset method exists. + +Make $DBI::err etc plain (untied) variables. +Set them in set_err() and when returning from dispatch. +Clear them, if appropriate, when entering dispatch dispatch(). + +Enable drivers to provide a hash to map err codes into state values. + +Unified test suite infrastructure to be reused by all drivers. +A big project. + +-- others -- + +Add (auto-maintained) #define macro giving the version number of the DBI +as an integer in a form that can be used by #if statements (eg 1043000) +e.g. Have Makefile.PL write a .h file that contains the value and have +that #included by DBIXS.h + +Fixup @DBD::Foo::ISA and ?->setup_driver issues + +Add "imp_xxh_t* imp_xxh;" element to com struct that points back at +itself so macros can be written to work with imp_??h without needing casts. +ALso make it cheap to get h from imp_xxh so only imp_xxh needs +to be passed around. + +Add utility function that does SvUTF8_on(sv) if the sv contains +valid-looking utf8. To be used (perhaps via OnFetch hook) where +utf8 data is being stored in a non-utf8 aware database. + +Add DBIS->carp(varargs) to simplify access to Carp::carp so warnings +like "execute called with 1 bind variables when 0 are needed" fr do() +get reported against caller's file and line number and not a line in DBI.pm + +pre and post call hooks via ima structure? + +Remove _not_impl. Alias debug to trace in DBI::(dr/db/st) and remove +debug() method from internals. + +DBD::Multiplex enhancements (Thomas Kishel ): +Enable DBIx::HA (http://search.cpan.org/~hasseily/DBIx-HA/HA.pm) features. +SQL translation hooks: +mx_translate_sql_parent - called by prepare() to translate sql from app +mx_translate_sql_child - called for each child handle so each can have different dialect +(note that mx_translate_sql_parent could parse into internal tree +from which mx_translate_sql_child then 'regenerates' custom sql for the child handle) +See also http://c-jdbc.objectweb.org/ + +Use subversion mechanism for $VERSION in source files. + +====== LATER ====== + +Define expected uft8 behaviour. Basically drivers need to set the +uft8 flag on returned strings themselves when appropriate. +The DBI I define a way for an application to indicate that +a particular column should be flagged as uft8 to help drivers +that are not able to determine that themselves. +The DBI won't support automatic character set conversions. + +Define "topic bits" for TraceLevel. +%DBI::TraceTopics & %DBD::Foo::TraceTopics +"Lint" topic for extra checking, eg warn on $sth DESTROY if still Active +"Verbose" topic adds verbosity to any other enabled topics +"Connect" topic to log connect/disconnect/reconnect/failed-ping +Add topic flags to ima struct and log when bits match? +Use one bit for logging just the SQL statement executed +(with no extra text) ideally in a way that lets the text +file be parsed again later. Perhaps append ";\n\n\n" to each. +Add parameter values and row count as comments afterwards? +Use one bit for logging just Errors. + +Ability to remove a handle from the parents cache: + $sth->uncache; +and $dbh->uncache; for connect_cached + +Add discard_pending_rows() as an alias +for finish() - which will be deprecated. + +$sth->{ParamAttr} eg { "1" => SQL_VARCHAR, "2" => { TYPE=>SQL_VARCHAR, ora_type=>99 }}; + +$h->{KidsHandles} = ref to cache (array or hash?) +of weakrefs to child handles (bugs pre 5.8.5 with CLONE and weakrefs, +see Perl changes 21936 and 22106) +DESTROY could automatically disconnect/finish children + +Document DbTypeSubclass (ala DBIx::AnyDBD) +Polish up and document _dbtype_names with an external interface and using get_info. + +FetchHashReuse attrib (=1 or ={}) copy from dbh to sth +and use to optimise fetchrow_hash + +--- Changes that may affect driver authors + +Add PERL_NO_GET_CONTEXT for multiplicity/threads? +force it for drivers? +And enable xsbypass in dispatch if possible. + +Add log_where() to "trace level set to" log message. + +Add bind_col($n, \$foo, { OnFetch => sub { ... } }); + +Add way to specify default bind_col attributes for each TYPE +e.g. $dbh->{DefaultBindTypeArgs} = { + SQL_DATE => { TYPE => SQL_DATE }, + SQL_DATETIME => { TYPE => SQL_DATETIME, OnFetch => \&foo }, + }; + # effectively automatically adds these as defaults: + $sth->bind_col(1, \$foo, { + %{ $dbh->{DefaultBindTypeArgs}{$sth->{TYPE}->[1]}, # <== + OnFetch => sub { ... } + }); # YYYY-MM-DD + +Method call for drivers to get (or indicate they've got) the sth metadata +which can then be used to trigger default bind_cols. + +Add a handle flag to say that the driver has a hash that maps error +codes into SQLSTATE values. The error event mechanism could check for +the flag and lookup the SQLSTATE value for the error from the hash. +Allow code hook as well. Maybe $dbh->{SQLSTATE_map} = code or hash ref + +Add minimum subset of ODBC3 SQLSTATE values that should be supported +(and corresponding ODBC2 values?) + +Add more macro hooks to Driver.xst: ping, quote etc. + +Add dbh active checks to some more sth methods where reasonable. + +Define consise DBI<>DBD interface with view towards parrot. + note that parrot will use more method calls instead of + 'sideways' hooks into DBIS and the driver C code. +DBI::DBD::Base module? +Update DBI::DBD with overview and (at least) recommend Driver.xst strongly. +Find XS drivers that don't use it and talk to authors. + +#define a large negative number to mean 'error' from st_execute and +change *.xst to treat either that or -2 as an error. (The -2 is +a transition for old drivers.) + +--- Other changes + +Simplify layering/subclassing of DBD's + +Reconsider clone() API + +See comment under $drh->$connect_meth in DBI.pm about $drh->errstr + +Ensure child $h has err reset after connect_cached() or prepare_cached() +or else document that $DBI:err may be true after those methods even +though they haven't failed. Umm. Fixed if $DBI::err isn't tied. + +Change t/zz_*_pp.t to be t/zXX_*.t where XX is a combination of: + - 'pp' (for DBI_PUREPERL=2) + - 'mx' (for DBI_AUTOPROXY=dbi:Multiplex:) + - 'pr' (for DBI_AUTOPROXY=dbi:Proxy:) +mx and pr wouldn't both apply to the same test + +Add data structure describing attributes +Use the data structure to replace similar data in Proxy, Multiplex, +PurePerl and other places. + +Add OnConnect attribute to connect() esp. for connect_cached() + +Macro to get new statement handle for XS code + +Trace to tied file handle. + +Add method to try to make the connection (session) read-only. + +preparse() - incl ability to split statements on semicolon + +Hooks for method entry and exit. + +$dbh->{Statement} can be wrong because fetch doesn't update value +maybe imp_dbh holds imp_sth (or inner handle) of last sth method +called (if not DESTROY) and sth outer DESTROY clears it (to reduce ref count) +Then $dbh->{LastSth} would work (returning outer handle if valid). +Then $dbh->{Statement} would be the same as $dbh->{LastSth}->{Statement} +Also $dbh->{ParamValues} would be the same as $dbh->{LastSth}->{ParamValues}. + +Remove dummy 'Switch' driver. + +Sponge behave_like - generalize into new_child() + copy RaiseError, PrintError, HandleError etc from the specified handle + but which attributes? LongReadLen, LongTruncOk etc? Presumably all + as we're acting as a proxy behind the scenes. + Should behave_like handle be dbh or sth or either or same as parent? + +Add per-handle debug file pointer: + NULL default => h->dbis->tracefp + if not NULL then dup() via PerlIO for child handles + close(h->tracefp) at end of DESTROY + macro to do (h->tracefp || h->dbis->tracefp) + $h->{TraceFileHandle} ? (enable "local $h->{TraceFileHandle} = ..."?) + +Move TIEHASH etc to XS (and to PurePerl) + +Change CachedKids to be a simple attribute cached in the handle hash +to remove FETCH method call overhead in prepare_cached(). + +--- Other things to consider + +Add $h->err_errstr_state method that returns all three in one go. + +Support async (non-blocking) mode + +Add $sql = $dbh->show_create($schema_object_name) to return statement +that would create that schema object, where possible. + +Add $id = $dbh->get_session_id() and $dbh->kill_session_id($id). + +Study alternate DBI's: + ruby + python + php + others? + ADO object model +identify any features we could usefully support and any incompatibilities etc + +Add DB version (major.minor ISA major) to DbSubType ISA tree. + +Add API to get table create statement (ala SHOW CREATE TABLE foo in MySQL). + +Consider closer mapping to SQL3 CLI API for driver API. + +Phalanx - test coverage + +=cut + +*** Small/quick/simple changes/checks *** + +fetchall_hashref for multiple keys - pending + my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; + my $names_hash = $sth->FETCH("${hash_key_name}_hash"); + + my @key_fields = (ref $key_field) ? @$key_field : ($key_field); + my @key_values; + foreach (@key_fields) { + + my $index = $names_hash->{$_}; # perl index not column + ++$index if defined $index; # convert to column number + $index ||= $key_field if DBI::looks_like_number($key_field) && $key_field>=1; + + push @key_values, undef; + $sth->bind_col($index, \$key_value[-1]) or return; + } + + my $rows = {}; + my $NAME = $sth->{$hash_key_name}; + while (my $row = $sth->fetchrow_arrayref($hash_key_name)) { + my $ref = $rows; + $ref = $ref->{$_} ||= {} for @key_values; + @{$ref}{@$NAME} = @$row; + } + return \%rows; + + + +*** Assorted to-do items and random thoughts *** IN NO PARTICULAR ORDER *** + +DBIx::DWIW + +make lasth return outer handle? + +update lasth on return from method so handles used by the implementation +of the called method don't affect it? + +document dbi_fetchall_arrayref_attr attr of selectall_arrayref(). + +ODBC 3.5 date and intervals types and subtypes (from unixODBC?) +http://www.vpservices.com/jeff/programs/SQL/docs/odbc-getinfo-msdn.html + +Proxy: allow config to specify SQL to allow/deny via regexen +Docs for connect_cached and test with proxy. + +Attribute to prepare() to prefer lazy-prepare, +e.g., don't talk to server till first execute +or a statement handle attribute is accessed. + +How to report error from attribute FETCH as fetch method is marked +keep_error? Perhaps some way to make the current keep_error value +in the dispatch code available to change (via pointer in DBIS?) so +a method can change the value of keep_error that's used when the +method returns. Fixed since 1.43? + +BINDING: + +Add to docs & tutorial re wrong bind type on a param may cause +index to not be used! (Find real examples first) +check using EXPLAIN SELECT * WHERE int_indexed_col='42' vs =42. +also WHERE int_column = '01' relies on db to convert '01' to an int +rather than convert int_colum values to strings (which wouldn't match). + +> And note that if you are using bind_param_inout as 'bind_param_by_ref', +> then the $maxlen parameter is redundant. I suspect all drivers could +> implement bind_param_by_ref; most drivers, and specifically the Informix +> driver, has no need for bind_param_inout as a mechanism for getting data +> back from the database as there are no methods in the database which +> work like that. With Informix, values are passed to the database for +> placeholders, and values are returned through a cursor, and that's all. +Okay. I'll take that as a vote for bind_param_by_ref as an alias for +bind_param_inout. >>todo. + +bind_param_by_ref (or bind_param_byref) could be provided as a fallback +method using a BeforeExecute hook to call bind_param with the 'current value' +from the reference. + +Should ParamValues hold the value or the ref? +Use ParamAttr to indicate byref? + +------ + +OTHERS: + +Add method like + sub perform_transaction { + my ($dbh, $attr, $coderef, @args) = @_; + my $wantarray = wantarray; + my $use_transaction = 1; + my $orig_AutoCommit = $dbh->{AutoCommit}; + if ($orig_AutoCommit) { + unless (eval { $dbh->{AutoCommit} = 0; 1 }) { + die unless $allow_non_transaction; + $use_transaction = 0; + } + } + local $dbh->{RaiseError} = 1; + eval { + @result = ($wantarray) ? $coderef->(@args) : scalar $coderef->(@args); + $dbh->commit if $use_transaction; + $attr->{OnCommit}->() if $attr->{OnCommit}->(); + }; + if ($@) { + local $@; protect original error + my $rv = eval { ($use_transaction) ? $dbh->rollback : 0 }; + $attr->{OnRollback}->($rv) if $attr->{OnRollback}; + } + die if $@; # propagate original error + $dbh->{AutoCommit} = 1 if $orig_AutoCommit; + return $result[0] unless $wantarray; + return @result; + } + +Change bind_column to save the info for get_fbav to use when +first called. Thus making bind before execute work for all drivers. + +ODBC attribute defining if transactions are supported +http://www.vpservices.com/jeff/programs/SQL/docs/odbc-getinfo-msdn.html + +Informix inspired changes? + +Add hook to DBI::DBD to write a myconfig.txt file into the +source directory containing key driver and config info. + +dbish - state AutoCommit status clearly at connect time. +(And try to set AutoCommit off in eval?) +test shell "/connect user pass" etc + +check out http://tegan.deltanet.com/~phlip/DBUIframe.html + +Check DBD::Proxy connect&fetch latency (e.g. CGI use). + +****** Less urgent changes ****** + +$dbh->ping($skip_seconds) - skip the ping if ping'd less than $skip_seconds ago +and $h->err is false +Change connect_cached() to use ping($skip_seconds || 1); + + +$dbh->get_inner_handle / set_inner_handle + use to make $dbh->connect return same handle +Hook to call code ref on each fetch, pass fbav ref +datarow_array(), datarow_arrayref(), datarow_hashref() +remove sth from prepare_cached cache. + + +Give handles names: $h->{Id} ? +Useful for reporting, Multiplex, DBD::AnyData etc etc +May become useful for weakrefs etc + +--- Fetch scroll and row set + +fetch_scroll() handling via get_fbav. +Also add: + row_array(offset) + row_arrayref(offset) + row_hashref(offset) +get_fbav has three modes: + single row - return cached RV to same cached AV + alternate rows - return RV to AV[row % 2] + row set - return RV to AV[++row] + +Enable fetchall_arrayref() to reuse a cached rowset so the overhead +of allocating and freeing the individual row arrays and the rowset +array can be avoided. fetchall_arrayref would then return the same +arrayref each time. Most useful when combined with $maxrows. + +Bless row into DBI::Row ? +Bless row set into DBI::Rowset ? +Give get/set access to entire rowset via method calls? + want to be able to plug in pre-loaded data row cache to new sth + so it'll return the same data. + +Add 'break handling' when field values change? +Use two fbav's so 'previous record' is available. +Define break fields and handlers. +Call them via an alternate fetch_with_break method. +Jan 2002: Also now see DBIx::FetchLoop (Brendan Fagan) +Alternatively, and perferably, add sufficient hooks for this to be +done efficiently externally. + +Devel::Leak integration? + +XA transaction interface. References: +http://xapool.experlog.com/ +http://www.opengroup.org/publications/catalog/s423.htm +http://www-106.ibm.com/developerworks/websphere/library/techarticles/0407_woolf/0407_woolf.html?ca=dnp-327 + +Consider issues affecting OSMM score. Add relevant notes to docs. + +--- DBI::Profile + +Add %time to per-node DBI::Profile dump + +Add 'executer' and 'fetcher' method attributes and increment +corresponding counters in DBIS when method with those attributes +are called. When profiling record in the profile data the amount +they have incremented. +Add DBI_PROFILE option so count is executions and avg time can be +totaltime/executions not totaltime/methodcalls. + +DBI::Profile: add simple way to normalise the sql (convert constants +to placeholders) so profiling is more effective for drivers/applications +which don't use placeholders. Requires preparse()? + +DBI::Profile: Add calc of approx XS method call and timing overhead +by calling perl_call("DBI::dbi_time") x100 at boot time for profile, +and add 1/100 (x2) to each sample. Beware Win32 where resolution +is too small and overhead will be 0 normally but may be eg 100ms +if overhead probe is on cusp of time unit. + +Add mechanism so "call path" can be included in the Path of the +profile data. Something like "@;..." or +optionally just the basename part. (See log_where()) + +Allow code ref in Path and use result as string for that element of the Path. + +Fix dbi_time for Windows by using or linking-to Time::HiRes code. + +--- + +Add a C call to return boolean for is a number' for a given SV. +Needs to do the right thing for a non-numeric string SV that's been +tested in a numeric context (eg $a='S23'; foo() if $a==-1; $sth->execute($a)) +So if SvNVOK is true but the value is 0 then should also do looks_like_number() +to be sure. [Does perl's looks_like_number() do this already, if not what code do +callers of looks_like_number() use?] + +Record attrib STOREs so can be replayed/copied to new or cloned handle. + +--- Test suite (random thoughts beyond the basic architecture in my head) + +one test file = one scenario setup (fixture) +cleanup (destroy all data, disconnect etc) +repeat tests with different data types (CHAR vs NCHAR) (implies changing fixtures?) +repeat tests with contextual changes (pureperl/proxy/multiplex etc) +test with overloaded and other kinds of 'magical' values +Good to have 'behavior' tests were the outcome is noted but doesn't + trigger failure e.g. limitation tests: data values out of range, + eg truncation, may or may not cause an error depending on the database. +random order of subtests +leak detection after cleanup diff --git a/TODO_gofer.txt b/TODO_gofer.txt new file mode 100644 index 0000000..d33116b --- /dev/null +++ b/TODO_gofer.txt @@ -0,0 +1,56 @@ +Gofer TODOs: + +DBD::Gofer and http transport changes +add comparisons with other proxies to gofer docs (see notes) + http://code.google.com/p/mod-ndb/ + http://code.nytimes.com/projects/dbslayer +update gofer pdf in distribution +talk about multiple statements in single sql for gofer +inbalance between two calls to _store_response_in_cache + - the call in transmit_request doesn't have the response_needs_retransmit logic + +Add server-side caching. + combine these: + my $request = $transport->thaw_request( $frozen_request, $serializer ); + my $response = $executor->execute_request( $request ); + my $frozen_response = $transport->freeze_response($response, $serializer); + into single method that first checks the cache and updates it if appropriate. + Different serializations will have different caches + +Add DBI::Gofer::Serialiser::MIME / Base64 +Add DBI::Gofer::Serialiser::JSON + +Gofer - allow dbh attrib changes after connect? + note them and pass in request as STORE method calls + but then gofer server need to reset them to restore dbh to original state + Or, change the attr in the connect() call, but that risks + bloating the number of cache dbh in the server. +Gofer request flags for: + - return current executor stats as an attribute - handy for tests + - will accept streamed resultsets +Add attr-passthru to prepare()? ie for gofer cache control & ReadOnly +Define and document termind that first checks the cache and updates it if appropriate. + Different serializations will have different caches + +Add DBI::Gofer::Serialiser::MIME / Base64 +Add DBI::Gofer::Serialiser::JSON + +Gofer - allow dbh attrib changes after connect? + note them and pass in request as STORE method calls + but then gofer server need to reset them to restore dbh to original state + Or, change the attr in the connect() call, but that risks + bloating the number of cache dbh in the server. +Gofer request flags for: + - return current executor stats as an attribute - handy for tests + - will accept streamed resultsets +Add attr-passthru to prepare()? ie for gofer cache control & ReadOnly +Define and document terminology for client and server ends +Document user/passwd issues at the various levels of the gofer stack + Remove "Password" from connect attr if the same as $password arg +Extract policy settings by parsing the pod +Policy for dbh attr FETCH (ie example_driver_path) + or piggyback on skip_connect_check + could also remember which attr have been returned to us + so not bother FETCHing them (unless pedantic) +Call method on transport failure so transport can cleanup/reset if it wants +Gofer: gearman - need to disable coallesing for non-idempotent requests diff --git a/dbd_xsh.h b/dbd_xsh.h new file mode 100644 index 0000000..f238bb5 --- /dev/null +++ b/dbd_xsh.h @@ -0,0 +1,58 @@ +/* @(#)$Id: dbd_xsh.h 11724 2008-09-02 13:34:31Z mjevans $ + * + * Copyright 2000-2002 Tim Bunce + * Copyright 2002 Jonathan Leffler + * + * These prototypes are for dbdimp.c funcs used in the XS file. + * These names are #defined to driver specific names by the + * dbdimp.h file in the driver source. + */ + +#ifndef DBI_DBD_XSH_H +#define DBI_DBD_XSH_H + +void dbd_init _((dbistate_t *dbistate)); + +int dbd_discon_all _((SV *drh, imp_drh_t *imp_drh)); +SV *dbd_take_imp_data _((SV *h, imp_xxh_t *imp_xxh, void *foo)); + +/* Support for dbd_dr_data_sources and dbd_db_do added to Driver.xst in DBI v1.33 */ +/* dbd_dr_data_sources: optional: defined by a driver that calls a C */ +/* function to get the list of data sources */ +AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs); + +int dbd_db_login6_sv _((SV *dbh, imp_dbh_t *imp_dbh, SV *dbname, SV *uid, SV *pwd, SV*attribs)); +int dbd_db_login6 _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd, SV*attribs)); +int dbd_db_login _((SV *dbh, imp_dbh_t *imp_dbh, char *dbname, char *uid, char *pwd)); /* deprecated */ +/* Note: interface of dbd_db_do changed in v1.33 */ +/* Old prototype: dbd_db_do _((SV *sv, char *statement)); */ +/* dbd_db_do: optional: defined by a driver if the DBI default version is too slow */ +int dbd_db_do4 _((SV *dbh, imp_dbh_t *imp_dbh, char *statement, SV *params)); +int dbd_db_commit _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_rollback _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_disconnect _((SV *dbh, imp_dbh_t *imp_dbh)); +void dbd_db_destroy _((SV *dbh, imp_dbh_t *imp_dbh)); +int dbd_db_STORE_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv, SV *valuesv)); +SV *dbd_db_FETCH_attrib _((SV *dbh, imp_dbh_t *imp_dbh, SV *keysv)); +SV *dbd_db_last_insert_id _((SV *dbh, imp_dbh_t *imp_dbh, SV *catalog, SV *schema, SV *table, SV *field, SV *attr)); +AV *dbd_db_data_sources _((SV *dbh, imp_dbh_t *imp_dbh, SV *attr)); + +int dbd_st_prepare _((SV *sth, imp_sth_t *imp_sth, char *statement, SV *attribs)); +int dbd_st_prepare_sv _((SV *sth, imp_sth_t *imp_sth, SV *statement, SV *attribs)); +int dbd_st_rows _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_execute _((SV *sth, imp_sth_t *imp_sth)); +AV *dbd_st_fetch _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_finish3 _((SV *sth, imp_sth_t *imp_sth, int from_destroy)); +int dbd_st_finish _((SV *sth, imp_sth_t *imp_sth)); /* deprecated */ +void dbd_st_destroy _((SV *sth, imp_sth_t *imp_sth)); +int dbd_st_blob_read _((SV *sth, imp_sth_t *imp_sth, + int field, long offset, long len, SV *destrv, long destoffset)); +int dbd_st_STORE_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv, SV *valuesv)); +SV *dbd_st_FETCH_attrib _((SV *sth, imp_sth_t *imp_sth, SV *keysv)); +SV *dbd_st_execute_for_fetch _((SV *sth, imp_sth_t *imp_sth, SV *fetch_tuple_sub, SV *tuple_status)); + +int dbd_bind_ph _((SV *sth, imp_sth_t *imp_sth, + SV *param, SV *value, IV sql_type, SV *attribs, + int is_inout, IV maxlen)); + +#endif /* end of dbd_xsh.h */ diff --git a/dbi_sql.h b/dbi_sql.h new file mode 100644 index 0000000..1d7869d --- /dev/null +++ b/dbi_sql.h @@ -0,0 +1,96 @@ +/* $Id: dbi_sql.h 2488 2006-02-07 22:24:43Z timbo $ + * + * Copyright (c) 1997,1998,1999 Tim Bunce England + * + * See COPYRIGHT section in DBI.pm for usage and distribution rights. + */ + + +/* Some core SQL CLI standard (ODBC) declarations */ +#ifndef SQL_SUCCESS /* don't clash with ODBC based drivers */ + +/* SQL datatype codes */ +#define SQL_GUID (-11) +#define SQL_WLONGVARCHAR (-10) +#define SQL_WVARCHAR (-9) +#define SQL_WCHAR (-8) +#define SQL_BIT (-7) +#define SQL_TINYINT (-6) +#define SQL_BIGINT (-5) +#define SQL_LONGVARBINARY (-4) +#define SQL_VARBINARY (-3) +#define SQL_BINARY (-2) +#define SQL_LONGVARCHAR (-1) +#define SQL_UNKNOWN_TYPE 0 +#define SQL_ALL_TYPES 0 +#define SQL_CHAR 1 +#define SQL_NUMERIC 2 +#define SQL_DECIMAL 3 +#define SQL_INTEGER 4 +#define SQL_SMALLINT 5 +#define SQL_FLOAT 6 +#define SQL_REAL 7 +#define SQL_DOUBLE 8 +#define SQL_DATETIME 9 +#define SQL_DATE 9 +#define SQL_INTERVAL 10 +#define SQL_TIME 10 +#define SQL_TIMESTAMP 11 +#define SQL_VARCHAR 12 +#define SQL_BOOLEAN 16 +#define SQL_UDT 17 +#define SQL_UDT_LOCATOR 18 +#define SQL_ROW 19 +#define SQL_REF 20 +#define SQL_BLOB 30 +#define SQL_BLOB_LOCATOR 31 +#define SQL_CLOB 40 +#define SQL_CLOB_LOCATOR 41 +#define SQL_ARRAY 50 +#define SQL_ARRAY_LOCATOR 51 +#define SQL_MULTISET 55 +#define SQL_MULTISET_LOCATOR 56 +#define SQL_TYPE_DATE 91 +#define SQL_TYPE_TIME 92 +#define SQL_TYPE_TIMESTAMP 93 +#define SQL_TYPE_TIME_WITH_TIMEZONE 94 +#define SQL_TYPE_TIMESTAMP_WITH_TIMEZONE 95 +#define SQL_INTERVAL_YEAR 101 +#define SQL_INTERVAL_MONTH 102 +#define SQL_INTERVAL_DAY 103 +#define SQL_INTERVAL_HOUR 104 +#define SQL_INTERVAL_MINUTE 105 +#define SQL_INTERVAL_SECOND 106 +#define SQL_INTERVAL_YEAR_TO_MONTH 107 +#define SQL_INTERVAL_DAY_TO_HOUR 108 +#define SQL_INTERVAL_DAY_TO_MINUTE 109 +#define SQL_INTERVAL_DAY_TO_SECOND 110 +#define SQL_INTERVAL_HOUR_TO_MINUTE 111 +#define SQL_INTERVAL_HOUR_TO_SECOND 112 +#define SQL_INTERVAL_MINUTE_TO_SECOND 113 + + +/* Main return codes */ +#define SQL_ERROR (-1) +#define SQL_SUCCESS 0 +#define SQL_SUCCESS_WITH_INFO 1 +#define SQL_NO_DATA_FOUND 100 + +/* + * for ODBC SQL Cursor Types + */ +#define SQL_CURSOR_FORWARD_ONLY 0UL +#define SQL_CURSOR_KEYSET_DRIVEN 1UL +#define SQL_CURSOR_DYNAMIC 2UL +#define SQL_CURSOR_STATIC 3UL +#define SQL_CURSOR_TYPE_DEFAULT SQL_CURSOR_FORWARD_ONLY + +#endif /* SQL_SUCCESS */ + +/* Handy macro for testing for success and success with info. */ +/* BEWARE that this macro can have side effects since rc appears twice! */ +/* So DONT use it as if(SQL_ok(func(...))) { ... } */ +#define SQL_ok(rc) ((rc)==SQL_SUCCESS || (rc)==SQL_SUCCESS_WITH_INFO) + + +/* end of dbi_sql.h */ diff --git a/dbilogstrip.PL b/dbilogstrip.PL new file mode 100644 index 0000000..3bad633 --- /dev/null +++ b/dbilogstrip.PL @@ -0,0 +1,71 @@ +# -*- perl -*- +my $file = $ARGV[0] || 'dbilogstrip'; + +my $script = <<'SCRIPT'; +~startperl~ + +=head1 NAME + +dbilogstrip - filter to normalize DBI trace logs for diff'ing + +=head1 SYNOPSIS + +Read DBI trace file C and write out a stripped version to C + + dbilogstrip dbitrace.log > dbitrace_stripped.log + +Run C twice, each with different sets of arguments, with +DBI_TRACE enabled. Filter the output and trace through C into a +separate file for each run. Then compare using diff. (This example assumes +you're using a standard shell.) + + DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log + DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log + diff -u dbitrace1.log dbitrace2.log + +=head1 DESCRIPTION + +Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>. + +Replaces any references to process id or thread id, like C with C. + +So a DBI trace line like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400 + +will look like this: + + -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN + +=cut + +use strict; + +while (<>) { + # normalize hex addresses: 0xDEADHEAD => 0xN + s/ \b 0x [0-9a-f]+ /0xN/gx; + # normalize process and thread id number + s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx; + +} continue { + print or die "-p destination: $!\n"; +} + + +SCRIPT + +require Config; +my $config = {}; +$config->{'startperl'} = $Config::Config{'startperl'}; + +$script =~ s/\~(\w+)\~/$config->{$1}/eg; +if (!(open(FILE, ">$file")) || + !(print FILE $script) || + !(close(FILE))) { + die "Error while writing $file: $!\n"; +} +chmod 0755, $file; +print "Extracted $file from ",__FILE__," with variable substitutions.\n"; +# syntax check resulting file, but only for developers +exit 1 if -d ".svn" and system($^X, '-wc', '-Mblib', $file) != 0; + diff --git a/dbipport.h b/dbipport.h new file mode 100644 index 0000000..b3de803 --- /dev/null +++ b/dbipport.h @@ -0,0 +1,7258 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.20 + + 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. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.20 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.11.5. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F. + +=head2 --patch=I + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagially add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C or a C program to be installed. + +=head2 --diff=I + +Manually set the diff program and options to use. The default +is to use C, when installed, and output unified +context diffs. + +=head2 --compat-version=I + +Tell F to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F. +This reduces the size of F dramatically and may be useful +if you want to include F in smaller modules without +increasing their distribution size too much. + +The stripped F will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I + +Show portability information for API elements matching I. +If I is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C prefix is deprecated. Also, +some API functions used to have a C prefix. Using this form is +also deprecated. You can safely use the supported API, as F +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F. + +These functions or variables will be marked C in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C or global +variants. + +For a C function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C +macro. Just C<#define> the macro before including C: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C. + +=back + +The good thing is that most of the above can be checked by running +F on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F is causing failure during +the compilation of this module, please check if newer versions +of either this module or C are available on CPAN +before sending a bug report. + +If F was generated using the latest version of +C and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2010, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.20; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : 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||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.010001||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||5.011000| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeUTF8||5.010001| +HeVAL||5.004000| +HvENAME||5.013007| +HvNAMELEN_get|5.009003||p +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LINKLIST||5.013006| +LVRET||| +MARK||| +MULTICALL||5.014000| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +OP_CLASS||5.013007| +OP_DESC||5.007003| +OP_NAME||5.007003| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_DUP||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||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 +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.014000||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||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 +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.014000| +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.014000||p +PL_bufptr|5.014000||p +PL_compiling|5.004050||p +PL_copline|5.014000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||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.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.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_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_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 +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.014000||p +POP_MULTICALL||5.014000| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.014000| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_nomg||5.013002| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +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||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE_nomg||5.013006| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.014000||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +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.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_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| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +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| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +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| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_type_and_open||| +check_uni||| +check_utf8_print||| +checkcomma||| +checkposixcc||| +ckWARN|5.006000||p +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|||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_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||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.014000||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +del_sv||| +delete_eval_scope||| +delimcpy||5.004000|n +deprecate_commaless_var_list||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_sv||5.013001| +die_unwind||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_close||| +do_delete_local||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all_perl||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +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||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +fetch_cop_label||5.011000| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +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||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +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_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +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 +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_add_by_type||5.011000| +gv_autoload4||5.004000| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_flags||5.011000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv|5.009002||p +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_get_super_pkg||| +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||| +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||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| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +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| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_dbargs||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +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 +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +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_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||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|n +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +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|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_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 +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.010001||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||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||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall1||| +magic_methcall|||v +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +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| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_bodies||| +more_sv||| +moreswitches||| +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.010001| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +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||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat_flags||| +my_lstat||5.014000| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat_flags||| +my_stat||5.014000| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_swabn|||n +my_swap||| +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||5.013007| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpv_share||5.013006| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.010001||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.010001||p +newSVpvn|5.004050||p +newSVpvs_flags|5.010001||p +newSVpvs_share|5.009003||p +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.013007| +newXS_flags||5.009004| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr|||n +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +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 +pTHX|5.006000||p +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||5.011002| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +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||| +path_is_absolute|||n +peep||| +pending_Slabs_to_ro||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +populate_isa|||v +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_madprops||| +prescan_version||5.011004| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.009005| +re_intuit_string||5.006000| +readpipe_override||| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch_pvn||| +refcounted_he_fetch_pvs||| +refcounted_he_fetch_pv||| +refcounted_he_fetch_sv||| +refcounted_he_free||| +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.014000| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_namedseq||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly||| +regdump_extflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy|||n +report_evil_fh||| +report_uninit||| +report_wrongway_fh||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr|||n +rpeep||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rv2cv_op_cv||5.013006| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +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||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +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||5.010001| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||5.005000| +save_padsv_and_mortalize||5.010001| +save_pptr||| +save_pushi32ptr||5.010001| +save_pushptri32ptr||| +save_pushptrptr||5.010001| +save_pushptr||5.010001| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_vptr||5.006000| +savepvn||| +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| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +screaminstr||5.005000| +search_const||| +seed||5.008001| +sequence_num||| +sequence_tail||| +sequence||| +set_context||5.006000|n +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| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.014000| +stdize_locale||| +store_cop_label||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool_flags||5.013006| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv_flags||5.013001| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +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 +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +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| +sv_catsv_mg|5.004050||p +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| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_i_ncmp||| +sv_inc_nomg||5.013002| +sv_inc||| +sv_insert_flags||5.010001| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.014000|5.004000|p +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +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| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +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||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagicext||5.013008| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +sv_xmlpeek||| +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_get||| +swash_init||5.006000| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tied_method|||v +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +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| +unwind_handler_stack||| +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| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +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||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while () { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <
$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while () { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print < }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#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 + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((U8) (c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# 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 +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# 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 +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } 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) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#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 + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# 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 + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#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 +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/dbiprof.PL b/dbiprof.PL new file mode 100644 index 0000000..d5688e7 --- /dev/null +++ b/dbiprof.PL @@ -0,0 +1,287 @@ +# -*- perl -*- + +my $file = $ARGV[0] || 'dbiprof'; + +my $script = <<'SCRIPT'; +~startperl~ + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision: 13336 $ =~ /(\d+)/o); + +use Data::Dumper; +use DBI::ProfileData; +use Getopt::Long; + +# default options +my $number = 10; +my $sort = 'total'; +my $filename = 'dbi.prof'; +my $reverse = 0; +my $case_sensitive = 0; +my (%match, %exclude); + +# get options from command line +GetOptions( + 'version' => sub { die "dbiprof $VERSION\n" }, + 'help' => sub { exit usage() }, + 'number=i' => \$number, + 'sort=s' => \$sort, + 'dumpnodes!' => \my $dumpnodes, + 'reverse' => \$reverse, + 'match=s' => \%match, + 'exclude=s' => \%exclude, + 'case-sensitive' => \$case_sensitive, + 'delete!' => \my $opt_delete, +) or exit usage(); + +sub usage { + print <new( + Files => \@files, + DeleteFiles => $opt_delete, + ); +}; +die "Unable to load profile data: $@\n" if $@; + +if (%match) { # handle matches + while (my ($key, $val) = each %match) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->match($key, $val, case_sensitive => $case_sensitive); + } +} + +if (%exclude) { # handle excludes + while (my ($key, $val) = each %exclude) { + if ($val =~ m!^/(.+)/$!) { + $val = $case_sensitive ? qr/$1/ : qr/$1/i; + } + $prof->exclude($key, $val, case_sensitive => $case_sensitive); + } +} + +# sort the data +$prof->sort(field => $sort, reverse => $reverse); + +# all done, print it out +if ($dumpnodes) { + $Data::Dumper::Indent = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Useqq = 1; + $Data::Dumper::Deparse = 0; + print Dumper($prof->nodes); +} +else { + print $prof->report(number => $number); +} +exit 0; + +__END__ + +=head1 NAME + +dbiprof - command-line client for DBI::ProfileData + +=head1 SYNOPSIS + +See a report of the ten queries with the longest total runtime in the +profile dump file F: + + dbiprof prof1.out + +See the top 10 most frequently run queries in the profile file +F (the default): + + dbiprof --sort count + +See the same report with 15 entries: + + dbiprof --sort count --number 15 + +=head1 DESCRIPTION + +This tool is a command-line client for the DBI::ProfileData. It +allows you to analyze the profile data file produced by +DBI::ProfileDumper and produce various useful reports. + +=head1 OPTIONS + +This program accepts the following options: + +=over 4 + +=item --number N + +Produce this many items in the report. Defaults to 10. If set to +"all" then all results are shown. + +=item --sort field + +Sort results by the given field. Sorting by multiple fields isn't currently +supported (patches welcome). The available sort fields are: + +=over 4 + +=item total + +Sorts by total time run time across all runs. This is the default +sort. + +=item longest + +Sorts by the longest single run. + +=item count + +Sorts by total number of runs. + +=item first + +Sorts by the time taken in the first run. + +=item shortest + +Sorts by the shortest single run. + +=item key1 + +Sorts by the value of the first element in the Path, which should be numeric. +You can also sort by C and C. + +=back + +=item --reverse + +Reverses the selected sort. For example, to see a report of the +shortest overall time: + + dbiprof --sort total --reverse + +=item --match keyN=value + +Consider only items where the specified key matches the given value. +Keys are numbered from 1. For example, let's say you used a +DBI::Profile Path of: + + [ DBIprofile_Statement, DBIprofile_Methodname ] + +And called dbiprof as in: + + dbiprof --match key2=execute + +Your report would only show execute queries, leaving out prepares, +fetches, etc. + +If the value given starts and ends with slashes (C) then it will be +treated as a regular expression. For example, to only include SELECT +queries where key1 is the statement: + + dbiprof --match key1=/^SELECT/ + +By default the match expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --exclude keyN=value + +Remove items for where the specified key matches the given value. For +example, to exclude all prepare entries where key2 is the method name: + + dbiprof --exclude key2=prepare + +Like C<--match>, If the value given starts and ends with slashes +(C) then it will be treated as a regular expression. For example, +to exclude UPDATE queries where key1 is the statement: + + dbiprof --match key1=/^UPDATE/ + +By default the exclude expression is matched case-insensitively, but +this can be changed with the --case-sensitive option. + +=item --case-sensitive + +Using this option causes --match and --exclude to work +case-sensitively. Defaults to off. + +=item --delete + +Sets the C option to L which causes the +files to be deleted after reading. See L for more details. + +=item --dumpnodes + +Print the list of nodes in the form of a perl data structure. +Use the C<-sort> option if you want the list sorted. + +=item --version + +Print the dbiprof version number and exit. + +=back + +=head1 AUTHOR + +Sam Tregar + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2002 Sam Tregar + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself. + +=head1 SEE ALSO + +L, +L, L. + +=cut + +SCRIPT + + +require Config; +my $config = {}; +$config->{'startperl'} = $Config::Config{'startperl'}; + +$script =~ s/\~(\w+)\~/$config->{$1}/eg; +if (!(open(FILE, ">$file")) || + !(print FILE $script) || + !(close(FILE))) { + die "Error while writing $file: $!\n"; +} +chmod 0755, $file; +print "Extracted $file from ",__FILE__," with variable substitutions.\n"; + +# syntax check resulting file, but only for developers +exit 1 if -d ".svn"|| -d ".git" and system($^X, '-wc', '-Mblib', $file) != 0; + diff --git a/dbiproxy.PL b/dbiproxy.PL new file mode 100644 index 0000000..1ac3100 --- /dev/null +++ b/dbiproxy.PL @@ -0,0 +1,208 @@ +# -*- perl -*- + +my $file = $ARGV[0] || 'dbiproxy'; + +my $script = <<'SCRIPT'; +~startperl~ + +use strict; + +my $VERSION = sprintf("1.%06d", q$Revision: 13336 $ =~ /(\d+)/o); + +my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test'; +$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//; + +require DBI::ProxyServer; + +# XXX these should probably be moved into DBI::ProxyServer +delete $ENV{IFS}; +delete $ENV{CDPATH}; +delete $ENV{ENV}; +delete $ENV{BASH_ENV}; + +if ($arg_test) { + require RPC::PlServer::Test; + @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI); +} + +DBI::ProxyServer::main(@ARGV); + +exit(0); + + +__END__ + +=head1 NAME + +dbiproxy - A proxy server for the DBD::Proxy driver + +=head1 SYNOPSIS + + dbiproxy --localport= + + +=head1 DESCRIPTION + +This tool is just a front end for the DBI::ProxyServer package. All it +does is picking options from the command line and calling +DBI::ProxyServer::main(). See L for details. + +Available options include: + +=over 4 + +=item B<--chroot=dir> + +(UNIX only) After doing a bind(), change root directory to the given +directory by doing a chroot(). This is useful for security, but it +restricts the environment a lot. For example, you need to load DBI +drivers in the config file or you have to create hard links to Unix +sockets, if your drivers are using them. For example, with MySQL, a +config file might contain the following lines: + + my $rootdir = '/var/dbiproxy'; + my $unixsockdir = '/tmp'; + my $unixsockfile = 'mysql.sock'; + foreach $dir ($rootdir, "$rootdir$unixsockdir") { + mkdir 0755, $dir; + } + link("$unixsockdir/$unixsockfile", + "$rootdir$unixsockdir/$unixsockfile"); + require DBD::mysql; + + { + 'chroot' => $rootdir, + ... + } + +If you don't know chroot(), think of an FTP server where you can see a +certain directory tree only after logging in. See also the --group and +--user options. + +=item B<--configfile=file> + +Config files are assumed to return a single hash ref that overrides the +arguments of the new method. However, command line arguments in turn take +precedence over the config file. See the "CONFIGURATION FILE" section +in the L documentation for details on the config file. + +=item B<--debug> + +Turn debugging mode on. Mainly this asserts that logging messages of +level "debug" are created. + +=item B<--facility=mode> + +(UNIX only) Facility to use for L. The default is +B. + +=item B<--group=gid> + +After doing a bind(), change the real and effective GID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --user option. + +GID's can be passed as group names or numeric values. + +=item B<--localaddr=ip> + +By default a daemon is listening to any IP number that a machine +has. This attribute allows to restrict the server to the given +IP number. + +=item B<--localport=port> + +This attribute sets the port on which the daemon is listening. It +must be given somehow, as there's no default. + +=item B<--logfile=file> + +Be default logging messages will be written to the syslog (Unix) or +to the event log (Windows NT). On other operating systems you need to +specify a log file. The special value "STDERR" forces logging to +stderr. See L for details. + +=item B<--mode=modename> + +The server can run in three different modes, depending on the environment. + +If you are running Perl 5.005 and did compile it for threads, then the +server will create a new thread for each connection. The thread will +execute the server's Run() method and then terminate. This mode is the +default, you can force it with "--mode=threads". + +If threads are not available, but you have a working fork(), then the +server will behave similar by creating a new process for each connection. +This mode will be used automatically in the absence of threads or if +you use the "--mode=fork" option. + +Finally there's a single-connection mode: If the server has accepted a +connection, he will enter the Run() method. No other connections are +accepted until the Run() method returns (if the client disconnects). +This operation mode is useful if you have neither threads nor fork(), +for example on the Macintosh. For debugging purposes you can force this +mode with "--mode=single". + +=item B<--pidfile=file> + +(UNIX only) If this option is present, a PID file will be created at the +given location. Default is to not create a pidfile. + +=item B<--user=uid> + +After doing a bind(), change the real and effective UID to the given. +This is useful, if you want your server to bind to a privileged port +(<1024), but don't want the server to execute as root. See also +the --group and the --chroot options. + +UID's can be passed as group names or numeric values. + +=item B<--version> + +Supresses startup of the server; instead the version string will +be printed and the program exits immediately. + +=back + + +=head1 AUTHOR + + Copyright (c) 1997 Jochen Wiedmann + Am Eisteich 9 + 72555 Metzingen + Germany + + Email: joe@ispsoft.de + Phone: +49 7123 14881 + +The DBI::ProxyServer module is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. In particular +permission is granted to Tim Bunce for distributing this as a part of +the DBI. + + +=head1 SEE ALSO + +L, L, L + +=cut +SCRIPT + + +require Config; +my $config = {}; +$config->{'startperl'} = $Config::Config{'startperl'}; + +$script =~ s/\~(\w+)\~/$config->{$1}/eg; +if (!(open(FILE, ">$file")) || + !(print FILE $script) || + !(close(FILE))) { + die "Error while writing $file: $!\n"; +} +chmod 0755, $file; +print "Extracted $file from ",__FILE__," with variable substitutions.\n"; + +# syntax check resulting file, but only for developers +exit 1 if -d ".svn" || -d ".git" and system($^X, '-wc', '-Mblib', $file) != 0; + diff --git a/dbivport.h b/dbivport.h new file mode 100644 index 0000000..77dd96b --- /dev/null +++ b/dbivport.h @@ -0,0 +1,52 @@ +/* dbivport.h + + Provides macros that enable greater portability between DBI versions. + + This file should be *copied* and included in driver distributions + and #included into the source, after #include DBIXS.h + + New driver releases should include an updated copy of dbivport.h + from the most recent DBI release. +*/ + +#ifndef DBI_VPORT_H +#define DBI_VPORT_H + +#ifndef DBIh_SET_ERR_CHAR +/* Emulate DBIh_SET_ERR_CHAR + Only uses the err_i, errstr and state parameters. +*/ +#define DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method) \ + sv_setiv(DBIc_ERR(imp_xxh), err_i); \ + (state) ? (void)sv_setpv(DBIc_STATE(imp_xxh), state) : (void)SvOK_off(DBIc_STATE(imp_xxh)); \ + sv_setpv(DBIc_ERRSTR(imp_xxh), errstr) +#endif + +#ifndef DBIcf_Executed +#define DBIcf_Executed 0x080000 +#endif + +#ifndef DBIc_TRACE_LEVEL_MASK +#define DBIc_TRACE_LEVEL_MASK 0x0000000F +#define DBIc_TRACE_FLAGS_MASK 0xFFFFFF00 +#define DBIc_TRACE_SETTINGS(imp) (DBIc_DBISTATE(imp)->debug) +#define DBIc_TRACE_LEVEL(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_LEVEL_MASK) +#define DBIc_TRACE_FLAGS(imp) (DBIc_TRACE_SETTINGS(imp) & DBIc_TRACE_FLAGS_MASK) +/* DBIc_TRACE_MATCHES - true if s1 'matches' s2 (c.f. trace_msg()) + DBIc_TRACE_MATCHES(foo, DBIc_TRACE_SETTINGS(imp)) +*/ +#define DBIc_TRACE_MATCHES(s1, s2) \ + ( ((s1 & DBIc_TRACE_LEVEL_MASK) >= (s2 & DBIc_TRACE_LEVEL_MASK)) \ + || ((s1 & DBIc_TRACE_FLAGS_MASK) & (s2 & DBIc_TRACE_FLAGS_MASK)) ) +/* DBIc_TRACE - true if flags match & DBI level>=flaglevel, or if DBI level>level + DBIc_TRACE(imp, 0, 0, 4) = if level >= 4 + DBIc_TRACE(imp, DBDtf_FOO, 2, 4) = if tracing DBDtf_FOO & level>=2 or level>=4 + DBIc_TRACE(imp, DBDtf_FOO, 2, 0) = as above but never trace just due to level +*/ +#define DBIc_TRACE(imp, flags, flaglevel, level) \ + ( (flags && (DBIc_TRACE_FLAGS(imp) & flags) && (DBIc_TRACE_LEVEL(imp) >= flaglevel)) \ + || (level && DBIc_TRACE_LEVEL(imp) >= level) ) +#endif + + +#endif /* !DBI_VPORT_H */ diff --git a/dbixs_rev.h b/dbixs_rev.h new file mode 100644 index 0000000..335aef0 --- /dev/null +++ b/dbixs_rev.h @@ -0,0 +1,4 @@ +/* Wed Apr 18 12:37:44 2012 */ +/* Mixed revision working copy (15267M:15268) */ +/* Code modified since last checkin */ +#define DBIXS_REVISION 15267 diff --git a/dbixs_rev.pl b/dbixs_rev.pl new file mode 100644 index 0000000..9e83eb1 --- /dev/null +++ b/dbixs_rev.pl @@ -0,0 +1,51 @@ +#!perl -w +use strict; + +my $dbixs_rev_file = "dbixs_rev.h"; + +my $is_make_dist; +my $svnversion; + +if (is_dbi_svn_dir(".")) { + $svnversion = `svnversion -n`; +} +elsif (is_dbi_svn_dir("..")) { + # presumably we're in a subdirectory because the user is doing a 'make dist' + $svnversion = `svnversion -n ..`; + $is_make_dist = 1; +} +else { + # presumably we're being run by an end-user because their file timestamps + # got messed up + print "Skipping regeneration of $dbixs_rev_file\n"; + utime(time(), time(), $dbixs_rev_file); # update modification time + exit 0; +} + +my @warn; +die "Neither current directory nor parent directory are an svn working copy\n" + unless $svnversion and $svnversion =~ m/^\d+/; +push @warn, "Mixed revision working copy ($svnversion:$1)" + if $svnversion =~ s/:(\d+)//; +push @warn, "Code modified since last checkin" + if $svnversion =~ s/[MS]+$//; +warn "$dbixs_rev_file warning: $_\n" for @warn; +die "$0 failed\n" if $is_make_dist && @warn; + +write_header($dbixs_rev_file, DBIXS_REVISION => $svnversion, \@warn); + +sub write_header { + my ($file, $macro, $version, $comments_ref) = @_; + open my $fh, ">$file" or die "Can't open $file: $!\n"; + unshift @$comments_ref, scalar localtime(time); + print $fh "/* $_ */\n" for @$comments_ref; + print $fh "#define $macro $version\n"; + close $fh or die "Error closing $file: $!\n"; + print "Wrote $macro $version to $file\n"; +} + +sub is_dbi_svn_dir { + my ($dir) = @_; + return (-d "$dir/.svn" && -f "$dir/MANIFEST.SKIP"); +} + diff --git a/ex/corogofer.pl b/ex/corogofer.pl new file mode 100644 index 0000000..8baa587 --- /dev/null +++ b/ex/corogofer.pl @@ -0,0 +1,32 @@ +#!perl + +use strict; +use warnings; +use Time::HiRes qw(time); + +BEGIN { $ENV{PERL_ANYEVENT_STRICT} = 1; $ENV{PERL_ANYEVENT_VERBOSE} = 1; } + +use AnyEvent; + +BEGIN { $ENV{DBI_TRACE} = 0; $ENV{DBI_PUREPERL} = 0; $ENV{DBI_GOFER_TRACE} = 0; $ENV{DBD_GOFER_TRACE} = 0; }; + +use DBI; + +$ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=corostream'; + +my $ticker = AnyEvent->timer( after => 0, interval => 0.1, cb => sub { + warn sprintf "-tick- %.2f\n", time +} ); + +warn "connecting...\n"; +my $dbh = DBI->connect("dbi:NullP:"); +warn "...connected\n"; + +for (1..5) { + warn "entering DBI...\n"; + $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver + warn "...returned\n"; +} + +warn "done."; + diff --git a/ex/perl_dbi_nulls_test.pl b/ex/perl_dbi_nulls_test.pl new file mode 100644 index 0000000..fbef238 --- /dev/null +++ b/ex/perl_dbi_nulls_test.pl @@ -0,0 +1,176 @@ +#! /usr/bin/perl -w + +# This script checks which style of WHERE clause(s) will support both +# null and non-null values. Refer to the NULL Values sub-section +# of the "Placeholders and Bind Values" section in the DBI +# documention for more information on this issue. The clause styles +# and their numbering (0-6) map directly to the examples in the +# documentation. +# +# To use this script: +# +# 1) If you are not using the DBI_DSN env variable, then update the +# connect method arguments to support your database engine and +# database, and remove the nearby check for DBI_DSN. +# 2) Set PrintError to 1 in the connect method if you want see the +# engine's reason WHY your engine won't support a particular +# style. +# 3) If your database does not support NULL columns by default +# (e.g. Sybase) find and edit the CREATE TABLE statement +# accordingly. +# 4) To properly test style #5, you need the capability to create the +# stored procedure SP_ISNULL that acts as a function: it tests its +# argument and returns 1 if it is null, 0 otherwise. For example, +# using Informix IDS engine, a definition would look like: +# +# CREATE PROCEDURE SP_ISNULL (arg VARCHAR(32)) RETURNING INTEGER; +# IF arg IS NULL THEN RETURN 1; +# ELSE RETURN 0; +# END IF; +# END PROCEDURE; +# +# Warning: This script will attempt to create a table named by the +# $tablename variable (default dbi__null_test_tmp) and WILL DESTROY +# any pre-existing table so named. + +use strict; +use DBI; + +# The array represents the values that will be stored in the char column of our table. +# One array element per row. +# We expect the non-null test to return row 3 (Marge) +# and the null test to return rows 2 and 4 (the undefs). + +my $homer = "Homer"; +my $marge = "Marge"; + +my @char_column_values = ( + $homer, # 1 + undef, # 2 + $marge, # 3 + undef, # 4 +); + +# Define the SQL statements with the various WHERE clause styles we want to test +# and the parameters we'll substitute. + +my @select_clauses = +( + {clause=>qq{WHERE mycol = ?}, nonnull=>[$marge], null=>[undef]}, + {clause=>qq{WHERE NVL(mycol, '-') = NVL(?, '-')}, nonnull=>[$marge], null=>[undef]}, + {clause=>qq{WHERE ISNULL(mycol, '-') = ISNULL(?, '-')}, nonnull=>[$marge], null=>[undef]}, + {clause=>qq{WHERE DECODE(mycol, ?, 1, 0) = 1}, nonnull=>[$marge], null=>[undef]}, + {clause=>qq{WHERE mycol = ? OR (mycol IS NULL AND ? IS NULL)}, nonnull=>[$marge,$marge], null=>[undef,undef]}, + {clause=>qq{WHERE mycol = ? OR (mycol IS NULL AND SP_ISNULL(?) = 1)}, nonnull=>[$marge,$marge], null=>[undef,undef]}, + {clause=>qq{WHERE mycol = ? OR (mycol IS NULL AND ? = 1)}, nonnull=>[$marge,0], null=>[undef,1]}, +); + +# This is the table we'll create and use for these tests. +# If it exists, we'll DESTROY it too. So the name must be obscure. + +my $tablename = "dbi__null_test_tmp"; + +# Remove this if you are not using the DBI_DSN env variable, +# and update the connect statement below. + +die "DBI_DSN environment variable not defined" + unless $ENV{DBI_DSN}; + +my $dbh = DBI->connect(undef, undef, undef, + { + RaiseError => 0, + PrintError => 1 + } +) || die DBI->errstr; + +printf "Using %s, db version: %s\n", $ENV{DBI_DSN} || "connect arguments", $dbh->get_info(18) || "(unknown)"; + +my $sth; +my @ok; + +print "=> Drop table '$tablename', if it already exists...\n"; +do { local $dbh->{PrintError}=0; $dbh->do("DROP TABLE $tablename"); }; + +print "=> Create table '$tablename'...\n"; +$dbh->do("CREATE TABLE $tablename (myid int NOT NULL, mycol char(5))"); +# Use this if your database does not support NULL columns by default: +#$dbh->do("CREATE TABLE $tablename (myid int NOT NULL, mycol char(5) NULL)"); + +print "=> Insert 4 rows into the table...\n"; + +$sth = $dbh->prepare("INSERT INTO $tablename (myid, mycol) VALUES (?,?)"); +for my $i (0..$#char_column_values) +{ + my $val = $char_column_values[$i]; + printf " Inserting values (%d, %s)\n", $i+1, $dbh->quote($val); + $sth->execute($i+1, $val); +} +print "(Driver bug: statement handle should not be Active after an INSERT.)\n" + if $sth->{Active}; + +# Run the tests... + +for my $i (0..$#select_clauses) +{ + my $sel = $select_clauses[$i]; + print "\n=> Testing clause style $i: ".$sel->{clause}."...\n"; + + $sth = $dbh->prepare("SELECT myid,mycol FROM $tablename ".$sel->{clause}) + or next; + + print " Selecting row with $marge\n"; + $sth->execute(@{$sel->{nonnull}}) + or next; + my $r1 = $sth->fetchall_arrayref(); + my $n1_rows = $sth->rows; + my $n1 = @$r1; + + print " Selecting rows with NULL\n"; + $sth->execute(@{$sel->{null}}) + or next; + my $r2 = $sth->fetchall_arrayref(); + my $n2_rows = $sth->rows; + my $n2 = @$r2; + + # Complain a bit... + + print "\n=>Your DBD driver doesn't support the 'rows' method very well.\n\n" + unless ($n1_rows == $n1 && $n2_rows == $n2); + + # Did we get back the expected "n"umber of rows? + # Did we get back the specific "r"ows we expected as identifed by the myid column? + + if ( $n1 == 1 # one row for Marge + && $n2 == 2 # two rows for nulls + && $r1->[0][0] == 3 # Marge is myid 3 + && $r2->[0][0] == 2 # NULL for myid 2 + && $r2->[1][0] == 4 # NULL for myid 4 + ) { + print "=> WHERE clause style $i is supported.\n"; + push @ok, "\tStyle $i: ".$sel->{clause}; + } + else + { + print "=> WHERE clause style $i returned incorrect results.\n"; + if ($n1 > 0 || $n2 > 0) + { + print " Non-NULL test rows returned these row ids: ". + join(", ", map { $r1->[$_][0] } (0..$#{$r1}))."\n"; + print " The NULL test rows returned these row ids: ". + join(", ", map { $r2->[$_][0] } (0..$#{$r2}))."\n"; + } + } +} + +$dbh->disconnect(); +print "\n"; +print "-" x 72, "\n"; +printf "%d styles are supported:\n", scalar @ok; +print "$_\n" for @ok; +print "-" x 72, "\n"; +print "\n"; +print "If these results don't match what's in the 'Placeholders and Bind Values'\n"; +print "section of the DBI documentation, or are for a database that not already\n"; +print "listed, please email the results to dbi-users\@perl.org. Thank you.\n"; + +exit 0; diff --git a/ex/profile.pl b/ex/profile.pl new file mode 100644 index 0000000..96df9ae --- /dev/null +++ b/ex/profile.pl @@ -0,0 +1,25 @@ +#!/usr/bin/perl -w + +use DBI; + +$dbh = DBI->connect('dbi:SQLite:dbname=ex_profile.db', '', '', { RaiseError => 1 }); + +$dbh->do("DROP TABLE IF EXISTS ex_profile"); +$dbh->do("CREATE TABLE ex_profile (a int)"); + + $dbh->do("INSERT INTO ex_profile (a) VALUES ($_)", undef) for 1..100; +#$dbh->do("INSERT INTO ex_profile (a) VALUES (?)", undef, $_) for 1..100; + +my $select_sql = "SELECT a FROM ex_profile"; + +$dbh->selectall_arrayref($select_sql); + +$dbh->selectall_hashref($select_sql, 'a'); + +my $sth = $dbh->prepare($select_sql); +$sth->execute; +while ( @row = $sth->fetchrow_array ) { +} + + +__DATA__ diff --git a/lib/Bundle/DBI.pm b/lib/Bundle/DBI.pm new file mode 100644 index 0000000..50375a3 --- /dev/null +++ b/lib/Bundle/DBI.pm @@ -0,0 +1,51 @@ +# -*- perl -*- + +package Bundle::DBI; + +our $VERSION = sprintf("12.%06d", q$Revision: 8695 $ =~ /(\d+)/o); + +1; + +__END__ + +=head1 NAME + +Bundle::DBI - A bundle to install DBI and required modules. + +=head1 SYNOPSIS + + perl -MCPAN -e 'install Bundle::DBI' + +=head1 CONTENTS + +DBI - for to get to know thyself + +DBI::Shell 11.91 - the DBI command line shell + +Storable 2.06 - for DBD::Proxy, DBI::ProxyServer, DBD::Forward + +Net::Daemon 0.37 - for DBD::Proxy and DBI::ProxyServer + +RPC::PlServer 0.2016 - for DBD::Proxy and DBI::ProxyServer + +DBD::Multiplex 1.19 - treat multiple db handles as one + +=head1 DESCRIPTION + +This bundle includes all the modules used by the Perl Database +Interface (DBI) module, created by Tim Bunce. + +A I is a module that simply defines a collection of other +modules. It is used by the L module to automate the fetching, +building and installing of modules from the CPAN ftp archive sites. + +This bundle does not deal with the various database drivers (e.g. +DBD::Informix, DBD::Oracle etc), most of which require software from +sources other than CPAN. You'll need to fetch and build those drivers +yourself. + +=head1 AUTHORS + +Jonathan Leffler, Jochen Wiedmann and Tim Bunce. + +=cut diff --git a/lib/DBD/DBM.pm b/lib/DBD/DBM.pm new file mode 100644 index 0000000..3c621a3 --- /dev/null +++ b/lib/DBD/DBM.pm @@ -0,0 +1,1461 @@ +####################################################################### +# +# DBD::DBM - a DBI driver for DBM files +# +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# Copyright (c) 2010 by Jens Rehsack & H.Merijn Brand +# +# All rights reserved. +# +# You may freely distribute and/or modify this module under the terms +# of either the GNU General Public License (GPL) or the Artistic License, +# as specified in the Perl README file. +# +# USERS - see the pod at the bottom of this file +# +# DBD AUTHORS - see the comments in the code +# +####################################################################### +require 5.008; +use strict; + +################# +package DBD::DBM; +################# +use base qw( DBD::File ); +use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed); +$VERSION = '0.06'; +$ATTRIBUTION = 'DBD::DBM by Jens Rehsack'; + +# no need to have driver() unless you need private methods +# +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + return $drh if ($drh); + + # do the real work in DBD::File + # + $attr->{Attribution} = 'DBD::DBM by Jens Rehsack'; + $drh = $class->SUPER::driver($attr); + + # install private methods + # + # this requires that dbm_ (or foo_) be a registered prefix + # but you can write private methods before official registration + # by hacking the $dbd_prefix_registry in a private copy of DBI.pm + # + unless ( $methods_already_installed++ ) + { + DBD::DBM::st->install_method('dbm_schema'); + } + + return $drh; +} + +sub CLONE +{ + undef $drh; +} + +##################### +package DBD::DBM::dr; +##################### +$DBD::DBM::dr::imp_data_size = 0; +@DBD::DBM::dr::ISA = qw(DBD::File::dr); + +# you could put some :dr private methods here + +# you may need to over-ride some DBD::File::dr methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::db; +##################### +$DBD::DBM::db::imp_data_size = 0; +@DBD::DBM::db::ISA = qw(DBD::File::db); + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + # carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W ); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_STORE_attr( $attrib, $value ); +} + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + # carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if( $^W ); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_FETCH_attr($attrib); +} + +sub set_versions +{ + my $this = $_[0]; + $this->{dbm_version} = $DBD::DBM::VERSION; + return $this->SUPER::set_versions(); +} + +sub init_valid_attributes +{ + my $dbh = shift; + + # define valid private attributes + # + # attempts to set non-valid attrs in connect() or + # with $dbh->{attr} will throw errors + # + # the attrs here *must* start with dbm_ or foo_ + # + # see the STORE methods below for how to check these attrs + # + $dbh->{dbm_valid_attrs} = { + dbm_type => 1, # the global DBM type e.g. SDBM_File + dbm_mldbm => 1, # the global MLDBM serializer + dbm_cols => 1, # the global column names + dbm_version => 1, # verbose DBD::DBM version + dbm_store_metadata => 1, # column names, etc. + dbm_berkeley_flags => 1, # for BerkeleyDB + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + dbm_tables => 1, # DBD::DBM public access for f_meta + }; + $dbh->{dbm_readonly_attrs} = { + dbm_version => 1, # verbose DBD::DBM version + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + }; + + $dbh->{dbm_meta} = "dbm_tables"; + + return $dbh->SUPER::init_valid_attributes(); +} + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + + $dbh->SUPER::init_default_attributes($phase); + $dbh->{f_lockfile} = '.lck'; + + return $dbh; +} + +sub get_dbm_versions +{ + my ( $dbh, $table ) = @_; + $table ||= ''; + + my $meta; + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) ); + + my $dver; + my $dtype = $meta->{dbm_type}; + eval { + $dver = $meta->{dbm_type}->VERSION(); + + # *) when we're still alive here, everthing went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + if ( $meta->{dbm_mldbm} ) + { + $dtype .= ' + MLDBM'; + eval { + $dver = MLDBM->VERSION(); + $dtype .= " ($dver)"; # (*) + }; + eval { + my $ser_class = "MLDBM::Serializer::" . $meta->{dbm_mldbm}; + my $ser_mod = $ser_class; + $ser_mod =~ s|::|/|g; + $ser_mod .= ".pm"; + require $ser_mod; + $dver = $ser_class->VERSION(); + $dtype .= ' + ' . $ser_class; # (*) + $dver and $dtype .= " ($dver)"; # (*) + }; + } + return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype ); +} + +# you may need to over-ride some DBD::File::db methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::st; +##################### +$DBD::DBM::st::imp_data_size = 0; +@DBD::DBM::st::ISA = qw(DBD::File::st); + +sub FETCH +{ + my ( $sth, $attr ) = @_; + + if ( $attr eq "NULLABLE" ) + { + my @colnames = $sth->sql_get_colnames(); + + # XXX only BerkeleyDB fails having NULL values for non-MLDBM databases, + # none accept it for key - but it requires more knowledge between + # queries and tables storage to return fully correct information + $attr eq "NULLABLE" and return [ map { 0 } @colnames ]; + } + + return $sth->SUPER::FETCH($attr); +} # FETCH + +sub dbm_schema +{ + my ( $sth, $tname ) = @_; + return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname; + return $sth->set_err( $DBI::stderr, "Unknown table '$tname'!" ) + unless ( $sth->{Database}->{f_meta} + and $sth->{Database}->{f_meta}->{$tname} ); + return $sth->{Database}->{f_meta}->{$tname}->{schema}; +} +# you could put some :st private methods here + +# you may need to over-ride some DBD::File::st methods here +# but you can probably get away with just letting it do the work +# in most cases + +############################ +package DBD::DBM::Statement; +############################ + +@DBD::DBM::Statement::ISA = qw(DBD::File::Statement); + +######################## +package DBD::DBM::Table; +######################## +use Carp; +use Fcntl; + +@DBD::DBM::Table::ISA = qw(DBD::File::Table); + +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; + +sub file2table +{ + my ( $self, $meta, $file, $file_is_table, $quoted ) = @_; + + my $tbl = $self->SUPER::file2table( $meta, $file, $file_is_table, $quoted ) or return; + + $meta->{f_dontopen} = 1; + + return $tbl; +} + +my %reset_on_modify = ( + dbm_type => "dbm_tietype", + dbm_mldbm => "dbm_tietype", + ); +__PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +my %compat_map = ( + ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ), + dbm_ext => 'f_ext', + dbm_file => 'f_file', + dbm_lockfile => ' f_lockfile', + ); +__PACKAGE__->register_compat_map (\%compat_map); + +sub bootstrap_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{dbm_type} ||= $dbh->{dbm_type} || 'SDBM_File'; + $meta->{dbm_mldbm} ||= $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} ); + $meta->{dbm_berkeley_flags} ||= $dbh->{dbm_berkeley_flags}; + + defined $meta->{f_ext} + or $meta->{f_ext} = $dbh->{f_ext}; + unless ( defined( $meta->{f_ext} ) ) + { + my $ext; + if ( $meta->{dbm_type} eq 'SDBM_File' or $meta->{dbm_type} eq 'ODBM_File' ) + { + $ext = '.pag/r'; + } + elsif ( $meta->{dbm_type} eq 'NDBM_File' ) + { + # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley + # behind the scenes and so create a single .db file. + if ( $^O =~ /bsd/i or lc($^O) eq 'darwin' ) + { + $ext = '.db/r'; + } + elsif ( $^O eq 'SunOS' or $^O eq 'Solaris' or $^O eq 'AIX' ) + { + $ext = '.pag/r'; # here it's implemented like dbm - just a bit improved + } + # else wrapped GDBM + } + defined($ext) and $meta->{f_ext} = $ext; + } + + $self->SUPER::bootstrap_table_meta( $dbh, $meta, $table ); +} + +sub init_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + unless ( defined( $meta->{dbm_tietype} ) ) + { + my $tie_type = $meta->{dbm_type}; + $INC{"$tie_type.pm"} or require "$tie_type.pm"; + $tie_type eq 'BerkeleyDB' and $tie_type = 'BerkeleyDB::Hash'; + + if ( $meta->{dbm_mldbm} ) + { + $INC{"MLDBM.pm"} or require "MLDBM.pm"; + $meta->{dbm_usedb} = $tie_type; + $tie_type = 'MLDBM'; + } + + $meta->{dbm_tietype} = $tie_type; + } + + unless ( defined( $meta->{dbm_store_metadata} ) ) + { + my $store = $dbh->{dbm_store_metadata}; + defined($store) or $store = 1; + $meta->{dbm_store_metadata} = $store; + } + + unless ( defined( $meta->{col_names} ) ) + { + defined( $dbh->{dbm_cols} ) and $meta->{col_names} = $dbh->{dbm_cols}; + } + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); +} + +sub open_file +{ + my ( $self, $meta, $attrs, $flags ) = @_; + $self->SUPER::open_file( $meta, $attrs, $flags ); + unless ( $flags->{dropMode} ) + { + # TIEING + # + # XXX allow users to pass in a pre-created tied object + # + my @tie_args; + if ( $meta->{dbm_type} eq 'BerkeleyDB' ) + { + my $DB_CREATE = BerkeleyDB::DB_CREATE(); + my $DB_RDONLY = BerkeleyDB::DB_RDONLY(); + my %tie_flags; + if ( my $f = $meta->{dbm_berkeley_flags} ) + { + defined( $f->{DB_CREATE} ) and $DB_CREATE = delete $f->{DB_CREATE}; + defined( $f->{DB_RDONLY} ) and $DB_RDONLY = delete $f->{DB_RDONLY}; + %tie_flags = %$f; + } + my $open_mode = $flags->{lockMode} || $flags->{createMode} ? $DB_CREATE : $DB_RDONLY; + @tie_args = ( + -Filename => $meta->{f_fqbn}, + -Flags => $open_mode, + %tie_flags + ); + } + else + { + my $open_mode = O_RDONLY; + $flags->{lockMode} and $open_mode = O_RDWR; + $flags->{createMode} and $open_mode = O_RDWR | O_CREAT | O_TRUNC; + + @tie_args = ( $meta->{f_fqbn}, $open_mode, 0666 ); + } + + if ( $meta->{dbm_mldbm} ) + { + $MLDBM::UseDB = $meta->{dbm_usedb}; + $MLDBM::Serializer = $meta->{dbm_mldbm}; + } + + $meta->{hash} = {}; + my $tie_class = $meta->{dbm_tietype}; + eval { tie %{ $meta->{hash} }, $tie_class, @tie_args }; + $@ and croak "Cannot tie(\%h $tie_class @tie_args): $@"; + -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" ); + } + + unless ( $flags->{createMode} ) + { + my ( $meta_data, $schema, $col_names ); + if ( $meta->{dbm_store_metadata} ) + { + $meta_data = $col_names = $meta->{hash}->{"_metadata \0"}; + if ( $meta_data and $meta_data =~ m~(.+)~is ) + { + $schema = $col_names = $1; + $schema =~ s~.*(.+).*~$1~is; + $col_names =~ s~.*(.+).*~$1~is; + } + } + $col_names ||= $meta->{col_names} || [ 'k', 'v' ]; + $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' ); + if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} ) + { + $schema or $schema = ''; + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "" + . join( ",", @{$col_names} ) + . "" + . ""; + } + + $meta->{schema} = $schema; + $meta->{col_names} = $col_names; + } +} + +# you must define drop +# it is called from execute of a SQL DROP statement +# +sub drop ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + $self->SUPER::drop($data); + # XXX extra_files + -f $meta->{f_fqbn} . $dirfext + and $meta->{f_ext} eq '.pag/r' + and unlink( $meta->{f_fqbn} . $dirfext ); + return 1; +} + +# you must define fetch_row, it is called on all fetches; +# it MUST return undef when no rows are left to fetch; +# checking for $ary[0] is specific to hashes so you'll +# probably need some other kind of check for nothing-left. +# as Janis might say: "undef's just another word for +# nothing left to fetch" :-) +# +sub fetch_row ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + # fetch with %each + # + my @ary = each %{ $meta->{hash} }; + $meta->{dbm_store_metadata} + and $ary[0] + and $ary[0] eq "_metadata \0" + and @ary = each %{ $meta->{hash} }; + + my ( $key, $val ) = @ary; + unless ($key) + { + delete $self->{row}; + return; + } + my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val ); + $self->{row} = @row ? \@row : undef; + return wantarray ? @row : \@row; +} + +# you must define push_row except insert_new_row and update_specific_row is defined +# it is called on inserts and updates as primitive +# +sub insert_new_row ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + my $ncols = scalar( @{ $meta->{col_names} } ); + my $nitems = scalar( @{$row_aryref} ); + $ncols == $nitems + or croak "You tried to insert $nitems, but table is created with $ncols columns"; + + my $key = shift @$row_aryref; + my $exists; + eval { $exists = exists( $meta->{hash}->{$key} ); }; + $exists and croak "Row with PK '$key' already exists"; + + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row_aryref : $row_aryref->[0]; + + return 1; +} + +# this is where you grab the column names from a CREATE statement +# if you don't need to do that, it must be defined but can be empty +# +sub push_names ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + + # some sanity checks ... + my $ncols = scalar(@$row_aryref); + $ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ..."; + !$meta->{dbm_mldbm} + and $ncols > 2 + and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols"; + $meta->{col_names} = $row_aryref; + return unless $meta->{dbm_store_metadata}; + + my $stmt = $data->{sql_stmt}; + my $col_names = join( ',', @{$row_aryref} ); + my $schema = $data->{Database}->{Statement}; + $schema =~ s/^[^\(]+\((.+)\)$/$1/s; + $schema = $stmt->schema_str() if ( $stmt->can('schema_str') ); + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "$col_names" + . ""; +} + +# fetch_one_row, delete_one_row, update_one_row +# are optimized for hash-style lookup without looping; +# if you don't need them, omit them, they're optional +# but, in that case you may need to define +# truncate() and seek(), see below +# +sub fetch_one_row ($$;$) +{ + my ( $self, $key_only, $key ) = @_; + my $meta = $self->{meta}; + $key_only and return $meta->{col_names}->[0]; + exists $meta->{hash}->{$key} or return; + my $val = $meta->{hash}->{$key}; + $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val]; + my $row = [ $key, @$val ]; + return wantarray ? @{$row} : $row; +} + +sub delete_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + delete $meta->{hash}->{ $aryref->[0] }; +} + +sub update_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + my $key = shift @$aryref; + defined $key or return; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +sub update_specific_row ($$$$) +{ + my ( $self, $data, $aryref, $origary ) = @_; + my $meta = $self->{meta}; + my $key = shift @$origary; + my $newkey = shift @$aryref; + return unless ( defined $key ); + $key eq $newkey or delete $meta->{hash}->{$key}; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +# you may not need to explicitly DESTROY the ::Table +# put cleanup code to run when the execute is done +# +sub DESTROY ($) +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + + $self->SUPER::DESTROY(); +} + +# truncate() and seek() must be defined to satisfy DBI::SQL::Nano +# *IF* you define the *_one_row methods above, truncate() and +# seek() can be empty or you can use them without actually +# truncating or seeking anything but if you don't define the +# *_one_row methods, you may need to define these + +# if you need to do something after a series of +# deletes or updates, you can put it in truncate() +# which is called at the end of executing +# +sub truncate ($$) +{ + # my ( $self, $data ) = @_; + return 1; +} + +# seek() is only needed if you use IO::File +# though it could be used for other non-file operations +# that you need to do before "writes" or truncate() +# +sub seek ($$$$) +{ + # my ( $self, $data, $pos, $whence ) = @_; + return 1; +} + +# Th, th, th, that's all folks! See DBD::File and DBD::CSV for other +# examples of creating pure perl DBDs. I hope this helped. +# Now it's time to go forth and create your own DBD! +# Remember to check in with dbi-dev@perl.org before you get too far. +# We may be able to make suggestions or point you to other related +# projects. + +1; +__END__ + +=pod + +=head1 NAME + +DBD::DBM - a DBI driver for DBM & MLDBM files + +=head1 SYNOPSIS + + use DBI; + $dbh = DBI->connect('dbi:DBM:'); # defaults to SDBM_File + $dbh = DBI->connect('DBI:DBM(RaiseError=1):'); # defaults to SDBM_File + $dbh = DBI->connect('dbi:DBM:dbm_type=DB_File'); # defaults to DB_File + $dbh = DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # MLDBM with SDBM_File + + # or + $dbh = DBI->connect('dbi:DBM:', undef, undef); + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + f_ext => '.db/r', + f_dir => '/path/to/dbfiles/', + f_lockfile => '.lck', + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'FreezeThaw', + dbm_store_metadata => 1, + dbm_berkeley_flags => { + '-Cachesize' => 1000, # set a ::Hash flag + }, + }); + +and other variations on connect() as shown in the L docs, +L and L +shown below. + +Use standard DBI prepare, execute, fetch, placeholders, etc., +see L for an example. + +=head1 DESCRIPTION + +DBD::DBM is a database management system that works right out of the +box. If you have a standard installation of Perl and DBI you can +begin creating, accessing, and modifying simple database tables +without any further modules. You can add other modules (e.g., +SQL::Statement, DB_File etc) for improved functionality. + +The module uses a DBM file storage layer. DBM file storage is common on +many platforms and files can be created with it in many programming +languages using different APIs. That means, in addition to creating +files with DBI/SQL, you can also use DBI/SQL to access and modify files +created by other DBM modules and programs and vice versa. B that +in those cases it might be necessary to use a common subset of the +provided features. + +DBM files are stored in binary format optimized for quick retrieval +when using a key field. That optimization can be used advantageously +to make DBD::DBM SQL operations that use key fields very fast. There +are several different "flavors" of DBM which use different storage +formats supported by perl modules such as SDBM_File and MLDBM. This +module supports all of the flavors that perl supports and, when used +with MLDBM, supports tables with any number of columns and insertion +of Perl objects into tables. + +DBD::DBM has been tested with the following DBM types: SDBM_File, +NDBM_File, ODBM_File, GDBM_File, DB_File, BerkeleyDB. Each type was +tested both with and without MLDBM and with the Data::Dumper, +Storable, FreezeThaw, YAML and JSON serializers using the DBI::SQL::Nano +or the SQL::Statement engines. + +=head1 QUICK START + +DBD::DBM operates like all other DBD drivers - it's basic syntax and +operation is specified by DBI. If you're not familiar with DBI, you should +start by reading L and the documents it points to and then come back +and read this file. If you are familiar with DBI, you already know most of +what you need to know to operate this module. Just jump in and create a +test script something like the one shown below. + +You should be aware that there are several options for the SQL engine +underlying DBD::DBM, see L. There are also many +options for DBM support, see especially the section on L. + +But here's a sample to get you started. + + use DBI; + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{RaiseError} = 1; + for my $sql( split /;\n+/," + CREATE TABLE user ( user_name TEXT, phone TEXT ); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + INSERT INTO user VALUES ('Sanjay Patel','777-3333'); + INSERT INTO user VALUES ('Junk','xxx-xxxx'); + DELETE FROM user WHERE user_name = 'Junk'; + UPDATE user SET phone = '999-4444' WHERE user_name = 'Sanjay Patel'; + SELECT * FROM user + "){ + my $sth = $dbh->prepare($sql); + $sth->execute; + $sth->dump_results if $sth->{NUM_OF_FIELDS}; + } + $dbh->disconnect; + +=head1 USAGE + +This section will explain some useage cases in more detail. To get an +overview about the available attributes, see L. + +=head2 Specifying Files and Directories + +DBD::DBM will automatically supply an appropriate file extension for the +type of DBM you are using. For example, if you use SDBM_File, a table +called "fruit" will be stored in two files called "fruit.pag" and +"fruit.dir". You should B specify the file extensions in your SQL +statements. + +DBD::DBM recognizes following default extensions for following types: + +=over 4 + +=item .pag/r + +Chosen for dbm_type C<< SDBM_File >>, C<< ODBM_File >> and C<< NDBM_File >> +when an implementation is detected which wraps C<< -ldbm >> for +C<< NDBM_File >> (e.g. Solaris, AIX, ...). + +For those types, the C<< .dir >> extension is recognized, too (for being +deleted when dropping a table). + +=item .db/r + +Chosen for dbm_type C<< NDBM_File >> when an implementation is detected +which wraps BerkeleyDB 1.x for C<< NDBM_File >> (typically BSD's, Darwin). + +=back + +C<< GDBM_File >>, C<< DB_File >> and C<< BerkeleyDB >> don't usually +use a file extension. + +If your DBM type uses an extension other than one of the recognized +types of extensions, you should set the I attribute to the +extension B file a bug report as described in DBI with the name +of the implementation and extension so we can add it to DBD::DBM. +Thanks in advance for that :-). + + $dbh = DBI->connect('dbi:DBM:f_ext=.db'); # .db extension is used + $dbh = DBI->connect('dbi:DBM:f_ext='); # no extension is used + + # or + $dbh->{f_ext}='.db'; # global setting + $dbh->{f_meta}->{'qux'}->{f_ext}='.db'; # setting for table 'qux' + +By default files are assumed to be in the current working directory. +To use other directories specify the I attribute in either the +connect string or by setting the database handle attribute. + +For example, this will look for the file /foo/bar/fruit (or +/foo/bar/fruit.pag for DBM types that use that extension) + + my $dbh = DBI->connect('dbi:DBM:f_dir=/foo/bar'); + # and this will too: + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->{f_dir} = '/foo/bar'; + # but this is recommended + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { f_dir => '/foo/bar' } ); + + # now you can do + my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM fruit }); + +You can also use delimited identifiers to specify paths directly in SQL +statements. This looks in the same place as the two examples above but +without setting I: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT x FROM "/foo/bar/fruit" + }); + +You can also tell DBD::DBM to use a specified path for a specific table: + + $dbh->{dbm_tables}->{f}->{file} = q(/foo/bar/fruit); + +Please be aware that you cannot specify this during connection. + +If you have SQL::Statement installed, you can use table aliases: + + my $dbh = DBI->connect('dbi:DBM:'); + my $ary = $dbh->selectall_arrayref(q{ + SELECT f.x FROM "/foo/bar/fruit" AS f + }); + +See the L for using DROP on tables. + +=head2 Table locking and flock() + +Table locking is accomplished using a lockfile which has the same +basename as the table's file but with the file extension '.lck' (or a +lockfile extension that you supply, see below). This lock file is +created with the table during a CREATE and removed during a DROP. +Every time the table itself is opened, the lockfile is flocked(). For +SELECT, this is a shared lock. For all other operations, it is an +exclusive lock (except when you specify something different using the +I attribute). + +Since the locking depends on flock(), it only works on operating +systems that support flock(). In cases where flock() is not +implemented, DBD::DBM will simply behave as if the flock() had +occurred although no actual locking will happen. Read the +documentation for flock() for more information. + +Even on those systems that do support flock(), locking is only +advisory - as is always the case with flock(). This means that if +another program tries to access the table file while DBD::DBM has the +table locked, that other program will *succeed* at opening unless +it is also using flock on the '.lck' file. As a result DBD::DBM's +locking only really applies to other programs using DBD::DBM or other +program written to cooperate with DBD::DBM locking. + +=head2 Specifying the DBM type + +Each "flavor" of DBM stores its files in a different format and has +different capabilities and limitations. See L for a +comparison of DBM types. + +By default, DBD::DBM uses the C<< SDBM_File >> type of storage since +C<< SDBM_File >> comes with Perl itself. If you have other types of +DBM storage available, you can use any of them with DBD::DBM. It is +strongly recommended to use at least C<< DB_File >>, because C<< +SDBM_File >> has quirks and limitations and C<< ODBM_file >>, C<< +NDBM_File >> and C<< GDBM_File >> are not always available. + +You can specify the DBM type using the I attribute which can +be set in the connection string or with C<< $dbh->{dbm_type} >> and +C<< $dbh->{f_meta}->{$table_name}->{type} >> for per-table settings in +cases where a single script is accessing more than one kind of DBM +file. + +In the connection string, just set C<< dbm_type=TYPENAME >> where +C<< TYPENAME >> is any DBM type such as GDBM_File, DB_File, etc. Do I +use MLDBM as your I as that is set differently, see below. + + my $dbh=DBI->connect('dbi:DBM:'); # uses the default SDBM_File + my $dbh=DBI->connect('dbi:DBM:dbm_type=GDBM_File'); # uses the GDBM_File + + # You can also use $dbh->{dbm_type} to set the DBM type for the connection: + $dbh->{dbm_type} = 'DB_File'; # set the global DBM type + print $dbh->{dbm_type}; # display the global DBM type + +If you have several tables in your script that use different DBM +types, you can use the $dbh->{dbm_tables} hash to store different +settings for the various tables. You can even use this to perform +joins on files that have completely different storage mechanisms. + + # sets global default of GDBM_File + my $dbh->('dbi:DBM:type=GDBM_File'); + + # overrides the global setting, but only for the tables called + # I and I + my $dbh->{f_meta}->{foo}->{dbm_type} = 'DB_File'; + my $dbh->{f_meta}->{bar}->{dbm_type} = 'BerkeleyDB'; + + # prints the dbm_type for the table "foo" + print $dbh->{f_meta}->{foo}->{dbm_type}; + +B that you must change the I of a table before you access +it for first time. + +=head2 Adding multi-column support with MLDBM + +Most of the DBM types only support two columns and even if it would +support more, DBD::DBM would only use two. However a CPAN module +called MLDBM overcomes this limitation by allowing more than two +columns. MLDBM does this by serializing the data - basically it puts +a reference to an array into the second column. It can also put almost +any kind of Perl object or even B into columns. + +If you want more than two columns, you B install MLDBM. It's available +for many platforms and is easy to install. + +MLDBM is by default distributed with three serializers - Data::Dumper, +Storable, and FreezeThaw. Data::Dumper is the default and Storable is the +fastest. MLDBM can also make use of user-defined serialization methods or +other serialization modules (e.g. L or +L. You select the serializer using the +I attribute. + +Some examples: + + $dbh=DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # use MLDBM with Storable + $dbh=DBI->connect( + 'dbi:DBM:dbm_mldbm=MySerializer' # use MLDBM with a user defined module + ); + $dbh=DBI->connect('dbi::dbm:', undef, + undef, { dbm_mldbm => 'YAML' }); # use 3rd party serializer + $dbh->{dbm_mldbm} = 'YAML'; # same as above + print $dbh->{dbm_mldbm} # show the MLDBM serializer + $dbh->{f_meta}->{foo}->{dbm_mldbm}='Data::Dumper'; # set Data::Dumper for table "foo" + print $dbh->{f_meta}->{foo}->{mldbm}; # show serializer for table "foo" + +MLDBM works on top of other DBM modules so you can also set a DBM type +along with setting dbm_mldbm. The examples above would default to using +SDBM_File with MLDBM. If you wanted GDBM_File instead, here's how: + + # uses DB_File with MLDBM and Storable + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'DB_File', + dbm_mldbm => 'Storable', + }); + +SDBM_File, the default I is quite limited, so if you are going to +use MLDBM, you should probably use a different type, see L. + +See below for some L about MLDBM. + +=head2 Support for Berkeley DB + +The Berkeley DB storage type is supported through two different Perl +modules - DB_File (which supports only features in old versions of Berkeley +DB) and BerkeleyDB (which supports all versions). DBD::DBM supports +specifying either "DB_File" or "BerkeleyDB" as a I, with or +without MLDBM support. + +The "BerkeleyDB" dbm_type is experimental and it's interface is likely to +change. It currently defaults to BerkeleyDB::Hash and does not currently +support ::Btree or ::Recno. + +With BerkeleyDB, you can specify initialization flags by setting them in +your script like this: + + use BerkeleyDB; + my $env = new BerkeleyDB::Env -Home => $dir; # and/or other Env flags + $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_type => 'BerkeleyDB', + dbm_mldbm => 'Storable', + dbm_berkeley_flags => { + 'DB_CREATE' => DB_CREATE, # pass in constants + 'DB_RDONLY' => DB_RDONLY, # pass in constants + '-Cachesize' => 1000, # set a ::Hash flag + '-Env' => $env, # pass in an environment + }, + }); + +Do I set the -Flags or -Filename flags as those are determined and +overwritten by the SQL (e.g. -Flags => DB_RDONLY is set automatically +when you issue a SELECT statement). + +Time has not permitted us to provide support in this release of DBD::DBM +for further Berkeley DB features such as transactions, concurrency, +locking, etc. We will be working on these in the future and would value +suggestions, patches, etc. + +See L and L for further details. + +=head2 Optimizing the use of key fields + +Most "flavors" of DBM have only two physical columns (but can contain +multiple logical columns as explained above in +L). They work similarly to a +Perl hash with the first column serving as the key. Like a Perl hash, DBM +files permit you to do quick lookups by specifying the key and thus avoid +looping through all records (supported by DBI::SQL::Nano only). Also like +a Perl hash, the keys must be unique. It is impossible to create two +records with the same key. To put this more simply and in SQL terms, +the key column functions as the I or UNIQUE INDEX. + +In DBD::DBM, you can take advantage of the speed of keyed lookups by using +DBI::SQL::Nano and a WHERE clause with a single equal comparison on the key +field. For example, the following SQL statements are optimized for keyed +lookup: + + CREATE TABLE user ( user_name TEXT, phone TEXT); + INSERT INTO user VALUES ('Fred Bloggs','233-7777'); + # ... many more inserts + SELECT phone FROM user WHERE user_name='Fred Bloggs'; + +The "user_name" column is the key column since it is the first +column. The SELECT statement uses the key column in a single equal +comparison - "user_name='Fred Bloggs'" - so the search will find it +very quickly without having to loop through all the names which were +inserted into the table. + +In contrast, these searches on the same table are not optimized: + + 1. SELECT phone FROM user WHERE user_name < 'Fred'; + 2. SELECT user_name FROM user WHERE phone = '233-7777'; + +In #1, the operation uses a less-than (<) comparison rather than an equals +comparison, so it will not be optimized for key searching. In #2, the key +field "user_name" is not specified in the WHERE clause, and therefore the +search will need to loop through all rows to find the requested row(s). + +B that the underlying DBM storage needs to loop over all I +pairs when the optimized fetch is used. SQL::Statement has a massively +improved where clause evaluation which costs around 15% of the evaluation +in DBI::SQL::Nano - combined with the loop in the DBM storage the speed +improvement isn't so impressive. + +Even if lookups are faster by around 50%, DBI::SQL::Nano and +SQL::Statement can benefit from the key field optimizations on +updating and deleting rows - and here the improved where clause +evaluation of SQL::Statement might beat DBI::SQL::Nano every time the +where clause contains not only the key field (or more than one). + +=head2 Supported SQL syntax + +DBD::DBM uses a subset of SQL. The robustness of that subset depends on +what other modules you have installed. Both options support basic SQL +operations including CREATE TABLE, DROP TABLE, INSERT, DELETE, UPDATE, and +SELECT. + +B