diff options
121 files changed, 60761 insertions, 0 deletions
@@ -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_*_* <driver_prefix>_*_* 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</FetchHashKeyName> + 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 @@ -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<The synopsis above only lists the major methods and parameters.> + + +=head2 GETTING HELP + +If you have questions about DBI, or DBD driver modules, you can get +help from the I<dbi-users@perl.org> mailing list. You 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<dbi-users-help@perl.org>. + +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<http://mikeash.com/getting_answers.html>. + +If you think you've found a bug then please also read +"How to Report Bugs Effectively" by Simon Tatham: +L<http://www.chiark.greenend.org.uk/~sgtatham/bugs.html>. + +The DBI home page at L<http://dbi.perl.org/> and the DBI FAQ +at L<http://faq.dbi-support.com/> 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<http://www.slideshare.net/Tim.Bunce/dbi-advanced-tutorial-2007> + +This document often uses terms like I<references>, I<objects>, +I<methods>. 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<perlreftut>, L<perldsc>, L<perllol>, and L<perlboot>. + +Please note that Tim Bunce does not maintain the mailing lists or the +web page (generous volunteers do that). So please don't send mail +directly to him; he just doesn't have the time to answer questions +personally. The I<dbi-users> mailing list has lots of experienced +people who should be able to help you if you need it. If you do email +Tim he 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<DBI::Changes> 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<DBI::Changes> module so you can read them by executing +C<perldoc DBI::Changes>. + +Some DBI changes require changes in the drivers, but the drivers +can take some time to catch up. Newer versions of the DBI have +added features that may not yet be supported by the drivers you +use. Talk to the authors of your drivers if you need a new feature +that 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<DBIx::*> namespace. +See L</Naming Conventions and Name Space>. DBI extension modules +can be found at L<http://search.cpan.org/search?mode=module&query=DBIx>. +And all modules related to the DBI can be found at +L<http://search.cpan.org/search?query=DBI&mode=all>. + +=cut + +# The POD text continues at the end of the file. + +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::<drivername>::driver() + my ($class, $initial_attr, $imp_data) = @_; + # Provide default storage for State,Err and Errstr. + # Note that these are shared by all child handles by default! XXX + # State must be undef to get automatic faking in DBI::var::FETCH + my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, 0, ''); + my $attr = { + # these attributes get copied down to child handles by default + 'State' => \$h_state_store, # Holder for DBI::state + 'Err' => \$h_err_store, # Holder for DBI::err + 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr + 'TraceLevel' => 0, + FetchHashKeyName=> 'NAME', + %$initial_attr, + }; + my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class); + + # XXX DBI_PROFILE unless DBI::PurePerl because for some reason + # it kills the t/zz_*_pp.t tests (they silently exit early) + if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $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::<drivername>::dr::connect() + my ($drh, $attr, $imp_data) = @_; + my $imp_class = $drh->{ImplementorClass} + or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); + substr($imp_class,-4,4) = '::db'; + my $app_class = ref $drh; + substr($app_class,-4,4) = '::db'; + $attr->{Err} ||= \my $err; + $attr->{Errstr} ||= \my $errstr; + $attr->{State} ||= \my $state; + _new_handle($app_class, $drh, $attr, $imp_data, $imp_class); +} + +sub _new_sth { # called by DBD::<drivername>::db::prepare) + my ($dbh, $attr, $imp_data) = @_; + my $imp_class = $dbh->{ImplementorClass} + or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); + substr($imp_class,-4,4) = '::st'; + my $app_class = ref $dbh; + substr($app_class,-4,4) = '::st'; + _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class); +} + + +# end of DBI package + + + +# -------------------------------------------------------------------- +# === The internal DBI Switch pseudo 'driver' class === + +{ package # hide from PAUSE + DBD::Switch::dr; + DBI->setup_driver('DBD::Switch'); # sets up @ISA + + $DBD::Switch::dr::imp_data_size = 0; + $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning + my $drh; + + sub driver { + return $drh if $drh; # a package global + + my $inner; + ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', { + 'Name' => 'Switch', + 'Version' => $DBI::VERSION, + 'Attribution' => "DBI $DBI::VERSION by Tim Bunce", + }); + Carp::croak("DBD::Switch init failed!") unless ($drh && $inner); + return $drh; + } + sub CLONE { + undef $drh; + } + + sub FETCH { + my($drh, $key) = @_; + return DBI->trace if $key eq 'DebugDispatch'; + return undef if $key eq 'DebugLog'; # not worth fetching, sorry + return $drh->DBD::_::dr::FETCH($key); + undef; + } + sub STORE { + my($drh, $key, $value) = @_; + if ($key eq 'DebugDispatch') { + DBI->trace($value); + } elsif ($key eq 'DebugLog') { + DBI->trace(-1, $value); + } else { + $drh->DBD::_::dr::STORE($key, $value); + } + } +} + + +# -------------------------------------------------------------------- +# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES === + +# We only define default methods for harmless functions. +# We don't, for example, define a DBD::_::st::prepare() + +{ package # hide from PAUSE + DBD::_::common; # ====== Common base class methods ====== + use strict; + + # methods common to all handle types: + + sub _not_impl { + my ($h, $method) = @_; + $h->trace_msg("Driver does not implement the $method method.\n"); + return; # empty list / undef + } + + # generic TIEHASH default methods: + sub FIRSTKEY { } + sub NEXTKEY { } + sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef? + sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" } + + 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<driver> +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<use strict;> isn't required but is strongly recommended.) + +Then you need to L</connect> to your data source and get a I<handle> 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<AutoCommit> 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<SELECT> statement is: + + prepare, + execute, fetch, fetch, ... + execute, fetch, fetch, ... + execute, fetch, fetch, ... + +for example: + + $sth = $dbh->prepare("SELECT foo, bar FROM table WHERE baz=?"); + + $sth->execute( $baz ); + + while ( @row = $sth->fetchrow_array ) { + print "@row\n"; + } + +The typical method call sequence for a I<non>-C<SELECT> statement is: + + prepare, + execute, + execute, + execute. + +for example: + + $sth = $dbh->prepare("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)"); + + while(<CSV>) { + chomp; + my ($foo,$bar,$baz) = split /,/; + $sth->execute( $foo, $bar, $baz ); + } + +The C<do()> method can be used for non repeated I<non>-C<SELECT> statement +(or with drivers that don't support placeholders): + + $rows_affected = $dbh->do("UPDATE your_table SET foo = foo + 1"); + +To commit your changes to the database (when L</AutoCommit> is off): + + $dbh->commit; # or call $dbh->rollback; to undo changes + +Finally, when you have finished working with the data source, you should +L</disconnect> from it: + + $dbh->disconnect; + + +=head2 General Interface Rules & Caveats + +The DBI does not have a concept of a "current session". Every session +has a handle object (i.e., a C<$dbh>) returned from the C<connect> method. +That handle object is used to invoke database related methods. + +Most data is returned to the Perl script as strings. (Null values are +returned as C<undef>.) This allows arbitrary precision numeric data to be +handled without loss of accuracy. Beware that Perl may not preserve +the same accuracy when the string is used as a number. + +Dates and times are returned as character strings in the current +default format of the corresponding database engine. Time zone effects +are database/driver dependent. + +Perl supports binary data in Perl strings, and the DBI will pass binary +data to and from the driver without change. It is up to the driver +implementors to decide how they wish to handle such binary data. + +Perl supports two kinds of strings: Unicode (utf8 internally) and non-Unicode +(defaults to iso-8859-1 if forced to assume an encoding). Drivers should +accept both kinds of strings and, if required, convert them to the character +set of the database being used. Similarly, when fetching from the database +character data that isn't iso-8859-1 the driver should convert it into utf8. + +Multiple SQL statements may not be combined in a single statement +handle (C<$sth>), although some databases and drivers do support this +(notably Sybase and SQL Server). + +Non-sequential record reads are not supported in this version of the DBI. +In other words, records can only be fetched in the order that the +database returned them, and once fetched they are forgotten. + +Positioned updates and deletes are not directly supported by the DBI. +See the description of the C<CursorName> attribute for an alternative. + +Individual driver implementors are free to provide any private +functions and/or handle attributes that they feel are useful. +Private driver functions can be invoked using the DBI C<func()> method. +Private driver attributes are accessed just like standard attributes. + +Many methods have an optional C<\%attr> parameter which can be used to +pass information to the driver implementing the method. Except where +specifically documented, the C<\%attr> parameter can only be used to pass +driver specific hints. In general, you can ignore C<\%attr> parameters +or pass it as C<undef>. + + +=head2 Naming Conventions and Name Space + +The DBI package and all packages below it (C<DBI::*>) are reserved for +use by the DBI. Extensions and related modules use the C<DBIx::> +namespace (see L<http://www.perl.com/CPAN/modules/by-module/DBIx/>). +Package names beginning with C<DBD::> are reserved for use +by DBI database drivers. All environment variables used by the DBI +or by individual DBDs begin with "C<DBI_>" or "C<DBD_>". + +The letter case used for attribute names is significant and plays an +important part in the portability of DBI scripts. The case of the +attribute name is used to signify who defined the meaning of that name +and its values. + + Case of name Has a meaning defined by + ------------ ------------------------ + UPPER_CASE Standards, e.g., X/Open, ISO SQL92 etc (portable) + MixedCase DBI API (portable), underscores are not used. + lower_case Driver or database engine specific (non-portable) + +It is of the utmost importance that Driver developers only use +lowercase attribute names when defining private attributes. Private +attribute names must be prefixed with the driver name or suitable +abbreviation (e.g., "C<ora_>" for Oracle, "C<ing_>" for Ingres, etc). + + +=head2 SQL - A Query Language + +Most DBI drivers require applications to use a dialect of SQL +(Structured Query Language) to interact with the database engine. +The L</"Standards Reference Information"> section provides links +to useful information about SQL. + +The DBI itself does not mandate or require any particular language to +be used; it is language independent. In ODBC terms, the DBI is in +"pass-thru" mode, although individual drivers might not be. The only requirement +is that queries and other statements must be expressed as a single +string of characters passed as the first argument to the L</prepare> or +L</do> methods. + +For an interesting diversion on the I<real> history of RDBMS and SQL, +from the people who made it happen, see: + + http://www.mcjones.org/System_R/SQL_Reunion_95/sqlr95.html + +Follow the "Full Contents" then "Intergalactic dataspeak" links for the +SQL history. + +=head2 Placeholders and Bind Values + +Some drivers support placeholders and bind values. +I<Placeholders>, also called parameter markers, are used to indicate +values in a database statement that will be supplied later, +before the prepared statement is executed. For example, an application +might use the following to insert a row of data into the SALES table: + + INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?) + +or the following, to select the description for a product: + + SELECT description FROM products WHERE product_code = ? + +The C<?> characters are the placeholders. The association of actual +values with placeholders is known as I<binding>, and the values are +referred to as I<bind values>. +Note that the C<?> is not enclosed in quotation marks, even when the +placeholder represents a string. + +Some drivers also allow placeholders like C<:>I<name> and C<:>I<N> (e.g., +C<:1>, C<:2>, and so on) in addition to C<?>, but their use is not portable. + +If the C<:>I<N> form of placeholder is supported by the driver you're using, +then you should be able to use either L</bind_param> or L</execute> to bind +values. Check your driver documentation. + +With most drivers, placeholders can't be used for any element of a +statement that would prevent the database server from validating the +statement and creating a query execution plan for it. For example: + + "SELECT name, age FROM ?" # wrong (will probably fail) + "SELECT name, ? FROM people" # wrong (but may not 'fail') + +Also, placeholders can only represent single scalar values. +For example, the following +statement won't work as expected for more than one value: + + "SELECT name, age FROM people WHERE name IN (?)" # wrong + "SELECT name, age FROM people WHERE name IN (?,?)" # two names + +When using placeholders with the SQL C<LIKE> qualifier, you must +remember that the placeholder substitutes for the whole string. +So you should use "C<... LIKE ? ...>" and include any wildcard +characters in the value that you bind to the placeholder. + +B<NULL Values> + +Undefined values, or C<undef>, are used to indicate NULL values. +You can insert and update columns with a NULL value as you would a +non-NULL value. These examples insert and update the column +C<age> with a NULL value: + + $sth = $dbh->prepare(qq{ + INSERT INTO people (fullname, age) VALUES (?, ?) + }); + $sth->execute("Joe Bloggs", undef); + + $sth = $dbh->prepare(qq{ + UPDATE people SET age = ? WHERE fullname = ? + }); + $sth->execute(undef, "Joe Bloggs"); + +However, care must be taken when trying to use NULL values in a +C<WHERE> clause. Consider: + + SELECT fullname FROM people WHERE age = ? + +Binding an C<undef> (NULL) to the placeholder will I<not> select rows +which have a NULL C<age>! At least for database engines that +conform to the SQL standard. Refer to the SQL manual for your database +engine or any SQL book for the reasons for this. To explicitly select +NULLs you have to say "C<WHERE age IS NULL>". + +A common issue is to have a code fragment handle a value that could be +either C<defined> or C<undef> (non-NULL or NULL) at runtime. +A simple technique is to prepare the appropriate statement as needed, +and substitute the placeholder for non-NULL cases: + + $sql_clause = defined $age? "age = ?" : "age IS NULL"; + $sth = $dbh->prepare(qq{ + SELECT fullname FROM people WHERE $sql_clause + }); + $sth->execute(defined $age ? $age : ()); + +The following technique illustrates qualifying a C<WHERE> clause with +several columns, whose associated values (C<defined> or C<undef>) are +in a hash %h: + + for my $col ("age", "phone", "email") { + if (defined $h{$col}) { + push @sql_qual, "$col = ?"; + push @sql_bind, $h{$col}; + } + else { + push @sql_qual, "$col IS NULL"; + } + } + $sql_clause = join(" AND ", @sql_qual); + $sth = $dbh->prepare(qq{ + SELECT fullname FROM people WHERE $sql_clause + }); + $sth->execute(@sql_bind); + +The techniques above call prepare for the SQL statement with each call to +execute. Because calls to prepare() can be expensive, performance +can suffer when an application iterates many times over statements +like the above. + +A better solution is a single C<WHERE> clause that supports both +NULL and non-NULL comparisons. Its SQL statement would need to be +prepared only once for all cases, thus improving performance. +Several examples of C<WHERE> clauses that support this are presented +below. But each example lacks portability, robustness, or simplicity. +Whether an example is supported on your database engine depends on +what SQL extensions it provides, and where it supports the C<?> +placeholder in a statement. + + 0) age = ? + 1) NVL(age, xx) = NVL(?, xx) + 2) ISNULL(age, xx) = ISNULL(?, xx) + 3) DECODE(age, ?, 1, 0) = 1 + 4) age = ? OR (age IS NULL AND ? IS NULL) + 5) age = ? OR (age IS NULL AND SP_ISNULL(?) = 1) + 6) age = ? OR (age IS NULL AND ? = 1) + +Statements formed with the above C<WHERE> clauses require execute +statements as follows. The arguments are required, whether their +values are C<defined> or C<undef>. + + 0,1,2,3) $sth->execute($age); + 4,5) $sth->execute($age, $age); + 6) $sth->execute($age, defined($age) ? 0 : 1); + +Example 0 should not work (as mentioned earlier), but may work on +a few database engines anyway (e.g. Sybase). Example 0 is part +of examples 4, 5, and 6, so if example 0 works, these other +examples may work, even if the engine does not properly support +the right hand side of the C<OR> expression. + +Examples 1 and 2 are not robust: they require that you provide a +valid column value xx (e.g. '~') which is not present in any row. +That means you must have some notion of what data won't be stored +in the column, and expect clients to adhere to that. + +Example 5 requires that you provide a stored procedure (SP_ISNULL +in this example) that acts as a function: it checks whether a value +is null, and returns 1 if it is, or 0 if not. + +Example 6, the least simple, is probably the most portable, i.e., it +should work with with most, if not all, database engines. + +Here is a table that indicates which examples above are known to +work on various database engines: + + -----Examples------ + 0 1 2 3 4 5 6 + - - - - - - - + Oracle 9 N Y N Y Y ? Y + Informix IDS 9 N N N Y N Y Y + MS SQL N N Y N Y ? Y + Sybase Y N N N N N Y + AnyData,DBM,CSV Y N N N Y Y* Y + SQLite 3.3 N N N N Y N N + MSAccess N N N N Y N Y + +* Works only because Example 0 works. + +DBI provides a sample perl script that will test the examples above +on your database engine and tell you which ones work. It is located +in the F<ex/> subdirectory of the DBI source distribution, or here: +L<http://svn.perl.org/modules/dbi/trunk/ex/perl_dbi_nulls_test.pl> +Please use the script to help us fill-in and maintain this table. + +B<Performance> + +Without using placeholders, the insert statement shown previously would have to +contain the literal values to be inserted and would have to be +re-prepared and re-executed for each row. With placeholders, the insert +statement only needs to be prepared once. The bind values for each row +can be given to the C<execute> method each time it's called. By avoiding +the need to re-prepare the statement for each row, the application +typically runs many times faster. Here's an example: + + my $sth = $dbh->prepare(q{ + INSERT INTO sales (product_code, qty, price) VALUES (?, ?, ?) + }) or die $dbh->errstr; + while (<>) { + chomp; + my ($product_code, $qty, $price) = split /,/; + $sth->execute($product_code, $qty, $price) or die $dbh->errstr; + } + $dbh->commit or die $dbh->errstr; + +See L</execute> and L</bind_param> for more details. + +The C<q{...}> style quoting used in this example avoids clashing with +quotes that may be used in the SQL statement. Use the double-quote like +C<qq{...}> operator if you want to interpolate variables into the string. +See L<perlop/"Quote and Quote-like Operators"> for more details. + +See also the L</bind_columns> method, which is used to associate Perl +variables with the output columns of a C<SELECT> 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<SQL_BIGINT> is (currently) omitted, because SQL/CLI and ODBC provide +conflicting codes. + +See the L</type_info>, L</type_info_all>, and L</bind_param> 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<parse_dsn> + + ($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<connect> + + $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-E<gt>disconnect> to terminate the connection. + +If the connect fails (see below), it returns C<undef> and sets both C<$DBI::err> +and C<$DBI::errstr>. (It does I<not> explicitly set C<$!>.) You should generally +test the return status of C<connect> and C<print $DBI::errstr> if it has failed. + +Multiple simultaneous connections to multiple databases through multiple +drivers can be made via the DBI. Simply make one C<connect> call for each +database and keep a copy of each returned database handle. + +The C<$data_source> value must begin with "C<dbi:>I<driver_name>C<:>". +The I<driver_name> 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<DBI_DSN>. +If just the I<driver_name> part is empty (i.e., the C<$data_source> +prefix is "C<dbi::>"), the environment variable C<DBI_DRIVER> is +used. If neither variable is set, then C<connect> 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<no standard> 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<host>', 'C<port>', and 'C<database>' (plus 'C<db>' +as an alias for C<database>). 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<DBI_AUTOPROXY> is defined (and the +driver in C<$data_source> is not "C<Proxy>") then the connect request +will automatically be changed to: + + $ENV{DBI_AUTOPROXY};dsn=$data_source + +C<DBI_AUTOPROXY> is typically set as "C<dbi:Proxy:hostname=...;port=...>". +If $ENV{DBI_AUTOPROXY} doesn't begin with 'C<dbi:>' 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<DBI_USER> and C<DBI_PASS> +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. + +C<DBI-E<gt>connect> automatically installs the driver if it has not been +installed yet. Driver installation either returns a valid driver +handle, or it I<dies> with an error message that includes the string +"C<install_driver>" and the underlying problem. So C<DBI-E<gt>connect> +will die +on a driver installation failure and will only return C<undef> on a +connect failure, in which case C<$DBI::errstr> will hold the error message. +Use C<eval { ... }> if you need to catch the "C<install_driver>" error. + +The C<$data_source> argument (with the "C<dbi:...:>" 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<AutoCommit> and C<PrintError> attributes for each connection +default to "on". (See L</AutoCommit> and L</PrintError> for more information.) +However, it is strongly recommended that you explicitly define C<AutoCommit> +rather than rely on the default. The C<PrintWarn> 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<PrintError>, C<RaiseError>, C<AutoCommit>, 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<Username> and C<Password>, 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<connect>. + +The C<dbi_connect_method> 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<connect> (instead of C<\%attr>): + + $dbh = DBI->connect($data_source, $user, $pass, $driver); + +In this "old-style" form of C<connect>, the C<$data_source> should not start +with "C<dbi:driver_name:>". (If it does, the embedded driver_name +will be ignored). Also note that in this older form of C<connect>, +the C<$dbh-E<gt>{AutoCommit}> attribute is I<undefined>, the +C<$dbh-E<gt>{PrintError}> attribute is off, and the old C<DBI_DBNAME> +environment variable is +checked if C<DBI_DSN> is not defined. Beware that this "old-style" +C<connect> will soon be withdrawn in a future version of DBI. + +=head3 C<connect_cached> + + $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<connect_cached> is like L</connect>, except that the database handle +returned is also +stored in a hash associated with the given parameters. If another call +is made to C<connect_cached> 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<ping> 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<connect_cached> 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<AutoCommit> 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<private_foo_cachekey> here as an example, you can use +any attribute name with a C<private_> 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</CachedKids> attribute: + + my $CachedKids_hashref = $dbh->{Driver}->{CachedKids}; + %$CachedKids_hashref = () if $CachedKids_hashref; + + +=head3 C<available_drivers> + + @ary = DBI->available_drivers; + @ary = DBI->available_drivers($quiet); + +Returns a list of all available drivers by searching for C<DBD::*> 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<installed_drivers> + + %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</available_drivers>. + +Added in DBI 1.49. + +=head3 C<installed_versions> + + 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<DBI::PurePerl> 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<DBI> version, +C<OS> 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<data_sources> + + @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<undef>, then the value of the +C<DBI_DRIVER> 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<dies> with an error message +that includes the string "C<install_driver>" and the underlying problem. + +Data sources are returned in a form suitable for passing to the +L</connect> method (that is, they will include the "C<dbi:$driver:>" 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<trace> + + DBI->trace($trace_setting) + DBI->trace($trace_setting, $trace_filename) + DBI->trace($trace_setting, $trace_filehandle) + $trace_setting = DBI->trace; + +The C<DBI-E<gt>trace> method sets the I<global default> trace +settings and returns the I<previous> trace settings. It can also +be used to change where the trace output is sent. + +There's a similar method, C<$h-E<gt>trace>, which sets the trace +settings for the specific handle it's called on. + +See the L</TRACING> section for full details about the DBI's powerful +tracing facilities. + + +=head3 C<visit_handles> + + 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</visit_child_handles> +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</visit_child_handles>. + +=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<use> 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<data_string_desc> + + $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<UTF8> 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<UTF8 on but INVALID encoding>. + +The C<ASCII> vs C<non-ASCII> portion shows C<ASCII> if I<all> the +characters in the string are ASCII (have code points <= 127). + +The data_string_desc() function was added in DBI 1.46. + +=head3 C<data_string_diff> + + $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<C> is the corresponding +latin-1 character. + +The data_string_diff() function only considers logical I<characters> +and not the underlying encoding. See L</data_diff> for an alternative. + +The data_string_diff() function was added in DBI 1.46. + +=head3 C<data_diff> + + $diff = data_diff($a, $b); + $diff = data_diff($a, $b, $logical); + +Returns an informal description of the difference between two strings. +It calls L</data_string_desc> and L</data_string_diff> +and returns the combined results as a multi-line string. + +For example, C<data_diff("abc", "ab\x{263a}")> will return: + + a: UTF8 off, ASCII, 3 characters 3 bytes + b: UTF8 on, non-ASCII, 3 characters 5 bytes + Strings differ at index 2: a[2]=c, b[2]=\x{263A} + +If $a and $b are identical in both the characters they contain I<and> +their physical encoding then data_diff() returns an empty string. +If $logical is true then physical encoding differences are ignored +(but are still reported if there is a difference in the characters). + +The data_diff() function was added in DBI 1.46. + +=head3 C<neat> + + $str = neat($value); + $str = neat($value, $maxlen); + +Return a string containing a neat (and tidy) representation of the +supplied value. + +Strings will be quoted, although internal quotes will I<not> be escaped. +Values known to be numeric will be unquoted. Undefined (NULL) values +will be shown as C<undef> (without quotes). + +If the string is flagged internally as utf8 then double quotes will +be used, otherwise single quotes are used and unprintable characters +will be replaced by dot (.). + +For result strings longer than C<$maxlen> the result string will be +truncated to C<$maxlen-4> and "C<...'>" will be appended. If C<$maxlen> is 0 +or C<undef>, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400. + +This function is designed to format values for human consumption. +It is used internally by the DBI for L</trace> output. It should +typically I<not> be used for formatting values for database use. +(See also L</quote>.) + +=head3 C<neat_list> + + $str = neat_list(\@listref, $maxlen, $field_sep); + +Calls C<neat> on each element of the list and returns a string +containing the results joined with C<$field_sep>. C<$field_sep> defaults +to C<", ">. + +=head3 C<looks_like_number> + + @bool = looks_like_number(@array); + +Returns true for each element that looks like a number. +Returns false for each element that does not look like a number. +Returns C<undef> for each element that is undefined or empty. + +=head3 C<hash> + + $hash_value = DBI::hash($buffer, $type); + +Return a 32-bit integer 'hash' value corresponding to the contents of $buffer. +The $type parameter selects which kind of hash algorithm should be used. + +For the technically curious, type 0 (which is the default if $type +isn't specified) is based on the Perl 5.1 hash except that the value +is forced to be negative (for obscure historical reasons). +Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See +L<http://www.isthe.com/chongo/tech/comp/fnv/> for more information. +Both types are implemented in C and are very fast. + +This function doesn't have much to do with databases, except that +it can be handy to store hash values in a database. + +=head3 C<sql_type_cast> + + $sts = DBI::sql_type_cast($sv, $sql_type, $flags); + +sql_type_cast attempts to cast C<$sv> to the SQL type (see L<DBI +Constants>) specified in C<$sql_type>. At present only the SQL types +C<SQL_INTEGER>, C<SQL_DOUBLE> and C<SQL_NUMERIC> are supported. + +For C<SQL_INTEGER> 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<SQL_DOUBLE> 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<SQL_NUMERIC> is similar to C<SQL_INTEGER> or C<SQL_DOUBLE> 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<SQL_INTEGER>, if it looks like a floating point value it will act +like C<SQL_DOUBLE>, if it looks like neither then it will do nothing - +and thereby avoid the warnings that would be generated by +C<SQL_INTEGER> and C<SQL_DOUBLE> when given non-numeric data. + +C<$flags> may be: + +=over 4 + +=item C<DBIstcf_DISCARD_STRING> + +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<DBIstcf_STRICT> + +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<DBIstcf_STRICT> 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<last handle used> +(that handle is represented by C<$h> in the descriptions below). + +Where an attribute is equivalent to a method call, then refer to +the method call for all related documentation. + +Warning: these attributes are provided as a convenience but they +do have limitations. Specifically, they have a short lifespan: +because they are associated with +the last handle used, they should only be used I<immediately> after +calling the method that "sets" them. +If in any doubt, use the corresponding method call. + +=head3 C<$DBI::err> + +Equivalent to C<$h-E<gt>err>. + +=head3 C<$DBI::errstr> + +Equivalent to C<$h-E<gt>errstr>. + +=head3 C<$DBI::state> + +Equivalent to C<$h-E<gt>state>. + +=head3 C<$DBI::rows> + +Equivalent to C<$h-E<gt>rows>. Please refer to the documentation +for the L</rows> 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<err> + + $rv = $h->err; + +Returns the I<native> 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<and> 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<err> 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</set_err> for more information. + +=head3 C<errstr> + + $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</err> 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</set_err> for more information. + +=head3 C<state> + + $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<S1000> (General Error) for all errors. + +The driver is free to return any value via C<state>, e.g., warning +codes, even if it has not declared an error by returning a true value +via the L</err> 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<set_err> + + $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<err>, C<errstr>, and C<state> values for the handle. +This method is typically only used by DBI drivers and DBI subclasses. + +If the L</HandleSetErr> attribute holds a reference to a subroutine +it is called first. The subroutine can alter the $err, $errstr, $state, +and $method values. See L</HandleSetErr> for full details. +If the subroutine returns a true value then the handle C<err>, +C<errstr>, and C<state> values are not altered and set_err() returns +an empty list (it normally returns $rv which defaults to undef, see below). + +Setting C<err> to a I<true> value indicates an error and will trigger +the normal DBI error handling mechanisms, such as C<RaiseError> and +C<HandleError>, if they are enabled, when execution returns from +the DBI back to the application. + +Setting C<err> to C<""> indicates an 'information' state, and setting +it to C<"0"> indicates a 'warning' state. Setting C<err> to C<undef> +also sets C<errstr> to undef, and C<state> to C<"">, irrespective +of the values of the $errstr and $state parameters. + +The $method parameter provides an alternate method name for the +C<RaiseError>/C<PrintError>/C<PrintWarn> error string instead of +the fairly unhelpful 'C<set_err>'. + +The C<set_err> method normally returns undef. The $rv parameter +provides an alternate return value. + +Some special rules apply if the C<err> or C<errstr> +values for the handle are I<already> set... + +If C<errstr> is true then: "C< [err was %s now %s]>" is appended if $err is +true and C<err> 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<state> 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<err> value is set to $err if: $err is true; or handle +C<err> value is undef; or $err is defined and the length is greater +than the handle C<err> 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<state> value is set to $state if $state is true and +the handle C<err> value was set (by the rules above). + +Support for warning and information states was added in DBI 1.41. + +=head3 C<trace> + + $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, C<DBI-E<gt>trace>, which sets the global +default trace settings. + +See the L</TRACING> section for full details about the DBI's powerful +tracing facilities. + +=head3 C<trace_msg> + + $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 C<DBI-E<gt>trace_msg($msg)>. + +See L</TRACING> for more details. + +=head3 C<func> + + $h->func(@func_arguments, $func_name) or die ...; + +The C<func> 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<last> 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<DBI::DBD> for how you can avoid needing to +use func() and gain direct access to driver-private methods. + +=head3 C<can> + + $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<parse_trace_flags> + + $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<parse_trace_flag> + + $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<private_attribute_info> + + $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<swap_inner_handle> + + $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<inner> 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<becomes> $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<visit_child_handles> + + $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<visit_child_handles> +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</visit_handles>. + +=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<Warn> + +Type: boolean, inherited + +The C<Warn> 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<warn> function, they can be intercepted using the Perl C<$SIG{__WARN__}> +hook. + +The C<Warn> attribute is not related to the C<PrintWarn> attribute. + +=head3 C<Active> + +Type: boolean, read-only + +The C<Active> 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-E<gt>disconnect> sets C<Active> off). For +a statement handle it typically means that the handle is a C<SELECT> +that may have more data to fetch. (Fetching all the data or calling C<$sth-E<gt>finish> +sets C<Active> off.) + +=head3 C<Executed> + +Type: boolean + +The C<Executed> attribute is true if the handle object has been "executed". +Currently only the $dbh do() method and the $sth execute(), execute_array(), +and execute_for_fetch() methods set the C<Executed> attribute. + +When it's set on a handle it is also set on the parent handle at the +same time. So calling execute() on a $sth also sets the C<Executed> +attribute on the parent $dbh. + +The C<Executed> attribute for a database handle is cleared by the commit() and +rollback() methods (even if they fail). The C<Executed> attribute of a +statement handle is not cleared by the DBI under any circumstances and so acts +as a permanent record of whether the statement handle was ever used. + +The C<Executed> attribute was added in DBI 1.41. + +=head3 C<Kids> + +Type: integer, read-only + +For a driver handle, C<Kids> is the number of currently existing database +handles that were created from that driver handle. For a database +handle, C<Kids> is the number of currently existing statement handles that +were created from that database handle. +For a statement handle, the value is zero. + +=head3 C<ActiveKids> + +Type: integer, read-only + +Like C<Kids>, but only counting those that are C<Active> (as above). + +=head3 C<CachedKids> + +Type: hash ref + +For a database handle, C<CachedKids> returns a reference to the cache (hash) of +statement handles created by the L</prepare_cached> method. For a +driver handle, returns a reference to the cache (hash) of +database handles created by the L</connect_cached> method. + +=head3 C<Type> + +Type: scalar, read-only + +The C<Type> attribute identifies the type of a DBI handle. Returns +"dr" for driver handles, "db" for database handles and "st" for +statement handles. + +=head3 C<ChildHandles> + +Type: array ref + +The ChildHandles attribute contains a reference to an array of all the +handles created by this handle which are still accessible. The +contents of the array are weak-refs and will become undef when the +handle goes out of scope. + +C<ChildHandles> returns undef if your perl version does not support weak +references (check the L<Scalar::Util|Scalar::Util> module). The referenced +array returned should be treated as read-only. + +For example, to enumerate all driver handles, database handles and +statement handles: + + sub show_child_handles { + my ($h, $level) = @_; + printf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h; + show_child_handles($_, $level + 1) + for (grep { defined } @{$h->{ChildHandles}}); + } + + my %drivers = DBI->installed_drivers(); + show_child_handles($_, 0) for (values %drivers); + +=head3 C<CompatMode> + +Type: boolean, inherited + +The C<CompatMode> attribute is used by emulation layers (such as +Oraperl) to enable compatible behaviour in the underlying driver +(e.g., DBD::Oracle) for this handle. Not normally set by application code. + +It also has the effect of disabling the 'quick FETCH' of attribute +values from the handles attribute cache. So all attribute values +are handled by the drivers own FETCH method. This makes them slightly +slower but is useful for special-purpose drivers like DBD::Multiplex. + +=head3 C<InactiveDestroy> + +Type: boolean + +The default value, false, means a handle will be fully destroyed +as normal when the last reference to it is removed, just as you'd expect. + +If set true then the handle will be treated by the DESTROY as if it was no +longer Active, and so the I<database engine> related effects of DESTROYing a +handle will be skipped. Think of the name as meaning 'treat the handle as +not-Active in the DESTROY method'. + +For a database handle, this attribute does not disable an I<explicit> +call to the disconnect method, only the implicit call from DESTROY +that happens if the handle is still marked as C<Active>. + +This attribute is specifically designed for use in Unix applications +that "fork" child processes. For some drivers, when the child process exits +the destruction of inherited handles cause the corresponding handles in the +parent process to cease working. + +Either the parent or the child process, but not both, should set +C<InactiveDestroy> true on all their shared handles. Alternatively the +L</AutoInactiveDestroy> can be set in the parent on connect. + +To help tracing applications using fork the process id is shown in +the trace log whenever a DBI or handle trace() method is called. +The process id also shown for I<every> method call if the DBI trace +level (not handle trace level) is set high enough to show the trace +from the DBI's method dispatcher, e.g. >= 9. + +=head3 C<AutoInactiveDestroy> + +Type: boolean, inherited + +The L</InactiveDestroy> attribute, described above, needs to be explicitly set +in the child process after a fork(). This is a problem if the code that performs +the fork() is not under your control, perhaps in a third-party module. +Use C<AutoInactiveDestroy> to get around this situation. + +If set true, the DESTROY method will check the process id of the handle and, if +different from the current process id, it will set the I<InactiveDestroy> attribute. + +This is the example it's designed to deal with: + + my $dbh = DBI->connect(...); + some_code_that_forks(); # Perhaps without your knowledge + # Child process dies, destroying the inherited dbh + $dbh->do(...); # Breaks because parent $dbh is now broken + +The C<AutoInactiveDestroy> attribute was added in DBI 1.614. + +=head3 C<PrintWarn> + +Type: boolean, inherited + +The C<PrintWarn> attribute controls the printing of warnings recorded +by the driver. When set to a true value the DBI will check method +calls to see if a warning condition has been set. If so, the DBI +will effectively do a C<warn("$class $method warning: $DBI::errstr")> +where C<$class> is the driver class and C<$method> is the name of +the method which failed. E.g., + + DBD::Oracle::db execute warning: ... warning text here ... + +By default, C<DBI-E<gt>connect> sets C<PrintWarn> "on" if $^W is true, +i.e., perl is running with warnings enabled. + +If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}> +handler or modules like CGI::Carp and CGI::ErrorWrap. + +See also L</set_err> for how warnings are recorded and L</HandleSetErr> +for how to influence it. + +Fetching the full details of warnings can require an extra round-trip +to the database server for some drivers. In which case the driver +may opt to only fetch the full details of warnings if the C<PrintWarn> +attribute is true. If C<PrintWarn> is false then these drivers should +still indicate the fact that there were warnings by setting the +warning string to, for example: "3 warnings". + +=head3 C<PrintError> + +Type: boolean, inherited + +The C<PrintError> attribute can be used to force errors to generate warnings (using +C<warn>) in addition to returning error codes in the normal way. When set +"on", any method which results in an error occurring will cause the DBI to +effectively do a C<warn("$class $method failed: $DBI::errstr")> where C<$class> +is the driver class and C<$method> is the name of the method which failed. E.g., + + DBD::Oracle::db prepare failed: ... error text here ... + +By default, C<DBI-E<gt>connect> sets C<PrintError> "on". + +If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}> +handler or modules like CGI::Carp and CGI::ErrorWrap. + +=head3 C<RaiseError> + +Type: boolean, inherited + +The C<RaiseError> attribute can be used to force errors to raise exceptions rather +than simply return error codes in the normal way. It is "off" by default. +When set "on", any method which results in an error will cause +the DBI to effectively do a C<die("$class $method failed: $DBI::errstr")>, +where C<$class> is the driver class and C<$method> is the name of the method +that failed. E.g., + + DBD::Oracle::db prepare failed: ... error text here ... + +If you turn C<RaiseError> on then you'd normally turn C<PrintError> off. +If C<PrintError> is also on, then the C<PrintError> is done first (naturally). + +Typically C<RaiseError> is used in conjunction with C<eval { ... }> +to catch the exception that's been thrown and followed by an +C<if ($@) { ... }> block to handle the caught exception. +For example: + + eval { + ... + $sth->execute(); + ... + }; + if ($@) { + # $sth->err and $DBI::err will be true if error was from DBI + warn $@; # print the error + ... # do whatever you need to deal with the error + } + +In that eval block the $DBI::lasth variable can be useful for +diagnosis and reporting if you can't be sure which handle triggered +the error. For example, $DBI::lasth->{Type} and $DBI::lasth->{Statement}. + +See also L</Transactions>. + +If you want to temporarily turn C<RaiseError> off (inside a library function +that is likely to fail, for example), the recommended way is like this: + + { + local $h->{RaiseError}; # localize and turn off for this block + ... + } + +The original value will automatically and reliably be restored by Perl, +regardless of how the block is exited. +The same logic applies to other attributes, including C<PrintError>. + +=head3 C<HandleError> + +Type: code ref, inherited + +The C<HandleError> attribute can be used to provide your own alternative behaviour +in case of errors. If set to a reference to a subroutine then that +subroutine is called when an error is detected (at the same point that +C<RaiseError> and C<PrintError> are handled). + +The subroutine is called with three parameters: the error message +string that C<RaiseError> and C<PrintError> would use, +the DBI handle being used, and the first value being returned by +the method that failed (typically undef). + +If the subroutine returns a false value then the C<RaiseError> +and/or C<PrintError> attributes are checked and acted upon as normal. + +For example, to C<die> with a full stack trace for any error: + + use Carp; + $h->{HandleError} = sub { confess(shift) }; + +Or to turn errors into exceptions: + + use Exception; # or your own favourite exception module + $h->{HandleError} = sub { Exception->new('DBI')->raise($_[0]) }; + +It is possible to 'stack' multiple HandleError handlers by using +closures: + + sub your_subroutine { + my $previous_handler = $h->{HandleError}; + $h->{HandleError} = sub { + return 1 if $previous_handler and &$previous_handler(@_); + ... your code here ... + }; + } + +Using a C<my> inside a subroutine to store the previous C<HandleError> +value is important. See L<perlsub> and L<perlref> for more information +about I<closures>. + +It is possible for C<HandleError> to alter the error message that +will be used by C<RaiseError> and C<PrintError> if it returns false. +It can do that by altering the value of $_[0]. This example appends +a stack trace to all errors and, unlike the previous example using +Carp::confess, this will work C<PrintError> as well as C<RaiseError>: + + $h->{HandleError} = sub { $_[0]=Carp::longmess($_[0]); 0; }; + +It is also possible for C<HandleError> to hide an error, to a limited +degree, by using L</set_err> to reset $DBI::err and $DBI::errstr, +and altering the return value of the failed method. For example: + + $h->{HandleError} = sub { + return 0 unless $_[0] =~ /^\S+ fetchrow_arrayref failed:/; + return 0 unless $_[1]->err == 1234; # the error to 'hide' + $h->set_err(undef,undef); # turn off the error + $_[2] = [ ... ]; # supply alternative return value + return 1; + }; + +This only works for methods which return a single value and is hard +to make reliable (avoiding infinite loops, for example) and so isn't +recommended for general use! If you find a I<good> use for it then +please let me know. + +=head3 C<HandleSetErr> + +Type: code ref, inherited + +The C<HandleSetErr> attribute can be used to intercept +the setting of handle C<err>, C<errstr>, and C<state> values. +If set to a reference to a subroutine then that subroutine is called +whenever set_err() is called, typically by the driver or a subclass. + +The subroutine is called with five arguments, the first five that +were passed to set_err(): the handle, the C<err>, C<errstr>, and +C<state> values being set, and the method name. These can be altered +by changing the values in the @_ array. The return value affects +set_err() behaviour, see L</set_err> for details. + +It is possible to 'stack' multiple HandleSetErr handlers by using +closures. See L</HandleError> for an example. + +The C<HandleSetErr> and C<HandleError> subroutines differ in subtle +but significant ways. HandleError is only invoked at the point where +the DBI is about to return to the application with C<err> set true. +It's not invoked by the failure of a method that's been called by +another DBI method. HandleSetErr, on the other hand, is called +whenever set_err() is called with a defined C<err> value, even if false. +So it's not just for errors, despite the name, but also warn and info states. +The set_err() method, and thus HandleSetErr, may be called multiple +times within a method and is usually invoked from deep within driver code. + +In theory a driver can use the return value from HandleSetErr via +set_err() to decide whether to continue or not. If set_err() returns +an empty list, indicating that the HandleSetErr code has 'handled' +the 'error', the driver could then continue instead of failing (if +that's a reasonable thing to do). This isn't excepted to be +common and any such cases should be clearly marked in the driver +documentation and discussed on the dbi-dev mailing list. + +The C<HandleSetErr> attribute was added in DBI 1.41. + +=head3 C<ErrCount> + +Type: unsigned integer + +The C<ErrCount> attribute is incremented whenever the set_err() +method records an error. It isn't incremented by warnings or +information states. It is not reset by the DBI at any time. + +The C<ErrCount> attribute was added in DBI 1.41. Older drivers may +not have been updated to use set_err() to record errors and so this +attribute may not be incremented when using them. + + +=head3 C<ShowErrorStatement> + +Type: boolean, inherited + +The C<ShowErrorStatement> attribute can be used to cause the relevant +Statement text to be appended to the error messages generated by +the C<RaiseError>, C<PrintError>, and C<PrintWarn> attributes. +Only applies to errors on statement handles +plus the prepare(), do(), and the various C<select*()> database handle methods. +(The exact format of the appended text is subject to change.) + +If C<$h-E<gt>{ParamValues}> returns a hash reference of parameter +(placeholder) values then those are formatted and appended to the +end of the Statement text in the error message. + +=head3 C<TraceLevel> + +Type: integer, inherited + +The C<TraceLevel> attribute can be used as an alternative to the +L</trace> method to set the DBI trace level and trace flags for a +specific handle. See L</TRACING> for more details. + +The C<TraceLevel> attribute is especially useful combined with +C<local> to alter the trace settings for just a single block of code. + +=head3 C<FetchHashKeyName> + +Type: string, inherited + +The C<FetchHashKeyName> attribute is used to specify whether the fetchrow_hashref() +method should perform case conversion on the field names used for +the hash keys. For historical reasons it defaults to 'C<NAME>' but +it is recommended to set it to 'C<NAME_lc>' (convert to lower case) +or 'C<NAME_uc>' (convert to upper case) according to your preference. +It can only be set for driver and database handles. For statement +handles the value is frozen when prepare() is called. + + +=head3 C<ChopBlanks> + +Type: boolean, inherited + +The C<ChopBlanks> attribute can be used to control the trimming of trailing space +characters from fixed width character (CHAR) fields. No other field +types are affected, even where field values have trailing spaces. + +The default is false (although it is possible that the default may change). +Applications that need specific behaviour should set the attribute as +needed. + +Drivers are not required to support this attribute, but any driver which +does not support it must arrange to return C<undef> as the attribute value. + + +=head3 C<LongReadLen> + +Type: unsigned integer, inherited + +The C<LongReadLen> attribute may be used to control the maximum +length of 'long' type fields (LONG, BLOB, CLOB, MEMO, etc.) which the driver will +read from the database automatically when it fetches each row of data. + +The C<LongReadLen> attribute only relates to fetching and reading +long values; it is not involved in inserting or updating them. + +A value of 0 means not to automatically fetch any long data. +Drivers may return undef or an empty string for long fields when +C<LongReadLen> is 0. + +The default is typically 0 (zero) or 80 bytes but may vary between drivers. +Applications fetching long fields should set this value to slightly +larger than the longest long field value to be fetched. + +Some databases return some long types encoded as pairs of hex digits. +For these types, C<LongReadLen> relates to the underlying data +length and not the doubled-up length of the encoded string. + +Changing the value of C<LongReadLen> for a statement handle after it +has been C<prepare>'d will typically have no effect, so it's common to +set C<LongReadLen> on the C<$dbh> before calling C<prepare>. + +For most drivers the value used here has a direct effect on the +memory used by the statement handle while it's active, so don't be +too generous. If you can't be sure what value to use you could +execute an extra select statement to determine the longest value. +For example: + + $dbh->{LongReadLen} = $dbh->selectrow_array(qq{ + SELECT MAX(OCTET_LENGTH(long_column_name)) + FROM table WHERE ... + }); + $sth = $dbh->prepare(qq{ + SELECT long_column_name, ... FROM table WHERE ... + }); + +You may need to take extra care if the table can be modified between +the first select and the second being executed. You may also need to +use a different function if OCTET_LENGTH() does not work for long +types in your database. For example, for Sybase use DATALENGTH() and +for Oracle use LENGTHB(). + +See also L</LongTruncOk> for information on truncation of long types. + +=head3 C<LongTruncOk> + +Type: boolean, inherited + +The C<LongTruncOk> attribute may be used to control the effect of +fetching a long field value which has been truncated (typically +because it's longer than the value of the C<LongReadLen> attribute). + +By default, C<LongTruncOk> is false and so fetching a long value that +needs to be truncated will cause the fetch to fail. +(Applications should always be sure to +check for errors after a fetch loop in case an error, such as a divide +by zero or long field truncation, caused the fetch to terminate +prematurely.) + +If a fetch fails due to a long field truncation when C<LongTruncOk> is +false, many drivers will allow you to continue fetching further rows. + +See also L</LongReadLen>. + +=head3 C<TaintIn> + +Type: boolean, inherited + +If the C<TaintIn> attribute is set to a true value I<and> Perl is running in +taint mode (e.g., started with the C<-T> option), then all the arguments +to most DBI method calls are checked for being tainted. I<This may change.> + +The attribute defaults to off, even if Perl is in taint mode. +See L<perlsec> for more about taint mode. If Perl is not +running in taint mode, this attribute has no effect. + +When fetching data that you trust you can turn off the TaintIn attribute, +for that statement handle, for the duration of the fetch loop. + +The C<TaintIn> attribute was added in DBI 1.31. + +=head3 C<TaintOut> + +Type: boolean, inherited + +If the C<TaintOut> attribute is set to a true value I<and> Perl is running in +taint mode (e.g., started with the C<-T> option), then most data fetched +from the database is considered tainted. I<This may change.> + +The attribute defaults to off, even if Perl is in taint mode. +See L<perlsec> for more about taint mode. If Perl is not +running in taint mode, this attribute has no effect. + +When fetching data that you trust you can turn off the TaintOut attribute, +for that statement handle, for the duration of the fetch loop. + +Currently only fetched data is tainted. It is possible that the results +of other DBI method calls, and the value of fetched attributes, may +also be tainted in future versions. That change may well break your +applications unless you take great care now. If you use DBI Taint mode, +please report your experience and any suggestions for changes. + +The C<TaintOut> attribute was added in DBI 1.31. + +=head3 C<Taint> + +Type: boolean, inherited + +The C<Taint> attribute is a shortcut for L</TaintIn> and L</TaintOut> (it is also present +for backwards compatibility). + +Setting this attribute sets both L</TaintIn> and L</TaintOut>, and retrieving +it returns a true value if and only if L</TaintIn> and L</TaintOut> are +both set to true values. + +=head3 C<Profile> + +Type: inherited + +The C<Profile> attribute enables the collection and reporting of +method call timing statistics. See the L<DBI::Profile> module +documentation for I<much> more detail. + +The C<Profile> attribute was added in DBI 1.24. + +=head3 C<ReadOnly> + +Type: boolean, inherited + +An application can set the C<ReadOnly> attribute of a handle to a true value to +indicate that it will not be attempting to make any changes using that handle +or any children of it. + +Note that the exact definition of 'read only' is rather fuzzy. +For more details see the documentation for the driver you're using. + +If the driver can make the handle truly read-only then it should +(unless doing so would have unpleasant side effect, like changing the +consistency level from per-statement to per-session). +Otherwise the attribute is simply advisory. + +A driver can set the C<ReadOnly> attribute itself to indicate that the data it +is connected to cannot be changed for some reason. + +Library modules and proxy drivers can use the attribute to influence +their behavior. For example, the DBD::Gofer driver considers the +C<ReadOnly> attribute when making a decision about whether to retry an +operation that failed. + +The attribute should be set to 1 or 0 (or undef). Other values are reserved. + +=head3 C<Callbacks> + +Type: hash ref + +The DBI callback mechanism lets you intercept, and optionally replace, any +method call on a DBI handle. At the extreme, it lets you become a puppet +master, deceiving the application in any way you want. + +The C<Callbacks> attribute is a hash reference where the keys are DBI method +names and the values are code references. For each key naming a method, the +DBI will execute the associated code reference before executing the method. + +The arguments to the code reference will be the same as to the method, +including the invocant (a database handle or statement handle). For example, +say that to callback to some code on a call to C<prepare()>: + + $dbh->{Callbacks} = { + prepare => sub { + my ($dbh, $query, $attrs) = @_; + print "Preparing q{$query}\n" + }, + }; + +The callback would then be executed when you called the C<prepare()> method: + + $dbh->prepare('SELECT 1'); + +And the output of course would be: + + Preparing q{SELECT 1} + +Because callbacks are executed I<before> the methods +they're associated with, you can modify the arguments before they're passed on +to the method call. For example, to make sure that all calls to C<prepare()> +are immediately prepared by L<DBD::Pg>, add a callback that makes sure that +the C<pg_prepare_now> attribute is always set: + + my $dbh = DBI->connect($dsn, $username, $auth, { + Callbacks => { + prepare => sub { + $_[2] ||= {}; + $_[2]->{pg_prepare_now} = 1; + return; # must return nothing + }, + } + }); + +Note that we are editing the contents of C<@_> directly. In this case we've +created the attributes hash if it's not passed to the C<prepare> call. + +You can also prevent the associated method from ever executing. While a +callback executes, C<$_> holds the method name. (This allows multiple callbacks +to share the same code reference and still know what method was called.) +To prevent the method from +executing, simply C<undef $_>. For example, if you wanted to disable calls to +C<ping()>, you could do this: + + $dbh->{Callbacks} = { + ping => sub { + # tell dispatch to not call the method: + undef $_; + # return this value instead: + return "42 bells"; + } + }; + +As with other attributes, Callbacks can be specified on a handle or via the +attributes to C<connect()>. Callbacks can also be applied to a statement +methods on a statement handle. For example: + + $sth->{Callbacks} = { + execute => sub { + print "Executing ", shift->{Statement}, "\n"; + } + }; + +The C<Callbacks> attribute of a database handle isn't copied to any statement +handles it creates. So setting callbacks for a statement handle requires you to +set the C<Callbacks> attribute on the statement handle yourself, as in the +example above, or use the special C<ChildCallbacks> key described below. + +B<Special Keys in Callbacks Attribute> + +In addition to DBI handle method names, the C<Callbacks> hash reference +supports three additional keys. + +The first is the C<ChildCallbacks> key. When a statement handle is created from +a database handle the C<ChildCallbacks> key of the database handle's +C<Callbacks> attribute, if any, becomes the new C<Callbacks> attribute of the +statement handle. +This allows you to define callbacks for all statement handles created from a +database handle. For example, if you wanted to count how many times C<execute> +was called in your application, you could write: + + my $exec_count = 0; + my $dbh = DBI->connect( $dsn, $username, $auth, { + Callbacks => { + ChildCallbacks => { + execute => sub { $exec_count++; return; } + } + } + }); + + END { + print "The execute method was called $exec_count times\n"; + } + +The other two special keys are C<connect_cached.new> and +C<connect_cached.reused>. These keys define callbacks that are called when +C<connect_cached()> is called, but allow different behaviors depending on +whether a new handle is created or a handle is returned. The callback is +invoked with these arguments: C<$dbh, $dsn, $user, $auth, $attr>. + +For example, some applications uses C<connect_cached()> to connect with +C<AutoCommit> enabled and then disable C<AutoCommit> temporarily for +transactions. If C<connect_cached()> is called during a transaction, perhaps in +a utility method, then it might select the same cached handle and then force +C<AutoCommit> on, forcing a commit of the transaction. See the L</connect_cached> +documentation for one way to deal with that. Here we'll describe an alternative +approach using a callback. + +Because the C<connect_cached.*> callbacks are invoked before connect_cached() +has applied the connect attributes you can use a callback to edit the attributes +that will be applied. To prevent a cached handle from having its transactions +committed before it's returned, you can eliminate the C<AutoCommit> attribute +in a C<connect_cached.reused> callback, like so: + + my $cb = { + 'connect_cached.reused' => sub { delete $_[4]->{AutoCommit} }, + }; + + sub dbh { + my $self = shift; + DBI->connect_cached( $dsn, $username, $auth, { + PrintError => 0, + RaiseError => 1, + AutoCommit => 1, + Callbacks => $cb, + }); + } + +The upshot is that new database handles are created with C<AutoCommit> +enabled, while cached database handles are left in whatever transaction state +they happened to be in when retrieved from the cache. + +A more common application for callbacks is setting connection state only when a +new connection is made (by connect() or connect_cached()). Adding a callback to +the connected method makes this easy. +This method is a no-op by default (unless you subclass the DBI and change it). +The DBI calls it to indicate that a new connection has been made and the connection +attributes have all been set. You can +give it a bit of added functionality by applying a callback to it. For +example, to make sure that MySQL understands your application's ANSI-compliant +SQL, set it up like so: + + my $dbh = DBI->connect($dsn, $username, $auth, { + Callbacks => { + connected => sub { + shift->do(q{ + SET SESSION sql_mode='ansi,strict_trans_tables,no_auto_value_on_zero'; + }); + return; + }, + } + }); + +One significant limitation with callbacks is that there can only be one per +method per handle. This means it's easy for one use of callbacks to interfere +with, or typically simply overwrite, another use of callbacks. For this reason +modules using callbacks should document the fact clearly so application authors +can tell if use of callbacks by the module will clash with use of callbacks by +the application. + +You might be able to work around this issue by taking a copy of the original +callback and calling it within your own. For example: + + my $prev_cb = $h->{Callbacks}{method_name}; + $h->{Callbacks}{method_name} = sub { + if ($prev_cb) { + my @result = $prev_cb->(@_); + return @result if not $_; # $prev_cb vetoed call + } + ... your callback logic here ... + }; + +=head3 C<private_your_module_name_*> + +The DBI provides a way to store extra information in a DBI handle as +"private" attributes. The DBI will allow you to store and retrieve any +attribute which has a name starting with "C<private_>". + +It is I<strongly> recommended that you use just I<one> private +attribute (e.g., use a hash ref) I<and> give it a long and unambiguous +name that includes the module or application name that the attribute +relates to (e.g., "C<private_YourFullModuleName_thingy>"). + +Because of the way the Perl tie mechanism works you cannot reliably +use the C<||=> operator directly to initialise the attribute, like this: + + my $foo = $dbh->{private_yourmodname_foo} ||= { ... }; # WRONG + +you should use a two step approach like this: + + my $foo = $dbh->{private_yourmodname_foo}; + $foo ||= $dbh->{private_yourmodname_foo} = { ... }; + +This attribute is primarily of interest to people sub-classing DBI, +or for applications to piggy-back extra information onto DBI handles. + +=head1 DBI DATABASE HANDLE OBJECTS + +This section covers the methods and attributes associated with +database handles. + +=head2 Database Handle Methods + +The following methods are specified for DBI database handles: + +=head3 C<clone> + + $new_dbh = $dbh->clone(\%attr); + +The C<clone> method duplicates the $dbh connection by connecting +with the same parameters ($dsn, $user, $password) as originally used. + +The attributes for the cloned connect are the same as those used +for the I<original> connect, with any other attributes in C<\%attr> +merged over them. Effectively the same as doing: + + %attributes_used = ( %original_attributes, %attr ); + +If \%attr is not given then it defaults to a hash containing all +the attributes in the attribute cache of $dbh excluding any non-code +references, plus the main boolean attributes (RaiseError, PrintError, +AutoCommit, etc.). I<This behaviour is unreliable and so use of clone without +an argument is deprecated and may cause a warning in a future release.> + +The clone method can be used even if the database handle is disconnected. + +The C<clone> method was added in DBI 1.33. + +=head3 C<data_sources> + + @ary = $dbh->data_sources(); + @ary = $dbh->data_sources(\%attr); + +Returns a list of data sources (databases) available via the $dbh +driver's data_sources() method, plus any extra data sources that +the driver can discover via the connected $dbh. Typically the extra +data sources are other databases managed by the same server process +that the $dbh is connected to. + +Data sources are returned in a form suitable for passing to the +L</connect> method (that is, they will include the "C<dbi:$driver:>" prefix). + +The data_sources() method, for a $dbh, was added in DBI 1.38. + +=head3 C<do> + + $rows = $dbh->do($statement) or die $dbh->errstr; + $rows = $dbh->do($statement, \%attr) or die $dbh->errstr; + $rows = $dbh->do($statement, \%attr, @bind_values) or die ... + +Prepare and execute a single statement. Returns the number of rows +affected or C<undef> on error. A return value of C<-1> means the +number of rows is not known, not applicable, or not available. + +This method is typically most useful for I<non>-C<SELECT> 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<SELECT> statements because it does not return a statement +handle (so you can't fetch any data). + +The default C<do> method is logically similar to: + + sub do { + my($dbh, $statement, $attr, @bind_values) = @_; + my $sth = $dbh->prepare($statement, $attr) or return undef; + $sth->execute(@bind_values) or return undef; + my $rows = $sth->rows; + ($rows == 0) ? "0E0" : $rows; # always return true if no error + } + +For example: + + my $rows_deleted = $dbh->do(q{ + DELETE FROM table + WHERE status = ? + }, undef, 'DONE') or die $dbh->errstr; + +Using placeholders and C<@bind_values> with the C<do> method can be +useful because it avoids the need to correctly quote any variables +in the C<$statement>. But if you'll be executing the statement many +times then it's more efficient to C<prepare> it once and call +C<execute> many times instead. + +The C<q{...}> style quoting used in this example avoids clashing with +quotes that may be used in the SQL statement. Use the double-quote-like +C<qq{...}> operator if you want to interpolate variables into the string. +See L<perlop/"Quote and Quote-like Operators"> for more details. + +Note drivers are free to avoid the overhead of creating an DBI +statement handle for do(), especially if there are no parameters. In +this case error handlers, if invoked during do(), will be passed the +database handle. + +=head3 C<last_insert_id> + + $rv = $dbh->last_insert_id($catalog, $schema, $table, $field); + $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr); + +Returns a value 'identifying' the row just inserted, if possible. +Typically this would be a value assigned by the database server +to a column with an I<auto_increment> or I<serial> type. +Returns undef if the driver does not support the method or can't +determine the value. + +The $catalog, $schema, $table, and $field parameters may be required +for some drivers (see below). If you don't know the parameter values +and your driver does not need them, then use C<undef> for each. + +There are several caveats to be aware of with this method if you want +to use it for portable applications: + +B<*> For some drivers the value may only available immediately after +the insert statement has executed (e.g., mysql, Informix). + +B<*> For some drivers the $catalog, $schema, $table, and $field parameters +are required, for others they are ignored (e.g., mysql). + +B<*> Drivers may return an indeterminate value if no insert has +been performed yet. + +B<*> For some drivers the value may only be available if placeholders +have I<not> been used (e.g., Sybase, MS SQL). In this case the value +returned would be from the last non-placeholder insert statement. + +B<*> Some drivers may need driver-specific hints about how to get +the value. For example, being told the name of the database 'sequence' +object that holds the value. Any such hints are passed as driver-specific +attributes in the \%attr parameter. + +B<*> If the underlying database offers nothing better, then some +drivers may attempt to implement this method by executing +"C<select max($field) from $table>". Drivers using any approach +like this should issue a warning if C<AutoCommit> 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<Warn> => 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<last_insert_id> method was added in DBI 1.38. + +=head3 C<selectrow_array> + + @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</prepare>, L</execute> and +L</fetchrow_array> 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<prepare> is skipped. + +If any method fails, and L</RaiseError> is not set, C<selectrow_array> +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<undef> is returned if there are no +more rows or if an error occurred. That C<undef> can't be distinguished +from an C<undef> returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C<selectrow_array> in a scalar context, or just don't do that. + + +=head3 C<selectrow_arrayref> + + $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</prepare>, L</execute> and +L</fetchrow_arrayref> 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<prepare> is skipped. + +If any method fails, and L</RaiseError> is not set, C<selectrow_array> +will return undef. + + +=head3 C<selectrow_hashref> + + $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</prepare>, L</execute> and +L</fetchrow_hashref> 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<prepare> is skipped. + +If any method fails, and L</RaiseError> is not set, C<selectrow_hashref> +will return undef. + + +=head3 C<selectall_arrayref> + + $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</prepare>, L</execute> and +L</fetchall_arrayref> 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<prepare> is skipped. This is recommended if the +statement is going to be executed many times. + +If L</RaiseError> is not set and any method except C<fetchall_arrayref> +fails then C<selectall_arrayref> will return C<undef>; if +C<fetchall_arrayref> fails then it will return with whatever data +has been fetched thus far. You should check C<$sth-E<gt>err> +afterwards (or use the C<RaiseError> attribute) to discover if the data is +complete or was truncated due to an error. + +The L</fetchall_arrayref> method called by C<selectall_arrayref> +supports a $max_rows parameter. You can specify a value for $max_rows +by including a 'C<MaxRows>' attribute in \%attr. In which case finish() +is called for you after fetchall_arrayref() returns. + +The L</fetchall_arrayref> method called by C<selectall_arrayref> +also supports a $slice parameter. You can specify a value for $slice by +including a 'C<Slice>' or 'C<Columns>' attribute in \%attr. The only +difference between the two is that if C<Slice> is not defined and +C<Columns> 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</fetchall_arrayref>. + +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</fetchall_arrayref> method for more details. + +=head3 C<selectall_hashref> + + $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</prepare>, L</execute> and +L</fetchall_hashref> 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<prepare> 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<fetchrow_hashref> fails, and L</RaiseError> is not set, +C<selectall_hashref> will return C<undef>. If C<fetchrow_hashref> fails and +L</RaiseError> 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<selectcol_arrayref> + + $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</prepare>, L</execute>, 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<prepare> is skipped. This is recommended if the +statement is going to be executed many times. + +If any method except C<fetch> fails, and L</RaiseError> is not set, +C<selectcol_arrayref> will return C<undef>. If C<fetch> fails and +L</RaiseError> 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<selectcol_arrayref> 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<Columns>' +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<MaxRows>' attribute in \%attr. + +=head3 C<prepare> + + $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</execute> method. See L</Statement Handle Methods>. + +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-E<gt>execute> is called. Such drivers are +unlikely to give much useful information about the +statement, such as C<$sth-E<gt>{NUM_OF_FIELDS}>, until after C<$sth-E<gt>execute> +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</Placeholders>). 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<prepare_cached> + + $sth = $dbh->prepare_cached($statement) + $sth = $dbh->prepare_cached($statement, \%attr) + $sth = $dbh->prepare_cached($statement, \%attr, $if_active) + +Like L</prepare> except that the statement handle returned will be +stored in a hash associated with the C<$dbh>. If another call is made to +C<prepare_cached> 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<prepare_cached>: + + 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<Caveat emptor:> 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<CachedKids> to an appropriate caching module, +such as L<Tie::Cache::LRU>: + + my $cache; + tie %$cache, 'Tie::Cache::LRU', 500; + $dbh->{CachedKids} = $cache; + +=head3 C<commit> + + $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<AutoCommit> is on, then calling +C<commit> will issue a "commit ineffective with AutoCommit" warning. + +See also L</Transactions> in the L</FURTHER INFORMATION> section below. + +=head3 C<rollback> + + $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<AutoCommit> is on, then calling +C<rollback> will issue a "rollback ineffective with AutoCommit" warning. + +See also L</Transactions> in the L</FURTHER INFORMATION> section below. + +=head3 C<begin_work> + + $rc = $dbh->begin_work or die $dbh->errstr; + +Enable transactions (by turning C<AutoCommit> off) until the next call +to C<commit> or C<rollback>. After the next C<commit> or C<rollback>, +C<AutoCommit> will automatically be turned on again. + +If C<AutoCommit> is already off when C<begin_work> is called then +it does nothing except return an error. If the driver does not support +transactions then when C<begin_work> attempts to set C<AutoCommit> off +the driver will trigger a fatal error. + +See also L</Transactions> in the L</FURTHER INFORMATION> section below. + + +=head3 C<disconnect> + + $rc = $dbh->disconnect or warn $dbh->errstr; + +Disconnects the database from the database handle. C<disconnect> is typically only used +before exiting the program. The handle is of little use after disconnecting. + +The transaction behaviour of the C<disconnect> 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<AutoCommit> should explicitly call C<commit> or C<rollback> before +calling C<disconnect>. + +The database is automatically disconnected by the C<DESTROY> method if +still connected when there are no longer any references to the handle. +The C<DESTROY> method for each driver should implicitly call C<rollback> to +undo any uncommitted changes. This is vital behaviour to ensure that +incomplete transactions don't get committed simply because Perl calls +C<DESTROY> 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</commit> or L</rollback> +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<finish> method on the active handles. + + +=head3 C<ping> + + $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<default> 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<get_info> + + $value = $dbh->get_info( $info_type ); + +Returns information about the implementation, i.e. driver and data +source capabilities, restrictions etc. It returns C<undef> 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</"Standards Reference Information"> 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<DBI::Const::GetInfoType> for more details. + +Because some DBI methods make use of get_info(), drivers are strongly +encouraged to support I<at least> 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<table_info> + + $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_CAT>: Table catalog identifier. This field is NULL (C<undef>) if not +applicable to the data source, which is usually the case. This field +is empty if not applicable to the table. + +B<TABLE_SCHEM>: The name of the schema containing the TABLE_NAME value. +This field is NULL (C<undef>) if not applicable to data source, and +empty if not applicable to the table. + +B<TABLE_NAME>: Name of the table (or view, synonym, etc). + +B<TABLE_TYPE>: 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<REMARKS>: A description of the table. May be NULL (C<undef>). + +Note that C<table_info> might not return records for all tables. +Applications can use any valid table regardless of whether it's +returned by C<table_info>. + +See also L</tables>, L</"Catalog Methods"> and +L</"Standards Reference Information">. + +=head3 C<column_info> + + $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<TABLE_CAT>: The catalog identifier. +This field is NULL (C<undef>) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B<TABLE_SCHEM>: The schema identifier. +This field is NULL (C<undef>) if not applicable to the data source, +and empty if not applicable to the table. + +B<TABLE_NAME>: The table identifier. +Note: A driver may provide column metadata not only for base tables, but +also for derived objects like SYNONYMS etc. + +B<COLUMN_NAME>: The column identifier. + +B<DATA_TYPE>: The concise data type code. + +B<TYPE_NAME>: A data source dependent data type name. + +B<COLUMN_SIZE>: 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<BUFFER_LENGTH>: The length in bytes of transferred data. + +B<DECIMAL_DIGITS>: The total number of significant digits to the right of +the decimal point. + +B<NUM_PREC_RADIX>: The radix for numeric precision. +The value is 10 or 2 for numeric data types and NULL (C<undef>) if not +applicable. + +B<NULLABLE>: Indicates if a column can accept NULLs. +The following values are defined: + + SQL_NO_NULLS 0 + SQL_NULLABLE 1 + SQL_NULLABLE_UNKNOWN 2 + +B<REMARKS>: A description of the column. + +B<COLUMN_DEF>: 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<COLUMN_DEF> +values would be: + + Database col1 col2 + -------- ---- ---- + Oracle: current_user 'string' + Postgres: "current_user"() 'string'::text + MS SQL: (user_name()) ('string') + +B<SQL_DATA_TYPE>: The SQL data type. + +B<SQL_DATETIME_SUB>: The subtype code for datetime and interval data types. + +B<CHAR_OCTET_LENGTH>: The maximum length in bytes of a character or binary +data type column. + +B<ORDINAL_POSITION>: The column sequence number (starting with 1). + +B<IS_NULLABLE>: 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</"Catalog Methods"> and L</"Standards Reference Information">. + +=head3 C<primary_key_info> + + $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<TABLE_CAT>: The catalog identifier. +This field is NULL (C<undef>) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B<TABLE_SCHEM>: The schema identifier. +This field is NULL (C<undef>) if not applicable to the data source, +and empty if not applicable to the table. + +B<TABLE_NAME>: The table identifier. + +B<COLUMN_NAME>: The column identifier. + +B<KEY_SEQ>: The column sequence number (starting with 1). +Note: This field is named B<ORDINAL_POSITION> in SQL/CLI. + +B<PK_NAME>: The primary key constraint identifier. +This field is NULL (C<undef>) if not applicable to the data source. + +See also L</"Catalog Methods"> and L</"Standards Reference Information">. + +=head3 C<primary_key> + + @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<foreign_key_info> + + $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<PKT>). + +C<$fk_catalog>, C<$fk_schema>, C<$fk_table> +identify the foreign key table (B<FKT>). + +If both B<PKT> and B<FKT> are given, the function returns the foreign key, if +any, in table B<FKT> that refers to the primary (unique) key of table B<PKT>. +(Note: In SQL/CLI, the result is implementation-defined.) + +If only B<PKT> is given, then the result set contains the primary key +of that table and all foreign keys that refer to it. + +If only B<FKT> 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<PKTABLE_CAT ( UK_TABLE_CAT )>: +The primary (unique) key table catalog identifier. +This field is NULL (C<undef>) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B<PKTABLE_SCHEM ( UK_TABLE_SCHEM )>: +The primary (unique) key table schema identifier. +This field is NULL (C<undef>) if not applicable to the data source, +and empty if not applicable to the table. + +B<PKTABLE_NAME ( UK_TABLE_NAME )>: +The primary (unique) key table identifier. + +B<PKCOLUMN_NAME (UK_COLUMN_NAME )>: +The primary (unique) key column identifier. + +B<FKTABLE_CAT ( FK_TABLE_CAT )>: +The foreign key table catalog identifier. +This field is NULL (C<undef>) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B<FKTABLE_SCHEM ( FK_TABLE_SCHEM )>: +The foreign key table schema identifier. +This field is NULL (C<undef>) if not applicable to the data source, +and empty if not applicable to the table. + +B<FKTABLE_NAME ( FK_TABLE_NAME )>: +The foreign key table identifier. + +B<FKCOLUMN_NAME ( FK_COLUMN_NAME )>: +The foreign key column identifier. + +B<KEY_SEQ ( ORDINAL_POSITION )>: +The column sequence number (starting with 1). + +B<UPDATE_RULE ( UPDATE_RULE )>: +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<DELETE_RULE ( DELETE_RULE )>: +The referential action for the DELETE rule. +The codes are the same as for UPDATE_RULE. + +B<FK_NAME ( FK_NAME )>: +The foreign key name. + +B<PK_NAME ( UK_NAME )>: +The primary (unique) key name. + +B<DEFERRABILITY ( DEFERABILITY )>: +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</"Catalog Methods"> and L</"Standards Reference Information">. + +=head3 C<statistics_info> + +B<Warning:> 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</table_info>). + +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<TABLE_CAT>: The catalog identifier. +This field is NULL (C<undef>) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B<TABLE_SCHEM>: The schema identifier. +This field is NULL (C<undef>) if not applicable to the data source, +and empty if not applicable to the table. + +B<TABLE_NAME>: The table identifier. + +B<NON_UNIQUE>: Unique index indicator. +Returns 0 for unique indexes, 1 for non-unique indexes + +B<INDEX_QUALIFIER>: Index qualifier identifier. +The identifier that is used to qualify the index name when doing a +C<DROP INDEX>; NULL (C<undef>) 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<DROP INDEX> statement; otherwise, +the TABLE_SCHEM should be used to qualify the index name. + +B<INDEX_NAME>: The index identifier. + +B<TYPE>: 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<undef>). + +B<ORDINAL_POSITION>: Column sequence number (starting with 1). + +B<COLUMN_NAME>: The column identifier. + +B<ASC_OR_DESC>: Column sort sequence. +C<A> for Ascending, C<D> for Descending, or NULL (C<undef>) if +not supported for this index. + +B<CARDINALITY>: 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<undef>). + +B<PAGES>: Number of storage pages used by this table or index. +If not supported, the value will be NULL (C<undef>). + +B<FILTER_CONDITION>: 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<undef>). +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<SALARY <= 4500>. + +See also L</"Catalog Methods"> and L</"Standards Reference Information">. + +=head3 C<tables> + + @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</table_info> for a description of the parameters. + +If C<$dbh-E<gt>get_info(29)> returns true (29 is SQL_IDENTIFIER_QUOTE_CHAR) +then the table names are constructed and quoted by L</quote_identifier> +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> + + $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 C<Name =>E<gt> C<Index> 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<DATA_TYPE> +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<AUTO_UNIQUE_VALUE> set, with and without C<UNSIGNED_ATTRIBUTE>, etc). + +The rows are ordered by C<DATA_TYPE> 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</type_info> 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</type_info> method provides a more usable and useful interface +to the data. + +=head3 C<type_info> + + @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<DATA_TYPE> 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<SQL_ALL_TYPES>, 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<type_info> returns the +information for the I<first> 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</Naming Conventions and Name Space>). 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<undef>) 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<undef>) is returned for data types where this is not applicable. + +=item CREATE_PARAMS (string) + +Parameter names for data type definition. For example, C<CREATE_PARAMS> for a +C<DECIMAL> would be "C<precision,scale>" if the DECIMAL type should be +declared as C<DECIMAL(>I<precision,scale>C<)> where I<precision> and I<scale> +are integer values. For a C<VARCHAR> it would be "C<max length>". +NULL (C<undef>) 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<undef>) 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<undef>) 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<undef>) is returned +for data types for which this is not applicable. + +=item LOCAL_TYPE_NAME (string) + +Localized version of the C<TYPE_NAME> for use in dialog with users. +NULL (C<undef>) is returned if a localized name is not available (in which +case C<TYPE_NAME> should be used). + +=item MINIMUM_SCALE (integer) + +The minimum scale of the data type. If a data type has a fixed scale, +then C<MAXIMUM_SCALE> holds the same value. NULL (C<undef>) 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<MINIMUM_SCALE> holds the same value. NULL (C<undef>) is returned for +data types for which this is not applicable. + +=item SQL_DATA_TYPE (integer) + +This column is the same as the C<DATA_TYPE> column, except for interval +and datetime data types. For interval and datetime data types, the +C<SQL_DATA_TYPE> field will return C<SQL_INTERVAL> or C<SQL_DATETIME>, and the +C<SQL_DATETIME_SUB> 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<SQL_DATA_TYPE> +field above is C<SQL_INTERVAL> or C<SQL_DATETIME>, this field will +hold the I<subcode> for the specific interval or datetime data type. +Otherwise it will be NULL (C<undef>). + +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<NUM_PREC_RADIX> +contains the value 2 and C<COLUMN_SIZE> holds the number of bits. For +exact numeric types, C<NUM_PREC_RADIX> contains the value 10 and C<COLUMN_SIZE> holds +the number of decimal digits. NULL (C<undef>) 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<SQL_SMALLINT>, C<SQL_INTEGER>, C<SQL_DECIMAL>, etc. + +See also L</"Standards Reference Information">. + + +=head3 C<quote> + + $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<NULL> (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</type_info>. +As a special case, the standard numeric types are optimized to return +C<$value> without calling C<type_info>. + +Quote will probably I<not> 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<not> be used with L</"Placeholders and +Bind Values">. + +=head3 C<quote_identifier> + + $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</get_info> +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<take_imp_data> + + $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<DESTROY> +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<DBI::Pool>. + +The returned $imp_data can be passed as a C<dbi_imp_data> 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<take_imp_data> 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<AutoCommit> + +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<commit> or C<rollback> +methods. + +Drivers should always default to C<AutoCommit> mode (an unfortunate +choice largely forced on the DBI by ODBC and JDBC conventions.) + +Attempting to set C<AutoCommit> 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<gt>{AutoCommit} = 0> (or +set C<AutoCommit> to 0 via L</connect>) +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<AutoCommit> off is a fatal error. +C<commit> and C<rollback> both issue warnings about being ineffective while +C<AutoCommit> 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<AutoCommit> is off, then changes to the database won't have any +lasting effect unless L</commit> is called (but see also +L</disconnect>). If L</rollback> is called then any changes since the +last commit are undone. + +If C<AutoCommit> is on, then the effect is the same as if the DBI +called C<commit> automatically after every successful database +operation. So calling C<commit> or C<rollback> explicitly while +C<AutoCommit> is on would be ineffective because the changes would +have already been committed. + +Changing C<AutoCommit> from off to on will trigger a L</commit>. + +For databases which don't support a specific auto-commit mode, the +driver has to commit each statement automatically using an explicit +C<COMMIT> after it completes successfully (and roll it back using an +explicit C<ROLLBACK> 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<AutoCommit> is turned off, or after a L</commit> or +L</rollback> (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</commit>, L</disconnect> and L</Transactions> for other important +notes about transactions. + + +=head3 C<Driver> + +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<Name> + +Type: string + +Holds the "name" of the database. Usually (and recommended to be) the +same as the "C<dbi:DriverName:...>" string used to connect to the database, +but with the leading "C<dbi:DriverName:>" removed. + + +=head3 C<Statement> + +Type: string, read-only + +Returns the statement string passed to the most recent L</prepare> or +L</do> method called in this database handle, even if that method +failed. This is especially useful where C<RaiseError> is enabled and +the exception handler checks $@ and sees that a 'prepare' method call +failed. + + +=head3 C<RowCacheSize> + +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<SELECT> statements. +If a row cache is not implemented, then setting C<RowCacheSize> is ignored +and getting the value returns C<undef>. + +Some C<RowCacheSize> values have special meaning, as follows: + + 0 - Automatically determine a reasonable cache size for each C<SELECT> + 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<SELECT>. + +Note that large cache sizes may require a very large amount of memory +(I<cached rows * maximum size of row>). Also, a large cache will cause +a longer delay not only for the first fetch, but also whenever the +cache needs refilling. + +See also the L</RowsInCache> statement handle attribute. + +=head3 C<Username> + +Type: string + +Returns the username used to connect to the database. + + +=head1 DBI STATEMENT HANDLE OBJECTS + +This section lists the methods and attributes associated with DBI +statement handles. + +=head2 Statement Handle Methods + +The DBI defines the following methods for use on DBI statement handles: + +=head3 C<bind_param> + + $sth->bind_param($p_num, $bind_value) + $sth->bind_param($p_num, $bind_value, \%attr) + $sth->bind_param($p_num, $bind_value, $bind_type) + +The C<bind_param> method takes a copy of $bind_value and associates it +(binds it) with a placeholder, identified by $p_num, embedded in +the prepared statement. Placeholders are indicated with question +mark character (C<?>). For example: + + $dbh->{RaiseError} = 1; # save having to check each method call + $sth = $dbh->prepare("SELECT name, age FROM people WHERE name LIKE ?"); + $sth->bind_param(1, "John%"); # placeholders are numbered from 1 + $sth->execute; + DBI::dump_results($sth); + +See L</"Placeholders and Bind Values"> for more information. + + +B<Data Types for Placeholders> + +The C<\%attr> parameter can be used to hint at the data type the +placeholder should have. This is rarely needed. Typically, the driver is only +interested in knowing if the placeholder should be bound as a number or a string. + + $sth->bind_param(1, $value, { TYPE => SQL_INTEGER }); + +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_param(1, $value, SQL_INTEGER); + +The C<TYPE> 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<gt> 97 }>. + +The SQL_INTEGER and other related constants can be imported using + + use DBI qw(:sql_types); + +See L</"DBI Constants"> for more information. + +The data type is 'sticky' in that bind values passed to execute() are bound +with the data type specified by earlier bind_param() calls, if any. +Portable applications should not rely on being able to change the data type +after the first C<bind_param> call. + +Perl only has string and number scalar data types. All database types +that aren't numbers are bound as strings and must be in a format the +database will understand except where the bind_param() TYPE attribute +specifies a type that implies a particular format. For example, given: + + $sth->bind_param(1, $value, SQL_DATETIME); + +the driver should expect $value to be in the ODBC standard SQL_DATETIME +format, which is 'YYYY-MM-DD HH:MM:SS'. Similarly for SQL_DATE, SQL_TIME etc. + +As an alternative to specifying the data type in the C<bind_param> call, +you can let the driver pass the value as the default type (C<VARCHAR>). +You can then use an SQL function to convert the type within the statement. +For example: + + INSERT INTO price(code, price) VALUES (?, CONVERT(MONEY,?)) + +The C<CONVERT> function used here is just an example. The actual function +and syntax will vary between different databases and is non-portable. + +See also L</"Placeholders and Bind Values"> for more information. + + +=head3 C<bind_param_inout> + + $rc = $sth->bind_param_inout($p_num, \$bind_value, $max_len) or die $sth->errstr; + $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, \%attr) or ... + $rv = $sth->bind_param_inout($p_num, \$bind_value, $max_len, $bind_type) or ... + +This method acts like L</bind_param>, but also enables values to be +updated by the statement. The statement is typically +a call to a stored procedure. The C<$bind_value> must be passed as a +reference to the actual value to be used. + +Note that unlike L</bind_param>, the C<$bind_value> variable is not +copied when C<bind_param_inout> is called. Instead, the value in the +variable is read at the time L</execute> is called. + +The additional C<$max_len> parameter specifies the minimum amount of +memory to allocate to C<$bind_value> for the new value. If the value +returned from the database is too +big to fit, then the execution should fail. If unsure what value to use, +pick a generous length, i.e., a length larger than the longest value that would ever be +returned. The only cost of using a larger value than needed is wasted memory. + +Undefined values or C<undef> are used to indicate null values. +See also L</"Placeholders and Bind Values"> for more information. + + +=head3 C<bind_param_array> + + $rc = $sth->bind_param_array($p_num, $array_ref_or_value) + $rc = $sth->bind_param_array($p_num, $array_ref_or_value, \%attr) + $rc = $sth->bind_param_array($p_num, $array_ref_or_value, $bind_type) + +The C<bind_param_array> method is used to bind an array of values +to a placeholder embedded in the prepared statement which is to be executed +with L</execute_array>. For example: + + $dbh->{RaiseError} = 1; # save having to check each method call + $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name, dept) VALUES(?, ?, ?)"); + $sth->bind_param_array(1, [ 'John', 'Mary', 'Tim' ]); + $sth->bind_param_array(2, [ 'Booth', 'Todd', 'Robinson' ]); + $sth->bind_param_array(3, "SALES"); # scalar will be reused for each row + $sth->execute_array( { ArrayTupleStatus => \my @tuple_status } ); + +The C<%attr> ($bind_type) argument is the same as defined for L</bind_param>. +Refer to L</bind_param> for general details on using placeholders. + +(Note that bind_param_array() can I<not> be used to expand a +placeholder into a list of values for a statement like "SELECT foo +WHERE bar IN (?)". A placeholder can only ever represent one value +per execution.) + +Scalar values, including C<undef>, may also be bound by +C<bind_param_array>. In which case the same value will be used for each +L</execute> call. Driver-specific implementations may behave +differently, e.g., when binding to a stored procedure call, some +databases may permit mixing scalars and arrays as arguments. + +The default implementation provided by DBI (for drivers that have +not implemented array binding) is to iteratively call L</execute> for +each parameter tuple provided in the bound arrays. Drivers may +provide more optimized implementations using whatever bulk operation +support the database API provides. The default driver behaviour should +match the default DBI behaviour, but always consult your driver +documentation as there may be driver specific issues to consider. + +Note that the default implementation currently only supports non-data +returning statements (INSERT, UPDATE, but not SELECT). Also, +C<bind_param_array> and L</bind_param> cannot be mixed in the same +statement execution, and C<bind_param_array> must be used with +L</execute_array>; using C<bind_param_array> will have no effect +for L</execute>. + +The C<bind_param_array> method was added in DBI 1.22. + +=head3 C<execute> + + $rv = $sth->execute or die $sth->errstr; + $rv = $sth->execute(@bind_values) or die $sth->errstr; + +Perform whatever processing is necessary to execute the prepared +statement. An C<undef> is returned if an error occurs. A successful +C<execute> always returns true regardless of the number of rows affected, +even if it's zero (see below). It is always important to check the +return status of C<execute> (and most other DBI methods) for errors +if you're not using L</RaiseError>. + +For a I<non>-C<SELECT> statement, C<execute> returns the number of rows +affected, if known. If no rows were affected, then C<execute> returns +"C<0E0>", which Perl will treat as 0 but will regard as true. Note that it +is I<not> an error for no rows to be affected by a statement. If the +number of rows affected is not known, then C<execute> returns -1. + +For C<SELECT> statements, execute simply "starts" the query within the +database engine. Use one of the fetch methods to retrieve the data after +calling C<execute>. The C<execute> method does I<not> return the number of +rows that will be returned by the query (because most databases can't +tell in advance), it simply returns a true value. + +You can tell if the statement was a C<SELECT> statement by checking if +C<$sth-E<gt>{NUM_OF_FIELDS}> is greater than zero after calling C<execute>. + +If any arguments are given, then C<execute> will effectively call +L</bind_param> for each value before executing the statement. Values +bound in this way are usually treated as C<SQL_VARCHAR> types unless +the driver can determine the correct type (which is rare), or unless +C<bind_param> (or C<bind_param_inout>) has already been used to +specify the type. + +Note that passing C<execute> 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<execute_array> + + $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</bind_param_array>, or via a reference passed in \%attr. + +When called in scalar context the execute_array() method returns the +number of tuples executed, or C<undef> 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<ArrayTupleFetch> attribute, or else column-wise in the +C<@bind_values> argument, or else column-wise by prior calls to +L</bind_param_array>. + +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<variable> 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<all> bound values are scalars then one tuple +will be executed, making execute_array() act just like execute(). + +The C<ArrayTupleFetch> 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<ArrayTupleFetch> 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<execute_array> will effectively call L</bind_param_array> +for each value before executing the statement. Values bound in +this way are usually treated as C<SQL_VARCHAR> types unless the +driver can determine the correct type (which is rare), or unless +C<bind_param>, C<bind_param_inout>, C<bind_param_array>, or +C<bind_param_inout_array> has already been used to specify the type. +See L</bind_param_array> for details. + +The C<ArrayTupleStatus> 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<ArrayTupleStatus> 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</err>, L</errstr> and L</state> set by the failed execution. + +If B<any> tuple execution returns an error, C<execute_array> will +return C<undef>. 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<execute_array> +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<AutoCommit> 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<AutoCommit> +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<AutoCommit> turned off, and using explicit C<commit> after each +C<execute_array> call. + +The C<execute_array> method was added in DBI 1.22, and ArrayTupleFetch +was added in 1.36. + +=head3 C<execute_for_fetch> + + $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<undef> 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<execute_for_fetch> method was added in DBI 1.38. + + +=head3 C<fetchrow_arrayref> + + $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<undef> +values in the array. +This is the fastest way to fetch data, particularly if used with +C<$sth-E<gt>bind_columns>. + +If there are no more rows or if an error occurs, then C<fetchrow_arrayref> +returns an C<undef>. You should check C<$sth-E<gt>err> afterwards (or use the +C<RaiseError> attribute) to discover if the C<undef> 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</bind_columns>. + +=head3 C<fetchrow_array> + + @ary = $sth->fetchrow_array; + +An alternative to C<fetchrow_arrayref>. Fetches the next row of data +and returns it as a list containing the field values. Null fields +are returned as C<undef> values in the list. + +If there are no more rows or if an error occurs, then C<fetchrow_array> +returns an empty list. You should check C<$sth-E<gt>err> afterwards (or use +the C<RaiseError> 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<undef> is returned if there are no +more rows or if an error occurred. That C<undef> can't be distinguished +from an C<undef> returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C<fetchrow_array> in a scalar context. + +=head3 C<fetchrow_hashref> + + $hash_ref = $sth->fetchrow_hashref; + $hash_ref = $sth->fetchrow_hashref($name); + +An alternative to C<fetchrow_arrayref>. 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<undef> values in the hash. + +If there are no more rows or if an error occurs, then C<fetchrow_hashref> +returns an C<undef>. You should check C<$sth-E<gt>err> afterwards (or use the +C<RaiseError> attribute) to discover if the C<undef> 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<NAME>", however using +either "C<NAME_lc>" or "C<NAME_uc>" is recommended for portability. + +The keys of the hash are the same names returned by C<$sth-E<gt>{$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<select foo, foo from bar>" +will return only a single key from C<fetchrow_hashref>. In these cases use +column aliases or C<fetchrow_arrayref>. Note that it is the database server +(and not the DBD implementation) which provides the I<name> for fields +containing functions like "C<count(*)>" or "C<max(c_foo)>" and they may clash +with existing column names (most databases don't care about duplicate column +names in a result-set). If you want these to return as unique names that are +the same across databases, use I<aliases>, as in "C<select count(*) as cnt>" +or "C<select max(c_foo) mx_foo, ...>" depending on the syntax your database +supports. + +Because of the extra work C<fetchrow_hashref> and Perl have to perform, it +is not as efficient as C<fetchrow_arrayref> or C<fetchrow_array>. + +By default a reference to a new hash is returned for each row. +It is likely that a future version of the DBI will support an +attribute which will enable the same hash to be reused for each +row. This will give a significant performance boost, but it won't +be enabled by default because of the risk of breaking old code. + + +=head3 C<fetchall_arrayref> + + $tbl_ary_ref = $sth->fetchall_arrayref; + $tbl_ary_ref = $sth->fetchall_arrayref( $slice ); + $tbl_ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); + +The C<fetchall_arrayref> method can be used to fetch all the data to be +returned from a prepared and executed statement handle. It returns a +reference to an array that contains one reference per row. + +If called on an I<inactive> statement handle, C<fetchall_arrayref> returns undef. + +If there are no rows left to return from an I<active> statement handle, C<fetchall_arrayref> returns a reference +to an empty array. If an error occurs, C<fetchall_arrayref> returns the +data fetched thus far, which may be none. You should check C<$sth-E<gt>err> +afterwards (or use the C<RaiseError> attribute) to discover if the data is +complete or was truncated due to an error. + +If $slice is an array reference, C<fetchall_arrayref> uses L</fetchrow_arrayref> +to fetch each row as an array ref. If the $slice array is not empty +then it is used as a slice to select individual columns by perl array +index number (starting at 0, unlike column and parameter numbers which +start at 1). + +With no parameters, or if $slice is undefined, C<fetchall_arrayref> +acts as if passed an empty array ref. + +For example, to fetch just the first column of every row: + + $tbl_ary_ref = $sth->fetchall_arrayref([0]); + +To fetch the second to last and last column of every row: + + $tbl_ary_ref = $sth->fetchall_arrayref([-2,-1]); + +Those two examples both return a reference to an array of array refs. + +If $slice is a hash reference, C<fetchall_arrayref> fetches each row as a hash +reference. If the $slice hash is empty then the keys in the hashes have +whatever name lettercase is returned by default. (See L</FetchHashKeyName> +attribute.) If the $slice hash is I<not> empty, then it is used as a slice to +select individual columns by name. The values of the hash should be set to 1. +The key names of the returned hashes match the letter case of the names in the +parameter hash, regardless of the L</FetchHashKeyName> attribute. + +For example, to fetch all fields of every row as a hash ref: + + $tbl_ary_ref = $sth->fetchall_arrayref({}); + +To fetch only the fields called "foo" and "bar" of every row as a hash ref +(with keys named "foo" and "BAR", regardless of the original capitalization): + + $tbl_ary_ref = $sth->fetchall_arrayref({ foo=>1, BAR=>1 }); + +Those two examples both return a reference to an array of hash refs. + +If $slice is a I<reference to a hash reference>, that hash is used to select +and rename columns. The keys are 0-based column index numbers and the values +are the corresponding keys for the returned row hashes. + +For example, to fetch only the first and second columns of every row as a hash +ref (with keys named "k" and "v" regardless of their original names): + + $tbl_ary_ref = $sth->fetchall_arrayref( \{ 0 => 'k', 1 => 'v' } ); + +If $max_rows is defined and greater than or equal to zero then it +is used to limit the number of rows fetched before returning. +fetchall_arrayref() can then be called again to fetch more rows. +This is especially useful when you need the better performance of +fetchall_arrayref() but don't have enough memory to fetch and return +all the rows in one go. + +Here's an example (assumes RaiseError is enabled): + + my $rows = []; # cache for batches of rows + while( my $row = ( shift(@$rows) || # get row from cache, or reload cache: + shift(@{$rows=$sth->fetchall_arrayref(undef,10_000)||[]}) ) + ) { + ... + } + +That I<might> be the fastest way to fetch and process lots of rows using the DBI, +but it depends on the relative cost of method calls vs memory allocation. + +A standard C<while> loop with column binding is often faster because +the cost of allocating memory for the batch of rows is greater than +the saving by reducing method calls. It's possible that the DBI may +provide a way to reuse the memory of a previous batch in future, which +would then shift the balance back towards fetchall_arrayref(). + + +=head3 C<fetchall_hashref> + + $hash_ref = $sth->fetchall_hashref($key_field); + +The C<fetchall_hashref> method can be used to fetch all the data to be +returned from a prepared and executed statement handle. It returns a reference +to a hash containing a key for each distinct value of the $key_field column +that was fetched. For each key the corresponding value is a reference to a hash +containing all the selected columns and their values, as returned by +C<fetchrow_hashref()>. + +If there are no rows to return, C<fetchall_hashref> returns a reference +to an empty hash. If an error occurs, C<fetchall_hashref> returns the +data fetched thus far, which may be none. You should check +C<$sth-E<gt>err> afterwards (or use the C<RaiseError> attribute) to +discover if the data is complete or was truncated due to an error. + +The $key_field parameter provides the name of the field that holds the +value to be used for the key for the returned hash. For example: + + $dbh->{FetchHashKeyName} = 'NAME_lc'; + $sth = $dbh->prepare("SELECT FOO, BAR, ID, NAME, BAZ FROM TABLE"); + $sth->execute; + $hash_ref = $sth->fetchall_hashref('id'); + print "Name for id 42 is $hash_ref->{42}->{name}\n"; + +The $key_field parameter can also be specified as an integer column +number (counting from 1). If $key_field doesn't match any column in +the statement, as a name first then as a number, then an error is +returned. + +For queries returning more than one 'key' column, you can specify +multiple column names by passing $key_field as a reference to an +array containing one or more key column names (or index numbers). +For example: + + $sth = $dbh->prepare("SELECT foo, bar, baz FROM table"); + $sth->execute; + $hash_ref = $sth->fetchall_hashref( [ qw(foo bar) ] ); + print "For foo 42 and bar 38, baz is $hash_ref->{42}->{38}->{baz}\n"; + +The fetchall_hashref() method is normally used only where the key +fields values for each row are unique. If multiple rows are returned +with the same values for the key fields then later rows overwrite +earlier ones. + +=head3 C<finish> + + $rc = $sth->finish; + +Indicate that no more data will be fetched from this statement handle +before it is either executed again or destroyed. You almost certainly +do I<not> need to call this method. + +Adding calls to C<finish> after loop that fetches all rows is a common mistake, +don't do it, it can mask genuine problems like uncaught fetch errors. + +When all the data has been fetched from a C<SELECT> statement, the driver will +automatically call C<finish> for you. So you should I<not> call it explicitly +I<except> when you know that you've not fetched all the data from a statement +handle I<and> 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<selectrow_*> 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<finish> method can be used to tell +the server that the buffer space can be freed. + +Calling C<finish> resets the L</Active> attribute for the statement. It +may also make some statement handle attributes (such as C<NAME> and C<TYPE>) +unavailable if they have not already been accessed (and thus cached). + +The C<finish> 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</disconnect> and the L</Active> attribute. + +The C<finish> method should have been called C<discard_pending_rows>. + + +=head3 C<rows> + + $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<non>-C<SELECT> +C<execute> (for some specific operations like C<UPDATE> and C<DELETE>), or +after fetching all the rows of a C<SELECT> statement. + +For C<SELECT> statements, it is generally not possible to know how many +rows will be returned except by fetching them all. Some drivers will +return the number of rows the application has fetched so far, but +others may return -1 until all rows have been fetched. So use of the +C<rows> method or C<$DBI::rows> with C<SELECT> statements is not +recommended. + +One alternative method to get a row count for a C<SELECT> is to execute a +"SELECT COUNT(*) FROM ..." SQL statement with the same "..." as your +query and then fetch the row count from that. + + +=head3 C<bind_col> + + $rc = $sth->bind_col($column_number, \$var_to_bind); + $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr ); + $rc = $sth->bind_col($column_number, \$var_to_bind, $bind_type ); + +Binds a Perl variable and/or some attributes to an output column +(field) of a C<SELECT> 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</bind_columns> for an example. + +The binding is performed at a low level using Perl aliasing. +Whenever a row is fetched from the database $var_to_bind appears +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</bind_param> method +performs a similar, but opposite, function for input variables. + +B<Data Types for Column Binding> + +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<TYPE> 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<gt> 97 }>. + +The SQL_DATETIME and other related constants can be imported using + + use DBI qw(:sql_types); + +See L</"DBI Constants"> for more information. + +Few drivers support specifying a data type via a C<bind_col> 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<TYPE> attribute to attempt to +cast the bound scalar to a perl type which more closely matches +C<TYPE>. At present DBI supports C<SQL_INTEGER>, C<SQL_DOUBLE> and +C<SQL_NUMERIC>. See L</sql_type_cast> for details of how types are +cast. + +B<Other attributes for Column Binding> + +The C<\%attr> parameter may also contain the following attributes: + +=over + +=item C<StrictlyTyped> + +If a C<TYPE> 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<TYPE> +then by default it is left untouched and no error is generated. If you +specify C<StrictlyTyped> 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<DiscardString> + +When the C<TYPE> attribute is passed to L</bind_col> and the driver +successfully casts the bound perl scalar to a non-string type +then if C<DiscardString> is set to 1, the string portion of the +scalar will be discarded. By default, C<DiscardString> 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<bind_columns> + + $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); + +Calls L</bind_col> for each column of the C<SELECT> statement. + +The list of references should have the same number of elements as the number of +columns in the C<SELECT> statement. If it doesn't then C<bind_columns> 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<undef> or a hash reference. + +Here's a more fancy example that binds columns to the values I<inside> +a hash (thanks to H.Merijn Brand): + + $sth->execute; + my %row; + $sth->bind_columns( \( @row{ @{$sth->{NAME_lc} } } )); + while ($sth->fetch) { + print "$row{region}: $row{sales}\n"; + } + + +=head3 C<dump_results> + + $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); + +Fetches all the rows from C<$sth>, calls C<DBI::neat_list> for each row, and +prints the results to C<$fh> (defaults to C<STDOUT>) separated by C<$lsep> +(default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35. + +This method is designed as a handy utility for prototyping and +testing queries. Since it uses L</neat_list> to +format and edit the string for reading by humans, it is not 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-E<gt>execute> has been successfully +called. Typically the attribute will be C<undef> in these situations. + +Some attributes, like NAME, are not appropriate to some types of +statement, like SELECT. Typically the attribute will be C<undef> +in these situations. + +For drivers which support stored procedures and multiple result sets +(see L</more_results>) these attributes relate to the I<current> result set. + +See also L</finish> to learn more about the effect it +may have on some attributes. + +=head3 C<NUM_OF_FIELDS> + +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<DELETE> and C<CREATE> +set C<NUM_OF_FIELDS> to 0 (though it may be undef in some drivers). + + +=head3 C<NUM_OF_PARAMS> + +Type: integer, read-only + +The number of parameters (placeholders) in the prepared statement. +See SUBSTITUTION VARIABLES below for more details. + + +=head3 C<NAME> + +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</NAME_lc> or L</NAME_uc>. + + print "First column name: $sth->{NAME}->[0]\n"; + +Also note that the name returned for (aggregate) functions like C<count(*)> +or C<max(c_foo)> is determined by the database server and not by C<DBI> or +the C<DBD> backend. + +=head3 C<NAME_lc> + +Type: array-ref, read-only + +Like L</NAME> but always returns lowercase names. + +=head3 C<NAME_uc> + +Type: array-ref, read-only + +Like L</NAME> but always returns uppercase names. + +=head3 C<NAME_hash> + +Type: hash-ref, read-only + +=head3 C<NAME_lc_hash> + +Type: hash-ref, read-only + +=head3 C<NAME_uc_hash> + +Type: hash-ref, read-only + +The C<NAME_hash>, C<NAME_lc_hash>, and C<NAME_uc_hash> 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<NAME>, +C<NAME_lc>, and C<NAME_uc> 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> + +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<TYPE> should have at least one entry in the +output of the C<type_info_all> method (see L</type_info_all>). + +=head3 C<PRECISION> + +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<SCALE> + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each column. +NULL (C<undef>) values indicate columns where scale is not applicable. + +=head3 C<NULLABLE> + +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<CursorName> + +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<undef>. + + +=head3 C<Database> + +Type: dbh, read-only + +Returns the parent $dbh of the statement handle. + + +=head3 C<Statement> + +Type: string, read-only + +Returns the statement string passed to the L</prepare> method. + + +=head3 C<ParamValues> + +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</ShowErrorStatement> for an example of how this is used. + +* Keys: + +If the driver supports C<ParamValues> 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<ParamValues> +are not exactly the same as those implied by the prepared statement. +For example, DBD::Oracle translates 'C<?>' placeholders into 'C<:pN>' +where N is a sequence number starting at 1. + +* Values: + +It is possible that the values in the hash returned by C<ParamValues> +are not I<exactly> 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<ParamValues> 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</ParamTypes> below. + +The C<ParamValues> attribute was added in DBI 1.28. + +=head3 C<ParamTypes> + +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</ParamValues> 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</bind_param> for the format +and values). + +It is possible that the values in the hash returned by C<ParamTypes> +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<ParamTypes> attribute was added in DBI 1.49. Implementation +is the responsibility of individual drivers; the DBI layer default +implementation simply returns undef. + + +=head3 C<ParamArrays> + +Type: hash ref, read-only + +Returns a reference to a hash containing the values currently bound to +placeholders with L</execute_array> or L</bind_param_array>. 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<ParamArrays> +are not I<exactly> the same as those passed to L</bind_param_array> or +L</execute_array>. 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<ParamArrays> 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<RowsInCache> + +Type: integer, read-only + +If the driver supports a local row cache for C<SELECT> statements, then +this attribute holds the number of un-fetched rows in the cache. If the +driver doesn't, then it returns C<undef>. Note that some drivers pre-fetch +rows on execute, whereas others wait till the first fetch. + +See also the L</RowCacheSize> database handle attribute. + +=head1 FURTHER INFORMATION + +=head2 Catalog Methods + +An application can retrieve metadata information from the DBMS by issuing +appropriate queries on the views of the Information Schema. Unfortunately, +C<INFORMATION_SCHEMA> views are seldom supported by the DBMS. +Special methods (catalog methods) are available to return result sets +for a small but important portion of that metadata: + + column_info + foreign_key_info + primary_key_info + table_info + statistics_info + +All catalog methods accept arguments in order to restrict the result sets. +Passing C<undef> to an optional argument does not constrain the search for +that argument. +However, an empty string ('') is treated as a regular search criteria +and will only match an empty value. + +B<Note>: SQL/CLI and ODBC differ in the handling of empty strings. An +empty string will not restrict the result set in SQL/CLI. + +Most arguments in the catalog methods accept only I<ordinary values>, e.g. +the arguments of C<primary_key_info()>. +Such arguments are treated as a literal string, i.e. the case is significant +and quote characters are taken literally. + +Some arguments in the catalog methods accept I<search patterns> (strings +containing '_' and/or '%'), e.g. the C<$table> argument of C<column_info()>. +Passing '%' is equivalent to leaving the argument C<undef>. + +B<Caveat>: The underscore ('_') is valid and often used in SQL identifiers. +Passing such a value to a search pattern argument may return more rows than +expected! +To include pattern characters as literals, they must be preceded by an +escape character which can be achieved with + + $esc = $dbh->get_info( 14 ); # SQL_SEARCH_PATTERN_ESCAPE + $search_pattern =~ s/([_%])/$esc$1/g; + +The ODBC and SQL/CLI specifications define a way to change the default +behaviour described above: All arguments (except I<list value arguments>) +are treated as I<identifier> if the C<SQL_ATTR_METADATA_ID> attribute is +set to C<SQL_TRUE>. +I<Quoted identifiers> are very similar to I<ordinary values>, i.e. their +body (the string within the quotes) is interpreted literally. +I<Unquoted identifiers> are compared in UPPERCASE. + +The DBI (currently) does not support the C<SQL_ATTR_METADATA_ID> attribute, +i.e. it behaves like an ODBC driver where C<SQL_ATTR_METADATA_ID> is set to +C<SQL_FALSE>. + + +=head2 Transactions + +Transactions are a fundamental part of any robust database system. They +protect against errors and database corruption by ensuring that sets of +related changes to the database take place in atomic (indivisible, +all-or-nothing) units. + +This section applies to databases that support transactions and where +C<AutoCommit> is off. See L</AutoCommit> for details of using C<AutoCommit> +with various types of databases. + +The recommended way to implement robust transactions in Perl +applications is to use C<RaiseError> and S<C<eval { ... }>> +(which is very fast, unlike S<C<eval "...">>). For example: + + $dbh->{AutoCommit} = 0; # enable transactions, if possible + $dbh->{RaiseError} = 1; + eval { + foo(...) # do lots of work here + bar(...) # including inserts + baz(...) # and updates + $dbh->commit; # commit the changes if we get this far + }; + if ($@) { + warn "Transaction aborted because $@"; + # now rollback to undo the incomplete changes + # but do it in an eval{} as it may also fail + eval { $dbh->rollback }; + # add other application on-error-clean-up code here + } + +If the C<RaiseError> attribute is not set, then DBI calls would need to be +manually checked for errors, typically like this: + + $h->method(@args) or die $h->errstr; + +With C<RaiseError> set, the DBI will automatically C<die> if any DBI method +call on that handle (or a child handle) fails, so you don't have to +test the return value of each method call. See L</RaiseError> for more +details. + +A major advantage of the C<eval> approach is that the transaction will be +properly rolled back if I<any> code (not just DBI calls) in the inner +application dies for any reason. The major advantage of using the +C<$h-E<gt>{RaiseError}> attribute is that all DBI calls will be checked +automatically. Both techniques are strongly recommended. + +After calling C<commit> or C<rollback> many drivers will not let you +fetch from a previously active C<SELECT> 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<SELECT> statements. + +See L</AutoCommit> and L</disconnect> for other important information +about transactions. + + +=head2 Handling BLOB / LONG / Memo Fields + +Many databases support "blob" (binary large objects), "long", or similar +datatypes for holding very long strings or large amounts of binary +data in a single field. Some databases support variable length long +values over 2,000,000,000 bytes in length. + +Since values of that size can't usually be held in memory, and because +databases can't usually know in advance the length of the longest long +that will be returned from a C<SELECT> statement (unlike other data +types), some special handling is required. + +In this situation, the value of the C<$h-E<gt>{LongReadLen}> +attribute is used to determine how much buffer space to allocate +when fetching such fields. The C<$h-E<gt>{LongTruncOk}> attribute +is used to determine how to behave if a fetched value can't fit +into the buffer. + +See the description of L</LongReadLen> 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<INSERT> +statement and the L</quote> method generally can't cope with binary +data. See L</Placeholders and Bind Values>. + + +=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<RaiseError> 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, "<phone.csv" or die "Unable to open phone.csv: $!"; + while (<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<q{...}> style quoting used in these examples avoids clashing with +quotes that may be used in the SQL statement. Use the double-quote like +C<qq{...}> operator if you want to interpolate variables into the string. +See L<perlop/"Quote and Quote-like Operators"> 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<not> 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<http://www.perlmonks.org/index.pl?node_id=288022> + +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<not> 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<not> 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<alarm()> and C<$SIG{ALRM}>. + +=over 4 + +=item Cancel + +The DBI provides a C<cancel> method for statement handles. The +C<cancel> 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<undef>) 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<cancel> returns true, then it has successfully +invoked the database engine's own cancel function. If it returns false, +then C<cancel> failed. If it returns C<undef>, 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<POSIX::sigaction()> +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<not> work with +perl versions less than perl 5.8 where C<POSIX::sigaction()> appears to be broken. + +For a cleaner implementation that works across perl versions, see Lincoln Baxter's +Sys::SigAction module at L<http://search.cpan.org/~lbaxter/Sys-SigAction/>. +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<perlipc> 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<unsafe> 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-E<gt>connect(...)> returns a $dbh blessed +into the C<DBI::db> class. And the C<$dbh-E<gt>prepare> method +returns an $sth blessed into the C<DBI::st> class (actually it +simply changes the last four characters of the calling handle class +to be C<::st>). + +The leading 'C<DBI>' 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<MySubDBI> and override the do(), prepare() and execute() methods, +then your do() and prepare() methods should be in the C<MySubDBI::db> +class and the execute() method should be in the C<MySubDBI::st> class. + +To setup the inheritance hierarchy the @ISA variable in C<MySubDBI::db> +should include C<DBI::db> and the @ISA variable in C<MySubDBI::st> +should include C<DBI::st>. The C<MySubDBI> root class itself isn't +currently used for anything visible and so, apart from setting @ISA +to include C<DBI>, 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<RootClass> 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<t/subclass.t> 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-E<gt>err> 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<RaiseError>, C<PrintError>, or C<HandleError> +etc. set then the set_err() method will honour them. This means +that if C<RaiseError> is set then set_err() won't return in the +normal way but will 'throw an exception' that can be caught with +an C<eval> block. + +You can stash private data into DBI handles +via C<$h-E<gt>{private_..._*}>. See the entry under L</ATTRIBUTES +COMMON TO ALL HANDLES> for info and important caveats. + + +=head1 TRACING + +The DBI has a powerful tracing mechanism built in. It enables you +to see what's going on 'behind the scenes', both within the DBI and +the drivers you're using. + +=head2 Trace Settings + +Which details are written to the trace output is controlled by a +combination of a I<trace level>, an integer from 0 to 15, and a set +of I<trace flags> that are either on or off. Together these are known +as the I<trace settings> and are stored together in a single integer. +For normal use you only need to set the trace level, and generally +only to a value between 1 and 4. + +Each handle has it's own trace settings, and so does the DBI. +When you call a method the DBI merges the handles settings into its +own for the duration of the call: the trace flags of the handle are +OR'd into the trace flags of the DBI, and if the handle has a higher +trace level then the DBI trace level is raised to match it. +The previous DBI trace settings are restored when the called method +returns. + +=head2 Trace Levels + +Trace I<levels> 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</neat> function, so strings +in the trace output may be edited and truncated by that function. + +=head2 Trace Flags + +Trace I<flags> are used to enable tracing of specific activities +within the DBI and drivers. The DBI defines some trace flags and +drivers can define others. DBI trace flag names begin with a capital +letter and driver specific names begin with a lowercase letter, as +usual. + +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</parse_trace_flags> and L</parse_trace_flag> methods are used +to convert trace flag names into the corresponding integer bit flags. + +=head2 Enabling Trace + +The C<$h-E<gt>trace> method sets the trace settings for a handle +and C<DBI-E<gt>trace> does the same for the DBI. + +In addition to the L</trace> method, you can enable the same trace +information, and direct the output to a file, by setting the +C<DBI_TRACE> environment variable before starting Perl. +See L</DBI_TRACE> for more information. + +Finally, you can set, or get, the trace settings for a handle using +the C<TraceLevel> attribute. + +All of those methods use parse_trace_flags() and so allow you set +both the trace level and multiple trace flags by using a string +containing the trace level and/or flag names separated by vertical +bar ("C<|>") or comma ("C<,>") characters. For example: + + local $h->{TraceLevel} = "3|SQL|foo"; + +=head2 Trace Output + +Initially trace output is written to C<STDERR>. Both the +C<$h-E<gt>trace> and C<DBI-E<gt>trace> methods take an optional +$trace_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<all> 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<STDERR> 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<not> closed. + +B<NOTE>: 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<trace()> that changes the trace file. + +=head2 Tracing to Layered Filehandles + +B<NOTE>: + +=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<PerlIO> 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 (I<Refer to >L<Perlio::via> I<for details +on creating custom PerlIO layers.>). 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</neat> for more details. + +=head2 Tracing Tips + +You can add tracing to your own application code using the L</trace_msg> method. + +It can sometimes be handy to compare trace files from two different runs of the +same script. However using a tool like C<diff> 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<dbilogstrip> 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<DBI_TRACE> 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</TRACING> 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<DBI::Profile> for more information. + +=head2 DBI_PUREPERL + +The DBI_PUREPERL environment variable can be used to enable the +use of DBI::PurePerl. See L<DBI::PurePerl> 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<prepare> is probably undefined because +the preceding C<connect> failed. You should always check the return status of +DBI methods, or use the L</RaiseError> attribute. + +=item Can't call method "execute" without a package or object reference + +The C<$sth> handle you're using to call C<execute> is probably undefined because +the preceding C<prepare> failed. You should always check the return status of +DBI methods, or use the L</RaiseError> 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<DBI::PurePerl>. + +=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<http://books.perl.org/book/154> + +Programming Perl 3rd Ed. by Larry Wall, Tom Christiansen & Jon Orwant. +L<http://books.perl.org/book/134> + +Learning Perl by Randal Schwartz. +L<http://books.perl.org/book/101> + +Details of many other books related to perl can be found at L<http://books.perl.org> + +=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<dbi-users> 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<http://faq.dbi-support.com/> + +=head1 AUTHORS + +DBI by Tim Bunce, L<http://www.tim.bunce.name> + +This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others. +Perl by Larry Wall and the C<perl5-porters>. + +=head1 COPYRIGHT + +The DBI module is Copyright (c) 1994-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<http://search.cpan.org/~timb/DBI/Roadmap.pod> + +If your company would benefit from a specific new DBI feature, +please consider sponsoring its development. Work is performed +rapidly, and usually on a fixed-price payment-on-delivery basis. +Contact me for details. + +Using such targeted financing allows you to contribute to DBI +development, and rapidly get something specific and valuable in return. + +=head1 ACKNOWLEDGEMENTS + +I would like to acknowledge the valuable contributions of the many +people I have worked with on the DBI project, especially in the early +years (1992-1994). In no particular order: Kevin Stock, Buzz Moschetti, +Kurt Andersen, Ted Lemon, William Hails, Garth Kennedy, Michael Peppler, +Neil S. Briscoe, Jeff Urlwin, David J. Hughes, Jeff Stander, +Forrest D Whitcher, Larry Wall, Jeff Fried, Roy Johnson, Paul Hudson, +Georg Rehfeld, Steve Sizemore, Ron Pool, Jon Meek, Tom Christiansen, +Steve Baumgarten, Randal Schwartz, and a whole lot more. + +Then, of course, there are the poor souls who have struggled through +untold and undocumented obstacles to actually implement DBI drivers. +Among their ranks are Jochen Wiedmann, Alligator Descartes, Jonathan +Leffler, Jeff Urlwin, Michael Peppler, Henrik Tougaard, Edwin Pratomo, +Davide Migliavacca, Jan Pazdziora, Peter Haworth, Edmund Mergl, Steve +Williams, Thomas Lowery, and Phlip Plumlee. Without them, the DBI would +not be the practical reality it is today. I'm also especially grateful +to Alligator Descartes for starting work on the first edition of the +"Programming the Perl DBI" book and letting me jump on board. + +The DBI and DBD::Oracle were originally developed while I was Technical +Director (CTO) of Ingeneering in the UK (L<http://www.ig.co.uk>) (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<http://BizRate.com>) + +The development of DBD::Gofer and related modules was sponsored by +Shopzilla.com (L<http://Shopzilla.com>), 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<http://dbi.perl.org/contributing> +and L<http://search.cpan.org/~timb/DBI/Roadmap.pod> + +If you'd like the DBI to do something new or different then a good way +to make that happen is to do it yourself and send me a patch to the +source code that shows the changes. (But read "Speak before you patch" +below.) + +=head2 Browsing the source code repository + +Use http://svn.perl.org/modules/dbi/trunk (basic) +or http://svn.perl.org/viewcvs/modules/ (more useful) + +=head2 How to create a patch using Subversion + +The DBI source code is maintained using Subversion (a replacement +for CVS, see L<http://subversion.tigris.org/>). To access the source +you'll need to install a Subversion client. Then, to get the source +code, do: + + svn checkout http://svn.perl.org/modules/dbi/trunk + +If it prompts for a username and password use your perl.org account +if you have one, else just 'guest' and 'guest'. The source code will +be in a new subdirectory called C<trunk>. + +To keep informed about changes to the source you can send an empty email +to 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<trunk> directory using: + + svn diff > foo.patch + +Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org. + +=head2 How to create a patch without Subversion + +Unpack a fresh copy of the distribution: + + tar xfz DBI-1.40.tar.gz + +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<another> 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<diff> 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<mod_perl>. 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<SQL::Statement> module, SQL parser and engine. + +=back + +=cut + +# LocalWords: DBI @@ -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 <sys/timeb.h> +# 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; i<hv_len; ++i) { + SV **hash_svp = hv_fetch(hash, keys[i], strlen(keys[i]), 0); + + sv_catpv(return_sv, keys[i]); /* XXX keys can't contain nul chars */ + sv_catpvn(return_sv, kv_sep, kv_sep_len); + + if (!hash_svp) { /* should never happen */ + warn("No hash entry with key '%s'", keys[i]); + sv_catpvn(return_sv, "???", 3); + continue; + } + + if (use_neat) { + sv_catpv(return_sv, neatsvpv(*hash_svp,0)); + } + else { + if (SvOK(*hash_svp)) { + STRLEN hv_val_len; + char *hv_val = SvPV(*hash_svp, hv_val_len); + sv_catpvn(return_sv, "'", 1); + sv_catpvn(return_sv, hv_val, hv_val_len); + sv_catpvn(return_sv, "'", 1); + } + else sv_catpvn(return_sv, "undef", 5); + } + + if (i < hv_len-1) + sv_catpvn(return_sv, pair_sep, pair_sep_len); + } + + Safefree(keys); + + return return_sv; +} + + + +/* handy for embedding into condition expression for debugging */ +/* +static int warn1(char *s) { warn(s); return 1; } +static int dump1(SV *sv) { dTHX; sv_dump(sv); return 1; } +*/ + + +/* --- */ + +static 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) +{ + dTHX; + dMY_CXT; + static const char msg[] = "you probably need to rebuild the DBD driver (or possibly the DBI)"; + (void)need_dbixs_cv; + if (dbis_cv != DBISTATE_VERSION || dbis_cs != sizeof(*DBIS)) + croak("DBI/DBD internal version mismatch (DBI is v%d/s%lu, DBD %s expected v%d/s%d) %s.\n", + DBISTATE_VERSION, (long unsigned int)sizeof(*DBIS), name, dbis_cv, dbis_cs, msg); + /* Catch structure size changes - We should probably force a recompile if the DBI */ + /* runtime version is different from the build time. That would be harsh but safe. */ + if (drc_s != sizeof(dbih_drc_t) || dbc_s != sizeof(dbih_dbc_t) || + stc_s != sizeof(dbih_stc_t) || fdc_s != sizeof(dbih_fdc_t) ) + croak("%s (dr:%d/%ld, db:%d/%ld, st:%d/%ld, fd:%d/%ld), %s.\n", + "DBI/DBD internal structure mismatch", + drc_s, (long)sizeof(dbih_drc_t), dbc_s, (long)sizeof(dbih_dbc_t), + stc_s, (long)sizeof(dbih_stc_t), fdc_s, (long)sizeof(dbih_fdc_t), msg); +} + +static void +dbi_bootinit(dbistate_t * parent_dbis) +{ + dTHX; + dMY_CXT; + dbistate_t* DBISx; + + DBISx = (struct dbistate_st*)malloc_using_sv(sizeof(struct dbistate_st)); + DBIS = DBISx; + + /* make DBIS available to DBD modules the "old" (<= 1.618) way, + * so that unrecompiled DBD's will still work against a newer DBI */ + sv_setiv(get_sv("DBI::_dbistate", GV_ADDMULTI), + PTR2IV(MY_CXT.dbi_state)); + + /* store version and size so we can spot DBI/DBD version mismatch */ + DBIS->check_version = check_version; + 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; i<items; ++i) { + PerlIO_printf(logfp," %s", + (ima && i==ima->hidearg) ? "****" : 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 @@ -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 <EXTERN.h> +#include <perl.h> +#include <XSUB.h> + +#ifdef debug /* causes problems with DBIS->debug */ +#undef debug +#endif + +#ifdef std /* causes problems with STLport <tscheresky@micron.com> */ +#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 = <<EOCM; +*** + This version of DBI conflicts with the version of + module %s (%s) you have installed. + + It's strongly recommended that you update it after + installing this version of DBI. +*** +EOCM + +sub CheckConflicts { + my %params = @_; + my %conflicts = %{ $params{CONFLICTS} }; + my $found = 0; + + while ( my ( $module, $version ) = each(%conflicts) ) { + undef $@; + eval "require $module"; + next if $@; + my $installed = eval "\$" . $module . "::VERSION"; + if ( $installed le $version ) { + ++$found; + my $msg = $conflictMsg; + my $warning = sprintf( $msg, $module, $installed ); + warn $warning; + } + } + + return !$found; +} + +sub WriteMakefile1 { + #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. + my %params = @_; + my $eumm_version = $ExtUtils::MakeMaker::VERSION; + $eumm_version = eval $eumm_version; + die "EXTRA_META is deprecated" if ( exists( $params{EXTRA_META} ) ); + die "License not specified" if ( !exists( $params{LICENSE} ) ); + if ( $params{BUILD_REQUIRES} and ( $eumm_version < 6.5503 ) ) { + #EUMM 6.5502 has problems with BUILD_REQUIRES + $params{PREREQ_PM} = { %{ $params{PREREQ_PM} || {} }, %{ $params{BUILD_REQUIRES} } }; + delete $params{BUILD_REQUIRES}; + } + + # more or less taken from Moose' Makefile.PL + if ( $params{CONFLICTS} ) { + my $ok = CheckConflicts(%params); + exit(0) if ( $params{PREREQ_FATAL} and not $ok ); + my $cpan_smoker = grep { $_ =~ m/(?:CR_SMOKER|CPAN_REPORTER|AUTOMATED_TESTING)/ } keys %ENV; + unless ( $cpan_smoker || $ENV{PERL_MM_USE_DEFAULT} ) { + sleep 4 unless ($ok); + } + %{$params{META_MERGE}{conflicts}} = %{$params{CONFLICTS}}; + delete $params{CONFLICTS}; + } + + delete $params{CONFIGURE_REQUIRES} if ( $eumm_version < 6.52 ); + delete $params{MIN_PERL_VERSION} if ( $eumm_version < 6.48 ); + delete $params{META_MERGE} if ( $eumm_version < 6.46 ); + delete $params{META_ADD} if ( $eumm_version < 6.46 ); + delete $params{LICENSE} if ( $eumm_version < 6.31 ); + + WriteMakefile(%params); +} + +$Verbose = $::opt_v; +WriteMakefile1( + dbd_edit_mm_attribs(\%opts, { + create_pp_tests => 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 <<EOT; + + I see you're using perl $] on $Config::Config{archname}, okay. + Remember to actually *read* the README file! + Use 'make' to build the software (dmake or nmake on Windows). + Then 'make test' to execute self tests. + Then 'make install' to install the DBI and then delete this working + directory before unpacking and building any DBD::* drivers. + +EOT +warn <<EOT if $os eq 'MSWin32'; + Windows users need to use the correct make command. + That may be nmake or dmake depending on which Perl you are using. + If using the Win32 ActiveState build then it is recommended that you + use the ppm utility to fetch and install a prebuilt DBI instead. + +EOT + return ""; +} + +sub libscan { + my($self, $path) = @_; + ($path =~ /\~$|\B\.(svn|git)\b/) ? undef : $path; +} + +sub const_cccmd { + my $self = shift; + local($_) = $self->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. @@ -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 @@ -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 <tom@kishel.net>): +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<may> 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 "<basename>@<linenum>;..." 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<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log> + + dbilogstrip dbitrace.log > dbitrace_stripped.log + +Run C<yourscript.pl> twice, each with different sets of arguments, with +DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> 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<pid#6254> with C<pidN>. + +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<ppport.h> 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<ppport.h>. + +=head2 --patch=I<file> + +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<suffix> + +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<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> 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<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> 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<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. 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<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> 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<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +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<ppport.h>. + +These functions or variables will be marked C<explicit> 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<static> or global +variants. + +For a C<static> 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<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> 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<diff> 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<newSVpvn> 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<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +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<Devel::PPPort> +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<Devel::PPPort>. + +=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 (<DATA>) { + 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 $/; <IN> }; + 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 = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + 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 <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + 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 <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$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 <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# 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 <limits.h> +#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 <values.h> */ +# 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 <values.h> */ +# 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 <note.h> +# 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 <locale.h> + 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 <<EOS; +dbiprof [options] [files] + +Reads and merges DBI profile data from files and prints a summary. + +files: defaults to $filename + +options: + + -number=N show top N, defaults to $number + -sort=S sort by S, defaults to $sort + -reverse reverse the sort + -match=K=V for filtering, see docs + -exclude=K=V for filtering, see docs + -case_sensitive for -match and -exclude + -delete rename files before reading then delete afterwards + -version print version number and exit + -help print this help + +EOS + return 1; +} + +# list of files defaults to dbi.prof +my @files = @ARGV ? @ARGV : ('dbi.prof'); + + +# instantiate ProfileData object +my $prof = eval { + DBI::ProfileData->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<prof1.out>: + + dbiprof prof1.out + +See the top 10 most frequently run queries in the profile file +F<dbi.prof> (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<key2> and C<key3>. + +=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<DeleteFiles> option to L<DBI::ProfileData> which causes the +files to be deleted after reading. See L<DBI::ProfileData> 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 <sam@tregar.com> + +=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<DBI::ProfileDumper|DBI::ProfileDumper>, +L<DBI::Profile|DBI::Profile>, L<DBI|DBI>. + +=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 <options> --localport=<port> + + +=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<DBI::ProxyServer> 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<DBI::ProxyServer> 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<Sys::Syslog>. The default is +B<daemon>. + +=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<Net::Daemon::Log> 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<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI> + +=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<Bundle> is a module that simply defines a collection of other +modules. It is used by the L<CPAN> 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~<dbd_metadata>(.+)</dbd_metadata>~is ) + { + $schema = $col_names = $1; + $schema =~ s~.*<schema>(.+)</schema>.*~$1~is; + $col_names =~ s~.*<col_names>(.+)</col_names>.*~$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"} = + "<dbd_metadata>" + . "<schema>$schema</schema>" + . "<col_names>" + . join( ",", @{$col_names} ) + . "</col_names>" + . "</dbd_metadata>"; + } + + $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"} = + "<dbd_metadata>" + . "<schema>$schema</schema>" + . "<col_names>$col_names</col_names>" + . "</dbd_metadata>"; +} + +# 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<DBI> docs, +L<DBD::File/Metadata|DBD::File metadata> and L</Metadata> +shown below. + +Use standard DBI prepare, execute, fetch, placeholders, etc., +see L<QUICK START> 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<Note> 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<DBI> 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<Supported SQL syntax>. There are also many +options for DBM support, see especially the section on L<Adding +multi-column support with MLDBM>. + +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</Metadata>. + +=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<never> 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<f_ext> attribute to the +extension B<and> 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<f_dir> 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<f_dir>: + + 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<GOTCHAS AND WARNINGS> 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<f_lock> 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<AnyDBM_File> 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<dbm_type> 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<not> +use MLDBM as your I<dbm_type> 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<foo> and I<bar> + 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<Note> that you must change the I<dbm_type> 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<Perl coderefs> into columns. + +If you want more than two columns, you B<must> 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<YAML::MLDBM> or +L<MLDBM::Serializer::JSON>. You select the serializer using the +I<dbm_mldbm> 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<dbm_type> is quite limited, so if you are going to +use MLDBM, you should probably use a different type, see L<AnyDBM_File>. + +See below for some L<GOTCHAS AND WARNINGS> 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<dbm_type>, 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<not> 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<DB_File> and L<BerkeleyDB> 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<Adding multi-column support with MLDBM>). 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<PRIMARY KEY> 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<Note> that the underlying DBM storage needs to loop over all I<key/value> +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<Option #1:> By default, this module inherits its SQL support from +DBI::SQL::Nano that comes with DBI. Nano is, as its name implies, a *very* +small SQL engine. Although limited in scope, it is faster than option #2 +for some operations (especially single I<primary key> lookups). See +L<DBI::SQL::Nano> for a description of the SQL it supports and comparisons +of it with option #2. + +B<Option #2:> If you install the pure Perl CPAN module SQL::Statement, +DBD::DBM will use it instead of Nano. This adds support for table aliases, +functions, joins, and much more. If you're going to use DBD::DBM +for anything other than very simple tables and queries, you should install +SQL::Statement. You don't have to change DBD::DBM or your scripts in any +way, simply installing SQL::Statement will give you the more robust SQL +capabilities without breaking scripts written for DBI::SQL::Nano. See +L<SQL::Statement> for a description of the SQL it supports. + +To find out which SQL module is working in a given script, you can use the +dbm_versions() method or, if you don't need the full output and version +numbers, just do this: + + print $dbh->{sql_handler}, "\n"; + +That will print out either "SQL::Statement" or "DBI::SQL::Nano". + +Baring the section about optimized access to the DBM storage in mind, +comparing the benefits of both engines: + + # DBI::SQL::Nano is faster + $sth = $dbh->prepare( "update foo set value='new' where key=15" ); + $sth->execute(); + $sth = $dbh->prepare( "delete from foo where key=27" ); + $sth->execute(); + $sth = $dbh->prepare( "select * from foo where key='abc'" ); + + # SQL::Statement might faster (depending on DB size) + $sth = $dbh->prepare( "update foo set value='new' where key=?" ); + $sth->execute(15); + $sth = $dbh->prepare( "update foo set value=? where key=15" ); + $sth->execute('new'); + $sth = $dbh->prepare( "delete from foo where key=?" ); + $sth->execute(27); + + # SQL::Statement is faster + $sth = $dbh->prepare( "update foo set value='new' where value='old'" ); + $sth->execute(); + # must be expressed using "where key = 15 or key = 27 or key = 42 or key = 'abc'" + # in DBI::SQL::Nano + $sth = $dbh->prepare( "delete from foo where key in (15,27,42,'abc')" ); + $sth->execute(); + # must be expressed using "where key > 10 and key < 90" in DBI::SQL::Nano + $sth = $dbh->prepare( "select * from foo where key between (10,90)" ); + $sth->execute(); + + # only SQL::Statement can handle + $sth->prepare( "select * from foo,bar where foo.name = bar.name" ); + $sth->execute(); + $sth->prepare( "insert into foo values ( 1, 'foo' ), ( 2, 'bar' )" ); + $sth->execute(); + +=head2 Specifying Column Names + +DBM files don't have a standard way to store column names. DBD::DBM gets +around this issue with a DBD::DBM specific way of storing the column names. +B<If you are working only with DBD::DBM and not using files created by or +accessed with other DBM programs, you can ignore this section.> + +DBD::DBM stores column names as a row in the file with the key I<_metadata +\0>. So this code + + my $dbh = DBI->connect('dbi:DBM:'); + $dbh->do("CREATE TABLE baz (foo CHAR(10), bar INTEGER)"); + $dbh->do("INSERT INTO baz (foo,bar) VALUES ('zippy',1)"); + +Will create a file that has a structure something like this: + + _metadata \0 | <dbd_metadata><schema></schema><col_names>foo,bar</col_names></dbd_metadata> + zippy | 1 + +The next time you access this table with DBD::DBM, it will treat the +I<_metadata \0> row as a header rather than as data and will pull the column +names from there. However, if you access the file with something other +than DBD::DBM, the row will be treated as a regular data row. + +If you do not want the column names stored as a data row in the table you +can set the I<dbm_store_metadata> attribute to 0. + + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_store_metadata => 0 }); + + # or + $dbh->{dbm_store_metadata} = 0; + + # or for per-table setting + $dbh->{f_meta}->{qux}->{dbm_store_metadata} = 0; + +By default, DBD::DBM assumes that you have two columns named "k" and "v" +(short for "key" and "value"). So if you have I<dbm_store_metadata> set to +1 and you want to use alternate column names, you need to specify the +column names like this: + + my $dbh = DBI->connect('dbi:DBM:', undef, undef, { + dbm_store_metadata => 0, + dbm_cols => [ qw(foo bar) ], + }); + + # or + $dbh->{dbm_store_metadata} = 0; + $dbh->{dbm_cols} = 'foo,bar'; + + # or to set the column names on per-table basis, do this: + # sets the column names only for table "qux" + $dbh->{f_meta}->{qux}->{dbm_store_metadata} = 0; + $dbh->{f_meta}->{qux}->{col_names} = [qw(foo bar)]; + +If you have a file that was created by another DBM program or created with +I<dbm_store_metadata> set to zero and you want to convert it to using +DBD::DBM's column name storage, just use one of the methods above to name +the columns but *without* specifying I<dbm_store_metadata> as zero. You +only have to do that once - thereafter you can get by without setting +either I<dbm_store_metadata> or setting I<dbm_cols> because the names will +be stored in the file. + +=head1 DBI database handle attributes + +=head2 Metadata + +=head3 Statement handle ($sth) attributes and methods + +Most statement handle attributes such as NAME, NUM_OF_FIELDS, etc. are +available only after an execute. The same is true of $sth->rows which is +available after the execute but does I<not> require a fetch. + +=head3 Driver handle ($dbh) attributes + +It is not supported anymore to use dbm-attributes without the dbm_-prefix. +Currently, if an DBD::DBM private attribute is accessed without an +underscore in it's name, dbm_ is prepended to that attribute and it's +processed further. If the resulting attribute name is invalid, an error is +thrown. + +=head4 dbm_cols + +Contains a comma separated list of column names or an array reference to +the column names. + +=head4 dbm_type + +Contains the DBM storage type. Currently known supported type are +C<< ODBM_File >>, C<< NDBM_File >>, C<< SDBM_File >>, C<< GDBM_File >>, +C<< DB_File >> and C<< BerkeleyDB >>. It is not recommended to use one +of the first three types - even if C<< SDBM_File >> is the most commonly +available I<dbm_type>. + +=head4 dbm_mldbm + +Contains the serializer for DBM storage (value column). Requires the +CPAN module L<MLDBM> installed. Currently known supported serializers +are: + +=over 8 + +=item Data::Dumper + +Default serializer. Deployed with Perl core. + +=item Storable + +Faster serializer. Deployed with Perl core. + +=item FreezeThaw + +Pure Perl serializer, requires L<FreezeThaw> to be installed. + +=item YAML + +Portable serializer (between languages but not architectures). +Requires L<YAML::MLDBM> installation. + +=item JSON + +Portable, fast serializer (between languages but not architectures). +Requires L<MLDBM::Serializer::JSON> installation. + +=back + +=head4 dbm_store_metadata + +Boolean value which determines if the metadata in DBM is stored or not. + +=head4 dbm_berkeley_flags + +Hash reference with additional flags for BerkeleyDB::Hash instantiation. + +=head4 dbm_version + +Readonly attribute containing the version of DBD::DBM. + +=head4 f_meta + +In addition to the attributes L<DBD::File> recognizes, DBD::DBM knows +about the (public) attributes C<col_names> (B<Note> not I<dbm_cols> +here!), C<dbm_type>, C<dbm_mldbm>, C<dbm_store_metadata> and +C<dbm_berkeley_flags>. As in DBD::File, there are undocumented, +internal attributes in DBD::DBM. Be very careful when modifying +attributes you do not know; the consequence might a destroyed or +corrupted table. + +=head4 dbm_tables + +This attribute provides restricted access to the table meta data. See +L<f_meta> and L<DBD::File/f_meta> for attribute details. + +dbm_tables is a tied hash providing the internal table names as keys +(accessing unknown tables might create an entry) and their meta +data as another tied hash. The table meta storage is obtained via +the C<get_table_meta> method from the table implementation (see +L<DBD::File::Developers>). Attribute setting and getting within the +table meta data is handled via the methods C<set_table_meta_attr> and +C<get_table_meta_attr>. + +=head3 Following attributes are no longer handled by DBD::DBM: + +=head4 dbm_ext + +This attribute is silently mapped to DBD::File's attribute I<f_ext>. +Later versions of DBI might show a depreciated warning when this attribute +is used and eventually it will be removed. + +=head4 dbm_lockfile + +This attribute is silently mapped to DBD::File's attribute I<f_lockfile>. +Later versions of DBI might show a depreciated warning when this attribute +is used and eventually it will be removed. + +=head1 DBI database handle methods + +=head2 The $dbh->dbm_versions() method + +The private method dbm_versions() returns a summary of what other modules +are being used at any given time. DBD::DBM can work with or without many +other modules - it can use either SQL::Statement or DBI::SQL::Nano as its +SQL engine, it can be run with DBI or DBI::PurePerl, it can use many kinds +of DBM modules, and many kinds of serializers when run with MLDBM. The +dbm_versions() method reports all of that and more. + + print $dbh->dbm_versions; # displays global settings + print $dbh->dbm_versions($table_name); # displays per table settings + +An important thing to note about this method is that when it called +with no arguments, it displays the *global* settings. If you override +these by setting per-table attributes, these will I<not> be shown +unless you specify a table name as an argument to the method call. + +=head2 Storing Objects + +If you are using MLDBM, you can use DBD::DBM to take advantage of its +serializing abilities to serialize any Perl object that MLDBM can handle. +To store objects in columns, you should (but don't absolutely need to) +declare it as a column of type BLOB (the type is *currently* ignored by +the SQL engine, but it's good form). + +=head1 EXTENSIBILITY + +=over 8 + +=item C<SQL::Statement> + +Improved SQL engine compared to the built-in DBI::SQL::Nano - see +L<Supported SQL syntax>. + +=item C<DB_File> + +Berkeley DB version 1. This database library is available on many +systems without additional installation and most systems are +supported. + +=item C<GDBM_File> + +Simple dbm type (comparable to C<DB_File>) under the GNU license. +Typically not available (or requires extra installation) on non-GNU +operating systems. + +=item C<BerkeleyDB> + +Berkeley DB version up to v4 (and maybe higher) - requires additional +installation but is easier than GDBM_File on non-GNU systems. + +db4 comes with a many tools which allow repairing and migrating +databases. This is the B<recommended> dbm type for production use. + +=item C<MLDBM> + +Serializer wrapper to support more than one column for the files. +Comes with serializers using C<Data::Dumper>, C<FreezeThaw> and +C<Storable>. + +=item C<YAML::MLDBM> + +Additional serializer for MLDBM. YAML is very portable between languanges. + +=item C<MLDBM::Serializer::JSON> + +Additional serializer for MLDBM. JSON is very portable between languanges, +probably more than YAML. + +=back + +=head1 GOTCHAS AND WARNINGS + +Using the SQL DROP command will remove any file that has the name specified +in the command with either '.pag' and '.dir', '.db' or your {f_ext} appended +to it. So this be dangerous if you aren't sure what file it refers to: + + $dbh->do(qq{DROP TABLE "/path/to/any/file"}); + +Each DBM type has limitations. SDBM_File, for example, can only store +values of less than 1,000 characters. *You* as the script author must +ensure that you don't exceed those bounds. If you try to insert a value +that is larger than DBM can store, the results will be unpredictable. +See the documentation for whatever DBM you are using for details. + +Different DBM implementations return records in different orders. +That means that you I<should not> rely on the order of records unless +you use an ORDER BY statement. + +DBM data files are platform-specific. To move them from one platform to +another, you'll need to do something along the lines of dumping your data +to CSV on platform #1 and then dumping from CSV to DBM on platform #2. +DBD::AnyData and DBD::CSV can help with that. There may also be DBM +conversion tools for your platforms which would probably be quicker. + +When using MLDBM, there is a very powerful serializer - it will allow +you to store Perl code or objects in database columns. When these get +de-serialized, they may be eval'ed - in other words MLDBM (or actually +Data::Dumper when used by MLDBM) may take the values and try to +execute them in Perl. Obviously, this can present dangers, so if you +do not know what is in a file, be careful before you access it with +MLDBM turned on! + +See the entire section on L<Table locking and flock()> for gotchas and +warnings about the use of flock(). + +=head1 BUGS AND LIMITATIONS + +This module uses hash interfaces of two column file databases. While +none of supported SQL engines have support for indices, the following +statements really do the same (even if they mean something completely +different) for each dbm type which lacks C<EXISTS> support: + + $sth->do( "insert into foo values (1, 'hello')" ); + + # this statement does ... + $sth->do( "update foo set v='world' where k=1" ); + # ... the same as this statement + $sth->do( "insert into foo values (1, 'world')" ); + +This is considered to be a bug and might change in a future release. + +Known affected dbm types are C<ODBM_File> and C<NDBM_File>. We highly +recommended you use a more modern dbm type such as C<DB_File>. + +=head1 GETTING HELP, MAKING SUGGESTIONS, AND REPORTING BUGS + +If you need help installing or using DBD::DBM, please write to the DBI +users mailing list at dbi-users@perl.org or to the +comp.lang.perl.modules newsgroup on usenet. I cannot always answer +every question quickly but there are many on the mailing list or in +the newsgroup who can. + +DBD developers for DBD's which rely on DBD::File or DBD::DBM or use +one of them as an example are suggested to join the DBI developers +mailing list at dbi-dev@perl.org and strongly encouraged to join our +IRC channel at L<irc://irc.perl.org/dbi>. + +If you have suggestions, ideas for improvements, or bugs to report, please +report a bug as described in DBI. Do not mail any of the authors directly, +you might not get an answer. + +When reporting bugs, please send the output of $dbh->dbm_versions($table) +for a table that exhibits the bug and as small a sample as you can make of +the code that produces the bug. And of course, patches are welcome, too +:-). + +If you need enhancements quickly, you can get commercial support as +described at L<http://dbi.perl.org/support/> or you can contact Jens Rehsack +at rehsack@cpan.org for commercial support in Germany. + +Please don't bother Jochen Wiedmann or Jeff Zucker for support - they +handed over further maintenance to H.Merijn Brand and Jens Rehsack. + +=head1 ACKNOWLEDGEMENTS + +Many, many thanks to Tim Bunce for prodding me to write this, and for +copious, wise, and patient suggestions all along the way. (Jeff Zucker) + +I send my thanks and acknowledgements to H.Merijn Brand for his +initial refactoring of DBD::File and his strong and ongoing support of +SQL::Statement. Without him, the current progress would never have +been made. And I have to name Martin J. Evans for each laugh (and +correction) of all those funny word creations I (as non-native +speaker) made to the documentation. And - of course - I have to thank +all those unnamed contributors and testers from the Perl +community. (Jens Rehsack) + +=head1 AUTHOR AND COPYRIGHT + +This module is written by Jeff Zucker < jzucker AT cpan.org >, who also +maintained it till 2007. After that, in 2010, Jens Rehsack & H.Merijn Brand +took over maintenance. + + Copyright (c) 2004 by Jeff Zucker, all rights reserved. + 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. + +=head1 SEE ALSO + +L<DBI>, +L<SQL::Statement>, L<DBI::SQL::Nano>, +L<AnyDBM_File>, L<DB_File>, L<BerkeleyDB>, +L<MLDBM>, L<YAML::MLDBM>, L<MLDBM::Serializer::JSON> + +=cut diff --git a/lib/DBD/ExampleP.pm b/lib/DBD/ExampleP.pm new file mode 100644 index 0000000..0bbace0 --- /dev/null +++ b/lib/DBD/ExampleP.pm @@ -0,0 +1,428 @@ +{ + package DBD::ExampleP; + + use Symbol; + + use DBI qw(:sql_types); + + require File::Spec; + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = sprintf("12.%06d", q$Revision: 14310 $ =~ /(\d+)/o); + + +# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z REHSACK $ +# +# Copyright (c) 1994,1997,1998 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + @statnames = qw(dev ino mode nlink + uid gid rdev size + atime mtime ctime + blksize blocks name); + @statnames{@statnames} = (0 .. @statnames-1); + + @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); + @stattypes{@statnames} = @stattypes; + @statprec = ((10) x (@statnames-1), 1024); + @statprec{@statnames} = @statprec; + die unless @statnames == @stattypes; + die unless @statprec == @stattypes; + + $drh = undef; # holds driver handle once initialised + #$gensym = "SYM000"; # used by st::execute() for filehandles + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'ExampleP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Perl stub by Tim Bunce', + }, ['example implementors private data '.__PACKAGE__]); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::ExampleP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my($drh, $dbname, $user, $auth)= @_; + my ($outer, $dbh) = DBI::_new_dbh($drh, { + Name => $dbname, + examplep_private_dbh_attrib => 42, # an example, for testing + }); + $dbh->{examplep_get_info} = { + 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR + 41 => '.', # SQL_CATALOG_NAME_SEPARATOR + 114 => 1, # SQL_CATALOG_LOCATION + }; + #$dbh->{Name} = $dbname; + $dbh->STORE('Active', 1); + return $outer; + } + + sub data_sources { + return ("dbi:ExampleP:dir=."); # possibly usefully meaningless + } + +} + + +{ package DBD::ExampleP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement)= @_; + my @fields; + my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; + + if (defined $fields and defined $dir) { + @fields = ($fields eq '*') + ? keys %DBD::ExampleP::statnames + : split(/\s*,\s*/, $fields); + } + else { + return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") + unless $statement =~ m/^\s*set\s+/; + # the SET syntax is just a hack so the ExampleP driver can + # be used to test non-select statements. + # Now we have DBI::DBM etc., ExampleP should be deprecated + } + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + examplep_private_sth_attrib => 24, # an example, for testing + }, ['example implementors private data '.__PACKAGE__]); + + my @bad = map { + defined $DBD::ExampleP::statnames{$_} ? () : $_ + } @fields; + return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") + if @bad; + + $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); + + $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; + $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); + + if (@fields) { + $outer->STORE('NAME' => \@fields); + $outer->STORE('NULLABLE' => [ (0) x @fields ]); + $outer->STORE('SCALE' => [ (0) x @fields ]); + } + + $outer; + } + + + sub table_info { + my $dbh = shift; + my ($catalog, $schema, $table, $type) = @_; + + my @types = split(/["']*,["']/, $type || 'TABLE'); + my %types = map { $_=>$_ } @types; + + # Return a list of all subdirectories + my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + my $dir = $catalog || File::Spec->curdir(); + my @list; + if ($types{VIEW}) { # for use by test harness + push @list, [ undef, "schema", "table", 'VIEW', undef ]; + push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; + push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; + } + if ($types{TABLE}) { + no strict 'refs'; + opendir($dh, $dir) + or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); + while (defined(my $item = readdir($dh))) { + if ($^O eq 'VMS') { + # if on VMS then avoid warnings from catdir if you use a file + # (not a dir) as the item below + next if $item !~ /\.dir$/oi; + } + my $file = File::Spec->catdir($dir,$item); + next unless -d $file; + my($dev, $ino, $mode, $nlink, $uid) = lstat($file); + my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; + push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; + } + close($dh); + } + # We would like to simply do a DBI->connect() here. However, + # this is wrong if we are in a subclass like DBI::ProxyServer. + $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') + or return $dbh->set_err($DBI::err, + "Failed to connect to DBI::Sponge: $DBI::errstr"); + + my $attr = { + 'rows' => \@list, + 'NUM_OF_FIELDS' => 5, + 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', + 'TABLE_TYPE', 'REMARKS'], + 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), + DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], + 'NULLABLE' => [1, 1, 1, 1, 1] + }; + my $sdbh = $dbh->{'dbd_sponge_dbh'}; + my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) + or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); + $sth; + } + + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE=> 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + + sub ping { + (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t + } + + + sub disconnect { + shift->STORE(Active => 0); + return 1; + } + + + sub get_info { + my ($dbh, $info_type) = @_; + return $dbh->{examplep_get_info}->{$info_type}; + } + + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + # else pass up to DBI to handle + return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; + return $dbh->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; + return $dbh->SUPER::STORE($attrib, $value); + } + + sub DESTROY { + my $dbh = shift; + $dbh->disconnect if $dbh->FETCH('Active'); + undef + } + + + # This is an example to demonstrate the use of driver-specific + # methods via $dbh->func(). + # Use it as follows: + # my @tables = $dbh->func($re, 'examplep_tables'); + # + # Returns all the tables that match the regular expression $re. + sub examplep_tables { + my $dbh = shift; my $re = shift; + grep { $_ =~ /$re/ } $dbh->tables(); + } + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + + sub private_attribute_info { + return { example_driver_path => undef }; + } +} + + +{ package DBD::ExampleP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; no strict 'refs'; # cause problems with filehandles + + sub bind_param { + my($sth, $param, $value, $attribs) = @_; + $sth->{'dbd_param'}->[$param-1] = $value; + return 1; + } + + + sub execute { + my($sth, @dir) = @_; + my $dir; + + if (@dir) { + $sth->bind_param($_, $dir[$_-1]) or return + foreach (1..@dir); + } + + my $dbd_param = $sth->{'dbd_param'} || []; + return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") + unless @$dbd_param == $sth->{NUM_OF_PARAMS}; + + return 0 unless $sth->{NUM_OF_FIELDS}; # not a select + + $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; + return $sth->set_err(2, "No bind parameter supplied") + unless defined $dir; + + $sth->finish; + + # + # If the users asks for directory "long_list_4532", then we fake a + # directory with files "file4351", "file4350", ..., "file0". + # This is a special case used for testing, especially DBD::Proxy. + # + if ($dir =~ /^long_list_(\d+)$/) { + $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode + $sth->{dbd_datahandle} = undef; + } + else { + $sth->{dbd_dir} = $dir; + my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + opendir($sym, $dir) + or return $sth->set_err(2, "opendir($dir): $!"); + $sth->{dbd_datahandle} = $sym; + } + $sth->STORE(Active => 1); + return 1; + } + + + sub fetch { + my $sth = shift; + my $dir = $sth->{dbd_dir}; + my %s; + + if (ref $dir) { # special fake-data test mode + my $num = $dir->[0]--; + unless ($num > 0) { + $sth->finish(); + return; + } + my $time = time; + @s{@DBD::ExampleP::statnames} = + ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, + $time, $time, $time, 512, 2, "file$num") + } + else { # normal mode + my $dh = $sth->{dbd_datahandle} + or return $sth->set_err($DBI::stderr, "fetch without successful execute"); + my $f = readdir($dh); + unless ($f) { + $sth->finish; + return; + } + # untaint $f so that we can use this for DBI taint tests + ($f) = ($f =~ m/^(.*)$/); + my $file = File::Spec->catfile($dir, $f); + # put in all the data fields + @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); + } + + # return just what fields the query asks for + my @new = @s{ @{$sth->{NAME}} }; + + return $sth->_set_fbav(\@new); + } + *fetchrow_arrayref = \&fetch; + + + sub finish { + my $sth = shift; + closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; + $sth->{dbd_datahandle} = undef; + $sth->{dbd_dir} = undef; + $sth->SUPER::finish(); + return 1; + } + + + sub FETCH { + my ($sth, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + if ($attrib eq 'TYPE'){ + return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'PRECISION'){ + return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'ParamValues') { + my $dbd_param = $sth->{dbd_param} || []; + my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; + return \%pv; + } + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->{$attrib} = $value + if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; + return $sth->SUPER::STORE($attrib, $value); + } + + *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; +} + +1; +# vim: sw=4:ts=8 diff --git a/lib/DBD/File.pm b/lib/DBD/File.pm new file mode 100644 index 0000000..d4d57ae --- /dev/null +++ b/lib/DBD/File.pm @@ -0,0 +1,1637 @@ +# -*- perl -*- +# +# DBD::File - A base class for implementing DBI drivers that +# act on plain files +# +# This module is currently maintained by +# +# H.Merijn Brand & Jens Rehsack +# +# The original author is Jochen Wiedmann. +# +# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack +# Copyright (C) 2004 by Jeff Zucker +# Copyright (C) 1998 by Jochen Wiedmann +# +# All rights reserved. +# +# You may distribute this module under the terms of either the GNU +# General Public License or the Artistic License, as specified in +# the Perl README file. + +require 5.008; + +use strict; +use warnings; + +use DBI (); + +package DBD::File; + +use strict; +use warnings; + +use base qw(DBI::DBD::SqlEngine); +use Carp; +use vars qw(@ISA $VERSION $drh); + +$VERSION = "0.40"; + +$drh = undef; # holds driver handle(s) once initialized + +my %accessors = ( + get_meta => "get_file_meta", + set_meta => "set_file_meta", + clear_meta => "clear_file_meta", + ); + +sub driver ($;$) +{ + my ($class, $attr) = @_; + + # Drivers typically use a singleton object for the $drh + # We use a hash here to have one singleton per subclass. + # (Otherwise DBD::CSV and DBD::DBM, for example, would + # share the same driver object which would cause problems.) + # An alternative would be not not cache the $drh here at all + # and require that subclasses do that. Subclasses should do + # their own caching, so caching here just provides extra safety. + $drh->{$class} and return $drh->{$class}; + + $attr ||= {}; + { no strict "refs"; + unless ($attr->{Attribution}) { + $class eq "DBD::File" and + $attr->{Attribution} = "$class by Jeff Zucker"; + $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} || + "oops the author of $class forgot to define this"; + } + $attr->{Version} ||= ${$class . "::VERSION"}; + $attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://; + } + + $drh->{$class} = $class->SUPER::driver ($attr); + + my $prefix = DBI->driver_prefix ($class); + if ($prefix) { + my $dbclass = $class . "::db"; + while (my ($accessor, $funcname) = each %accessors) { + my $method = $prefix . $accessor; + $dbclass->can ($method) and next; + my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname; +sub %s::%s +{ + my $func = %s->can (q{%s}); + goto &$func; + } +EOI + eval $inject; + $dbclass->install_method ($method); + } + } + + # XXX inject DBD::XXX::Statement unless exists + + return $drh->{$class}; + } # driver + +sub CLONE +{ + undef $drh; + } # CLONE + +# ====== DRIVER ================================================================ + +package DBD::File::dr; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +@DBD::File::dr::ISA = qw(DBI::DBD::SqlEngine::dr); +$DBD::File::dr::imp_data_size = 0; + +sub dsn_quote +{ + my $str = shift; + ref $str and return ""; + defined $str or return ""; + $str =~ s/([;:\\])/\\$1/g; + return $str; + } # dsn_quote + +sub data_sources ($;$) +{ + my ($drh, $attr) = @_; + my $dir = $attr && exists $attr->{f_dir} + ? $attr->{f_dir} + : File::Spec->curdir (); + my %attrs; + $attr and %attrs = %$attr; + delete $attrs{f_dir}; + my $dsnextra = join ";", map { $_ . "=" . dsn_quote ($attrs{$_}) } keys %attrs; + my ($dirh) = Symbol::gensym (); + unless (opendir $dirh, $dir) { + $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return; + } + + my ($file, @dsns, %names, $driver); + $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File"; + + while (defined ($file = readdir ($dirh))) { + my $d = File::Spec->catdir ($dir, $file); + # allow current dir ... it can be a data_source too + $file ne File::Spec->updir () && -d $d and + push @dsns, "DBI:$driver:f_dir=" . dsn_quote ($d) . ($dsnextra ? ";$dsnextra" : ""); + } + return @dsns; + } # data_sources + +sub disconnect_all +{ + } # disconnect_all + +sub DESTROY +{ + undef; + } # DESTROY + +# ====== DATABASE ============================================================== + +package DBD::File::db; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +use Carp; +require File::Spec; +require Cwd; +use Scalar::Util qw(refaddr); # in CORE since 5.7.3 + +@DBD::File::db::ISA = qw(DBI::DBD::SqlEngine::db); +$DBD::File::db::imp_data_size = 0; + +sub set_versions +{ + my $dbh = shift; + $dbh->{f_version} = $DBD::File::VERSION; + + return $dbh->SUPER::set_versions (); + } # set_versions + +sub init_valid_attributes +{ + my $dbh = shift; + + $dbh->{f_valid_attrs} = { + f_version => 1, # DBD::File version + f_dir => 1, # base directory + f_ext => 1, # file extension + f_schema => 1, # schema name + f_meta => 1, # meta data for tables + f_meta_map => 1, # mapping table for identifier case + f_lock => 1, # Table locking mode + f_lockfile => 1, # Table lockfile extension + f_encoding => 1, # Encoding of the file + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + $dbh->{f_readonly_attrs} = { + f_version => 1, # DBD::File version + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + + return $dbh->SUPER::init_valid_attributes (); + } # init_valid_attributes + +sub init_default_attributes +{ + my ($dbh, $phase) = @_; + + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->SUPER::init_default_attributes ($phase); + + # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and + # don't call twice + unless (defined $phase) { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if (0 == $phase) { + # check whether we're running in a Gofer server or not (see + # validate_FETCH_attr for details) + $dbh->{f_in_gofer} = (defined $INC{"DBD/Gofer.pm"} && (caller(5))[0] eq "DBI::Gofer::Execute"); + # f_ext should not be initialized + # f_map is deprecated (but might return) + $dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ()); + $dbh->{f_meta} = {}; + $dbh->{f_meta_map} = {}; # choose new name because it contains other keys + + # complete derived attributes, if required + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + my $valid_attrs = $drv_prefix . "valid_attrs"; + my $ro_attrs = $drv_prefix . "readonly_attrs"; + + my @comp_attrs = (); + if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{f_in_gofer}) { + my $attr = $dbh->{$drv_prefix . "meta"}; + defined $attr and defined $dbh->{$valid_attrs} and + !defined $dbh->{$valid_attrs}{$attr} and + $dbh->{$valid_attrs}{$attr} = 1; + + my %h; + tie %h, "DBD::File::TieTables", $dbh; + $dbh->{$attr} = \%h; + + push @comp_attrs, "meta"; + } + + foreach my $comp_attr (@comp_attrs) { + my $attr = $drv_prefix . $comp_attr; + defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and + $dbh->{$valid_attrs}{$attr} = 1; + defined $dbh->{$ro_attrs} and !defined $dbh->{$ro_attrs}{$attr} and + $dbh->{$ro_attrs}{$attr} = 1; + } + } + + return $dbh; + } # init_default_attributes + +sub disconnect ($) +{ + %{$_[0]->{f_meta}} = (); + return $_[0]->SUPER::disconnect (); + } # disconnect + +sub validate_FETCH_attr +{ + my ($dbh, $attrib) = @_; + + # If running in a Gofer server, access to our tied compatibility hash + # would force Gofer to serialize the tieing object including it's + # private $dbh reference used to do the driver function calls. + # This will result in nasty exceptions. So return a copy of the + # f_meta structure instead, which is the source of for the compatibility + # tie-hash. It's not as good as liked, but the best we can do in this + # situation. + if ($dbh->{f_in_gofer}) { + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + exists $dbh->{$drv_prefix . "meta"} && $attrib eq $dbh->{$drv_prefix . "meta"} and + $attrib = "f_meta"; + } + + return $attrib; + } # validate_FETCH_attr + +sub validate_STORE_attr +{ + my ($dbh, $attrib, $value) = @_; + + if ($attrib eq "f_dir") { + -d $value or + return $dbh->set_err ($DBI::stderr, "No such directory '$value'"); + File::Spec->file_name_is_absolute ($value) or + $value = Cwd::abs_path ($value); + } + + if ($attrib eq "f_ext") { + $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or + carp "'$value' doesn't look like a valid file extension attribute\n"; + } + + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + + if (exists $dbh->{$drv_prefix . "meta"}) { + my $attr = $dbh->{$drv_prefix . "meta"}; + if ($attrib eq $attr) { + while (my ($k, $v) = each %$value) { + $dbh->{$attrib}{$k} = $v; + } + } + } + + return $dbh->SUPER::validate_STORE_attr ($attrib, $value); + } # validate_STORE_attr + +sub get_f_versions +{ + my ($dbh, $table) = @_; + + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + my (undef, $meta); + $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + unless ($meta) { + $meta = {}; + $class->bootstrap_table_meta ($dbh, $meta, $table); + } + + my $dver; + my $dtype = "IO::File"; + eval { + $dver = IO::File->VERSION (); + + # when we're still alive here, everthing went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + + $meta->{f_encoding} and $dtype .= " + " . $meta->{f_encoding} . " encoding"; + + return sprintf "%s using %s", $dbh->{f_version}, $dtype; + } # get_f_versions + +sub get_single_table_meta +{ + my ($dbh, $table, $attr) = @_; + my $meta; + + $table eq "." and + return $dbh->FETCH ($attr); + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta or croak "No such table '$table'"; + + # prevent creation of undef attributes + return $class->get_table_meta_attr ($meta, $attr); + } # get_single_table_meta + +sub get_file_meta +{ + my ($dbh, $table, $attr) = @_; + + my $gstm = $dbh->{ImplementorClass}->can ("get_single_table_meta"); + + $table eq "*" and + $table = [ ".", keys %{$dbh->{f_meta}} ]; + $table eq "+" and + $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ]; + ref $table eq "Regexp" and + $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ]; + + ref $table || ref $attr or + return &$gstm ($dbh, $table, $attr); + + ref $table or $table = [ $table ]; + ref $attr or $attr = [ $attr ]; + "ARRAY" eq ref $table or + croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table; + "ARRAY" eq ref $attr or + croak "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr; + + my %results; + foreach my $tname (@{$table}) { + my %tattrs; + foreach my $aname (@{$attr}) { + $tattrs{$aname} = &$gstm ($dbh, $tname, $aname); + } + $results{$tname} = \%tattrs; + } + + return \%results; + } # get_file_meta + +sub set_single_table_meta +{ + my ($dbh, $table, $attr, $value) = @_; + my $meta; + + $table eq "." and + return $dbh->STORE ($attr, $value); + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta or croak "No such table '$table'"; + $class->set_table_meta_attr ($meta, $attr, $value); + + return $dbh; + } # set_single_table_meta + +sub set_file_meta +{ + my ($dbh, $table, $attr, $value) = @_; + + my $sstm = $dbh->{ImplementorClass}->can ("set_single_table_meta"); + + $table eq "*" and + $table = [ ".", keys %{$dbh->{f_meta}} ]; + $table eq "+" and + $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{$dbh->{f_meta}} ]; + ref ($table) eq "Regexp" and + $table = [ grep { $_ =~ $table } keys %{$dbh->{f_meta}} ]; + + ref $table || ref $attr or + return &$sstm ($dbh, $table, $attr, $value); + + ref $table or $table = [ $table ]; + ref $attr or $attr = { $attr => $value }; + "ARRAY" eq ref $table or + croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table; + "HASH" eq ref $attr or + croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr; + + foreach my $tname (@{$table}) { + my %tattrs; + while (my ($aname, $aval) = each %$attr) { + &$sstm ($dbh, $tname, $aname, $aval); + } + } + + return $dbh; + } # set_file_meta + +sub clear_file_meta +{ + my ($dbh, $table) = @_; + + (my $class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + my (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta and %{$meta} = (); + + return; + } # clear_file_meta + +sub get_avail_tables +{ + my $dbh = shift; + + my @tables = $dbh->SUPER::get_avail_tables (); + my $dir = $dbh->{f_dir}; + my $dirh = Symbol::gensym (); + + unless (opendir $dirh, $dir) { + $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return @tables; + } + + my $class = $dbh->FETCH ("ImplementorClass"); + $class =~ s/::db$/::Table/; + my ($file, %names); + my $schema = exists $dbh->{f_schema} + ? defined $dbh->{f_schema} && $dbh->{f_schema} ne "" + ? $dbh->{f_schema} : undef + : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent + my %seen; + while (defined ($file = readdir ($dirh))) { + my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX + # $tbl && $meta && -f $meta->{f_fqfn} or next; + $seen{defined $schema ? $schema : "\0"}{$tbl}++ or + push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ]; + } + closedir $dirh or + $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!"); + + return @tables; + } # get_avail_tables + +# ====== Tie-Meta ============================================================== + +package DBD::File::TieMeta; + +use Carp qw(croak); +require Tie::Hash; +@DBD::File::TieMeta::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ($class, $tblClass, $tblMeta) = @_; + + my $self = bless ({ tblClass => $tblClass, tblMeta => $tblMeta, }, $class); + return $self; + } # new + +sub STORE +{ + my ($self, $meta_attr, $meta_val) = @_; + + $self->{tblClass}->set_table_meta_attr ($self->{tblMeta}, $meta_attr, $meta_val); + + return; + } # STORE + +sub FETCH +{ + my ($self, $meta_attr) = @_; + + return $self->{tblClass}->get_table_meta_attr ($self->{tblMeta}, $meta_attr); + } # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]->{tblMeta}}; + each %{$_[0]->{tblMeta}}; + } # FIRSTKEY + +sub NEXTKEY +{ + each %{$_[0]->{tblMeta}}; + } # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{tblMeta}{$_[1]}; + } # EXISTS + +sub DELETE +{ + croak "Can't delete single attributes from table meta structure"; + } # DELETE + +sub CLEAR +{ + %{$_[0]->{tblMeta}} = () + } # CLEAR + +sub SCALAR +{ + scalar %{$_[0]->{tblMeta}} + } # SCALAR + +# ====== Tie-Tables ============================================================ + +package DBD::File::TieTables; + +use Carp qw(croak); +require Tie::Hash; +@DBD::File::TieTables::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ($class, $dbh) = @_; + + (my $tbl_class = $dbh->{ImplementorClass}) =~ s/::db$/::Table/; + my $self = bless ({ dbh => $dbh, tblClass => $tbl_class, }, $class); + return $self; + } # new + +sub STORE +{ + my ($self, $table, $tbl_meta) = @_; + + "HASH" eq ref $tbl_meta or + croak "Invalid data for storing as table meta data (must be hash)"; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + while (my ($meta_attr, $meta_val) = each %$tbl_meta) { + $self->{tblClass}->set_table_meta_attr ($meta, $meta_attr, $meta_val); + } + + return; + } # STORE + +sub FETCH +{ + my ($self, $table) = @_; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + my %h; + tie %h, "DBD::File::TieMeta", $self->{tblClass}, $meta; + + return \%h; + } # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{$_[0]->{dbh}->{f_meta}}; + each %{$_[0]->{dbh}->{f_meta}}; + } # FIRSTKEY + +sub NEXTKEY +{ + each %{$_[0]->{dbh}->{f_meta}}; + } # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{dbh}->{f_meta}->{$_[1]} or + exists $_[0]->{dbh}->{f_meta_map}->{$_[1]}; + } # EXISTS + +sub DELETE +{ + my ($self, $table) = @_; + + (undef, my $meta) = $self->{tblClass}->get_table_meta ($self->{dbh}, $table, 1); + $meta or croak "Invalid table name '$table'"; + + delete $_[0]->{dbh}->{f_meta}->{$meta->{table_name}}; + } # DELETE + +sub CLEAR +{ + %{$_[0]->{dbh}->{f_meta}} = (); + %{$_[0]->{dbh}->{f_meta_map}} = (); + } # CLEAR + +sub SCALAR +{ + scalar %{$_[0]->{dbh}->{f_meta}} + } # SCALAR + +# ====== STATEMENT ============================================================= + +package DBD::File::st; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +@DBD::File::st::ISA = qw(DBI::DBD::SqlEngine::st); +$DBD::File::st::imp_data_size = 0; + +my %supported_attrs = ( + TYPE => 1, + PRECISION => 1, + NULLABLE => 1, + ); + +sub FETCH +{ + my ($sth, $attr) = @_; + + if ($supported_attrs{$attr}) { + my $stmt = $sth->{sql_stmt}; + + if (exists $sth->{ImplementorClass} && + exists $sth->{sql_stmt} && + $sth->{sql_stmt}->isa ("SQL::Statement")) { + + # fill overall_defs unless we know + unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) { + my $all_meta = + $sth->{Database}->func ("*", "table_defs", "get_file_meta"); + while (my ($tbl, $meta) = each %$all_meta) { + exists $meta->{table_defs} && ref $meta->{table_defs} or next; + foreach (keys %{$meta->{table_defs}{columns}}) { + $sth->{f_overall_defs}{$_} = $meta->{table_defs}{columns}{$_}; + } + } + } + + my @colnames = $sth->sql_get_colnames (); + + $attr eq "TYPE" and + return [ map { $sth->{f_overall_defs}{$_}{data_type} || "CHAR" } + @colnames ]; + + $attr eq "PRECISION" and + return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 } + @colnames ]; + + $attr eq "NULLABLE" and + return [ map { ( grep m/^NOT NULL$/ => + @{ $sth->{f_overall_defs}{$_}{constraints} || [] }) + ? 0 : 1 } + @colnames ]; + } + } + + return $sth->SUPER::FETCH ($attr); + } # FETCH + +# ====== SQL::STATEMENT ======================================================== + +package DBD::File::Statement; + +use strict; +use warnings; + +@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement ); + +sub open_table ($$$$$) +{ + my ($self, $data, $table, $createMode, $lockMode) = @_; + + my $class = ref $self; + $class =~ s/::Statement/::Table/; + + my $flags = { + createMode => $createMode, + lockMode => $lockMode, + }; + $self->{command} eq "DROP" and $flags->{dropMode} = 1; + + return $class->new ($data, { table => $table }, $flags); + } # open_table + +# ====== SQL::TABLE ============================================================ + +package DBD::File::Table; + +use strict; +use warnings; + +use Carp; +require IO::File; +require File::Basename; +require File::Spec; +require Cwd; + +# We may have a working flock () built-in but that doesn't mean that locking +# will work on NFS (flock () may hang hard) +my $locking = eval { flock STDOUT, 0; 1 }; + +@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table ); + +# ====== FLYWEIGHT SUPPORT ===================================================== + +my $fn_any_ext_regex = qr/\.[^.]*/; + +# Flyweight support for table_info +# The functions file2table, init_table_meta, default_table_meta and +# get_table_meta are using $self arguments for polymorphism only. The +# must not rely on an instantiated DBD::File::Table +sub file2table +{ + my ($self, $meta, $file, $file_is_table, $respect_case) = @_; + + $file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir + + my ($ext, $req) = ("", 0); + if ($meta->{f_ext}) { + ($ext, my $opt) = split m/\//, $meta->{f_ext}; + if ($ext && $opt) { + $opt =~ m/r/i and $req = 1; + } + } + + # (my $tbl = $file) =~ s/$ext$//i; + my ($tbl, $basename, $dir, $fn_ext, $user_spec_file); + if ($file_is_table and defined $meta->{f_file}) { + $tbl = $file; + ($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex); + $file = $basename . $fn_ext; + $user_spec_file = 1; + } + else { + ($basename, $dir, undef) = File::Basename::fileparse ($file, $ext); + $file = $tbl = $basename; + $user_spec_file = 0; + } + + if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER + $basename = uc $basename; + $tbl = uc $tbl; + } + if( !$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER + $basename = lc $basename; + $tbl = lc $tbl; + } + + my $searchdir = File::Spec->file_name_is_absolute ($dir) + ? ($dir =~ s|/$||, $dir) + : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir)); + -d $searchdir or + croak "-d $searchdir: $!"; + + $searchdir eq $meta->{f_dir} and + $dir = ""; + + unless ($user_spec_file) { + $file_is_table and $file = "$basename$ext"; + + # Fully Qualified File Name + my $cmpsub; + if ($respect_case) { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot + $fn eq $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + else { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension turns up as a dot + lc $fn eq lc $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + + opendir my $dh, $searchdir or croak "Can't open '$searchdir': $!"; + my @f = sort { length $b <=> length $a } grep { &$cmpsub ($_) } readdir $dh; + @f > 0 && @f <= 2 and $file = $f[0]; + !$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED + ($tbl = $file) =~ s/$ext$//i; + closedir $dh or croak "Can't close '$searchdir': $!"; + + my $tmpfn = $file; + if ($ext && $req) { + # File extension required + $tmpfn =~ s/$ext$//i or return; + } + } + + my $fqfn = File::Spec->catfile ($searchdir, $file); + my $fqbn = File::Spec->catfile ($searchdir, $basename); + + $meta->{f_fqfn} = $fqfn; + $meta->{f_fqbn} = $fqbn; + defined $meta->{f_lockfile} && $meta->{f_lockfile} and + $meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile}; + + $dir && !$user_spec_file and $tbl = File::Spec->catfile ($dir, $tbl); + $meta->{table_name} = $tbl; + + return $tbl; + } # file2table + +sub bootstrap_table_meta +{ + my ($self, $dbh, $meta, $table) = @_; + + exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir}; + defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext}; + defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding}; + exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock}; + exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile}; + defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema}; + defined $meta->{sql_identifier_case} or + $meta->{sql_identifier_case} = $dbh->{sql_identifier_case}; + } # bootstrap_table_meta + +sub init_table_meta +{ + my ($self, $dbh, $meta, $table) = @_; + + return; + } # init_table_meta + +sub get_table_meta ($$$$;$) +{ + my ($self, $dbh, $table, $file_is_table, $respect_case) = @_; + unless (defined $respect_case) { + $respect_case = 0; + $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers + $table =~ s/\"$//; + } + + unless ($respect_case) { + defined $dbh->{f_meta_map}{$table} and $table = $dbh->{f_meta_map}{$table}; + } + + my $meta = {}; + defined $dbh->{f_meta}{$table} and $meta = $dbh->{f_meta}{$table}; + + unless ($meta->{initialized}) { + $self->bootstrap_table_meta ($dbh, $meta, $table); + + unless (defined $meta->{f_fqfn}) { + $self->file2table ($meta, $table, $file_is_table, $respect_case) or return; + } + + if (defined $meta->{table_name} and $table ne $meta->{table_name}) { + $dbh->{f_meta_map}{$table} = $meta->{table_name}; + $table = $meta->{table_name}; + } + + # now we know a bit more - let's check if user can't use consequent spelling + # XXX add know issue about reset sql_identifier_case here ... + if (defined $dbh->{f_meta}{$table} && defined $dbh->{f_meta}{$table}{initialized}) { + $meta = $dbh->{f_meta}{$table}; + $self->file2table ($meta, $table, $file_is_table, $respect_case) or + return unless $dbh->{f_meta}{$table}{initialized}; + } + unless ($dbh->{f_meta}{$table}{initialized}) { + $self->init_table_meta ($dbh, $meta, $table); + $meta->{initialized} = 1; + $dbh->{f_meta}{$table} = $meta; + } + } + + return ($table, $meta); + } # get_table_meta + +my %reset_on_modify = ( + f_file => "f_fqfn", + f_dir => "f_fqfn", + f_ext => "f_fqfn", + f_lockfile => "f_fqfn", # forces new file2table call + ); + +my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile ); + +sub register_reset_on_modify +{ + my ($proto, $extra_resets) = @_; + %reset_on_modify = (%reset_on_modify, %$extra_resets); + return; + } # register_reset_on_modify + +sub register_compat_map +{ + my ($proto, $extra_compat_map) = @_; + %compat_map = (%compat_map, %$extra_compat_map); + return; + } # register_compat_map + +sub get_table_meta_attr +{ + my ($class, $meta, $attrib) = @_; + exists $compat_map{$attrib} and + $attrib = $compat_map{$attrib}; + exists $meta->{$attrib} and + return $meta->{$attrib}; + return; + } # get_table_meta_attr + +sub set_table_meta_attr +{ + my ($class, $meta, $attrib, $value) = @_; + exists $compat_map{$attrib} and + $attrib = $compat_map{$attrib}; + $class->table_meta_attr_changed ($meta, $attrib, $value); + $meta->{$attrib} = $value; + } # set_table_meta_attr + +sub table_meta_attr_changed +{ + my ($class, $meta, $attrib, $value) = @_; + defined $reset_on_modify{$attrib} and + delete $meta->{$reset_on_modify{$attrib}} and + $meta->{initialized} = 0; + } # table_meta_attr_changed + +# ====== FILE OPEN ============================================================= + +sub open_file ($$$) +{ + my ($self, $meta, $attrs, $flags) = @_; + + defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename given"; + + my ($fh, $fn); + unless ($meta->{f_dontopen}) { + $fn = $meta->{f_fqfn}; + if ($flags->{createMode}) { + -f $meta->{f_fqfn} and + croak "Cannot create table $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + if ($fh) { + $fh->seek (0, 0) or + croak "Error while seeking back: $!"; + if (my $enc = $meta->{f_encoding}) { + binmode $fh, ":encoding($enc)" or + croak "Failed to set encoding layer '$enc' on $fn: $!"; + } + else { + binmode $fh or croak "Failed to set binary mode on $fn: $!"; + } + } + + $meta->{fh} = $fh; + } + if ($meta->{f_fqln}) { + $fn = $meta->{f_fqln}; + if ($flags->{createMode}) { + -f $fn and + croak "Cannot create table lock for $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + $meta->{lockfh} = $fh; + } + + if ($locking && $fh) { + my $lm = defined $flags->{f_lock} + && $flags->{f_lock} =~ m/^[012]$/ + ? $flags->{f_lock} + : $flags->{lockMode} ? 2 : 1; + if ($lm == 2) { + flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; + } + elsif ($lm == 1) { + flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!"; + } + # $lm = 0 is forced no locking at all + } + } # open_file + +# ====== SQL::Eval API ========================================================= + +sub new +{ + my ($className, $data, $attrs, $flags) = @_; + my $dbh = $data->{Database}; + + my ($tblnm, $meta) = $className->get_table_meta ($dbh, $attrs->{table}, 1) or + croak "Cannot find appropriate file for table '$attrs->{table}'"; + $attrs->{table} = $tblnm; + + # Being a bit dirty here, as SQL::Statement::Structure does not offer + # me an interface to the data I want + $flags->{createMode} && $data->{sql_stmt}{table_defs} and + $meta->{table_defs} = $data->{sql_stmt}{table_defs}; + + $className->open_file ($meta, $attrs, $flags); + + my $columns = {}; + my $array = []; + my $tbl = { + %{$attrs}, + meta => $meta, + col_names => $meta->{col_names} || [], + }; + return $className->SUPER::new ($tbl); + } # new + +sub drop ($) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + # We have to close the file before unlinking it: Some OS'es will + # refuse the unlink otherwise. + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + $meta->{f_fqfn} and unlink $meta->{f_fqfn}; + $meta->{f_fqln} and unlink $meta->{f_fqln}; + delete $data->{Database}{f_meta}{$self->{table}}; + return 1; + } # drop + +sub seek ($$$$) +{ + my ($self, $data, $pos, $whence) = @_; + my $meta = $self->{meta}; + if ($whence == 0 && $pos == 0) { + $pos = defined $meta->{first_row_pos} ? $meta->{first_row_pos} : 0; + } + elsif ($whence != 2 || $pos != 0) { + croak "Illegal seek position: pos = $pos, whence = $whence"; + } + + $meta->{fh}->seek ($pos, $whence) or + croak "Error while seeking in " . $meta->{f_fqfn} . ": $!"; + } # seek + +sub truncate ($$) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + $meta->{fh}->truncate ($meta->{fh}->tell ()) or + croak "Error while truncating " . $meta->{f_fqfn} . ": $!"; + return 1; + } # truncate + +sub DESTROY +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + } # DESTROY + +1; + +__END__ + +=head1 NAME + +DBD::File - Base class for writing file based DBI drivers + +=head1 SYNOPSIS + +This module is a base class for writing other L<DBD|DBI::DBD>s. +It is not intended to function as a DBD itself (though it is possible). +If you want to access flat files, use L<DBD::AnyData|DBD::AnyData>, or +L<DBD::CSV|DBD::CSV> (both of which are subclasses of DBD::File). + +=head1 DESCRIPTION + +The DBD::File module is not a true L<DBI|DBI> driver, but an abstract +base class for deriving concrete DBI drivers from it. The implication +is, that these drivers work with plain files, for example CSV files or +INI files. The module is based on the L<SQL::Statement|SQL::Statement> +module, a simple SQL engine. + +See L<DBI|DBI> for details on DBI, L<SQL::Statement|SQL::Statement> for +details on SQL::Statement and L<DBD::CSV|DBD::CSV>, L<DBD::DBM|DBD::DBM> +or L<DBD::AnyData|DBD::AnyData> for example drivers. + +=head2 Metadata + +The following attributes are handled by DBI itself and not by DBD::File, +thus they all work as expected: + + Active + ActiveKids + CachedKids + CompatMode (Not used) + InactiveDestroy + AutoInactiveDestroy + Kids + PrintError + RaiseError + Warn (Not used) + +=head3 The following DBI attributes are handled by DBD::File: + +=head4 AutoCommit + +Always on. + +=head4 ChopBlanks + +Works. + +=head4 NUM_OF_FIELDS + +Valid after C<< $sth->execute >>. + +=head4 NUM_OF_PARAMS + +Valid after C<< $sth->prepare >>. + +=head4 NAME + +Valid after C<< $sth->execute >>; undef for Non-Select statements. + +=head4 NULLABLE + +Not really working, always returns an array ref of ones, except the +affected table has been created in this session. Valid after +C<< $sth->execute >>; undef for non-select statements. + +=head3 The following DBI attributes and methods are not supported: + +=over 4 + +=item bind_param_inout + +=item CursorName + +=item LongReadLen + +=item LongTruncOk + +=back + +=head3 DBD::File specific attributes + +In addition to the DBI attributes, you can use the following dbh +attributes: + +=head4 f_dir + +This attribute is used for setting the directory where the files are +opened and it defaults to the current directory (F<.>). Usually you set +it on the dbh but it may be overridden per table (see L<f_meta>). + +When the value for C<f_dir> is a relative path, it is converted into +the appropriate absolute path name (based on the current working +directory) when the dbh attribute is set. + +See L<KNOWN BUGS AND LIMITATIONS>. + +=head4 f_ext + +This attribute is used for setting the file extension. The format is: + + extension{/flag} + +where the /flag is optional and the extension is case-insensitive. +C<f_ext> allows you to specify an extension which: + +=over + +=item * + +makes DBD::File prefer F<table.extension> over F<table>. + +=item * + +makes the table name the filename minus the extension. + +=back + + DBI:CSV:f_dir=data;f_ext=.csv + +In the above example and when C<f_dir> contains both F<table.csv> and +F<table>, DBD::File will open F<table.csv> and the table will be +named "table". If F<table.csv> does not exist but F<table> does +that file is opened and the table is also called "table". + +If C<f_ext> is not specified and F<table.csv> exists it will be opened +and the table will be called "table.csv" which is probably not what +you want. + +NOTE: even though extensions are case-insensitive, table names are +not. + + DBI:CSV:f_dir=data;f_ext=.csv/r + +The C<r> flag means the file extension is required and any filename +that does not match the extension is ignored. + +Usually you set it on the dbh but it may be overridden per table +(see L<f_meta>). + +=head4 f_schema + +This will set the schema name and defaults to the owner of the +directory in which the table file resides. You can set C<f_schema> to +C<undef>. + + my $dbh = DBI->connect ("dbi:CSV:", "", "", { + f_schema => undef, + f_dir => "data", + f_ext => ".csv/r", + }) or die $DBI::errstr; + +By setting the schema you affect the results from the tables call: + + my @tables = $dbh->tables (); + + # no f_schema + "merijn".foo + "merijn".bar + + # f_schema => "dbi" + "dbi".foo + "dbi".bar + + # f_schema => undef + foo + bar + +Defining C<f_schema> to the empty string is equal to setting it to C<undef> +so the DSN can be C<"dbi:CSV:f_schema=;f_dir=.">. + +=head4 f_lock + +The C<f_lock> attribute is used to set the locking mode on the opened +table files. Note that not all platforms support locking. By default, +tables are opened with a shared lock for reading, and with an +exclusive lock for writing. The supported modes are: + + 0: No locking at all. + + 1: Shared locks will be used. + + 2: Exclusive locks will be used. + +But see L<KNOWN BUGS|/"KNOWN BUGS AND LIMITATIONS"> below. + +=head4 f_lockfile + +If you wish to use a lockfile extension other than C<.lck>, simply specify +the C<f_lockfile> attribute: + + $dbh = DBI->connect ("dbi:DBM:f_lockfile=.foo"); + $dbh->{f_lockfile} = ".foo"; + $dbh->{f_meta}{qux}{f_lockfile} = ".foo"; + +If you wish to disable locking, set the C<f_lockfile> to C<0>. + + $dbh = DBI->connect ("dbi:DBM:f_lockfile=0"); + $dbh->{f_lockfile} = 0; + $dbh->{f_meta}{qux}{f_lockfile} = 0; + +=head4 f_encoding + +With this attribute, you can set the encoding in which the file is opened. +This is implemented using C<< binmode $fh, ":encoding(<f_encoding>)" >>. + +=head4 f_meta + +Private data area which contains information about the tables this +module handles. Table meta data might not be available until the +table has been accessed for the first time e.g., by issuing a select +on it however it is possible to pre-initialize attributes for each table +you use. + +DBD::File recognizes the (public) attributes C<f_ext>, C<f_dir>, +C<f_file>, C<f_encoding>, C<f_lock>, C<f_lockfile>, C<f_schema>, +C<col_names>, C<table_name> and C<sql_identifier_case>. Be very careful +when modifying attributes you do not know, the consequence might be a +destroyed or corrupted table. + +C<f_file> is an attribute applicable to table meta data only and you +will not find a corresponding attribute in the dbh. Whilst it may be +reasonable to have several tables with the same column names, it is +not for the same file name. If you need access to the same file using +different table names, use C<SQL::Statement> as the SQL engine and the +C<AS> keyword: + + SELECT * FROM tbl AS t1, tbl AS t2 WHERE t1.id = t2.id + +C<f_file> can be an absolute path name or a relative path name but if +it is relative, it is interpreted as being relative to the C<f_dir> +attribute of the table meta data. When C<f_file> is set DBD::File will +use C<f_file> as specified and will not attempt to work out an +alternative for C<f_file> using the C<table name> and C<f_ext> +attribute. + +While C<f_meta> is a private and readonly attribute (which means, you +cannot modify it's values), derived drivers might provide restricted +write access through another attribute. Well known accessors are +C<csv_tables> for L<DBD::CSV>, C<ad_tables> for L<DBD::AnyData> and +C<dbm_tables> for L<DBD::DBM>. + +=head3 Internally private attributes to deal with SQL backends: + +Do not modify any of these private attributes unless you understand +the implications of doing so. The behavior of DBD::File and derived +DBDs might be unpredictable when one or more of those attributes are +modified. + +=head4 sql_nano_version + +Contains the version of loaded DBI::SQL::Nano. + +=head4 sql_statement_version + +Contains the version of loaded SQL::Statement. + +=head4 sql_handler + +Contains either the text 'SQL::Statement' or 'DBI::SQL::Nano'. + +=head4 sql_ram_tables + +Contains optionally temporary tables. + +=head4 sql_flags + +Contains optional flags to instantiate the SQL::Parser parsing engine +when SQL::Statement is used as SQL engine. See L<SQL::Parser> for valid +flags. + +=head2 Driver private methods + +=head3 Default DBI methods + +=head4 data_sources + +The C<data_sources> method returns a list of subdirectories of the current +directory in the form "dbi:CSV:f_dir=$dirname". + +If you want to read the subdirectories of another directory, use + + my ($drh) = DBI->install_driver ("CSV"); + my (@list) = $drh->data_sources (f_dir => "/usr/local/csv_data"); + +=head4 list_tables + +This method returns a list of file names inside $dbh->{f_dir}. +Example: + + my ($dbh) = DBI->connect ("dbi:CSV:f_dir=/usr/local/csv_data"); + my (@list) = $dbh->func ("list_tables"); + +Note that the list includes all files contained in the directory, even +those that have non-valid table names, from the view of SQL. + +=head3 Additional methods + +The following methods are only available via their documented name when +DBD::File is used directly. Because this is only reasonable for testing +purposes, the real names must be used instead. Those names can be computed +by replacing the C<f_> in the method name with the driver prefix. + +=head4 f_versions + +Signature: + + sub f_versions (;$) + { + my ($table_name) = @_; + $table_name ||= "."; + ... + } + +Returns the versions of the driver, including the DBI version, the Perl +version, DBI::PurePerl version (if DBI::PurePerl is active) and the version +of the SQL engine in use. + + my $dbh = DBI->connect ("dbi:File:"); + my $f_versions = $dbh->f_versions (); + print "$f_versions\n"; + __END__ + # DBD::File 0.39 using SQL::Statement 1.28 + # DBI 1.612 + # OS netbsd (5.99.24) + # Perl 5.010001 (x86_64-netbsd-thread-multi) + +Called in list context, f_versions will return an array containing each +line as single entry. + +Some drivers might use the optional (table name) argument and modify +version information related to the table (e.g. DBD::DBM provides storage +backend information for the requested table, when it has a table name). + +=head4 f_get_meta + +Signature: + + sub f_get_meta ($$) + { + my ($table_name, $attrib) = @_; + ... + } + +Returns the value of a meta attribute set for a specific table, if any. +See L<f_meta> for the possible attributes. + +A table name of C<"."> (single dot) is interpreted as the default table. +This will retrieve the appropriate attribute globally from the dbh. +This has the same restrictions as C<< $dbh->{$attrib} >>. + +=head4 f_set_meta + +Signature: + + sub f_set_meta ($$$) + { + my ($table_name, $attrib, $value) = @_; + ... + } + +Sets the value of a meta attribute set for a specific table. +See L<f_meta> for the possible attributes. + +A table name of C<"."> (single dot) is interpreted as the default table +which will set the specified attribute globally for the dbh. +This has the same restrictions as C<< $dbh->{$attrib} = $value >>. + +=head4 f_clear_meta + +Signature: + + sub f_clear_meta ($) + { + my ($table_name) = @_; + ... + } + +Clears the table specific meta information in the private storage of the +dbh. + +=head1 SQL ENGINES + +DBD::File currently supports two SQL engines: L<SQL::Statement|SQL::Statement> +and L<DBI::SQL::Nano::Statement_|DBI::SQL::Nano>. DBI::SQL::Nano supports a +I<very> limited subset of SQL statements, but it might be faster for some +very simple tasks. SQL::Statement in contrast supports a much larger subset +of ANSI SQL. + +To use SQL::Statement, you need at least version 1.28 of +SQL::Statement and the environment variable C<DBI_SQL_NANO> must not +be set to a true value. + +=head1 KNOWN BUGS AND LIMITATIONS + +=over 4 + +=item * + +This module uses flock () internally but flock is not available on all +platforms. On MacOS and Windows 95 there is no locking at all (perhaps +not so important on MacOS and Windows 95, as there is only a single +user). + +=item * + +The module stores details about the handled tables in a private area +of the driver handle (C<$drh>). This data area is not shared between +different driver instances, so several C<< DBI->connect () >> calls will +cause different table instances and private data areas. + +This data area is filled for the first time when a table is accessed, +either via an SQL statement or via C<table_info> and is not +destroyed until the table is dropped or the driver handle is released. +Manual destruction is possible via L<f_clear_meta>. + +The following attributes are preserved in the data area and will +evaluated instead of driver globals: + +=over 8 + +=item f_ext + +=item f_dir + +=item f_lock + +=item f_lockfile + +=item f_encoding + +=item f_schema + +=item col_names + +=item sql_identifier_case + +=back + +The following attributes are preserved in the data area only and +cannot be set globally. + +=over 8 + +=item f_file + +=back + +The following attributes are preserved in the data area only and are +computed when initializing the data area: + +=over 8 + +=item f_fqfn + +=item f_fqbn + +=item f_fqln + +=item table_name + +=back + +For DBD::CSV tables this means, once opened "foo.csv" as table named "foo", +another table named "foo" accessing the file "foo.txt" cannot be opened. +Accessing "foo" will always access the file "foo.csv" in memorized +C<f_dir>, locking C<f_lockfile> via memorized C<f_lock>. + +You can use L<f_clear_meta> or the C<f_file> attribute for a specific table +to work around this. + +=item * + +When used with SQL::Statement and temporary tables e.g., + + CREATE TEMP TABLE ... + +the table data processing bypasses DBD::File::Table. No file system +calls will be made and there are no clashes with existing (file based) +tables with the same name. Temporary tables are chosen over file +tables, but they will not covered by C<table_info>. + +=back + +=head1 AUTHOR + +This module is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original author is Jochen Wiedmann. + +=head1 COPYRIGHT AND LICENSE + + Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack + Copyright (C) 2004-2009 by Jeff Zucker + Copyright (C) 1998-2004 by Jochen Wiedmann + +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. + +=head1 SEE ALSO + +L<DBI|DBI>, L<DBD::DBM|DBD::DBM>, L<DBD::CSV|DBD::CSV>, L<Text::CSV|Text::CSV>, +L<Text::CSV_XS|Text::CSV_XS>, L<SQL::Statement|SQL::Statement>, and +L<DBI::SQL::Nano|DBI::SQL::Nano> + +=cut diff --git a/lib/DBD/File/Developers.pod b/lib/DBD/File/Developers.pod new file mode 100644 index 0000000..a9bef85 --- /dev/null +++ b/lib/DBD/File/Developers.pod @@ -0,0 +1,556 @@ +=head1 NAME + +DBD::File::Developers - Developers documentation for DBD::File + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBD::File); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + sub CLONE { ... } + + package DBD::myDriver::dr; + + @ISA = qw(DBD::File::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBD::File::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBD::File::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBD::File::Statement); + + package DBD::myDriver::Table; + + @ISA = qw(DBD::File::Table); + + my %reset_on_modify = ( + myd_abc => "myd_foo", + myd_mno => "myd_bar", + ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + my %compat_map = ( + abc => 'foo_abc', + xyz => 'foo_xyz', + ); + __PACKAGE__->register_compat_map( \%compat_map ); + + sub bootstrap_table_meta { ... } + sub init_table_meta { ... } + sub table_meta_attr_changed { ... } + sub open_file { ... } + + sub fetch_row { ... } + sub push_row { ... } + sub push_names { ... } + + # optimize the SQL engine by add one or more of + sub update_current_row { ... } + # or + sub update_specific_row { ... } + # or + sub update_one_row { ... } + # or + sub insert_new_row { ... } + # or + sub delete_current_row { ... } + # or + sub delete_one_row { ... } + +=head1 DESCRIPTION + +This document describes how DBD developers can write DBD::File based DBI +drivers. It supplements L<DBI::DBD> and L<DBI::DBD::SqlEngine::Developers>, +which you should read first. + +=head1 CLASSES + +Each DBI driver must provide a package global C<driver> method and three +DBI related classes: + +=over 4 + +=item DBD::File::dr + +Driver package, contains the methods DBI calls indirectly via DBI +interface: + + DBI->connect ('DBI:DBM:', undef, undef, {}) + + # invokes + package DBD::DBM::dr; + @DBD::DBM::dr::ISA = qw(DBD::File::dr); + + sub connect ($$;$$$) + { + ... + } + +Similar for C<< data_sources () >> and C<< disconnect_all() >>. + +Pure Perl DBI drivers derived from DBD::File do not usually need to +override any of the methods provided through the DBD::XXX::dr package +however if you need additional initialization in the connect method +you may need to. + +=item DBD::File::db + +Contains the methods which are called through DBI database handles +(C<< $dbh >>). e.g., + + $sth = $dbh->prepare ("select * from foo"); + # returns the f_encoding setting for table foo + $dbh->csv_get_meta ("foo", "f_encoding"); + +DBD::File provides the typical methods required here. Developers who +write DBI drivers based on DBD::File need to override the methods C<< +set_versions >> and C<< init_valid_attributes >>. + +=item DBD::File::st + +Contains the methods to deal with prepared statement handles. e.g., + + $sth->execute () or die $sth->errstr; + +=back + +=head2 DBD::File + +This is the main package containing the routines to initialize +DBD::File based DBI drivers. Primarily the C<< DBD::File::driver >> +method is invoked, either directly from DBI when the driver is +initialized or from the derived class. + + package DBD::DBM; + + use base qw( DBD::File ); + + sub driver + { + my ( $class, $attr ) = @_; + ... + my $drh = $class->SUPER::driver( $attr ); + ... + return $drh; + } + +It is not necessary to implement your own driver method as long as +additional initialization (e.g. installing more private driver +methods) is not required. You do not need to call C<< setup_driver >> +as DBD::File takes care of it. + +=head2 DBD::File::dr + +The driver package contains the methods DBI calls indirectly via the DBI +interface (see L<DBI/DBI Class Methods>). + +DBD::File based DBI drivers usually do not need to implement anything here, +it is enough to do the basic initialization: + + package DBD:XXX::dr; + + @DBD::XXX::dr::ISA = qw (DBD::File::dr); + $DBD::XXX::dr::imp_data_size = 0; + $DBD::XXX::dr::data_sources_attr = undef; + $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; + +=head2 DBD::File::db + +This package defines the database methods, which are called via the DBI +database handle C<< $dbh >>. + +Methods provided by DBD::File: + +=over 4 + +=item ping + +Simply returns the content of the C<< Active >> attribute. Override +when your driver needs more complicated actions here. + +=item prepare + +Prepares a new SQL statement to execute. Returns a statement handle, +C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor +recommended to override this method. + +=item FETCH + +Fetches an attribute of a DBI database object. Private handle attributes +must have a prefix (this is mandatory). If a requested attribute is +detected as a private attribute without a valid prefix, the driver prefix +(written as C<$drv_prefix>) is added. + +The driver prefix is extracted from the attribute name and verified against +C<< $dbh->{ $drv_prefix . "valid_attrs" } >> (when it exists). If the +requested attribute value is not listed as a valid attribute, this method +croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ +$drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the +attribute value is returned. So it's not possible to modify +C<f_valid_attrs> from outside of DBD::File::db or a derived class. + +=item STORE + +Stores a database private attribute. Private handle attributes must have a +prefix (this is mandatory). If a requested attribute is detected as a private +attribute without a valid prefix, the driver prefix (written as +C<$drv_prefix>) is added. If the database handle has an attribute +C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in +that hash, this method croaks. If the database handle has an attribute +C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there +can be stored (once they are initialized). Trying to overwrite such an +immutable attribute forces this method to croak. + +An example of a valid attributes list can be found in +C<< DBD::File::db::init_valid_attributes >>. + +=item set_versions + +This method sets the attribute C<f_version> with the version of DBD::File. + +This method is called at the begin of the C<connect ()> phase. + +When overriding this method, do not forget to invoke the superior one. + +=item init_valid_attributes + +This method is called after the database handle is instantiated as the +first attribute initialization. + +C<< DBD::File::db::init_valid_attributes >> initializes the attributes +C<f_valid_attrs> and C<f_readonly_attrs>. + +When overriding this method, do not forget to invoke the superior one, +preferably before doing anything else. Compatibility table attribute +access must be initialized here to allow DBD::File to instantiate the +map tie: + + # for DBD::CSV + $dbh->{csv_meta} = "csv_tables"; + # for DBD::DBM + $dbh->{dbm_meta} = "dbm_tables"; + # for DBD::AnyData + $dbh->{ad_meta} = "ad_tables"; + +=item init_default_attributes + +This method is called after the database handle is instantiated to +initialize the default attributes. + +C<< DBD::File::db::init_default_attributes >> initializes the attributes +C<f_dir>, C<f_meta>, C<f_meta_map>, C<f_version>. + +When the derived implementor class provides the attribute to validate +attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute +containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} += {...}; >>), the attributes C<drv_valid_attrs>, C<drv_readonly_attrs>, +C<drv_version> and C<drv_meta> are added (when available) to the list of +valid and immutable attributes (where C<drv_> is interpreted as the driver +prefix). + +If C<drv_meta> is set, an attribute with the name in C<drv_meta> is +initialized providing restricted read/write access to the meta data of the +tables using C<DBD::File::TieTables> in the first (table) level and +C<DBD::File::TieMeta> for the meta attribute level. C<DBD::File::TieTables> +uses C<DBD::DRV::Table::get_table_meta> to initialize the second level +tied hash on FETCH/STORE. The C<DBD::File::TieMeta> class uses +C<DBD::DRV::Table::get_table_meta_attr> to FETCH attribute values and +C<DBD::DRV::Table::set_table_meta_attr> to STORE attribute values. This +allows it to map meta attributes for compatibility reasons. + +=item get_single_table_meta + +=item get_file_meta + +Retrieve an attribute from a table's meta information. The method +signature is C<< get_file_meta ($dbh, $table, $attr) >>. This method +is called by the injected db handle method C<< ${drv_prefix}get_meta +>>. + +While get_file_meta allows C<$table> or C<$attr> to be a list of tables or +attributes to retrieve, get_single_table_meta allows only one table name +and only one attribute name. A table name of C<'.'> (single dot) is +interpreted as the default table and this will retrieve the appropriate +attribute globally from the dbh. This has the same restrictions as +C<< $dbh->{$attrib} >>. + +get_file_meta allows C<'+'> and C<'*'> as wildcards for table names and +C<$table> being a regular expression matching against the table names +(evaluated without the default table). The table name C<'*'> is +I<all currently known tables, including the default one>. The table +name C<'+'> is I<all table names which conform to +ANSI file name restrictions> (/^[_A-Za-z0-9]+$/). + +The table meta information is retrieved using the get_table_meta and +get_table_meta_attr methods of the table class of the implementation. + +=item set_single_table_meta + +=item set_file_meta + +Sets an attribute in a table's meta information. The method signature is +C<< set_file_meta ($dbh, $table, $attr, $value) >>. This method is called +by the injected db handle method C<< ${drv_prefix}set_meta >>. + +While set_file_meta allows C<$table> to be a list of tables and C<$attr> +to be a hash of several attributes to set, set_single_table_meta allows +only one table name and only one attribute name/value pair. + +The wildcard characters for the table name are the same as for +get_file_meta. + +The table meta information is updated using the get_table_meta and +set_table_meta_attr methods of the table class of the implementation. + +=item clear_file_meta + +Clears all meta information cached about a table. The method signature is +C<< clear_file_meta ($dbh, $table) >>. This method is called +by the injected db handle method C<< ${drv_prefix}clear_meta >>. + +=back + +=head2 DBD::File::st + +Contains the methods to deal with prepared statement handles: + +=over 4 + +=item FETCH + +Fetches statement handle attributes. Supported attributes (for full overview +see L<DBI/Statement Handle Attributes>) are C<NAME>, C<TYPE>, C<PRECISION> +and C<NULLABLE> in case that SQL::Statement is used as SQL execution engine +and a statement is successful prepared. When SQL::Statement has additional +information about a table, those information are returned. Otherwise, the +same defaults as in L<DBI::DBD::SqlEngine> are used. + +This method usually requires extending in a derived implementation. +See L<DBD::CSV> or L<DBD::DBM> for some example. + +=back + +=head2 DBD::File::Statement + +Derives from DBI::SQL::Nano::Statement to provide following method: + +=over 4 + +=item open_table + +Implements the open_table method required by L<SQL::Statement> and +L<DBI::SQL::Nano>. All the work for opening the file(s) belonging to the +table is handled and parameterized in DBD::File::Table. Unless you intend +to add anything to the following implementation, an empty DBD::XXX::Statement +package satisfies DBD::File. + + sub open_table ($$$$$) + { + my ($self, $data, $table, $createMode, $lockMode) = @_; + + my $class = ref $self; + $class =~ s/::Statement/::Table/; + + my $flags = { + createMode => $createMode, + lockMode => $lockMode, + }; + $self->{command} eq "DROP" and $flags->{dropMode} = 1; + + return $class->new ($data, { table => $table }, $flags); + } # open_table + +=back + +=head2 DBD::File::Table + +Derives from DBI::SQL::Nano::Table and provides physical file access for +the table data which are stored in the files. + +=over 4 + +=item file2table + +This method tries to map a filename to the associated table +name. It is called with a partially filled meta structure for the +resulting table containing at least the following attributes: +C<< f_ext >>, C<< f_dir >>, C<< f_lockfile >> and C<< sql_identifier_case >>. + +If a file/table map can be found then this method sets the C<< f_fqfn +>>, C<< f_fqbn >>, C<< f_fqln >> and C<< table_name >> attributes in +the meta structure. If a map cannot be found the table name will be +undef. + +=item bootstrap_table_meta + +Initializes a table meta structure. Can be safely overridden in a +derived class, as long as the C<< SUPER >> method is called at the end +of the overridden method. + +It copies the following attributes from the database into the table meta data +C<< f_dir >>, C<< f_ext >>, C<< f_encoding >>, C<< f_lock >>, C<< f_schema >>, +C<< f_lockfile >> and C<< sql_identifier_case >> and makes them sticky to the +table. + +This method should be called before you attempt to map between file +name and table name to ensure the correct directory, extension etc. are +used. + +=item init_table_meta + +Initializes more attributes of the table meta data - usually more +expensive ones (e.g. those which require class instantiations) - when +the file name and the table name could mapped. + +=item get_table_meta + +Returns the table meta data. If there are none for the required +table, a new one is initialized. When it fails, nothing is +returned. On success, the name of the table and the meta data +structure is returned. + +=item get_table_meta_attr + +Returns a single attribute from the table meta data. If the attribute +name appears in C<%compat_map>, the attribute name is updated from +there. + +=item set_table_meta_attr + +Sets a single attribute in the table meta data. If the attribute +name appears in C<%compat_map>, the attribute name is updated from +there. + +=item table_meta_attr_changed + +Called when an attribute of the meta data is modified. + +If the modified attribute requires to reset a calculated attribute, the +calculated attribute is reset (deleted from meta data structure) and +the I<initialized> flag is removed, too. The decision is made based on +C<%register_reset_on_modify>. + +=item register_reset_on_modify + +Allows C<set_table_meta_attr> to reset meta attributes when special +attributes are modified. For DBD::File, modifying one of C<f_file>, C<f_dir>, +C<f_ext> or C<f_lockfile> will reset C<f_fqfn>. DBD::DBM extends the +list for C<dbm_type> and C<dbm_mldbm> to reset the value of C<dbm_tietype>. + +If your DBD has calculated values in the meta data area, then call +C<register_reset_on_modify>: + + my %reset_on_modify = ( "xxx_foo" => "xxx_bar" ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +=item register_compat_map + +Allows C<get_table_meta_attr> and C<set_table_meta_attr> to update the +attribute name to the current favored one: + + # from DBD::DBM + my %compat_map = ( "dbm_ext" => "f_ext" ); + __PACKAGE__->register_compat_map( \%compat_map ); + +=item open_file + +Called to open the table's data file. + +Depending on the attributes set in the table's meta data, the +following steps are performed. Unless C<< f_dontopen >> is set to a +true value, C<< f_fqfn >> must contain the full qualified file name +for the table to work on (file2table ensures this). The encoding in +C<< f_encoding >> is applied if set and the file is opened. If +C<<f_fqln >> (full qualified lock name) is set, this file is opened, +too. Depending on the value in C<< f_lock >>, the appropriate lock is +set on the opened data file or lock file. + +After this is done, a derived class might add more steps in an overridden +C<< open_file >> method. + +=item new + +Instantiates the table. This is done in 3 steps: + + 1. get the table meta data + 2. open the data file + 3. bless the table data structure using inherited constructor new + +It is not recommended to override the constructor of the table class. +Find a reasonable place to add you extensions in one of the above four +methods. + +=item drop + +Implements the abstract table method for the C<< DROP >> +command. Discards table meta data after all files belonging to the +table are closed and unlinked. + +Overriding this method might be reasonable in very rare cases. + +=item seek + +Implements the abstract table method used when accessing the table from the +engine. C<< seek >> is called every time the engine uses dumb algorithms +for iterating over the table content. + +=item truncate + +Implements the abstract table method used when dumb table algorithms +for C<< UPDATE >> or C<< DELETE >> need to truncate the table storage +after the last written row. + +=back + +You should consult the documentation of C<< SQL::Eval::Table >> (see +L<SQL::Eval>) to get more information about the abstract methods of the +table's base class you have to override and a description of the table +meta information expected by the SQL engines. + +=head1 AUTHOR + +The module DBD::File is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original author is Jochen Wiedmann. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +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. + +=cut diff --git a/lib/DBD/File/HowTo.pod b/lib/DBD/File/HowTo.pod new file mode 100644 index 0000000..3d45257 --- /dev/null +++ b/lib/DBD/File/HowTo.pod @@ -0,0 +1,270 @@ +=head1 NAME + +DBD::File::HowTo - Guide to create DBD::File based driver + +=head1 SYNOPSIS + + perldoc DBD::File::HowTo + perldoc DBI + perldoc DBI::DBD + perldoc DBD::File::Developers + perldoc DBI::DBD::SqlEngine::Developers + perldoc DBI::DBD::SqlEngine + perldoc SQL::Eval + perldoc DBI::DBD::SqlEngine::HowTo + perldoc SQL::Statement::Embed + perldoc DBD::File + perldoc DBD::File::HowTo + perldoc DBD::File::Developers + +=head1 DESCRIPTION + +This document provides a step-by-step guide, how to create a new +C<DBD::File> based DBD. It expects that you carefully read the L<DBI> +documentation and that you're familiar with L<DBI::DBD> and had read and +understood L<DBD::ExampleP>. + +This document addresses experienced developers who are really sure that +they need to invest time when writing a new DBI Driver. Writing a DBI +Driver is neither a weekend project nor an easy job for hobby coders +after work. Expect one or two man-month of time for the first start. + +Those who are still reading, should be able to sing the rules of +L<DBI::DBD/CREATING A NEW DRIVER>. + +Of course, DBD::File is a DBI::DBD::SqlEngine and you surely read +L<DBI::DBD::SqlEngine::HowTo> before continuing here. + +=head1 CREATING DRIVER CLASSES + +Do you have an entry in DBI's DBD registry? For this guide, a prefix of +C<foo_> is assumed. + +=head2 Sample Skeleton + + package DBD::Foo; + + use strict; + use warnings; + use vars qw(@ISA $VERSION); + use base qw(DBD::File); + + use DBI (); + + $VERSION = "0.001"; + + package DBD::Foo::dr; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::dr); + $imp_data_size = 0; + + package DBD::Foo::db; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::db); + $imp_data_size = 0; + + package DBD::Foo::st; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBD::File::st); + $imp_data_size = 0; + + package DBD::Foo::Statement; + + use vars qw(@ISA); + + @ISA = qw(DBD::File::Statement); + + package DBD::Foo::Table; + + use vars qw(@ISA); + + @ISA = qw(DBD::File::Table); + + 1; + +Tiny, eh? And all you have now is a DBD named foo which will is able to +deal with temporary tables, as long as you use L<SQL::Statement>. In +L<DBI::SQL::Nano> environments, this DBD can do nothing. + +=head2 Start over + +Based on L<DBI::DBD::SqlEngine::HowTo>, we're now having a driver which +could do basic things. Of course, it should now derive from DBD::File +instead of DBI::DBD::SqlEngine, shouldn't it? + +DBD::File extends DBI::DBD::SqlEngine to deal with any kind of files. +In principle, the only extensions required are to the table class: + + package DBD::Foo::Table; + + sub bootstrap_table_meta + { + my ( $self, $dbh, $meta, $table ) = @_; + + # initialize all $meta attributes which might be relevant for + # file2table + + return $self->SUPER::bootstrap_table_meta($dbh, $meta, $table); + } + + sub init_table_meta + { + my ( $self, $dbh, $meta, $table ) = @_; + + # called after $meta contains the results from file2table + # initialize all missing $meta attributes + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); + } + +In case C<DBD::File::Table::open_file> doesn't open the files as the driver +needs that, override it! + + sub open_file + { + my ( $self, $meta, $attrs, $flags ) = @_; + # ensure that $meta->{f_dontopen} is set + $self->SUPER::open_file( $meta, $attrs, $flags ); + # now do what ever needs to be done + } + +Combined with the methods implemented using the L<SQL::Statement::Embed> +guide, the table is full working and you could try a start over. + +=head2 User comfort + +C<DBD::File> since C<0.39> consolidates all persistent meta data of a table +into a single structure stored in C<< $dbh->{f_meta} >>. While DBD::File +provides only readonly access to this structure, modifications are still +allowed. + +Primarily DBD::File provides access via setters C<get_file_meta>, +C<set_file_meta> and C<clear_file_meta>. Those methods are easily +accessible by the users via the C<< $dbh->func () >> interface provided +by DBI. Well, many users don't feel comfortize when calling + + # don't require extension for tables cars + $dbh->func ("cars", "f_ext", ".csv", "set_file_meta"); + +DBD::File will inject a method into your driver to increase the user +comfort to allow: + + # don't require extension for tables cars + $dbh->foo_set_meta ("cars", "f_ext", ".csv"); + +Better, but here and there users likes to do: + + # don't require extension for tables cars + $dbh->{foo_tables}->{cars}->{f_ext} = ".csv"; + +This interface is provided when derived DBD's define following in +C<init_valid_attributes> (please compare carefully with the example in +DBI::DBD::SqlEngine::HowTo): + + sub init_valid_attributes + { + my $dbh = $_[0]; + + $dbh->SUPER::init_valid_attributes (); + + $dbh->{foo_valid_attrs} = { + foo_version => 1, # contains version of this driver + foo_valid_attrs => 1, # contains the valid attributes of foo drivers + foo_readonly_attrs => 1, # contains immutable attributes of foo drivers + foo_bar => 1, # contains the bar attribute + foo_baz => 1, # contains the baz attribute + foo_manager => 1, # contains the manager of the driver instance + foo_manager_type => 1, # contains the manager class of the driver instance + foo_meta => 1, # contains the public interface to modify table meta attributes + }; + $dbh->{foo_readonly_attrs} = { + foo_version => 1, # ensure no-one modifies the driver version + foo_valid_attrs => 1, # do not permit to add more valid attributes ... + foo_readonly_attrs => 1, # ... or make the immutable mutable + foo_manager => 1, # manager is set internally only + foo_meta => 1, # ensure public interface to modify table meta attributes are immutable + }; + + $dbh->{foo_meta} = "foo_tables"; + + return $dbh; + } + +This provides a tied hash in C<< $dbh->{foo_tables} >> and a tied hash for +each table's meta data in C<< $dbh->{foo_tables}->{$table_name} >>. +Modifications on the table meta attributes are done using the table +methods: + + sub get_table_meta_attr { ... } + sub set_table_meta_attr { ... } + +Both methods can adjust the attribute name for compatibility reasons, e.g. +when former versions of the DBD allowed different names to be used for the +same flag: + + my %compat_map = ( + abc => 'foo_abc', + xyz => 'foo_xyz', + ); + __PACKAGE__->register_compat_map( \%compat_map ); + +If any user modification on a meta attribute needs reinitialization of +the meta structure (in case of C<DBD::File> these are the attributes +C<f_file>, C<f_dir>, C<f_ext> and C<f_lockfile>), inform DBD::File by +doing + + my %reset_on_modify = ( + foo_xyz => "foo_bar", + foo_abc => "foo_bar", + ); + __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +The next access to the table meta data will force DBD::File to re-do the +entire meta initialization process. + +Any further action which needs to be taken can handled in +C<table_meta_attr_changed>: + + sub table_meta_attr_changed + { + my ($class, $meta, $attrib, $value) = @_; + ... + $class->SUPER::table_meta_attr_changed ($meta, $attrib, $value); + } + +This is done before the new value is set in C<$meta>, so the attribute +changed handler can act depending on the old value. + +=head2 Testing + +Now you should have your own DBD::File based driver. Was easy, wasn't it? +But does it work well? Prove it by writing tests and remember to use +dbd_edit_mm_attribs from L<DBI::DBD> to ensure testing even rare cases. + +=head1 AUTHOR + +This guide is written by Jens Rehsack. DBD::File is written by Jochen +Wiedmann and Jeff Zucker. + +The module DBD::File is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +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. + +=cut diff --git a/lib/DBD/File/Roadmap.pod b/lib/DBD/File/Roadmap.pod new file mode 100644 index 0000000..804d759 --- /dev/null +++ b/lib/DBD/File/Roadmap.pod @@ -0,0 +1,176 @@ +=head1 NAME + +DBD::File::Roadmap - Planned Enhancements for DBD::File and pure Perl DBD's + +Jens Rehsack - May 2010 + +=head1 SYNOPSIS + +This document gives a high level overview of the future of the DBD::File DBI +driver and groundwork for pure Perl DBI drivers. + +The planned enhancements cover features, testing, performance, reliability, +extensibility and more. + +=head1 CHANGES AND ENHANCEMENTS + +=head2 Features + +There are some features missing we would like to add, but there is +no time plan: + +=over 4 + +=item LOCK TABLE + +The newly implemented internal common table meta storage area would allow +us to implement LOCK TABLE support based on file system C<flock ()> +support. + +=item Transaction support + +While DBD::AnyData recommends explicitly committing by importing and +exporting tables, DBD::File might be enhanced in a future version to allow +transparent transactions using the temporary tables of SQL::Statement as +shadow (dirty) tables. + +Transaction support will heavily rely on lock table support. + +=item Data Dictionary Persistence + +SQL::Statement provides dictionary information when a "CREATE TABLE ..." +statement is executed. This dictionary is preserved for some statement +handle attribute fetches (as C<NULLABLE> or C<PRECISION>). + +It is planned to extend DBD::File to support data dictionaries to work +on the tables in it. It is not planned to support one table in different +dictionaries, but you can have several dictionaries in one directory. + +=item SQL Engine selecting on connect + +Currently the SQL engine selected is chosen during the loading of the module +L<DBI::SQL::Nano>. Ideally end users should be able to select the engine +used in C<< DBI->connect () >> with a special DBD::File attribute. + +=back + +Other points of view to the planned features (and more features for the +SQL::Statement engine) are shown in L<SQL::Statement::Roadmap>. + +=head2 Testing + +DBD::File and the dependent DBD::DBM requires a lot more automated tests +covering API stability and compatibility with optional modules +like SQL::Statement. + +=head2 Performance + +Several arguments for support of features like indexes on columns +and cursors are made for DBD::CSV (which is a DBD::File based driver, +too). Similar arguments could be made for DBD::DBM, DBD::AnyData, +DBD::RAM or DBD::PO etc. + +To improve the performance of the underlying SQL engines, a clean +reimplementation seems to be required. Currently both engines are +prematurely optimized and therefore it is not trivial to provide +further optimization without the risk of breaking existing features. + +Join the DBI developers IRC channel at L<irc://irc.perl.org/dbi> to +participate or post to the DBI Developers Mailing List. + +=head2 Reliability + +DBD::File currently lacks the following points: + +=over 4 + +=item duplicate table names + +It is currently possible to access a table quoted with a relative path +(a) and additionally using an absolute path (b). If (a) and (b) are +the same file that is not recognized (except for +flock protection handled by the Operating System) and two independent +tables are handled. + +=item invalid table names + +The current implementation does not prevent someone choosing a +directory name as a physical file name for the table to open. + +=back + +=head2 Extensibility + +I (Jens Rehsack) have some (partially for example only) DBD's in mind: + +=over 4 + +=item DBD::Sys + +Derive DBD::Sys from a common code base shared with DBD::File which handles +all the emulation DBI needs (as getinfo, SQL engine handling, ...) + +=item DBD::Dir + +Provide a DBD::File derived to work with fixed table definitions through the +file system to demonstrate how DBI / Pure Perl DBDs could handle databases +with hierarchical structures. + +=item DBD::Join + +Provide a DBI driver which is able to manage multiple connections to other +Databases (as DBD::Multiplex), but allow them to point to different data +sources and allow joins between the tables of them: + + # Example + # Let table 'lsof' being a table in DBD::Sys giving a list of open files using lsof utility + # Let table 'dir' being a atable from DBD::Dir + $sth = $dbh->prepare( "select * from dir,lsof where path='/documents' and dir.entry = lsof.filename" ) + $sth->execute(); # gives all open files in '/documents' + ... + + # Let table 'filesys' a DBD::Sys table of known file systems on current host + # Let table 'applications' a table of your Configuration Management Database + # where current applications (relocatable, with mountpoints for filesystems) + # are stored + $sth = dbh->prepare( "select * from applications,filesys where " . + "application.mountpoint = filesys.mountpoint and ". + "filesys.mounted is true" ); + $sth->execute(); # gives all currently mounted applications on this host + +=back + +=head1 PRIORITIES + +Our priorities are focussed on current issues. Initially many new test +cases for DBD::File and DBD::DBM should be added to the DBI test +suite. After that some additional documentation on how to use the +DBD::File API will be provided. + +Any additional priorities will come later and can be modified by (paying) +users. + +=head1 RESOURCES AND CONTRIBUTIONS + +See L<http://dbi.perl.org/contributing> for I<how you can help>. + +If your company has benefited from DBI, please consider if +it could make a donation to The Perl Foundation "DBI Development" +fund at L<http://dbi.perl.org/donate> to secure future development. + +Alternatively, if your company would benefit from a specific new +DBI feature, please consider sponsoring it's development through +the options listed in the section "Commercial Support from the Author" +on L<http://dbi.perl.org/support/>. + +Using such targeted financing allows you to contribute to DBI +development and rapidly get something specific and directly valuable +to you in return. + +My company also offers annual support contracts for the DBI, which +provide another way to support the DBI and get something specific +in return. Contact me for details. + +Thank you. + +=cut diff --git a/lib/DBD/Gofer.pm b/lib/DBD/Gofer.pm new file mode 100644 index 0000000..afd8201 --- /dev/null +++ b/lib/DBD/Gofer.pm @@ -0,0 +1,1292 @@ +{ + package DBD::Gofer; + + use strict; + + require DBI; + require DBI::Gofer::Request; + require DBI::Gofer::Response; + require Carp; + + our $VERSION = sprintf("0.%06d", q$Revision: 15326 $ =~ /(\d+)/o); + +# $Id: Gofer.pm 15326 2012-06-06 16:32:38Z timbo $ +# +# Copyright (c) 2007, 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. + + + + # attributes we'll allow local STORE + our %xxh_local_store_attrib = map { $_=>1 } qw( + Active + CachedKids + Callbacks + DbTypeSubclass + ErrCount Executed + FetchHashKeyName + HandleError HandleSetErr + InactiveDestroy + AutoInactiveDestroy + PrintError PrintWarn + Profile + RaiseError + RootClass + ShowErrorStatement + Taint TaintIn TaintOut + TraceLevel + Warn + dbi_quote_identifier_cache + dbi_connect_closure + dbi_go_execute_unique + ); + our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw( + Username + dbi_connect_method + ); + + our $drh = undef; # holds driver handle once initialized + our $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBI->setup_driver('DBD::Gofer'); + + unless ($methods_already_installed++) { + my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR + DBD::Gofer::db->install_method('go_dbh_method', $opts); + DBD::Gofer::st->install_method('go_sth_method', $opts); + DBD::Gofer::st->install_method('go_clone_sth', $opts); + DBD::Gofer::db->install_method('go_cache', $opts); + DBD::Gofer::st->install_method('go_cache', $opts); + } + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Gofer', + 'Version' => $VERSION, + 'Attribution' => 'DBD Gofer by Tim Bunce', + }); + + $drh; + } + + + sub CLONE { + undef $drh; + } + + + sub go_cache { + my $h = shift; + $h->{go_cache} = shift if @_; + # return handle's override go_cache, if it has one + return $h->{go_cache} if defined $h->{go_cache}; + # or else the transports default go_cache + return $h->{go_transport}->{go_cache}; + } + + + sub set_err_from_response { # set error/warn/info and propagate warnings + my $h = shift; + my $response = shift; + if (my $warnings = $response->warnings) { + warn $_ for @$warnings; + } + my ($err, $errstr, $state) = $response->err_errstr_state; + # Only set_err() if there's an error else leave the current values + # (The current values will normally be set undef by the DBI dispatcher + # except for methods marked KEEPERR such as ping.) + $h->set_err($err, $errstr, $state) if defined $err; + return undef; + } + + + sub install_methods_proxy { + my ($installed_methods) = @_; + while ( my ($full_method, $attr) = each %$installed_methods ) { + # need to install both a DBI dispatch stub and a proxy stub + # (the dispatch stub may be already here due to local driver use) + + DBI->_install_method($full_method, "", $attr||{}) + unless defined &{$full_method}; + + # now install proxy stubs on the driver side + $full_method =~ m/^DBI::(\w\w)::(\w+)$/ + or die "Invalid method name '$full_method' for install_method"; + my ($type, $method) = ($1, $2); + my $driver_method = "DBD::Gofer::${type}::${method}"; + next if defined &{$driver_method}; + my $sub; + if ($type eq 'db') { + $sub = sub { return shift->go_dbh_method(undef, $method, @_) }; + } + else { + $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; }; + } + no strict 'refs'; + *$driver_method = $sub; + } + } +} + + +{ package DBD::Gofer::dr; # ====== DRIVER ====== + + $imp_data_size = 0; + use strict; + + sub connect_cached { + my ($drh, $dsn, $user, $auth, $attr)= @_; + $attr ||= {}; + return $drh->SUPER::connect_cached($dsn, $user, $auth, { + (%$attr), + go_connect_method => $attr->{go_connect_method} || 'connect_cached', + }); + } + + + sub connect { + my($drh, $dsn, $user, $auth, $attr)= @_; + my $orig_dsn = $dsn; + + # first remove dsn= and everything after it + my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1) + or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'"); + + if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection + # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t + return DBI->connect($remote_dsn, $user, $auth, $attr); + } + + my %go_attr; + # extract any go_ attributes from the connect() attr arg + for my $k (grep { /^go_/ } keys %$attr) { + $go_attr{$k} = delete $attr->{$k}; + } + # then override those with any attributes embedded in our dsn (not remote_dsn) + for my $kv (grep /=/, split /;/, $dsn, -1) { + my ($k, $v) = split /=/, $kv, 2; + $go_attr{ "go_$k" } = $v; + } + + if (not ref $go_attr{go_policy}) { # if not a policy object already + my $policy_class = $go_attr{go_policy} || 'classic'; + $policy_class = "DBD::Gofer::Policy::$policy_class" + unless $policy_class =~ /::/; + _load_class($policy_class) + or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@"); + # replace policy name in %go_attr with policy object + $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@"); + } + # policy object is left in $go_attr{go_policy} so transport can see it + my $go_policy = $go_attr{go_policy}; + + if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already + my $cache_class = $go_attr{go_cache}; + $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1'; + _load_class($cache_class) + or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@"); + $go_attr{go_cache} = eval { $cache_class->new() } + or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning + } + + # delete any other attributes that don't apply to transport + my $go_connect_method = delete $go_attr{go_connect_method}; + + my $transport_class = delete $go_attr{go_transport} + or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'"); + $transport_class = "DBD::Gofer::Transport::$transport_class" + unless $transport_class =~ /::/; + _load_class($transport_class) + or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@"); + my $go_transport = eval { $transport_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@"); + + my $request_class = "DBI::Gofer::Request"; + my $go_request = eval { + my $go_attr = { %$attr }; + # XXX user/pass of fwd server vs db server ? also impact of autoproxy + if ($user) { + $go_attr->{Username} = $user; + $go_attr->{Password} = $auth; + } + # delete any attributes we can't serialize (or don't want to) + delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)}; + # delete any attributes that should only apply to the client-side + delete @{$go_attr}{qw(RootClass DbTypeSubclass)}; + + $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect'; + $request_class->new({ + dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ], + }) + } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@"); + + my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + 'USER' => $user, + go_transport => $go_transport, + go_request => $go_request, + go_policy => $go_policy, + }); + + # mark as inactive temporarily for STORE. Active not set until connected() called. + $dbh->STORE(Active => 0); + + # should we ping to check the connection + # and fetch dbh attributes + my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh); + if (not $skip_connect_check) { + if (not $dbh->go_dbh_method(undef, 'ping')) { + return undef if $dbh->err; # error already recorded, typically + return $dbh->set_err($DBI::stderr, "ping failed"); + } + } + + return $dbh; + } + + sub _load_class { # return true or false+$@ + my $class = shift; + (my $pm = $class) =~ s{::}{/}g; + $pm .= ".pm"; + return 1 if eval { require $pm }; + delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough + undef; # error in $@ + } + +} + + +{ package DBD::Gofer::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + use Carp qw(carp croak); + + my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib; + + sub connected { + shift->STORE(Active => 1); + } + + sub go_dbh_method { + my $dbh = shift; + my $meta = shift; + # @_ now contains ($method_name, @args) + + my $request = $dbh->{go_request}; + $request->init_request([ wantarray, @_ ], $dbh); + ++$dbh->{go_request_count}; + + my $go_policy = $dbh->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $transport = $dbh->{go_transport} + or return $dbh->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $dbh->{go_cache} + if defined $dbh->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $dbh->{go_response} = $response + or die "No response object returned by $transport"; + + die "response '$response' returned by $transport is not a response object" + unless UNIVERSAL::isa($response,"DBI::Gofer::Response"); + + if (my $dbh_attributes = $response->dbh_attributes) { + + # XXX installed_methods piggybacks on dbh_attributes for now + if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) { + DBD::Gofer::install_methods_proxy($installed_methods) + if $dbh->{go_request_count}==1; + } + + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + } + + my $rv = $response->rv; + if (my $resultset_list = $response->sth_resultsets) { + # dbh method call returned one or more resultsets + # (was probably a metadata method like table_info) + # + # setup an sth but don't execute/forward it + my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 }); + # set the sth response to our dbh response + (tied %$sth)->{go_response} = $response; + # setup the sth with the results in our response + $sth->more_results; + # and return that new sth as if it came from original request + $rv = [ $sth ]; + } + elsif (!$rv) { # should only occur for major transport-level error + #carp("no rv in response { @{[ %$response ]} }"); + $rv = [ ]; + } + + DBD::Gofer::set_err_from_response($dbh, $response); + + return (wantarray) ? @$rv : $rv->[0]; + } + + + # Methods that should be forwarded but can be cached + for my $method (qw( + tables table_info column_info primary_key_info foreign_key_info statistics_info + data_sources type_info_all get_info + parse_trace_flags parse_trace_flag + func + )) { + my $policy_name = "cache_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + my $rv; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + my $cache; + my $cache_key; + if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) { + $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache + $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0, + join(",\t", map { # XXX basic but sufficient for now + !ref($_) ? DBI::neat($_,1e6) + : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001") + : ref($_) eq 'HASH' ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") } + : do { warn "unhandled argument type ($_)"; $_ } + } @_); + if ($rv = $cache->{$cache_key}) { + $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + return (wantarray) ? @cache_rv : $cache_rv[0]; + } + } + + $rv = [ (wantarray) + ? ($dbh->go_dbh_method(undef, $method, @_)) + : scalar $dbh->go_dbh_method(undef, $method, @_) + ]; + + if ($cache) { + $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + #$cache_rv[0] = $cache_rv[0]->go_clone_sth + # if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + $cache->{$cache_key} = \@cache_rv + unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done + } + + return (wantarray) ? @$rv : $rv->[0]; + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that can use the DBI defaults for some situations/drivers + for my $method (qw( + quote quote_identifier + )) { # XXX keep DBD::Gofer::Policy::Base in sync + my $policy_name = "locally_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + # false: use remote gofer + # 1: use local DBI default method + # code ref: use the code ref + my $locally = $dbh->{go_policy}->$policy_name($dbh, @_); + if ($locally) { + return $locally->($dbh, @_) if ref $locally eq 'CODE'; + return $dbh->$super_name(@_); + } + return $dbh->go_dbh_method(undef, $method, @_); # propagate context + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that should always fail + for my $method (qw( + begin_work commit rollback + )) { + no strict 'refs'; + *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") } + } + + + sub do { + my ($dbh, $sql, $attr, @args) = @_; + delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted" + $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement + my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} }; + return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args); + } + + sub ping { + my $dbh = shift; + return $dbh->set_err(0, "can't ping while not connected") # warning + unless $dbh->SUPER::FETCH('Active'); + my $skip_ping = $dbh->{go_policy}->skip_ping(); + return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_); + } + + sub last_insert_id { + my $dbh = shift; + my $response = $dbh->{go_response} or return undef; + return $response->last_insert_id; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + + # FETCH is effectively already cached because the DBI checks the + # attribute cache in the handle before calling FETCH + # and this FETCH copies the value into the attribute cache + + # forward driver-private attributes (except ours) + if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) { + my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib); + $dbh->{$attrib} = $value; # XXX forces caching by DBI + return $dbh->{$attrib} = $value; + } + + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + if ($attrib eq 'AutoCommit') { + croak "Can't enable transactions when using DBD::Gofer" if !$value; + return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900); + } + return $dbh->SUPER::STORE($attrib => $value) + # we handle this attribute locally + if $dbh_local_store_attrib{$attrib} + # or it's a private_ (application) attribute + or $attrib =~ /^private_/ + # or not yet connected (ie being called by DBI->connect) + or not $dbh->FETCH('Active'); + + return $dbh->SUPER::STORE($attrib => $value) + if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib} + && do { # values are the same + my $crnt = $dbh->FETCH($attrib); + local $^W; + (defined($value) ^ defined($crnt)) + ? 0 # definedness differs + : $value eq $crnt; + }; + + # dbh attributes are set at connect-time - see connect() + carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn'); + return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer"); + } + + sub disconnect { + my $dbh = shift; + $dbh->{go_transport} = undef; + $dbh->STORE(Active => 0); + } + + sub prepare { + my ($dbh, $statement, $attr)= @_; + + return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected") + unless $dbh->FETCH('Active'); + + $attr = { %$attr } if $attr; # copy so we can edit + + my $policy = delete($attr->{go_policy}) || $dbh->{go_policy}; + my $lii_args = delete $attr->{go_last_insert_id_args}; + my $go_prepare = delete($attr->{go_prepare_method}) + || $dbh->{go_prepare_method} + || $policy->prepare_method($dbh, $statement, $attr) + || 'prepare'; # e.g. for code not using placeholders + my $go_cache = delete $attr->{go_cache}; + # set to undef if there are no attributes left for the actual prepare call + $attr = undef if $attr and not %$attr; + + my ($sth, $sth_inner) = DBI::_new_sth($dbh, { + Statement => $statement, + go_prepare_call => [ 0, $go_prepare, $statement, $attr ], + # go_method_calls => [], # autovivs if needed + go_request => $dbh->{go_request}, + go_transport => $dbh->{go_transport}, + go_policy => $policy, + go_last_insert_id_args => $lii_args, + go_cache => $go_cache, + }); + $sth->STORE(Active => 0); + + my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth); + if (not $skip_prepare_check) { + $sth->go_sth_method() or return undef; + } + + return $sth; + } + + sub prepare_cached { + my ($dbh, $sql, $attr, $if_active)= @_; + $attr ||= {}; + return $dbh->SUPER::prepare_cached($sql, { + %$attr, + go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached', + }, $if_active); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + + +{ package DBD::Gofer::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1); + + sub go_sth_method { + my ($sth, $meta) = @_; + + if (my $ParamValues = $sth->{ParamValues}) { + my $ParamAttr = $sth->{ParamAttr}; + # XXX the sort here is a hack to work around a DBD::Sybase bug + # but only works properly for params 1..9 + # (reverse because of the unshift) + my @params = reverse sort keys %$ParamValues; + if (@params > 9 && ($sth->{Database}{go_dsn}||'') =~ /dbi:Sybase/) { + # if more than 9 then we need to do a proper numeric sort + # also warn to alert user of this issue + warn "Sybase param binding order hack in use"; + @params = sort { $b <=> $a } @params; + } + for my $p (@params) { + # unshift to put binds before execute call + unshift @{ $sth->{go_method_calls} }, + [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ]; + } + } + + my $dbh = $sth->{Database} or die "panic"; + ++$dbh->{go_request_count}; + + my $request = $sth->{go_request}; + $request->init_request($sth->{go_prepare_call}, $sth); + $request->sth_method_calls(delete $sth->{go_method_calls}) + if $sth->{go_method_calls}; + $request->sth_result_attr({}); # (currently) also indicates this is an sth request + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $go_policy = $sth->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + my $transport = $sth->{go_transport} + or return $sth->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $sth->{go_cache} + if defined $sth->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $sth->{go_response} = $response + or die "No response object returned by $transport"; + $dbh->{go_response} = $response; # mainly for last_insert_id + + if (my $dbh_attributes = $response->dbh_attributes) { + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + # record the values returned, so we know that we have fetched + # values are which we have fetched (see dbh->FETCH method) + $dbh->{go_dbh_attributes_fetched} = $dbh_attributes; + } + + my $rv = $response->rv; # may be undef on error + if ($response->sth_resultsets) { + # setup first resultset - including sth attributes + $sth->more_results; + } + else { + $sth->STORE(Active => 0); + $sth->{go_rows} = $rv; + } + # set error/warn/info (after more_results as that'll clear err) + DBD::Gofer::set_err_from_response($sth, $response); + + return $rv; + } + + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute' ]; + my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args} }; + return $sth->go_sth_method($meta); + } + + + sub more_results { + my $sth = shift; + + $sth->finish; + + my $response = $sth->{go_response} or do { + # e.g., we haven't sent a request yet (ie prepare then more_results) + $sth->trace_msg(" No response object present", 3); + return; + }; + + my $resultset_list = $response->sth_resultsets + or return $sth->set_err($DBI::stderr, "No sth_resultsets"); + + my $meta = shift @$resultset_list + or return undef; # no more result sets + #warn "more_results: ".Data::Dumper::Dumper($meta); + + # pull out the special non-atributes first + my ($rowset, $err, $errstr, $state) + = delete @{$meta}{qw(rowset err errstr state)}; + + # copy meta attributes into attribute cache + my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS}; + $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS); + # XXX need to use STORE for some? + $sth->{$_} = $meta->{$_} for keys %$meta; + + if (($NUM_OF_FIELDS||0) > 0) { + $sth->{go_rows} = ($rowset) ? @$rowset : -1; + $sth->{go_current_rowset} = $rowset; + $sth->{go_current_rowset_err} = [ $err, $errstr, $state ] + if defined $err; + $sth->STORE(Active => 1) if $rowset; + } + + return $sth; + } + + + sub go_clone_sth { + my ($sth1) = @_; + # clone an (un-fetched-from) sth - effectively undoes the initial more_results + # not 100% so just for use in caching returned sth e.g. table_info + my $sth2 = $sth1->{Database}->prepare($sth1->{Statement}, { go_skip_prepare_check => 1 }); + $sth2->STORE($_, $sth1->{$_}) for qw(NUM_OF_FIELDS Active); + my $sth2_inner = tied %$sth2; + $sth2_inner->{$_} = $sth1->{$_} for qw(NUM_OF_PARAMS FetchHashKeyName); + die "not fully implemented yet"; + return $sth2; + } + + + sub fetchrow_arrayref { + my ($sth) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + return $sth->_set_fbav(shift @$resultset) if @$resultset; + $sth->finish; # no more data so finish + return undef; + } + *fetch = \&fetchrow_arrayref; # alias + + + sub fetchall_arrayref { + my ($sth, $slice, $max_rows) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + my $mode = ref($slice) || 'ARRAY'; + return $sth->SUPER::fetchall_arrayref($slice, $max_rows) + if ref($slice) or defined $max_rows; + $sth->finish; # no more data after this so finish + return $resultset; + } + + + sub rows { + return shift->{go_rows}; + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + + return $sth->SUPER::STORE($attrib => $value) + if $sth_local_store_attrib{$attrib} # handle locally + # or it's a private_ (application) attribute + or $attrib =~ /^private_/; + + # otherwise warn but do it anyway + # this will probably need refining later + my $msg = "Altering \$sth->{$attrib} won't affect proxied handle"; + Carp::carp($msg) if $sth->FETCH('Warn'); + + # XXX could perhaps do + # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ] + # if not $sth->FETCH('Executed'); + # but how to handle repeat executions? How to we know when an + # attribute is being set to affect the current resultset or the + # next execution? + # Could just always use go_method_calls I guess. + + # do the store locally anyway, just in case + $sth->SUPER::STORE($attrib => $value); + + return $sth->set_err($DBI::stderr, $msg); + } + + # sub bind_param_array + # we use DBI's default, which sets $sth->{ParamArrays}{$param} = $value + # and calls bind_param($param, undef, $attr) if $attr. + + sub execute_array { + my $sth = shift; + my $attr = shift; + $sth->bind_param_array($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute_array', $attr ]; + return $sth->go_sth_method($attr); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer - A stateless-proxy driver for communicating with a remote DBI + +=head1 SYNOPSIS + + use DBI; + + $original_dsn = "dbi:..."; # your original DBI Data Source Name + + $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$original_dsn", + $user, $passwd, \%attributes); + + ... use $dbh as if it was connected to $original_dsn ... + + +The C<transport=$transport> part specifies the name of the module to use to +transport the requests to the remote DBI. If $transport doesn't contain any +double colons then it's prefixed with C<DBD::Gofer::Transport::>. + +The C<dsn=$original_dsn> part I<must be the last element> of the DSN because +everything after C<dsn=> is assumed to be the DSN that the remote DBI should +use. + +The C<...> represents attributes that influence the operation of the Gofer +driver or transport. These are described below or in the documentation of the +transport module being used. + +=encoding ISO8859-1 + +=head1 DESCRIPTION + +DBD::Gofer is a DBI database driver that forwards requests to another DBI +driver, usually in a separate process, often on a separate machine. It tries to +be as transparent as possible so it appears that you are using the remote +driver directly. + +DBD::Gofer is very similar to DBD::Proxy. The major difference is that with +DBD::Gofer no state is maintained on the remote end. That means every +request contains all the information needed to create the required state. (So, +for example, every request includes the DSN to connect to.) Each request can be +sent to any available server. The server executes the request and returns a +single response that includes all the data. + +This is very similar to the way http works as a stateless protocol for the web. +Each request from your web browser can be handled by a different web server process. + +=head2 Use Cases + +This may seem like pointless overhead but there are situations where this is a +very good thing. Let's consider a specific case. + +Imagine using DBD::Gofer with an http transport. Your application calls +connect(), prepare("select * from table where foo=?"), bind_param(), and execute(). +At this point DBD::Gofer builds a request containing all the information +about the method calls. It then uses the httpd transport to send that request +to an apache web server. + +This 'dbi execute' web server executes the request (using DBI::Gofer::Execute +and related modules) and builds a response that contains all the rows of data, +if the statement returned any, along with all the attributes that describe the +results, such as $sth->{NAME}. This response is sent back to DBD::Gofer which +unpacks it and presents it to the application as if it had executed the +statement itself. + +=head2 Advantages + +Okay, but you still don't see the point? Well let's consider what we've gained: + +=head3 Connection Pooling and Throttling + +The 'dbi execute' web server leverages all the functionality of web +infrastructure in terms of load balancing, high-availability, firewalls, access +management, proxying, caching. + +At its most basic level you get a configurable pool of persistent database connections. + +=head3 Simple Scaling + +Got thousands of processes all trying to connect to the database? You can use +DBD::Gofer to connect them to your smaller pool of 'dbi execute' web servers instead. + +=head3 Caching + +Client-side caching is as simple as adding "C<cache=1>" to the DSN. +This feature alone can be worth using DBD::Gofer for. + +=head3 Fewer Network Round-trips + +DBD::Gofer sends as few requests as possible (dependent on the policy being used). + +=head3 Thin Clients / Unsupported Platforms + +You no longer need drivers for your database on every system. DBD::Gofer is pure perl. + +=head1 CONSTRAINTS + +There are some natural constraints imposed by the DBD::Gofer 'stateless' approach. +But not many: + +=head2 You can't change database handle attributes after connect() + +You can't change database handle attributes after you've connected. +Use the connect() call to specify all the attribute settings you want. + +This is because it's critical that when a request is complete the database +handle is left in the same state it was when first connected. + +An exception is made for attributes with names starting "C<private_>": +They can be set after connect() but the change is only applied locally. + +=head2 You can't change statement handle attributes after prepare() + +You can't change statement handle attributes after prepare. + +An exception is made for attributes with names starting "C<private_>": +They can be set after prepare() but the change is only applied locally. + +=head2 You can't use transactions + +AutoCommit only. Transactions aren't supported. + +(In theory transactions could be supported when using a transport that +maintains a connection, like C<stream> does. If you're interested in this +please get in touch via dbi-dev@perl.org) + +=head2 You can't call driver-private sth methods + +But that's rarely needed anyway. + +=head1 GENERAL CAVEATS + +A few important things to keep in mind when using DBD::Gofer: + +=head2 Temporary tables, locks, and other per-connection persistent state + +You shouldn't expect any per-session state to persist between requests. +This includes locks and temporary tables. + +Because the server-side may execute your requests via a different +database connections, you can't rely on any per-connection persistent state, +such as temporary tables, being available from one request to the next. + +This is an easy trap to fall into. A good way to check for this is to test your +code with a Gofer policy package that sets the C<connect_method> policy to +'connect' to force a new connection for each request. The C<pedantic> policy does this. + +=head2 Driver-private Database Handle Attributes + +Some driver-private dbh attributes may not be available if the driver has not +implemented the private_attribute_info() method (added in DBI 1.54). + +=head2 Driver-private Statement Handle Attributes + +Driver-private sth attributes can be set in the prepare() call. TODO + +Some driver-private sth attributes may not be available if the driver has not +implemented the private_attribute_info() method (added in DBI 1.54). + +=head2 Multiple Resultsets + +Multiple resultsets are supported only if the driver supports the more_results() method +(an exception is made for DBD::Sybase). + +=head2 Statement activity that also updates dbh attributes + +Some drivers may update one or more dbh attributes after performing activity on +a child sth. For example, DBD::mysql provides $dbh->{mysql_insertid} in addition to +$sth->{mysql_insertid}. Currently mysql_insertid is supported via a hack but a +more general mechanism is needed for other drivers to use. + +=head2 Methods that report an error always return undef + +With DBD::Gofer, a method that sets an error always return an undef or empty list. +That shouldn't be a problem in practice because the DBI doesn't define any +methods that return meaningful values while also reporting an error. + +=head2 Subclassing only applies to client-side + +The RootClass and DbTypeSubclass attributes are not passed to the Gofer server. + +=head1 CAVEATS FOR SPECIFIC METHODS + +=head2 last_insert_id + +To enable use of last_insert_id you need to indicate to DBD::Gofer that you'd +like to use it. You do that my adding a C<go_last_insert_id_args> attribute to +the do() or prepare() method calls. For example: + + $dbh->do($sql, { go_last_insert_id_args => [...] }); + +or + + $sth = $dbh->prepare($sql, { go_last_insert_id_args => [...] }); + +The array reference should contains the args that you want passed to the +last_insert_id() method. + +=head2 execute_for_fetch + +The array methods bind_param_array() and execute_array() are supported. +When execute_array() is called the data is serialized and executed in a single +round-trip to the Gofer server. This makes it very fast, but requires enough +memory to store all the serialized data. + +The execute_for_fetch() method currently isn't optimised, it uses the DBI +fallback behaviour of executing each tuple individually. +(It could be implemented as a wrapper for execute_array() - patches welcome.) + +=head1 TRANSPORTS + +DBD::Gofer doesn't concern itself with transporting requests and responses to and fro. +For that it uses special Gofer transport modules. + +Gofer transport modules usually come in pairs: one for the 'client' DBD::Gofer +driver to use and one for the remote 'server' end. They have very similar names: + + DBD::Gofer::Transport::<foo> + DBI::Gofer::Transport::<foo> + +Sometimes the transports on the DBD and DBI sides may have different names. For +example DBD::Gofer::Transport::http is typically used with DBI::Gofer::Transport::mod_perl +(DBD::Gofer::Transport::http and DBI::Gofer::Transport::mod_perl modules are +part of the GoferTransport-http distribution). + +=head2 Bundled Transports + +Several transport modules are provided with DBD::Gofer: + +=head3 null + +The null transport is the simplest of them all. It doesn't actually transport the request anywhere. +It just serializes (freezes) the request into a string, then thaws it back into +a data structure before passing it to DBI::Gofer::Execute to execute. The same +freeze and thaw is applied to the results. + +The null transport is the best way to test if your application will work with Gofer. +Just set the DBI_AUTOPROXY environment variable to "C<dbi:Gofer:transport=null;policy=pedantic>" +(see L</Using DBI_AUTOPROXY> below) and run your application, or ideally its test suite, as usual. + +It doesn't take any parameters. + +=head3 pipeone + +The pipeone transport launches a subprocess for each request. It passes in the +request and reads the response. + +The fact that a new subprocess is started for each request ensures that the +server side is truly stateless. While this does make the transport I<very> slow, +it is useful as a way to test that your application doesn't depend on +per-connection state, such as temporary tables, persisting between requests. + +It's also useful both as a proof of concept and as a base class for the stream +driver. + +=head3 stream + +The stream driver also launches a subprocess and writes requests and reads +responses, like the pipeone transport. In this case, however, the subprocess +is expected to handle more that one request. (Though it will be automatically +restarted if it exits.) + +This is the first transport that is truly useful because it can launch the +subprocess on a remote machine using C<ssh>. This means you can now use DBD::Gofer +to easily access any databases that's accessible from any system you can login to. +You also get all the benefits of ssh, including encryption and optional compression. + +See L</Using DBI_AUTOPROXY> below for an example. + +=head2 Other Transports + +Implementing a Gofer transport is I<very> simple, and more transports are very welcome. +Just take a look at any existing transports that are similar to your needs. + +=head3 http + +See the GoferTransport-http distribution on CPAN: http://search.cpan.org/dist/GoferTransport-http/ + +=head3 Gearman + +I know Ask Bjørn Hansen has implemented a transport for the C<gearman> distributed +job system, though it's not on CPAN at the time of writing this. + +=head1 CONNECTING + +Simply prefix your existing DSN with "C<dbi:Gofer:transport=$transport;dsn=>" +where $transport is the name of the Gofer transport you want to use (see L</TRANSPORTS>). +The C<transport> and C<dsn> attributes must be specified and the C<dsn> attributes must be last. + +Other attributes can be specified in the DSN to configure DBD::Gofer and/or the +Gofer transport module being used. The main attributes after C<transport>, are +C<url> and C<policy>. These and other attributes are described below. + +=head2 Using DBI_AUTOPROXY + +The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment variable. +In this case you don't include the C<dsn=> part. For example: + + export DBI_AUTOPROXY="dbi:Gofer:transport=null" + +or, for a more useful example, try: + + export DBI_AUTOPROXY="dbi:Gofer:transport=stream;url=ssh:user@example.com" + +=head2 Connection Attributes + +These attributes can be specified in the DSN. They can also be passed in the +\%attr parameter of the DBI connect method by adding a "C<go_>" prefix to the name. + +=head3 transport + +Specifies the Gofer transport class to use. Required. See L</TRANSPORTS> above. + +If the value does not include C<::> then "C<DBD::Gofer::Transport::>" is prefixed. + +The transport object can be accessed via $h->{go_transport}. + +=head3 dsn + +Specifies the DSN for the remote side to connect to. Required, and must be last. + +=head3 url + +Used to tell the transport where to connect to. The exact form of the value depends on the transport used. + +=head3 policy + +Specifies the policy to use. See L</CONFIGURING BEHAVIOUR POLICY>. + +If the value does not include C<::> then "C<DBD::Gofer::Policy>" is prefixed. + +The policy object can be accessed via $h->{go_policy}. + +=head3 timeout + +Specifies a timeout, in seconds, to use when waiting for responses from the server side. + +=head3 retry_limit + +Specifies the number of times a failed request will be retried. Default is 0. + +=head3 retry_hook + +Specifies a code reference to be called to decide if a failed request should be retried. +The code reference is called like this: + + $transport = $h->{go_transport}; + $retry = $transport->go_retry_hook->($request, $response, $transport); + +If it returns true then the request will be retried, upto the C<retry_limit>. +If it returns a false but defined value then the request will not be retried. +If it returns undef then the default behaviour will be used, as if C<retry_hook> +had not been specified. + +The default behaviour is to retry requests where $request->is_idempotent is true, +or the error message matches C</induced by DBI_GOFER_RANDOM/>. + +=head3 cache + +Specifies that client-side caching should be performed. The value is the name +of a cache class to use. + +Any class implementing get($key) and set($key, $value) methods can be used. +That includes a great many powerful caching classes on CPAN, including the +Cache and Cache::Cache distributions. + +You can use "C<cache=1>" is a shortcut for "C<cache=DBI::Util::CacheMemory>". +See L<DBI::Util::CacheMemory> for a description of this simple fast default cache. + +The cache object can be accessed via $h->go_cache. For example: + + $dbh->go_cache->clear; # free up memory being used by the cache + +The cache keys are the frozen (serialized) requests, and the values are the +frozen responses. + +The default behaviour is to only use the cache for requests where +$request->is_idempotent is true (i.e., the dbh has the ReadOnly attribute set +or the SQL statement is obviously a SELECT without a FOR UPDATE clause.) + +For even more control you can use the C<go_cache> attribute to pass in an +instantiated cache object. Individual methods, including prepare(), can also +specify alternative caches via the C<go_cache> attribute. For example, to +specify no caching for a particular query, you could use + + $sth = $dbh->prepare( $sql, { go_cache => 0 } ); + +This can be used to implement different caching policies for different statements. + +It's interesting to note that DBD::Gofer can be used to add client-side caching +to any (gofer compatible) application, with no code changes and no need for a +gofer server. Just set the DBI_AUTOPROXY environment variable like this: + + DBI_AUTOPROXY='dbi:Gofer:transport=null;cache=1' + +=head1 CONFIGURING BEHAVIOUR POLICY + +DBD::Gofer supports a 'policy' mechanism that allows you to fine-tune the number of round-trips to the Gofer server. +The policies are grouped into classes (which may be subclassed) and referenced by the name of the class. + +The L<DBD::Gofer::Policy::Base> class is the base class for all the policy +packages and describes all the available policies. + +Three policy packages are supplied with DBD::Gofer: + +L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it +makes more round-trips to the Gofer server. + +L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy. + +L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications. + +Generally the default C<classic> policy is fine. When first testing an existing +application with Gofer it is a good idea to start with the C<pedantic> policy +first and then switch to C<classic> or a custom policy, for final testing. + + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 ACKNOWLEDGEMENTS + +The development of DBD::Gofer and related modules was sponsored by +Shopzilla.com (L<http://Shopzilla.com>), where I currently work. + +=head1 SEE ALSO + +L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>. + +L<DBI::Gofer::Transport::Base>, L<DBD::Gofer::Policy::Base>. + +L<DBI> + +=head1 Caveats for specific drivers + +This section aims to record issues to be aware of when using Gofer with specific drivers. +It usually only documents issues that are not natural consequences of the limitations +of the Gofer approach - as documented above. + +=head1 TODO + +This is just a random brain dump... (There's more in the source of the Changes file, not the pod) + +Document policy mechanism + +Add mechanism for transports to list config params and for Gofer to apply any that match (and warn if any left over?) + +Driver-private sth attributes - set via prepare() - change DBI spec + +add hooks into transport base class for checking & updating a result set cache + ie via a standard cache interface such as: + http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm + http://search.cpan.org/~bradfitz/Cache-Memcached/lib/Cache/Memcached.pm + http://search.cpan.org/~dclinton/Cache-Cache/ + http://search.cpan.org/~cleishman/Cache/ +Also caching instructions could be passed through the httpd transport layer +in such a way that appropriate http cache headers are added to the results +so that web caches (squid etc) could be used to implement the caching. +(MUST require the use of GET rather than POST requests.) + +Rework handling of installed_methods to not piggyback on dbh_attributes? + +Perhaps support transactions for transports where it's possible (ie null and stream)? +Would make stream transport (ie ssh) more useful to more people. + +Make sth_result_attr more like dbh_attributes (using '*' etc) + +Add @val = FETCH_many(@names) to DBI in C and use in Gofer/Execute? + +Implement _new_sth in C. + +=cut diff --git a/lib/DBD/Gofer/Policy/Base.pm b/lib/DBD/Gofer/Policy/Base.pm new file mode 100644 index 0000000..1725b03 --- /dev/null +++ b/lib/DBD/Gofer/Policy/Base.pm @@ -0,0 +1,162 @@ +package DBD::Gofer::Policy::Base; + +# $Id: Base.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; +use Carp; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); +our $AUTOLOAD; + +my %policy_defaults = ( + # force connect method (unless overridden by go_connect_method=>'...' attribute) + # if false: call same method on client as on server + connect_method => 'connect', + # force prepare method (unless overridden by go_prepare_method=>'...' attribute) + # if false: call same method on client as on server + prepare_method => 'prepare', + skip_connect_check => 0, + skip_default_methods => 0, + skip_prepare_check => 0, + skip_ping => 0, + dbh_attribute_update => 'every', + dbh_attribute_list => ['*'], + locally_quote => 0, + locally_quote_identifier => 0, + cache_parse_trace_flags => 1, + cache_parse_trace_flag => 1, + cache_data_sources => 1, + cache_type_info_all => 1, + cache_tables => 0, + cache_table_info => 0, + cache_column_info => 0, + cache_primary_key_info => 0, + cache_foreign_key_info => 0, + cache_statistics_info => 0, + cache_get_info => 0, + cache_func => 0, +); + +my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; + +__PACKAGE__->create_policy_subs(\%policy_defaults); + +sub create_policy_subs { + my ($class, $policy_defaults) = @_; + + while ( my ($policy_name, $policy_default) = each %$policy_defaults) { + my $policy_attr_name = "go_$policy_name"; + my $sub = sub { + # $policy->foo($attr, ...) + #carp "$policy_name($_[1],...)"; + # return the policy default value unless an attribute overrides it + return (ref $_[1] && exists $_[1]->{$policy_attr_name}) + ? $_[1]->{$policy_attr_name} + : $policy_default; + }; + no strict 'refs'; + *{$class . '::' . $policy_name} = $sub; + } +} + +sub AUTOLOAD { + carp "Unknown policy name $AUTOLOAD used"; + # only warn once + no strict 'refs'; + *$AUTOLOAD = sub { undef }; + return undef; +} + +sub new { + my ($class, $args) = @_; + my $policy = {}; + bless $policy, $class; +} + +sub DESTROY { }; + +1; + +=head1 NAME + +DBD::Gofer::Policy::Base - Base class for DBD::Gofer policies + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=...", ...) + +=head1 DESCRIPTION + +DBD::Gofer can be configured via a 'policy' mechanism that allows you to +fine-tune the number of round-trips to the Gofer server. The policies are +grouped into classes (which may be subclassed) and referenced by the name of +the class. + +The L<DBD::Gofer::Policy::Base> class is the base class for all the policy +classes and describes all the individual policy items. + +The Base policy is not used directly. You should use a policy class derived from it. + +=head1 POLICY CLASSES + +Three policy classes are supplied with DBD::Gofer: + +L<DBD::Gofer::Policy::pedantic> is most 'transparent' but slowest because it +makes more round-trips to the Gofer server. + +L<DBD::Gofer::Policy::classic> is a reasonable compromise - it's the default policy. + +L<DBD::Gofer::Policy::rush> is fastest, but may require code changes in your applications. + +Generally the default C<classic> policy is fine. When first testing an existing +application with Gofer it is a good idea to start with the C<pedantic> policy +first and then switch to C<classic> or a custom policy, for final testing. + +=head1 POLICY ITEMS + +These are temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +See the source code to this module for more details. + +=head1 POLICY CUSTOMIZATION + +XXX This area of DBD::Gofer is subject to change. + +There are three ways to customize policies: + +Policy classes are designed to influence the overall behaviour of DBD::Gofer +with existing, unaltered programs, so they work in a reasonably optimal way +without requiring code changes. You can implement new policy classes as +subclasses of existing policies. + +In many cases individual policy items can be overridden on a case-by-case basis +within your application code. You do this by passing a corresponding +C<<go_<policy_name>>> attribute into DBI methods by your application code. +This let's you fine-tune the behaviour for special cases. + +The policy items are implemented as methods. In many cases the methods are +passed parameters relating to the DBD::Gofer code being executed. This means +the policy can implement dynamic behaviour that varies depending on the +particular circumstances, such as the particular statement being executed. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/classic.pm b/lib/DBD/Gofer/Policy/classic.pm new file mode 100644 index 0000000..8f828f0 --- /dev/null +++ b/lib/DBD/Gofer/Policy/classic.pm @@ -0,0 +1,79 @@ +package DBD::Gofer::Policy::classic; + +# $Id: classic.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + prepare_method => '', + + # don't skip the connect check since that also sets dbh attributes + # although this makes connect more expensive, that's partly offset + # by skip_ping=>1 below, which makes connect_cached very fast. + skip_connect_check => 0, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is not important for DBD::Gofer and most transports + skip_ping => 1, + + # only update dbh attributes on first contact with server + dbh_attribute_update => 'first', + + # we'd like to set locally_* but can't because drivers differ + + # get_info results usually don't change + cache_get_info => 1, +}); + + +1; + +=head1 NAME + +DBD::Gofer::Policy::classic - The 'classic' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=classic", ...) + +The C<classic> policy is the default DBD::Gofer policy, so need not be included in the DSN. + +=head1 DESCRIPTION + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/pedantic.pm b/lib/DBD/Gofer/Policy/pedantic.pm new file mode 100644 index 0000000..6829bea --- /dev/null +++ b/lib/DBD/Gofer/Policy/pedantic.pm @@ -0,0 +1,53 @@ +package DBD::Gofer::Policy::pedantic; + +# $Id: pedantic.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +# the 'pedantic' policy is the same as the Base policy + +1; + +=head1 NAME + +DBD::Gofer::Policy::pedantic - The 'pedantic' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=pedantic", ...) + +=head1 DESCRIPTION + +The C<pedantic> policy tries to be as transparent as possible. To do this it +makes round-trips to the server for almost every DBI method call. + +This is the best policy to use when first testing existing code with Gofer. +Once it's working well you should consider moving to the C<classic> policy or defining your own policy class. + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Policy/rush.pm b/lib/DBD/Gofer/Policy/rush.pm new file mode 100644 index 0000000..9cfd582 --- /dev/null +++ b/lib/DBD/Gofer/Policy/rush.pm @@ -0,0 +1,90 @@ +package DBD::Gofer::Policy::rush; + +# $Id: rush.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + # (because code not using placeholders would bloat the sth cache) + prepare_method => '', + + # Skipping the connect check is fast, but it also skips + # fetching the remote dbh attributes! + # Make sure that your application doesn't need access to dbh attributes. + skip_connect_check => 1, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is almost meaningless for DBD::Gofer and most transports anyway + skip_ping => 1, + + # don't update dbh attributes at all + # XXX actually we currently need dbh_attribute_update for skip_default_methods to work + # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update + dbh_attribute_update => 'none', # actually means 'first' currently + #dbh_attribute_list => undef, + + # we'd like to set locally_* but can't because drivers differ + + # in a rush assume metadata doesn't change + cache_tables => 1, + cache_table_info => 1, + cache_column_info => 1, + cache_primary_key_info => 1, + cache_foreign_key_info => 1, + cache_statistics_info => 1, + cache_get_info => 1, +}); + + +1; + +=head1 NAME + +DBD::Gofer::Policy::rush - The 'rush' policy for DBD::Gofer + +=head1 SYNOPSIS + + $dbh = DBI->connect("dbi:Gofer:transport=...;policy=rush", ...) + +=head1 DESCRIPTION + +The C<rush> policy tries to make as few round-trips as possible. +It's the opposite end of the policy spectrum to the C<pedantic> policy. + +Temporary docs: See the source code for list of policies and their defaults. + +In a future version the policies and their defaults will be defined in the pod and parsed out at load-time. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBD/Gofer/Transport/Base.pm b/lib/DBD/Gofer/Transport/Base.pm new file mode 100644 index 0000000..fe0d078 --- /dev/null +++ b/lib/DBD/Gofer/Transport/Base.pm @@ -0,0 +1,410 @@ +package DBD::Gofer::Transport::Base; + +# $Id: Base.pm 14120 2010-06-07 19:52:19Z hmbrand $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use base qw(DBI::Gofer::Transport::Base); + +our $VERSION = sprintf("0.%06d", q$Revision: 14120 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + trace + go_dsn + go_url + go_policy + go_timeout + go_retry_hook + go_retry_limit + go_cache + cache_hit + cache_miss + cache_store +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($class, $args) = @_; + $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); + $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; + #warn "args @{[ %$args ]}\n"; + return $class->SUPER::new($args); +} + + +sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } + + +sub new_response { + my $self = shift; + return DBI::Gofer::Response->new(@_); +} + + +sub transmit_request { + my ($self, $request) = @_; + my $trace = $self->trace; + my $response; + + my ($go_cache, $request_cache_key); + if ($go_cache = $self->{go_cache}) { + $request_cache_key + = $request->{meta}{request_cache_key} + = $self->get_cache_key_for_request($request); + if ($request_cache_key) { + my $frozen_response = eval { $go_cache->get($request_cache_key) }; + if ($frozen_response) { + $self->_dump("cached response found for ".ref($request), $request) + if $trace; + $response = $self->thaw_response($frozen_response); + $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") + if $trace; + ++$self->{cache_hit}; + return $response; + } + warn $@ if $@; + ++$self->{cache_miss}; + $self->trace_msg("transmit_request cache miss\n") + if $trace; + } + } + + my $to = $self->go_timeout; + my $transmit_sub = sub { + $self->trace_msg("transmit_request\n") if $trace; + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + local $SIG{PIPE} = sub { + my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; + die "Unable to send request: Broken pipe$extra\n"; + }; + alarm($to) if $to; + $self->transmit_request_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("transmit_request", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + + return $response; + }; + + $response = $self->_transmit_request_with_retries($request, $transmit_sub); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key; + } + + $self->trace_msg("transmit_request is returning a response itself\n") + if $trace && $response; + + return $response unless wantarray; + return ($response, $transmit_sub); +} + + +sub _transmit_request_with_retries { + my ($self, $request, $transmit_sub) = @_; + my $response; + do { + $response = $transmit_sub->(); + } while ( $response && $self->response_needs_retransmit($request, $response) ); + return $response; +} + + +sub receive_response { + my ($self, $request, $retransmit_sub) = @_; + my $to = $self->go_timeout; + + my $receive_sub = sub { + $self->trace_msg("receive_response\n"); + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + alarm($to) if $to; + $self->receive_response_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("receive_response", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + return $response; + }; + + my $response; + do { + $response = $receive_sub->(); + if ($self->response_needs_retransmit($request, $response)) { + $response = $self->_transmit_request_with_retries($request, $retransmit_sub); + $response ||= $receive_sub->(); + } + } while ( $self->response_needs_retransmit($request, $response) ); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + my $request_cache_key = $request->{meta}{request_cache_key}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key && $self->{go_cache}; + } + + return $response; +} + + +sub response_retry_preference { + my ($self, $request, $response) = @_; + + # give the user a chance to express a preference (or undef for default) + if (my $go_retry_hook = $self->go_retry_hook) { + my $retry = $go_retry_hook->($request, $response, $self); + $self->trace_msg(sprintf "go_retry_hook returned %s\n", + (defined $retry) ? $retry : 'undef'); + return $retry if defined $retry; + } + + # This is the main decision point. We don't retry requests that got + # as far as executing because the error is probably from the database + # (not transport) so retrying is unlikely to help. But note that any + # severe transport error occuring after execute is likely to return + # a new response object that doesn't have the execute flag set. Beware! + return 0 if $response->executed_flag_set; + + return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; + + return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set + + return undef; # we couldn't make up our mind +} + + +sub response_needs_retransmit { + my ($self, $request, $response) = @_; + + my $err = $response->err + or return 0; # nothing went wrong + + my $retry = $self->response_retry_preference($request, $response); + + if (!$retry) { # false or undef + $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); + return 0; + } + + # we'd like to retry but have we retried too much already? + + my $retry_limit = $self->go_retry_limit; + if (!$retry_limit) { + $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); + return 0; + } + + my $request_meta = $request->meta; + my $retry_count = $request_meta->{retry_count} || 0; + if ($retry_count >= $retry_limit) { + $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); + # XXX should be possible to disable altering the err + $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); + return 0; + } + + # will retry now, do the admin + ++$retry_count; + $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); + + # hook so response_retry_preference can defer some code execution + # until we've checked retry_count and retry_limit. + if (ref $retry eq 'CODE') { + $retry->($retry_count, $retry_limit) + and warn "should return false"; # protect future use + } + + ++$request_meta->{retry_count}; # update count for this request object + ++$self->meta->{request_retry_count}; # update cumulative transport stats + + return 1; +} + + +sub transport_timedout { + my ($self, $method, $timeout) = @_; + $timeout ||= $self->go_timeout; + return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); +} + + +# return undef if we don't want to cache this request +# subclasses may use more specialized rules +sub get_cache_key_for_request { + my ($self, $request) = @_; + + # we only want to cache idempotent requests + # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set + return undef if not $request->is_idempotent; + + # XXX would be nice to avoid the extra freeze here + my $key = $self->freeze_request($request, undef, 1); + + #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; + + return $key; +} + + +sub _store_response_in_cache { + my ($self, $frozen_response, $request_cache_key) = @_; + my $go_cache = $self->{go_cache} + or return; + + # new() ensures that enabling go_cache also enables keep_meta_frozen + warn "No meta frozen in response" if !$frozen_response; + warn "No request_cache_key" if !$request_cache_key; + + if ($frozen_response && $request_cache_key) { + $self->trace_msg("receive_response added response to cache $go_cache\n"); + eval { $go_cache->set($request_cache_key, $frozen_response) }; + warn $@ if $@; + ++$self->{cache_store}; + } +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports + +=head1 SYNOPSIS + + my $remote_dsn = "..." + DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...' + +which will force I<all> DBI connections to be made via that Gofer server. + +=head1 DESCRIPTION + +This is the base class for all DBD::Gofer client transports. + +=head1 ATTRIBUTES + +Gofer transport attributes can be specified either in the attributes parameter +of the connect() method call, or in the DSN string. When used in the DSN +string, attribute names don't have the C<go_> prefix. + +=head2 go_dsn + +The full DBI DSN that the Gofer server should connect to on your behalf. + +When used in the DSN it must be the last element in the DSN string. + +=head2 go_timeout + +A time limit for sending a request and receiving a response. Some drivers may +implement sending and receiving as separate steps, in which case (currently) +the timeout applies to each separately. + +If a request needs to be resent then the timeout is restarted for each sending +of a request and receiving of a response. + +=head2 go_retry_limit + +The maximum number of times an request may be retried. The default is 2. + +=head2 go_retry_hook + +This subroutine reference is called, if defined, for each response received where $response->err is true. + +The subroutine is pass three parameters: the request object, the response object, and the transport object. + +If it returns an undefined value then the default retry behaviour is used. See L</RETRY ON ERROR> below. + +If it returns a defined but false value then the request is not resent. + +If it returns true value then the request is resent, so long as the number of retries does not exceed C<go_retry_limit>. + +=head1 RETRY ON ERROR + +The default retry on error behaviour is: + + - Retry if the error was due to DBI_GOFER_RANDOM. See L<DBI::Gofer::Execute>. + + - Retry if $request->is_idempotent returns true. See L<DBI::Gofer::Request>. + +A retry won't be allowed if the number of previous retries has reached C<go_retry_limit>. + +=head1 TRACING + +Tracing of gofer requests and responses can be enabled by setting the +C<DBD_GOFER_TRACE> environment variable. A value of 1 gives a reasonably +compact summary of each request and response. A value of 2 or more gives a +detailed, and voluminous, dump. + +The trace is written using DBI->trace_msg() and so is written to the default +DBI trace output, which is usually STDERR. + +=head1 METHODS + +I<This section is currently far from complete.> + +=head2 response_retry_preference + + $retry = $transport->response_retry_preference($request, $response); + +The response_retry_preference is called by DBD::Gofer when considering if a +request should be retried after an error. + +Returns true (would like to retry), false (must not retry), undef (no preference). + +If a true value is returned in the form of a CODE ref then, if DBD::Gofer does +decide to retry the request, it calls the code ref passing $retry_count, $retry_limit. +Can be used for logging and/or to implement exponential backoff behaviour. +Currently the called code must return using C<return;> to allow for future extensions. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007-2008, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer>, L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>. + +and some example transports: + +L<DBD::Gofer::Transport::stream> + +L<DBD::Gofer::Transport::http> + +L<DBI::Gofer::Transport::mod_perl> + +=cut diff --git a/lib/DBD/Gofer/Transport/corostream.pm b/lib/DBD/Gofer/Transport/corostream.pm new file mode 100644 index 0000000..6e79278 --- /dev/null +++ b/lib/DBD/Gofer/Transport/corostream.pm @@ -0,0 +1,144 @@ +package DBD::Gofer::Transport::corostream; + +use strict; +use warnings; + +use Carp; + +use Coro::Select; # a slow but coro-aware replacement for CORE::select (global effect!) + +use Coro; +use Coro::Handle; + +use base qw(DBD::Gofer::Transport::stream); + +# XXX ensure DBI_PUREPERL for parent doesn't pass to child +sub start_pipe_command { + local $ENV{DBI_PUREPERL} = $ENV{DBI_PUREPERL_COROCHILD}; # typically undef + my $connection = shift->SUPER::start_pipe_command(@_); + return $connection; +} + + + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::corostream - Async DBD::Gofer stream transport using Coro and AnyEvent + +=head1 SYNOPSIS + + DBI_AUTOPROXY="dbi:Gofer:transport=corostream" perl some-perl-script-using-dbi.pl + +or + + $dsn = ...; # the DSN for the driver and database you want to use + $dbh = DBI->connect("dbi:Gofer:transport=corostream;dsn=$dsn", ...); + +=head1 DESCRIPTION + +The I<BIG WIN> from using L<Coro> is that it enables the use of existing +DBI frameworks like L<DBIx::Class>. + +=head1 KNOWN ISSUES AND LIMITATIONS + + - Uses Coro::Select so alters CORE::select globally + Parent class probably needs refactoring to enable a more encapsulated approach. + + - Doesn't prevent multiple concurrent requests + Probably just needs a per-connection semaphore + + - Coro has many caveats. Caveat emptor. + +=head1 STATUS + +THIS IS CURRENTLY JUST A PROOF-OF-CONCEPT IMPLEMENTATION FOR EXPERIMENTATION. + +Please note that I have no plans to develop this code further myself. +I'd very much welcome contributions. Interested? Let me know! + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2010, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::stream> + +L<DBD::Gofer> + +=head1 APPENDIX + +Example code: + + #!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_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..3) { + warn "entering DBI...\n"; + $dbh->do("sleep 0.3"); # pseudo-sql understood by the DBD::NullP driver + warn "...returned\n"; + } + + warn "done."; + +Example output: + + $ perl corogofer.pl + connecting... + -tick- 1293631437.14 + -tick- 1293631437.14 + ...connected + entering DBI... + -tick- 1293631437.25 + -tick- 1293631437.35 + -tick- 1293631437.45 + -tick- 1293631437.55 + ...returned + entering DBI... + -tick- 1293631437.66 + -tick- 1293631437.76 + -tick- 1293631437.86 + ...returned + entering DBI... + -tick- 1293631437.96 + -tick- 1293631438.06 + -tick- 1293631438.16 + ...returned + done. at corogofer.pl line 39. + +You can see that the timer callback is firing while the code 'waits' inside the +do() method for the response from the database. Normally that would block. + +=cut diff --git a/lib/DBD/Gofer/Transport/null.pm b/lib/DBD/Gofer/Transport/null.pm new file mode 100644 index 0000000..4b8d86c --- /dev/null +++ b/lib/DBD/Gofer/Transport/null.pm @@ -0,0 +1,111 @@ +package DBD::Gofer::Transport::null; + +# $Id: null.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use base qw(DBD::Gofer::Transport::Base); + +use DBI::Gofer::Execute; + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + pending_response + transmit_count +)); + +my $executor = DBI::Gofer::Execute->new(); + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests + + my $frozen_request = $self->freeze_request($request); + + # ... + # the request is magically transported over to ... ourselves + # ... + + my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) ); + + # put response 'on the shelf' ready for receive_response() + $self->pending_response( $response ); + + return undef; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $response = $self->pending_response; + + my $frozen_response = $self->freeze_response($response, undef, 1); + + # ... + # the response is magically transported back to ... ourselves + # ... + + return $self->thaw_response($frozen_response); +} + + +1; +__END__ + +=head1 NAME + +DBD::Gofer::Transport::null - DBD::Gofer client transport for testing + +=head1 SYNOPSIS + + my $original_dsn = "..." + DBI->connect("dbi:Gofer:transport=null;dsn=$original_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY="dbi:Gofer:transport=null" + +=head1 DESCRIPTION + +Connect via DBD::Gofer but execute the requests within the same process. + +This is a quick and simple way to test applications for compatibility with the +(few) restrictions that DBD::Gofer imposes. + +It also provides a simple, portable way for the DBI test suite to be used to +test DBD::Gofer on all platforms with no setup. + +Also, by measuring the difference in performance between normal connections and +connections via C<dbi:Gofer:transport=null> the basic cost of using DBD::Gofer +can be measured. Furthermore, the additional cost of more advanced transports can be +isolated by comparing their performance with the null transport. + +The C<t/85gofer.t> script in the DBI distribution includes a comparative benchmark. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/Gofer/Transport/pipeone.pm b/lib/DBD/Gofer/Transport/pipeone.pm new file mode 100644 index 0000000..3df2bf3 --- /dev/null +++ b/lib/DBD/Gofer/Transport/pipeone.pm @@ -0,0 +1,253 @@ +package DBD::Gofer::Transport::pipeone; + +# $Id: pipeone.pm 10087 2007-10-16 12:42:37Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use Carp; +use Fcntl; +use IO::Select; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +use base qw(DBD::Gofer::Transport::Base); + +our $VERSION = sprintf("0.%06d", q$Revision: 10087 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + connection_info + go_perl +)); + + +sub new { + my ($self, $args) = @_; + $args->{go_perl} ||= do { + ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ]; + }; + if (not ref $args->{go_perl}) { + # user can override the perl to be used, either with an array ref + # containing the command name and args to use, or with a string + # (ie via the DSN) in which case, to enable args to be passed, + # we split on two or more consecutive spaces (otherwise the path + # to perl couldn't contain a space itself). + $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ]; + } + return $self->SUPER::new($args); +} + + +# nonblock($fh) puts filehandle into nonblocking mode +sub nonblock { + my $fh = shift; + my $flags = fcntl($fh, F_GETFL, 0) + or croak "Can't get flags for filehandle $fh: $!"; + fcntl($fh, F_SETFL, $flags | O_NONBLOCK) + or croak "Can't make filehandle $fh nonblocking: $!"; +} + + +sub start_pipe_command { + my ($self, $cmd) = @_; + $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY'; + + # if it's important that the subprocess uses the same + # (versions of) modules as us then the caller should + # set PERL5LIB itself. + + # limit various forms of insanity, for now + local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead + local $ENV{DBI_AUTOPROXY}; + local $ENV{DBI_PROFILE}; + + my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); + my $pid = open3($wfh, $rfh, $efh, @$cmd) + or die "error starting @$cmd: $!\n"; + if ($self->trace) { + $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0); + } + nonblock($rfh); + nonblock($efh); + my $ios = IO::Select->new($rfh, $efh); + + return { + cmd=>$cmd, + pid=>$pid, + wfh=>$wfh, rfh=>$rfh, efh=>$efh, + ios=>$ios, + }; +} + + +sub cmd_as_string { + my $self = shift; + # XXX meant to return a properly shell-escaped string suitable for system + # but its only for debugging so that can wait + my $connection_info = $self->connection_info; + return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}}; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + + my $frozen_request = $self->freeze_request($request); + + my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)]; + my $info = $self->start_pipe_command($cmd); + + my $wfh = delete $info->{wfh}; + # send frozen request + local $\; + print $wfh $frozen_request + or warn "error writing to @$cmd: $!\n"; + # indicate that there's no more + close $wfh + or die "error closing pipe to @$cmd: $!\n"; + + $self->connection_info( $info ); + return; +} + + +sub read_response_from_fh { + my ($self, $fh_actions) = @_; + my $trace = $self->trace; + + my $info = $self->connection_info || die; + my ($ios) = @{$info}{qw(ios)}; + my $errors = 0; + my $complete; + + die "No handles to read response from" unless $ios->count; + + while ($ios->count) { + my @readable = $ios->can_read(); + for my $fh (@readable) { + local $_; + my $actions = $fh_actions->{$fh} || die "panic: no action for $fh"; + my $rv = sysread($fh, $_='', 1024*31); # to fit in 32KB slab + unless ($rv) { # error (undef) or end of file (0) + my $action; + unless (defined $rv) { # was an error + $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4; + $action = $actions->{error} || $actions->{eof}; + ++$errors; + # XXX an error may be a permenent condition of the handle + # if so we'll loop here - not good + } + else { + $action = $actions->{eof}; + $self->trace_msg("eof on handle $fh\n") if $trace >= 4; + } + if ($action->($fh)) { + $self->trace_msg("removing $fh from handle set\n") if $trace >= 4; + $ios->remove($fh); + } + next; + } + # action returns true if the response is now complete + # (we finish all handles + $actions->{read}->($fh) && ++$complete; + } + last if $complete; + } + return $errors; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $info = $self->connection_info || die; + my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)}; + + my $frozen_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; 1 }, + eof => sub { warn "eof on stderr" if 0; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; 1 }, + eof => sub { warn "eof on stdout" if 0; 1 }, + read => sub { $frozen_response .= $_; 0 }, + }, + }); + + waitpid $info->{pid}, 0 + or warn "waitpid: $!"; # XXX do something more useful? + + die ref($self)." command (@$cmd) failed: $stderr_msg" + if not $frozen_response; # no output on stdout at all + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $self->trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::pipeone - DBD::Gofer client transport for testing + +=head1 SYNOPSIS + + $original_dsn = "..."; + DBI->connect("dbi:Gofer:transport=pipeone;dsn=$original_dsn",...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY="dbi:Gofer:transport=pipeone" + +=head1 DESCRIPTION + +Connect via DBD::Gofer and execute each request by starting executing a subprocess. + +This is, as you might imagine, spectacularly inefficient! + +It's only intended for testing. Specifically it demonstrates that the server +side is completely stateless. + +It also provides a base class for the much more useful L<DBD::Gofer::Transport::stream> +transport. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/Gofer/Transport/stream.pm b/lib/DBD/Gofer/Transport/stream.pm new file mode 100644 index 0000000..61e211c --- /dev/null +++ b/lib/DBD/Gofer/Transport/stream.pm @@ -0,0 +1,292 @@ +package DBD::Gofer::Transport::stream; + +# $Id: stream.pm 14598 2010-12-21 22:53:25Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use Carp; + +use base qw(DBD::Gofer::Transport::pipeone); + +our $VERSION = sprintf("0.%06d", q$Revision: 14598 $ =~ /(\d+)/o); + +__PACKAGE__->mk_accessors(qw( + go_persist +)); + +my $persist_all = 5; +my %persist; + + +sub _connection_key { + my ($self) = @_; + return join "~", $self->go_url||"", @{ $self->go_perl || [] }; +} + + +sub _connection_get { + my ($self) = @_; + + my $persist = $self->go_persist; # = 0 can force non-caching + $persist = $persist_all if not defined $persist; + my $key = ($persist) ? $self->_connection_key : ''; + if ($persist{$key} && $self->_connection_check($persist{$key})) { + $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1; + return $persist{$key}; + } + + my $connection = $self->_make_connection; + + if ($key) { + %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses + $persist{$key} = $connection; + } + + return $connection; +} + + +sub _connection_check { + my ($self, $connection) = @_; + $connection ||= $self->connection_info; + my $pid = $connection->{pid}; + my $ok = (kill 0, $pid); + $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace; + return $ok; +} + + +sub _connection_kill { + my ($self) = @_; + my $connection = $self->connection_info; + my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)}; + $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace; + # closing the write file handle should be enough, generally + close $wfh; + # in future we may want to be more aggressive + #close $rfh; close $efh; kill 15, $pid + # but deleting from the persist cache... + delete $persist{ $self->_connection_key }; + # ... and removing the connection_info should suffice + $self->connection_info( undef ); + return; +} + + +sub _make_connection { + my ($self) = @_; + + my $go_perl = $self->go_perl; + my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)]; + + #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c"; + if (my $url = $self->go_url) { + die "Only 'ssh:user\@host' style url supported by this transport" + unless $url =~ s/^ssh://; + my $ssh = $url; + my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile); + my $setup = $setup_env.q{; exec "$@"}; + # don't use $^X on remote system by default as it's possibly wrong + $cmd->[0] = 'perl' if "@$go_perl" eq $^X; + # -x not only 'Disables X11 forwarding' but also makes connections *much* faster + unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup; + } + + $self->trace_msg("new connection: @$cmd\n",0) if $self->trace; + + # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's + # sent as soon as it starts that we can wait for to report success - and soak up + # and report useful warnings etc from ssh before we get it? Increases latency though. + my $connection = $self->start_pipe_command($cmd); + return $connection; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + my $trace = $self->trace; + + my $connection = $self->connection_info || do { + my $con = $self->_connection_get; + $self->connection_info( $con ); + $con; + }; + + my $encoded_request = unpack("H*", $self->freeze_request($request)); + $encoded_request .= "\015\012"; + + my $wfh = $connection->{wfh}; + $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0) + if $trace >= 4; + + # send frozen request + local $\; + $wfh->print($encoded_request) # autoflush enabled + or do { + my $err = $!; + # XXX could/should make new connection and retry + $self->_connection_kill; + die "Error sending request: $err"; + }; + $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4; + + return undef; # indicate no response yet (so caller calls receive_response_by_transport) +} + + +sub receive_response_by_transport { + my $self = shift; + my $trace = $self->trace; + + $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4; + my $connection = $self->connection_info || die; + my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)}; + + my $errno = 0; + my $encoded_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading efh" if $trace >= 4; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading rfh" if $trace >= 4; 1 }, + read => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 }, + }, + }); + + # if we got no output on stdout at all then the command has + # probably exited, possibly with an error to stderr. + # Turn this situation into a reasonably useful DBI error. + if (not $encoded_response) { + my @msg; + push @msg, "error while reading response: $errno" if $errno; + if ($stderr_msg) { + chomp $stderr_msg; + push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s", + $self->cmd_as_string, + $pid, ((kill 0, $pid) ? "" : ", exited"), + $stderr_msg; + } + die join(", ", "No response received", @msg)."\n"; + } + + $self->trace_msg("Response received: $encoded_response\n",0) + if $trace >= 4; + + $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0) + if $stderr_msg && $trace; + + my $frozen_response = pack("H*", $encoded_response); + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + +sub transport_timedout { + my $self = shift; + $self->_connection_kill; + return $self->SUPER::transport_timedout(@_); +} + +1; + +__END__ + +=head1 NAME + +DBD::Gofer::Transport::stream - DBD::Gofer transport for stdio streaming + +=head1 SYNOPSIS + + DBI->connect('dbi:Gofer:transport=stream;url=ssh:username@host.example.com;dsn=dbi:...',...) + +or, enable by setting the DBI_AUTOPROXY environment variable: + + export DBI_AUTOPROXY='dbi:Gofer:transport=stream;url=ssh:username@host.example.com' + +=head1 DESCRIPTION + +Without the C<url=> parameter it launches a subprocess as + + perl -MDBI::Gofer::Transport::stream -e run_stdio_hex + +and feeds requests into it and reads responses from it. But that's not very useful. + +With a C<url=ssh:username@host.example.com> parameter it uses ssh to launch the subprocess +on a remote system. That's much more useful! + +It gives you secure remote access to DBI databases on any system you can login to. +Using ssh also gives you optional compression and many other features (see the +ssh manual for how to configure that and many other options via ~/.ssh/config file). + +The actual command invoked is something like: + + ssh -xq ssh:username@host.example.com bash -c $setup $run + +where $run is the command shown above, and $command is + + . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile 2>/dev/null; exec "$@" + +which is trying (in a limited and fairly unportable way) to setup the environment +(PATH, PERL5LIB etc) as it would be if you had logged in to that system. + +The "C<perl>" used in the command will default to the value of $^X when not using ssh. +On most systems that's the full path to the perl that's currently executing. + + +=head1 PERSISTENCE + +Currently gofer stream connections persist (remain connected) after all +database handles have been disconnected. This makes later connections in the +same process very fast. + +Currently up to 5 different gofer stream connections (based on url) can +persist. If more than 5 are in the cache when a new connection is made then +the cache is cleared before adding the new connection. Simple but effective. + +=head1 TO DO + +Document go_perl attribute + +Automatically reconnect (within reason) if there's a transport error. + +Decide on default for persistent connection - on or off? limits? ttl? + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=head1 SEE ALSO + +L<DBD::Gofer::Transport::Base> + +L<DBD::Gofer> + +=cut diff --git a/lib/DBD/NullP.pm b/lib/DBD/NullP.pm new file mode 100644 index 0000000..b1f8a71 --- /dev/null +++ b/lib/DBD/NullP.pm @@ -0,0 +1,166 @@ +{ + package DBD::NullP; + + require DBI; + require Carp; + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = sprintf("12.%06d", q$Revision: 14714 $ =~ /(\d+)/o); + +# $Id: NullP.pm 14714 2011-02-22 17:27:07Z timbo $ +# +# Copyright (c) 1994-2007 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + $drh = undef; # holds driver handle once initialised + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'NullP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Null Perl stub by Tim Bunce', + }, [ qw'example implementors private data']); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::NullP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my $dbh = shift->SUPER::connect(@_) + or return; + $dbh->STORE(Active => 1); + $dbh; + } + + + sub DESTROY { undef } +} + + +{ package DBD::NullP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + use Carp qw(croak); + + sub prepare { + my ($dbh, $statement)= @_; + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }); + + return $outer; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + Carp::croak("Can't disable AutoCommit") unless $value; + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub ping { 1 } + + sub disconnect { + shift->STORE(Active => 0); + } + +} + + +{ package DBD::NullP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) { + $sth->STORE(NUM_OF_FIELDS => 1); + $sth->{NAME} = [ "fieldname" ]; + # just for the sake of returning something, we return the params + my $params = $sth->{ParamValues} || {}; + $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ]; + $sth->STORE(Active => 1); + } + # force a sleep - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) { + my $secs = $1; + if (eval { require Time::HiRes; defined &Time::HiRes::sleep }) { + Time::HiRes::sleep($secs); + } + else { + sleep $secs; + } + } + # force an error - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) { + return $sth->set_err($1, $2); + } + # anything else is silently ignored, sucessfully + 1; + } + + sub fetchrow_arrayref { + my $sth = shift; + my $data = $sth->{dbd_nullp_data}; + if (!$data || !@$data) { + $sth->finish; # no more data so finish + return undef; + } + return $sth->_set_fbav(shift @$data); + } + *fetch = \&fetchrow_arrayref; # alias + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } + +} + +1; diff --git a/lib/DBD/Proxy.pm b/lib/DBD/Proxy.pm new file mode 100644 index 0000000..6c9e14d --- /dev/null +++ b/lib/DBD/Proxy.pm @@ -0,0 +1,997 @@ +# -*- perl -*- +# +# +# DBD::Proxy - DBI Proxy driver +# +# +# Copyright (c) 1997,1998 Jochen Wiedmann +# +# The DBD::Proxy 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. +# +# +# Author: Jochen Wiedmann +# Am Eisteich 9 +# 72555 Metzingen +# Germany +# +# Email: joe@ispsoft.de +# Phone: +49 7123 14881 +# + +use strict; +use Carp; + +require DBI; +DBI->require_version(1.0201); + +use RPC::PlClient 0.2000; # XXX change to 0.2017 once it's released + +{ package DBD::Proxy::RPC::PlClient; + @DBD::Proxy::RPC::PlClient::ISA = qw(RPC::PlClient); + sub Call { + my $self = shift; + if ($self->{debug}) { + my ($rpcmeth, $obj, $method, @args) = @_; + local $^W; # silence undefs + Carp::carp("Server $rpcmeth $method(@args)"); + } + return $self->SUPER::Call(@_); + } +} + + +package DBD::Proxy; + +use vars qw($VERSION $drh %ATTR); + +$VERSION = "0.2004"; + +$drh = undef; # holds driver handle once initialised + +%ATTR = ( # common to db & st, see also %ATTR in DBD::Proxy::db & ::st + 'Warn' => 'local', + 'Active' => 'local', + 'Kids' => 'local', + 'CachedKids' => 'local', + 'PrintError' => 'local', + 'RaiseError' => 'local', + 'HandleError' => 'local', + 'TraceLevel' => 'cached', + 'CompatMode' => 'local', +); + +sub driver ($$) { + if (!$drh) { + my($class, $attr) = @_; + + $class .= "::dr"; + + $drh = DBI::_new_drh($class, { + 'Name' => 'Proxy', + 'Version' => $VERSION, + 'Attribution' => 'DBD::Proxy by Jochen Wiedmann', + }); + $drh->STORE(CompatMode => 1); # disable DBI dispatcher attribute cache (for FETCH) + } + $drh; +} + +sub CLONE { + undef $drh; +} + +sub proxy_set_err { + my ($h,$errmsg) = @_; + my ($err, $state) = ($errmsg =~ s/ \[err=(.*?),state=(.*?)\]//) + ? ($1, $2) : (1, ' ' x 5); + return $h->set_err($err, $errmsg, $state); +} + +package DBD::Proxy::dr; # ====== DRIVER ====== + +$DBD::Proxy::dr::imp_data_size = 0; + +sub connect ($$;$$) { + my($drh, $dsn, $user, $auth, $attr)= @_; + my($dsnOrig) = $dsn; + + my %attr = %$attr; + my ($var, $val); + while (length($dsn)) { + if ($dsn =~ /^dsn=(.*)/) { + $attr{'dsn'} = $1; + last; + } + if ($dsn =~ /^(.*?);(.*)/) { + $var = $1; + $dsn = $2; + } else { + $var = $dsn; + $dsn = ''; + } + if ($var =~ /^(.*?)=(.*)/) { + $var = $1; + $val = $2; + $attr{$var} = $val; + } + } + + my $err = ''; + if (!defined($attr{'hostname'})) { $err .= " Missing hostname."; } + if (!defined($attr{'port'})) { $err .= " Missing port."; } + if (!defined($attr{'dsn'})) { $err .= " Missing remote dsn."; } + + # Create a cipher object, if requested + my $cipherRef = undef; + if ($attr{'cipher'}) { + $cipherRef = eval { $attr{'cipher'}->new(pack('H*', + $attr{'key'})) }; + if ($@) { $err .= " Cannot create cipher object: $@."; } + } + my $userCipherRef = undef; + if ($attr{'userkey'}) { + my $cipher = $attr{'usercipher'} || $attr{'cipher'}; + $userCipherRef = eval { $cipher->new(pack('H*', $attr{'userkey'})) }; + if ($@) { $err .= " Cannot create usercipher object: $@."; } + } + + return DBD::Proxy::proxy_set_err($drh, $err) if $err; # Returns undef + + my %client_opts = ( + 'peeraddr' => $attr{'hostname'}, + 'peerport' => $attr{'port'}, + 'socket_proto' => 'tcp', + 'application' => $attr{dsn}, + 'user' => $user || '', + 'password' => $auth || '', + 'version' => $DBD::Proxy::VERSION, + 'cipher' => $cipherRef, + 'debug' => $attr{debug} || 0, + 'timeout' => $attr{timeout} || undef, + 'logfile' => $attr{logfile} || undef + ); + # Options starting with 'proxy_rpc_' are forwarded to the RPC layer after + # stripping the prefix. + while (my($var,$val) = each %attr) { + if ($var =~ s/^proxy_rpc_//) { + $client_opts{$var} = $val; + } + } + # Create an RPC::PlClient object. + my($client, $msg) = eval { DBD::Proxy::RPC::PlClient->new(%client_opts) }; + + return DBD::Proxy::proxy_set_err($drh, "Cannot log in to DBI::ProxyServer: $@") + if $@; # Returns undef + return DBD::Proxy::proxy_set_err($drh, "Constructor didn't return a handle: $msg") + unless ($msg =~ /^((?:\w+|\:\:)+)=(\w+)/); # Returns undef + + $msg = RPC::PlClient::Object->new($1, $client, $msg); + + my $max_proto_ver; + my ($server_ver_str) = eval { $client->Call('Version') }; + if ( $@ ) { + # Server denies call, assume legacy protocol. + $max_proto_ver = 1; + } else { + # Parse proxy server version. + my ($server_ver_num) = $server_ver_str =~ /^DBI::ProxyServer\s+([\d\.]+)/; + $max_proto_ver = $server_ver_num >= 0.3 ? 2 : 1; + } + my $req_proto_ver; + if ( exists $attr{proxy_lazy_prepare} ) { + $req_proto_ver = ($attr{proxy_lazy_prepare} == 0) ? 2 : 1; + return DBD::Proxy::proxy_set_err($drh, + "DBI::ProxyServer does not support synchronous statement preparation.") + if $max_proto_ver < $req_proto_ver; + } + + # Switch to user specific encryption mode, if desired + if ($userCipherRef) { + $client->{'cipher'} = $userCipherRef; + } + + # create a 'blank' dbh + my $this = DBI::_new_dbh($drh, { + 'Name' => $dsnOrig, + 'proxy_dbh' => $msg, + 'proxy_client' => $client, + 'RowCacheSize' => $attr{'RowCacheSize'} || 20, + 'proxy_proto_ver' => $req_proto_ver || 1 + }); + + foreach $var (keys %attr) { + if ($var =~ /proxy_/) { + $this->{$var} = $attr{$var}; + } + } + $this->SUPER::STORE('Active' => 1); + + $this; +} + + +sub DESTROY { undef } + + +package DBD::Proxy::db; # ====== DATABASE ====== + +$DBD::Proxy::db::imp_data_size = 0; + +# XXX probably many more methods need to be added here +# in order to trigger our AUTOLOAD to redirect them to the server. +# (Unless the sub is declared it's bypassed by perl method lookup.) +# See notes in ToDo about method metadata +# The question is whether to add all the methods in %DBI::DBI_methods +# to the corresponding classes (::db, ::st etc) +# Also need to consider methods that, if proxied, would change the server state +# in a way that might not be visible on the client, ie begin_work -> AutoCommit. + +sub commit; +sub connected; +sub rollback; +sub ping; + + +use vars qw(%ATTR $AUTOLOAD); + +# inherited: STORE / FETCH against this class. +# local: STORE / FETCH against parent class. +# cached: STORE to remote and local objects, FETCH from local. +# remote: STORE / FETCH against remote object only (default). +# +# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. +# +%ATTR = ( # see also %ATTR in DBD::Proxy::st + %DBD::Proxy::ATTR, + RowCacheSize => 'inherited', + #AutoCommit => 'cached', + 'FetchHashKeyName' => 'cached', + Statement => 'local', + Driver => 'local', + dbi_connect_closure => 'local', + Username => 'local', +); + +sub AUTOLOAD { + my $method = $AUTOLOAD; + $method =~ s/(.*::(.*)):://; + my $class = $1; + my $type = $2; + #warn "AUTOLOAD of $method (class=$class, type=$type)"; + my %expand = ( + 'method' => $method, + 'class' => $class, + 'type' => $type, + 'call' => "$method(\@_)", + # XXX was trying to be smart but was tripping up over the DBI's own + # smartness. Disabled, but left here in case there are issues. + # 'call' => (UNIVERSAL::can("DBI::_::$type", $method)) ? "$method(\@_)" : "func(\@_, '$method')", + ); + + my $method_code = q{ + package ~class~; + sub ~method~ { + my $h = shift; + local $@; + my @result = wantarray + ? eval { $h->{'proxy_~type~h'}->~call~ } + : eval { scalar $h->{'proxy_~type~h'}->~call~ }; + return DBD::Proxy::proxy_set_err($h, $@) if $@; + return wantarray ? @result : $result[0]; + } + }; + $method_code =~ s/\~(\w+)\~/$expand{$1}/eg; + local $SIG{__DIE__} = 'DEFAULT'; + my $err = do { local $@; eval $method_code.2; $@ }; + die $err if $err; + goto &$AUTOLOAD; +} + +sub DESTROY { + my $dbh = shift; + local $@ if $@; # protect $@ + $dbh->disconnect if $dbh->SUPER::FETCH('Active'); +} + +sub disconnect ($) { + my ($dbh) = @_; + + # Sadly the Proxy too-often disagrees with the backend database + # on the subject of 'Active'. In the short term, I'd like the + # Proxy to ease up and let me decide when it's proper to go over + # the wire. This ultimately applies to finish() as well. + #return unless $dbh->SUPER::FETCH('Active'); + + # Drop database connection at remote end + my $rdbh = $dbh->{'proxy_dbh'}; + if ( $rdbh ) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + eval { $rdbh->disconnect() } ; + DBD::Proxy::proxy_set_err($dbh, $@) if $@; + } + + # Close TCP connect to remote + # XXX possibly best left till DESTROY? Add a config attribute to choose? + #$dbh->{proxy_client}->Disconnect(); # Disconnect method requires newer PlRPC module + $dbh->{proxy_client}->{socket} = undef; # hack + + $dbh->SUPER::STORE('Active' => 0); + 1; +} + + +sub STORE ($$$) { + my($dbh, $attr, $val) = @_; + my $type = $ATTR{$attr} || 'remote'; + + if ($attr eq 'TraceLevel') { + warn("TraceLevel $val"); + my $pc = $dbh->{proxy_client} || die; + $pc->{logfile} ||= 1; # XXX hack + $pc->{debug} = ($val && $val >= 4); + $pc->Debug("$pc debug enabled") if $pc->{debug}; + } + + if ($attr =~ /^proxy_/ || $type eq 'inherited') { + $dbh->{$attr} = $val; + return 1; + } + + if ($type eq 'remote' || $type eq 'cached') { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->STORE($attr => $val) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; # returns undef + $dbh->SUPER::STORE($attr => $val) if $type eq 'cached'; + return $result; + } + return $dbh->SUPER::STORE($attr => $val); +} + +sub FETCH ($$) { + my($dbh, $attr) = @_; + # we only get here for cached attribute values if the handle is in CompatMode + # otherwise the DBI dispatcher handles the FETCH itself from the attribute cache. + my $type = $ATTR{$attr} || 'remote'; + + if ($attr =~ /^proxy_/ || $type eq 'inherited' || $type eq 'cached') { + return $dbh->{$attr}; + } + + return $dbh->SUPER::FETCH($attr) unless $type eq 'remote'; + + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->FETCH($attr) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + +sub prepare ($$;$) { + my($dbh, $stmt, $attr) = @_; + my $sth = DBI::_new_sth($dbh, { + 'Statement' => $stmt, + 'proxy_attr' => $attr, + 'proxy_cache_only' => 0, + 'proxy_params' => [], + } + ); + my $proto_ver = $dbh->{'proxy_proto_ver'}; + if ( $proto_ver > 1 ) { + $sth->{'proxy_attr_cache'} = {cache_filled => 0}; + my $rdbh = $dbh->{'proxy_dbh'}; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $rsth = eval { $rdbh->prepare($sth->{'Statement'}, $sth->{'proxy_attr'}, undef, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") + unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); + + my $client = $dbh->{'proxy_client'}; + $rsth = RPC::PlClient::Object->new($1, $client, $rsth); + + $sth->{'proxy_sth'} = $rsth; + # If statement is a positioned update we do not want any readahead. + $sth->{'RowCacheSize'} = 1 if $stmt =~ /\bfor\s+update\b/i; + # Since resources are used by prepared remote handle, mark us active. + $sth->SUPER::STORE(Active => 1); + } + $sth; +} + +sub quote { + my $dbh = shift; + my $proxy_quote = $dbh->{proxy_quote} || 'remote'; + + return $dbh->SUPER::quote(@_) + if $proxy_quote eq 'local' && @_ == 1; + + # For the common case of only a single argument + # (no $data_type) we could learn and cache the behaviour. + # Or we could probe the driver with a few test cases. + # Or we could add a way to ask the DBI::ProxyServer + # if $dbh->can('quote') == \&DBI::_::db::quote. + # Tim + # + # Sounds all *very* smart to me. I'd rather suggest to + # implement some of the typical quote possibilities + # and let the user set + # $dbh->{'proxy_quote'} = 'backslash_escaped'; + # for example. + # Jochen + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->quote(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + +sub table_info { + my $dbh = shift; + my $rdbh = $dbh->{'proxy_dbh'}; + #warn "table_info(@_)"; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my($numFields, $names, $types, @rows) = eval { $rdbh->table_info(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + my ($sth, $inner) = DBI::_new_sth($dbh, { + 'Statement' => "SHOW TABLES", + 'proxy_params' => [], + 'proxy_data' => \@rows, + 'proxy_attr_cache' => { + 'NUM_OF_PARAMS' => 0, + 'NUM_OF_FIELDS' => $numFields, + 'NAME' => $names, + 'TYPE' => $types, + 'cache_filled' => 1 + }, + 'proxy_cache_only' => 1, + }); + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $inner->{NAME} = $names; + $inner->{TYPE} = $types; + $sth->SUPER::STORE('Active' => 1); # already execute()'d + $sth->{'proxy_rows'} = @rows; + return $sth; +} + +sub tables { + my $dbh = shift; + #warn "tables(@_)"; + return $dbh->SUPER::tables(@_); +} + + +sub type_info_all { + my $dbh = shift; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $dbh->{'proxy_dbh'}->type_info_all(@_) }; + return DBD::Proxy::proxy_set_err($dbh, $@) if $@; + return $result; +} + + +package DBD::Proxy::st; # ====== STATEMENT ====== + +$DBD::Proxy::st::imp_data_size = 0; + +use vars qw(%ATTR); + +# inherited: STORE to current object. FETCH from current if exists, else call up +# to the (proxy) database object. +# local: STORE / FETCH against parent class. +# cache_only: STORE noop (read-only). FETCH from private_* if exists, else call +# remote and cache the result. +# remote: STORE / FETCH against remote object only (default). +# +# Note: Attribute names starting with 'proxy_' always treated as 'inherited'. +# +%ATTR = ( # see also %ATTR in DBD::Proxy::db + %DBD::Proxy::ATTR, + 'Database' => 'local', + 'RowsInCache' => 'local', + 'RowCacheSize' => 'inherited', + 'NULLABLE' => 'cache_only', + 'NAME' => 'cache_only', + 'TYPE' => 'cache_only', + 'PRECISION' => 'cache_only', + 'SCALE' => 'cache_only', + 'NUM_OF_FIELDS' => 'cache_only', + 'NUM_OF_PARAMS' => 'cache_only' +); + +*AUTOLOAD = \&DBD::Proxy::db::AUTOLOAD; + +sub execute ($@) { + my $sth = shift; + my $params = @_ ? \@_ : $sth->{'proxy_params'}; + + # new execute, so delete any cached rows from previous execute + undef $sth->{'proxy_data'}; + undef $sth->{'proxy_rows'}; + + my $rsth = $sth->{proxy_sth}; + my $dbh = $sth->FETCH('Database'); + my $proto_ver = $dbh->{proxy_proto_ver}; + + my ($numRows, @outData); + + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + if ( $proto_ver > 1 ) { + ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + + # Attributes passed back only on the first execute() of a statement. + unless ($sth->{proxy_attr_cache}->{cache_filled}) { + my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); + $sth->{'proxy_attr_cache'} = { + 'NUM_OF_FIELDS' => $numFields, + 'NUM_OF_PARAMS' => $numParams, + 'NAME' => $names, + 'cache_filled' => 1 + }; + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); + } + + } + else { + if ($rsth) { + ($numRows, @outData) = eval { $rsth->execute($params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + + } + else { + my $rdbh = $dbh->{'proxy_dbh'}; + + # Legacy prepare is actually prepare + first execute on the server. + ($rsth, @outData) = + eval { $rdbh->prepare($sth->{'Statement'}, + $sth->{'proxy_attr'}, $params, $proto_ver) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return DBD::Proxy::proxy_set_err($sth, "Constructor didn't return a handle: $rsth") + unless ($rsth =~ /^((?:\w+|\:\:)+)=(\w+)/); + + my $client = $dbh->{'proxy_client'}; + $rsth = RPC::PlClient::Object->new($1, $client, $rsth); + + my ($numFields, $numParams, $names, $types) = splice(@outData, 0, 4); + $sth->{'proxy_sth'} = $rsth; + $sth->{'proxy_attr_cache'} = { + 'NUM_OF_FIELDS' => $numFields, + 'NUM_OF_PARAMS' => $numParams, + 'NAME' => $names + }; + $sth->SUPER::STORE('NUM_OF_FIELDS' => $numFields); + $sth->SUPER::STORE('NUM_OF_PARAMS' => $numParams); + $numRows = shift @outData; + } + } + # Always condition active flag. + $sth->SUPER::STORE('Active' => 1) if $sth->FETCH('NUM_OF_FIELDS'); # is SELECT + $sth->{'proxy_rows'} = $numRows; + # Any remaining items are output params. + if (@outData) { + foreach my $p (@$params) { + if (ref($p->[0])) { + my $ref = shift @outData; + ${$p->[0]} = $$ref; + } + } + } + + $sth->{'proxy_rows'} || '0E0'; +} + +sub fetch ($) { + my $sth = shift; + + my $data = $sth->{'proxy_data'}; + + $sth->{'proxy_rows'} = 0 unless defined $sth->{'proxy_rows'}; + + if(!$data || !@$data) { + return undef unless $sth->SUPER::FETCH('Active'); + + my $rsth = $sth->{'proxy_sth'}; + if (!$rsth) { + die "Attempt to fetch row without execute"; + } + my $num_rows = $sth->FETCH('RowCacheSize') || 20; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my @rows = eval { $rsth->fetch($num_rows) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + unless (@rows == $num_rows) { + undef $sth->{'proxy_data'}; + # server side has already called finish + $sth->SUPER::STORE(Active => 0); + } + return undef unless @rows; + $sth->{'proxy_data'} = $data = [@rows]; + } + my $row = shift @$data; + + $sth->SUPER::STORE(Active => 0) if ( $sth->{proxy_cache_only} and !@$data ); + $sth->{'proxy_rows'}++; + return $sth->_set_fbav($row); +} +*fetchrow_arrayref = \&fetch; + +sub rows ($) { + my $rows = shift->{'proxy_rows'}; + return (defined $rows) ? $rows : -1; +} + +sub finish ($) { + my($sth) = @_; + return 1 unless $sth->SUPER::FETCH('Active'); + my $rsth = $sth->{'proxy_sth'}; + $sth->SUPER::STORE('Active' => 0); + return 0 unless $rsth; # Something's out of sync + my $no_finish = exists($sth->{'proxy_no_finish'}) + ? $sth->{'proxy_no_finish'} + : $sth->FETCH('Database')->{'proxy_no_finish'}; + unless ($no_finish) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->finish() }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return $result; + } + 1; +} + +sub STORE ($$$) { + my($sth, $attr, $val) = @_; + my $type = $ATTR{$attr} || 'remote'; + + if ($attr =~ /^proxy_/ || $type eq 'inherited') { + $sth->{$attr} = $val; + return 1; + } + + if ($type eq 'cache_only') { + return 0; + } + + if ($type eq 'remote' || $type eq 'cached') { + my $rsth = $sth->{'proxy_sth'} or return undef; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->STORE($attr => $val) }; + return DBD::Proxy::proxy_set_err($sth, $@) if ($@); + return $result if $type eq 'remote'; # else fall through to cache locally + } + return $sth->SUPER::STORE($attr => $val); +} + +sub FETCH ($$) { + my($sth, $attr) = @_; + + if ($attr =~ /^proxy_/) { + return $sth->{$attr}; + } + + my $type = $ATTR{$attr} || 'remote'; + if ($type eq 'inherited') { + if (exists($sth->{$attr})) { + return $sth->{$attr}; + } + return $sth->FETCH('Database')->{$attr}; + } + + if ($type eq 'cache_only' && + exists($sth->{'proxy_attr_cache'}->{$attr})) { + return $sth->{'proxy_attr_cache'}->{$attr}; + } + + if ($type ne 'local') { + my $rsth = $sth->{'proxy_sth'} or return undef; + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + my $result = eval { $rsth->FETCH($attr) }; + return DBD::Proxy::proxy_set_err($sth, $@) if $@; + return $result; + } + elsif ($attr eq 'RowsInCache') { + my $data = $sth->{'proxy_data'}; + $data ? @$data : 0; + } + else { + $sth->SUPER::FETCH($attr); + } +} + +sub bind_param ($$$@) { + my $sth = shift; my $param = shift; + $sth->{'proxy_params'}->[$param-1] = [@_]; +} +*bind_param_inout = \&bind_param; + +sub DESTROY { + my $sth = shift; + $sth->finish if $sth->SUPER::FETCH('Active'); +} + + +1; + + +__END__ + +=head1 NAME + +DBD::Proxy - A proxy driver for the DBI + +=head1 SYNOPSIS + + use DBI; + + $dbh = DBI->connect("dbi:Proxy:hostname=$host;port=$port;dsn=$db", + $user, $passwd); + + # See the DBI module documentation for full details + +=head1 DESCRIPTION + +DBD::Proxy is a Perl module for connecting to a database via a remote +DBI driver. See L<DBD::Gofer> for an alternative with different trade-offs. + +This is of course not needed for DBI drivers which already +support connecting to a remote database, but there are engines which +don't offer network connectivity. + +Another application is offering database access through a firewall, as +the driver offers query based restrictions. For example you can +restrict queries to exactly those that are used in a given CGI +application. + +Speaking of CGI, another application is (or rather, will be) to reduce +the database connect/disconnect overhead from CGI scripts by using +proxying the connect_cached method. The proxy server will hold the +database connections open in a cache. The CGI script then trades the +database connect/disconnect overhead for the DBD::Proxy +connect/disconnect overhead which is typically much less. +I<Note that the connect_cached method is new and still experimental.> + + +=head1 CONNECTING TO THE DATABASE + +Before connecting to a remote database, you must ensure, that a Proxy +server is running on the remote machine. There's no default port, so +you have to ask your system administrator for the port number. See +L<DBI::ProxyServer> for details. + +Say, your Proxy server is running on machine "alpha", port 3334, and +you'd like to connect to an ODBC database called "mydb" as user "joe" +with password "hello". When using DBD::ODBC directly, you'd do a + + $dbh = DBI->connect("DBI:ODBC:mydb", "joe", "hello"); + +With DBD::Proxy this becomes + + $dsn = "DBI:Proxy:hostname=alpha;port=3334;dsn=DBI:ODBC:mydb"; + $dbh = DBI->connect($dsn, "joe", "hello"); + +You see, this is mainly the same. The DBD::Proxy module will create a +connection to the Proxy server on "alpha" which in turn will connect +to the ODBC database. + +Refer to the L<DBI> documentation on the C<connect> method for a way +to automatically use DBD::Proxy without having to change your code. + +DBD::Proxy's DSN string has the format + + $dsn = "DBI:Proxy:key1=val1; ... ;keyN=valN;dsn=valDSN"; + +In other words, it is a collection of key/value pairs. The following +keys are recognized: + +=over 4 + +=item hostname + +=item port + +Hostname and port of the Proxy server; these keys must be present, +no defaults. Example: + + hostname=alpha;port=3334 + +=item dsn + +The value of this attribute will be used as a dsn name by the Proxy +server. Thus it must have the format C<DBI:driver:...>, in particular +it will contain colons. The I<dsn> value may contain semicolons, hence +this key *must* be the last and it's value will be the complete +remaining part of the dsn. Example: + + dsn=DBI:ODBC:mydb + +=item cipher + +=item key + +=item usercipher + +=item userkey + +By using these fields you can enable encryption. If you set, +for example, + + cipher=$class;key=$key + +(note the semicolon) then DBD::Proxy will create a new cipher object +by executing + + $cipherRef = $class->new(pack("H*", $key)); + +and pass this object to the RPC::PlClient module when creating a +client. See L<RPC::PlClient>. Example: + + cipher=IDEA;key=97cd2375efa329aceef2098babdc9721 + +The usercipher/userkey attributes allow you to use two phase encryption: +The cipher/key encryption will be used in the login and authorisation +phase. Once the client is authorised, he will change to usercipher/userkey +encryption. Thus the cipher/key pair is a B<host> based secret, typically +less secure than the usercipher/userkey secret and readable by anyone. +The usercipher/userkey secret is B<your> private secret. + +Of course encryption requires an appropriately configured server. See +<DBD::ProxyServer/CONFIGURATION FILE>. + +=item debug + +Turn on debugging mode + +=item stderr + +This attribute will set the corresponding attribute of the RPC::PlClient +object, thus logging will not use syslog(), but redirected to stderr. +This is the default under Windows. + + stderr=1 + +=item logfile + +Similar to the stderr attribute, but output will be redirected to the +given file. + + logfile=/dev/null + +=item RowCacheSize + +The DBD::Proxy driver supports this attribute (which is DBI standard, +as of DBI 1.02). It's used to reduce network round-trips by fetching +multiple rows in one go. The current default value is 20, but this may +change. + + +=item proxy_no_finish + +This attribute can be used to reduce network traffic: If the +application is calling $sth->finish() then the proxy tells the server +to finish the remote statement handle. Of course this slows down things +quite a lot, but is perfectly good for reducing memory usage with +persistent connections. + +However, if you set the I<proxy_no_finish> attribute to a TRUE value, +either in the database handle or in the statement handle, then finish() +calls will be supressed. This is what you want, for example, in small +and fast CGI applications. + +=item proxy_quote + +This attribute can be used to reduce network traffic: By default calls +to $dbh->quote() are passed to the remote driver. Of course this slows +down things quite a lot, but is the safest default behaviour. + +However, if you set the I<proxy_quote> attribute to the value 'C<local>' +either in the database handle or in the statement handle, and the call +to quote has only one parameter, then the local default DBI quote +method will be used (which will be faster but may be wrong). + +=back + +=head1 KNOWN ISSUES + +=head2 Unproxied method calls + +If a method isn't being proxied, try declaring a stub sub in the appropriate +package (DBD::Proxy::db for a dbh method, and DBD::Proxy::st for an sth method). +For example: + + sub DBD::Proxy::db::selectall_arrayref; + +That will enable selectall_arrayref to be proxied. + +Currently many methods aren't explicitly proxied and so you get the DBI's +default methods executed on the client. + +Some of those methods, like selectall_arrayref, may then call other methods +that are proxied (selectall_arrayref calls fetchall_arrayref which calls fetch +which is proxied). So things may appear to work but operate more slowly than +the could. + +This may all change in a later version. + +=head2 Complex handle attributes + +Sometimes handles are having complex attributes like hash refs or +array refs and not simple strings or integers. For example, with +DBD::CSV, you would like to write something like + + $dbh->{"csv_tables"}->{"passwd"} = + { "sep_char" => ":", "eol" => "\n"; + +The above example would advice the CSV driver to assume the file +"passwd" to be in the format of the /etc/passwd file: Colons as +separators and a line feed without carriage return as line +terminator. + +Surprisingly this example doesn't work with the proxy driver. To understand +the reasons, you should consider the following: The Perl compiler is +executing the above example in two steps: + +=over + +=item 1 + +The first step is fetching the value of the key "csv_tables" in the +handle $dbh. The value returned is complex, a hash ref. + +=item 2 + +The second step is storing some value (the right hand side of the +assignment) as the key "passwd" in the hash ref from step 1. + +=back + +This becomes a little bit clearer, if we rewrite the above code: + + $tables = $dbh->{"csv_tables"}; + $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; + +While the examples work fine without the proxy, the fail due to a +subtle difference in step 1: By DBI magic, the hash ref +$dbh->{'csv_tables'} is returned from the server to the client. +The client creates a local copy. This local copy is the result of +step 1. In other words, step 2 modifies a local copy of the hash ref, +but not the server's hash ref. + +The workaround is storing the modified local copy back to the server: + + $tables = $dbh->{"csv_tables"}; + $tables->{"passwd"} = { "sep_char" => ":", "eol" => "\n"; + $dbh->{"csv_tables"} = $tables; + + +=head1 AUTHOR AND COPYRIGHT + +This module is Copyright (c) 1997, 1998 + + Jochen Wiedmann + Am Eisteich 9 + 72555 Metzingen + Germany + + Email: joe@ispsoft.de + Phone: +49 7123 14887 + +The DBD::Proxy 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<DBI>, L<RPC::PlClient>, L<Storable> + +=cut diff --git a/lib/DBD/Sponge.pm b/lib/DBD/Sponge.pm new file mode 100644 index 0000000..2413bc0 --- /dev/null +++ b/lib/DBD/Sponge.pm @@ -0,0 +1,305 @@ +{ + package DBD::Sponge; + + require DBI; + require Carp; + + our @EXPORT = qw(); # Do NOT @EXPORT anything. + our $VERSION = sprintf("12.%06d", q$Revision: 10002 $ =~ /(\d+)/o); + + +# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z timbo $ +# +# Copyright (c) 1994-2003 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. + + $drh = undef; # holds driver handle once initialised + my $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBD::Sponge::db->install_method("sponge_test_installed_method") + unless $methods_already_installed++; + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Sponge', + 'Version' => $VERSION, + 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", + }); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::Sponge::dr; # ====== DRIVER ====== + $imp_data_size = 0; + # we use default (dummy) connect method +} + + +{ package DBD::Sponge::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement, $attribs) = @_; + my $rows = delete $attribs->{'rows'} + or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare"); + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + 'rows' => $rows, + (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } + qw(execute_hook) + ), + }); + if (my $behave_like = $attribs->{behave_like}) { + $outer->{$_} = $behave_like->{$_} + foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); + } + + if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() + $sth->{is_insert} = 1; + my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} + or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); + $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); + } + else { #assume select + + # we need to set NUM_OF_FIELDS + my $numFields; + if ($attribs->{'NUM_OF_FIELDS'}) { + $numFields = $attribs->{'NUM_OF_FIELDS'}; + } elsif ($attribs->{'NAME'}) { + $numFields = @{$attribs->{NAME}}; + } elsif ($attribs->{'TYPE'}) { + $numFields = @{$attribs->{TYPE}}; + } elsif (my $firstrow = $rows->[0]) { + $numFields = scalar @$firstrow; + } else { + return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); + } + $sth->STORE('NUM_OF_FIELDS' => $numFields); + $sth->{NAME} = $attribs->{NAME} + || [ map { "col$_" } 1..$numFields ]; + $sth->{TYPE} = $attribs->{TYPE} + || [ (DBI::SQL_VARCHAR()) x $numFields ]; + $sth->{PRECISION} = $attribs->{PRECISION} + || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; + $sth->{SCALE} = $attribs->{SCALE} + || [ (0) x $numFields ]; + $sth->{NULLABLE} = $attribs->{NULLABLE} + || [ (2) x $numFields ]; + } + + $outer; + } + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return 1 if $attrib eq 'AutoCommit'; + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + return 1 if $value; # is already set + Carp::croak("Can't disable AutoCommit"); + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub sponge_test_installed_method { + my ($dbh, @args) = @_; + return $dbh->set_err(42, "not enough parameters") unless @args >= 2; + return \@args; + } +} + + +{ package DBD::Sponge::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + sub execute { + my $sth = shift; + + # hack to support ParamValues (when not using bind_param) + $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; + + if (my $hook = $sth->{execute_hook}) { + &$hook($sth, @_) or return; + } + + if ($sth->{is_insert}) { + my $row; + $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; + my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; + return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") + if @$row != $NUM_OF_PARAMS; + { local $^W; $sth->trace_msg("inserting (@$row)\n"); } + push @{ $sth->{rows} }, $row; + } + else { # mark select sth as Active + $sth->STORE(Active => 1); + } + # else do nothing for select as data is already in $sth->{rows} + return 1; + } + + sub fetch { + my ($sth) = @_; + my $row = shift @{$sth->{'rows'}}; + unless ($row) { + $sth->STORE(Active => 0); + return undef; + } + return $sth->_set_fbav($row); + } + *fetchrow_arrayref = \&fetch; + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +DBD::Sponge - Create a DBI statement handle from Perl data + +=head1 SYNOPSIS + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=head1 DESCRIPTION + +DBD::Sponge is useful for making a Perl data structure accessible through a +standard DBI statement handle. This may be useful to DBD module authors who +need to transform data in this way. + +=head1 METHODS + +=head2 connect() + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + +Here's a sample syntax for creating a database handle for the Sponge driver. +No username and password are needed. + +=head2 prepare() + + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=over 4 + +=item * + +The C<$statement> here is an arbitrary statement or name you want +to provide as identity of your data. If you're using DBI::Profile +it will appear in the profile data. + +Generally it's expected that you are preparing a statement handle +as if a C<select> statement happened. + +=item * + +C<$data> is a reference to the data you are providing, given as an array of arrays. + +=item * + +C<$names> is a reference an array of column names for the C<$data> you are providing. +The number and order should match the number and ordering of the C<$data> columns. + +=item * + +C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement. + +Currently only NAME, TYPE, and PRECISION are supported. + +=back + +=head1 BUGS + +Using this module to prepare INSERT-like statements is not currently documented. + +=head1 AUTHOR AND COPYRIGHT + +This module is Copyright (c) 2003 Tim Bunce + +Documentation initially written by Mark Stosberg + +The DBD::Sponge 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<DBI> + +=cut diff --git a/lib/DBI/Const/GetInfo/ANSI.pm b/lib/DBI/Const/GetInfo/ANSI.pm new file mode 100644 index 0000000..428ce37 --- /dev/null +++ b/lib/DBI/Const/GetInfo/ANSI.pm @@ -0,0 +1,236 @@ +# $Id: ANSI.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing ANSI CLI info types and return values for the +# SQLGetInfo() method of ODBC. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfo::ANSI; + +=head1 NAME + +DBI::Const::GetInfo::ANSI - ISO/IEC SQL/CLI Constants for GetInfo + +=head1 SYNOPSIS + + The API for this module is private and subject to change. + +=head1 DESCRIPTION + +Information requested by GetInfo(). + +See: A.1 C header file SQLCLI.H, Page 316, 317. + +The API for this module is private and subject to change. + +=head1 REFERENCES + + ISO/IEC FCD 9075-3:200x Information technology - Database Languages - + SQL - Part 3: Call-Level Interface (SQL/CLI) + + SC32 N00744 = WG3:VIE-005 = H2-2002-007 + + Date: 2002-01-15 + +=cut + +my +$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +%InfoTypes = +( + SQL_ALTER_TABLE => 86 +, SQL_CATALOG_NAME => 10003 +, SQL_COLLATING_SEQUENCE => 10004 +, SQL_CURSOR_COMMIT_BEHAVIOR => 23 +, SQL_CURSOR_SENSITIVITY => 10001 +, SQL_DATA_SOURCE_NAME => 2 +, SQL_DATA_SOURCE_READ_ONLY => 25 +, SQL_DBMS_NAME => 17 +, SQL_DBMS_VERSION => 18 +, SQL_DEFAULT_TRANSACTION_ISOLATION => 26 +, SQL_DESCRIBE_PARAMETER => 10002 +, SQL_FETCH_DIRECTION => 8 +, SQL_GETDATA_EXTENSIONS => 81 +, SQL_IDENTIFIER_CASE => 28 +, SQL_INTEGRITY => 73 +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 +, SQL_MAXIMUM_COLUMNS_IN_TABLE => 101 +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 +, SQL_MAXIMUM_STMT_OCTETS => 20000 +, SQL_MAXIMUM_STMT_OCTETS_DATA => 20001 +, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 20002 +, SQL_MAXIMUM_TABLES_IN_SELECT => 106 +, SQL_MAXIMUM_TABLE_NAME_LENGTH => 35 +, SQL_MAXIMUM_USER_NAME_LENGTH => 107 +, SQL_NULL_COLLATION => 85 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 +, SQL_OUTER_JOIN_CAPABILITIES => 115 +, SQL_SCROLL_CONCURRENCY => 43 +, SQL_SEARCH_PATTERN_ESCAPE => 14 +, SQL_SERVER_NAME => 13 +, SQL_SPECIAL_CHARACTERS => 94 +, SQL_TRANSACTION_CAPABLE => 46 +, SQL_TRANSACTION_ISOLATION_OPTION => 72 +, SQL_USER_NAME => 47 +); + +=head2 %ReturnTypes + +See: Codes and data types for implementation information (Table 28), Page 85, 86. + +Mapped to ODBC datatype names. + +=cut + +%ReturnTypes = # maxlen +( + SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # INTEGER +, SQL_CATALOG_NAME => 'SQLCHAR' # CHARACTER (1) +, SQL_COLLATING_SEQUENCE => 'SQLCHAR' # CHARACTER (254) +, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # SMALLINT +, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # INTEGER +, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # CHARACTER (128) +, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # CHARACTER (1) +, SQL_DBMS_NAME => 'SQLCHAR' # CHARACTER (254) +, SQL_DBMS_VERSION => 'SQLCHAR' # CHARACTER (254) +, SQL_DEFAULT_TRANSACTION_ISOLATION => 'SQLUINTEGER' # INTEGER +, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # CHARACTER (1) +, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # INTEGER +, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # INTEGER +, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # SMALLINT +, SQL_INTEGRITY => 'SQLCHAR' # CHARACTER (1) +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS_DATA => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_TABLE_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_NULL_COLLATION => 'SQLUSMALLINT' # SMALLINT +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # CHARACTER (1) +, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # INTEGER +, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # INTEGER +, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # CHARACTER (1) +, SQL_SERVER_NAME => 'SQLCHAR' # CHARACTER (128) +, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # CHARACTER (254) +, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # SMALLINT +, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # INTEGER +, SQL_USER_NAME => 'SQLCHAR' # CHARACTER (128) +); + +=head2 %ReturnValues + +See: A.1 C header file SQLCLI.H, Page 317, 318. + +=cut + +$ReturnValues{SQL_ALTER_TABLE} = +{ + SQL_AT_ADD_COLUMN => 0x00000001 +, SQL_AT_DROP_COLUMN => 0x00000002 +, SQL_AT_ALTER_COLUMN => 0x00000004 +, SQL_AT_ADD_CONSTRAINT => 0x00000008 +, SQL_AT_DROP_CONSTRAINT => 0x00000010 +}; +$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = +{ + SQL_CB_DELETE => 0 +, SQL_CB_CLOSE => 1 +, SQL_CB_PRESERVE => 2 +}; +$ReturnValues{SQL_FETCH_DIRECTION} = +{ + SQL_FD_FETCH_NEXT => 0x00000001 +, SQL_FD_FETCH_FIRST => 0x00000002 +, SQL_FD_FETCH_LAST => 0x00000004 +, SQL_FD_FETCH_PRIOR => 0x00000008 +, SQL_FD_FETCH_ABSOLUTE => 0x00000010 +, SQL_FD_FETCH_RELATIVE => 0x00000020 +}; +$ReturnValues{SQL_GETDATA_EXTENSIONS} = +{ + SQL_GD_ANY_COLUMN => 0x00000001 +, SQL_GD_ANY_ORDER => 0x00000002 +}; +$ReturnValues{SQL_IDENTIFIER_CASE} = +{ + SQL_IC_UPPER => 1 +, SQL_IC_LOWER => 2 +, SQL_IC_SENSITIVE => 3 +, SQL_IC_MIXED => 4 +}; +$ReturnValues{SQL_NULL_COLLATION} = +{ + SQL_NC_HIGH => 1 +, SQL_NC_LOW => 2 +}; +$ReturnValues{SQL_OUTER_JOIN_CAPABILITIES} = +{ + SQL_OUTER_JOIN_LEFT => 0x00000001 +, SQL_OUTER_JOIN_RIGHT => 0x00000002 +, SQL_OUTER_JOIN_FULL => 0x00000004 +, SQL_OUTER_JOIN_NESTED => 0x00000008 +, SQL_OUTER_JOIN_NOT_ORDERED => 0x00000010 +, SQL_OUTER_JOIN_INNER => 0x00000020 +, SQL_OUTER_JOIN_ALL_COMPARISON_OPS => 0x00000040 +}; +$ReturnValues{SQL_SCROLL_CONCURRENCY} = +{ + SQL_SCCO_READ_ONLY => 0x00000001 +, SQL_SCCO_LOCK => 0x00000002 +, SQL_SCCO_OPT_ROWVER => 0x00000004 +, SQL_SCCO_OPT_VALUES => 0x00000008 +}; +$ReturnValues{SQL_TRANSACTION_ACCESS_MODE} = +{ + SQL_TRANSACTION_READ_ONLY => 0x00000001 +, SQL_TRANSACTION_READ_WRITE => 0x00000002 +}; +$ReturnValues{SQL_TRANSACTION_CAPABLE} = +{ + SQL_TC_NONE => 0 +, SQL_TC_DML => 1 +, SQL_TC_ALL => 2 +, SQL_TC_DDL_COMMIT => 3 +, SQL_TC_DDL_IGNORE => 4 +}; +$ReturnValues{SQL_TRANSACTION_ISOLATION} = +{ + SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 +, SQL_TRANSACTION_READ_COMMITTED => 0x00000002 +, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 +, SQL_TRANSACTION_SERIALIZABLE => 0x00000008 +}; + +1; + +=head1 TODO + +Corrections, e.g.: + + SQL_TRANSACTION_ISOLATION_OPTION vs. SQL_TRANSACTION_ISOLATION + +=cut diff --git a/lib/DBI/Const/GetInfo/ODBC.pm b/lib/DBI/Const/GetInfo/ODBC.pm new file mode 100644 index 0000000..0f71a06 --- /dev/null +++ b/lib/DBI/Const/GetInfo/ODBC.pm @@ -0,0 +1,1363 @@ +# $Id: ODBC.pm 11373 2008-06-02 19:01:33Z timbo $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing Microsoft ODBC info types and return values +# for the SQLGetInfo() method of ODBC. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfo::ODBC; + +=head1 NAME + +DBI::Const::GetInfo::ODBC - ODBC Constants for GetInfo + +=head1 SYNOPSIS + + The API for this module is private and subject to change. + +=head1 DESCRIPTION + +Information requested by GetInfo(). + +The API for this module is private and subject to change. + +=head1 REFERENCES + + MDAC SDK 2.6 + ODBC version number (0x0351) + + sql.h + sqlext.h + +=cut + +my +$VERSION = sprintf("2.%06d", q$Revision: 11373 $ =~ /(\d+)/o); + + +%InfoTypes = +( + SQL_ACCESSIBLE_PROCEDURES => 20 +, SQL_ACCESSIBLE_TABLES => 19 +, SQL_ACTIVE_CONNECTIONS => 0 +, SQL_ACTIVE_ENVIRONMENTS => 116 +, SQL_ACTIVE_STATEMENTS => 1 +, SQL_AGGREGATE_FUNCTIONS => 169 +, SQL_ALTER_DOMAIN => 117 +, SQL_ALTER_TABLE => 86 +, SQL_ASYNC_MODE => 10021 +, SQL_BATCH_ROW_COUNT => 120 +, SQL_BATCH_SUPPORT => 121 +, SQL_BOOKMARK_PERSISTENCE => 82 +, SQL_CATALOG_LOCATION => 114 # SQL_QUALIFIER_LOCATION +, SQL_CATALOG_NAME => 10003 +, SQL_CATALOG_NAME_SEPARATOR => 41 # SQL_QUALIFIER_NAME_SEPARATOR +, SQL_CATALOG_TERM => 42 # SQL_QUALIFIER_TERM +, SQL_CATALOG_USAGE => 92 # SQL_QUALIFIER_USAGE +, SQL_COLLATION_SEQ => 10004 +, SQL_COLUMN_ALIAS => 87 +, SQL_CONCAT_NULL_BEHAVIOR => 22 +, SQL_CONVERT_BIGINT => 53 +, SQL_CONVERT_BINARY => 54 +, SQL_CONVERT_BIT => 55 +, SQL_CONVERT_CHAR => 56 +, SQL_CONVERT_DATE => 57 +, SQL_CONVERT_DECIMAL => 58 +, SQL_CONVERT_DOUBLE => 59 +, SQL_CONVERT_FLOAT => 60 +, SQL_CONVERT_FUNCTIONS => 48 +, SQL_CONVERT_GUID => 173 +, SQL_CONVERT_INTEGER => 61 +, SQL_CONVERT_INTERVAL_DAY_TIME => 123 +, SQL_CONVERT_INTERVAL_YEAR_MONTH => 124 +, SQL_CONVERT_LONGVARBINARY => 71 +, SQL_CONVERT_LONGVARCHAR => 62 +, SQL_CONVERT_NUMERIC => 63 +, SQL_CONVERT_REAL => 64 +, SQL_CONVERT_SMALLINT => 65 +, SQL_CONVERT_TIME => 66 +, SQL_CONVERT_TIMESTAMP => 67 +, SQL_CONVERT_TINYINT => 68 +, SQL_CONVERT_VARBINARY => 69 +, SQL_CONVERT_VARCHAR => 70 +, SQL_CONVERT_WCHAR => 122 +, SQL_CONVERT_WLONGVARCHAR => 125 +, SQL_CONVERT_WVARCHAR => 126 +, SQL_CORRELATION_NAME => 74 +, SQL_CREATE_ASSERTION => 127 +, SQL_CREATE_CHARACTER_SET => 128 +, SQL_CREATE_COLLATION => 129 +, SQL_CREATE_DOMAIN => 130 +, SQL_CREATE_SCHEMA => 131 +, SQL_CREATE_TABLE => 132 +, SQL_CREATE_TRANSLATION => 133 +, SQL_CREATE_VIEW => 134 +, SQL_CURSOR_COMMIT_BEHAVIOR => 23 +, SQL_CURSOR_ROLLBACK_BEHAVIOR => 24 +, SQL_CURSOR_SENSITIVITY => 10001 +, SQL_DATA_SOURCE_NAME => 2 +, SQL_DATA_SOURCE_READ_ONLY => 25 +, SQL_DATABASE_NAME => 16 +, SQL_DATETIME_LITERALS => 119 +, SQL_DBMS_NAME => 17 +, SQL_DBMS_VER => 18 +, SQL_DDL_INDEX => 170 +, SQL_DEFAULT_TXN_ISOLATION => 26 +, SQL_DESCRIBE_PARAMETER => 10002 +, SQL_DM_VER => 171 +, SQL_DRIVER_HDBC => 3 +, SQL_DRIVER_HDESC => 135 +, SQL_DRIVER_HENV => 4 +, SQL_DRIVER_HLIB => 76 +, SQL_DRIVER_HSTMT => 5 +, SQL_DRIVER_NAME => 6 +, SQL_DRIVER_ODBC_VER => 77 +, SQL_DRIVER_VER => 7 +, SQL_DROP_ASSERTION => 136 +, SQL_DROP_CHARACTER_SET => 137 +, SQL_DROP_COLLATION => 138 +, SQL_DROP_DOMAIN => 139 +, SQL_DROP_SCHEMA => 140 +, SQL_DROP_TABLE => 141 +, SQL_DROP_TRANSLATION => 142 +, SQL_DROP_VIEW => 143 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 144 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 145 +, SQL_EXPRESSIONS_IN_ORDERBY => 27 +, SQL_FETCH_DIRECTION => 8 +, SQL_FILE_USAGE => 84 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 146 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 147 +, SQL_GETDATA_EXTENSIONS => 81 +, SQL_GROUP_BY => 88 +, SQL_IDENTIFIER_CASE => 28 +, SQL_IDENTIFIER_QUOTE_CHAR => 29 +, SQL_INDEX_KEYWORDS => 148 +# SQL_INFO_DRIVER_START => 1000 +# SQL_INFO_FIRST => 0 +# SQL_INFO_LAST => 114 # SQL_QUALIFIER_LOCATION +, SQL_INFO_SCHEMA_VIEWS => 149 +, SQL_INSERT_STATEMENT => 172 +, SQL_INTEGRITY => 73 +, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 150 +, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 151 +, SQL_KEYWORDS => 89 +, SQL_LIKE_ESCAPE_CLAUSE => 113 +, SQL_LOCK_TYPES => 78 +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 # SQL_MAX_CATALOG_NAME_LEN +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 # SQL_MAX_COLUMNS_IN_GROUP_BY +, SQL_MAXIMUM_COLUMNS_IN_INDEX => 98 # SQL_MAX_COLUMNS_IN_INDEX +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 # SQL_MAX_COLUMNS_IN_ORDER_BY +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 # SQL_MAX_COLUMNS_IN_SELECT +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 # SQL_MAX_COLUMN_NAME_LEN +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 # SQL_MAX_CONCURRENT_ACTIVITIES +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 # SQL_MAX_CURSOR_NAME_LEN +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 # SQL_MAX_DRIVER_CONNECTIONS +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 # SQL_MAX_IDENTIFIER_LEN +, SQL_MAXIMUM_INDEX_SIZE => 102 # SQL_MAX_INDEX_SIZE +, SQL_MAXIMUM_ROW_SIZE => 104 # SQL_MAX_ROW_SIZE +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 # SQL_MAX_SCHEMA_NAME_LEN +, SQL_MAXIMUM_STATEMENT_LENGTH => 105 # SQL_MAX_STATEMENT_LEN +, SQL_MAXIMUM_TABLES_IN_SELECT => 106 # SQL_MAX_TABLES_IN_SELECT +, SQL_MAXIMUM_USER_NAME_LENGTH => 107 # SQL_MAX_USER_NAME_LEN +, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 10022 +, SQL_MAX_BINARY_LITERAL_LEN => 112 +, SQL_MAX_CATALOG_NAME_LEN => 34 +, SQL_MAX_CHAR_LITERAL_LEN => 108 +, SQL_MAX_COLUMNS_IN_GROUP_BY => 97 +, SQL_MAX_COLUMNS_IN_INDEX => 98 +, SQL_MAX_COLUMNS_IN_ORDER_BY => 99 +, SQL_MAX_COLUMNS_IN_SELECT => 100 +, SQL_MAX_COLUMNS_IN_TABLE => 101 +, SQL_MAX_COLUMN_NAME_LEN => 30 +, SQL_MAX_CONCURRENT_ACTIVITIES => 1 +, SQL_MAX_CURSOR_NAME_LEN => 31 +, SQL_MAX_DRIVER_CONNECTIONS => 0 +, SQL_MAX_IDENTIFIER_LEN => 10005 +, SQL_MAX_INDEX_SIZE => 102 +, SQL_MAX_OWNER_NAME_LEN => 32 +, SQL_MAX_PROCEDURE_NAME_LEN => 33 +, SQL_MAX_QUALIFIER_NAME_LEN => 34 +, SQL_MAX_ROW_SIZE => 104 +, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 103 +, SQL_MAX_SCHEMA_NAME_LEN => 32 +, SQL_MAX_STATEMENT_LEN => 105 +, SQL_MAX_TABLES_IN_SELECT => 106 +, SQL_MAX_TABLE_NAME_LEN => 35 +, SQL_MAX_USER_NAME_LEN => 107 +, SQL_MULTIPLE_ACTIVE_TXN => 37 +, SQL_MULT_RESULT_SETS => 36 +, SQL_NEED_LONG_DATA_LEN => 111 +, SQL_NON_NULLABLE_COLUMNS => 75 +, SQL_NULL_COLLATION => 85 +, SQL_NUMERIC_FUNCTIONS => 49 +, SQL_ODBC_API_CONFORMANCE => 9 +, SQL_ODBC_INTERFACE_CONFORMANCE => 152 +, SQL_ODBC_SAG_CLI_CONFORMANCE => 12 +, SQL_ODBC_SQL_CONFORMANCE => 15 +, SQL_ODBC_SQL_OPT_IEF => 73 +, SQL_ODBC_VER => 10 +, SQL_OJ_CAPABILITIES => 115 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 +, SQL_OUTER_JOINS => 38 +, SQL_OUTER_JOIN_CAPABILITIES => 115 # SQL_OJ_CAPABILITIES +, SQL_OWNER_TERM => 39 +, SQL_OWNER_USAGE => 91 +, SQL_PARAM_ARRAY_ROW_COUNTS => 153 +, SQL_PARAM_ARRAY_SELECTS => 154 +, SQL_POSITIONED_STATEMENTS => 80 +, SQL_POS_OPERATIONS => 79 +, SQL_PROCEDURES => 21 +, SQL_PROCEDURE_TERM => 40 +, SQL_QUALIFIER_LOCATION => 114 +, SQL_QUALIFIER_NAME_SEPARATOR => 41 +, SQL_QUALIFIER_TERM => 42 +, SQL_QUALIFIER_USAGE => 92 +, SQL_QUOTED_IDENTIFIER_CASE => 93 +, SQL_ROW_UPDATES => 11 +, SQL_SCHEMA_TERM => 39 # SQL_OWNER_TERM +, SQL_SCHEMA_USAGE => 91 # SQL_OWNER_USAGE +, SQL_SCROLL_CONCURRENCY => 43 +, SQL_SCROLL_OPTIONS => 44 +, SQL_SEARCH_PATTERN_ESCAPE => 14 +, SQL_SERVER_NAME => 13 +, SQL_SPECIAL_CHARACTERS => 94 +, SQL_SQL92_DATETIME_FUNCTIONS => 155 +, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 156 +, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 157 +, SQL_SQL92_GRANT => 158 +, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 159 +, SQL_SQL92_PREDICATES => 160 +, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 161 +, SQL_SQL92_REVOKE => 162 +, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 163 +, SQL_SQL92_STRING_FUNCTIONS => 164 +, SQL_SQL92_VALUE_EXPRESSIONS => 165 +, SQL_SQL_CONFORMANCE => 118 +, SQL_STANDARD_CLI_CONFORMANCE => 166 +, SQL_STATIC_CURSOR_ATTRIBUTES1 => 167 +, SQL_STATIC_CURSOR_ATTRIBUTES2 => 168 +, SQL_STATIC_SENSITIVITY => 83 +, SQL_STRING_FUNCTIONS => 50 +, SQL_SUBQUERIES => 95 +, SQL_SYSTEM_FUNCTIONS => 51 +, SQL_TABLE_TERM => 45 +, SQL_TIMEDATE_ADD_INTERVALS => 109 +, SQL_TIMEDATE_DIFF_INTERVALS => 110 +, SQL_TIMEDATE_FUNCTIONS => 52 +, SQL_TRANSACTION_CAPABLE => 46 # SQL_TXN_CAPABLE +, SQL_TRANSACTION_ISOLATION_OPTION => 72 # SQL_TXN_ISOLATION_OPTION +, SQL_TXN_CAPABLE => 46 +, SQL_TXN_ISOLATION_OPTION => 72 +, SQL_UNION => 96 +, SQL_UNION_STATEMENT => 96 # SQL_UNION +, SQL_USER_NAME => 47 +, SQL_XOPEN_CLI_YEAR => 10000 +); + +=head2 %ReturnTypes + +See: mk:@MSITStore:X:\dm\cli\mdac\sdk26\Docs\odbc.chm::/htm/odbcsqlgetinfo.htm + + => : alias + => !!! : edited + +=cut + +%ReturnTypes = +( + SQL_ACCESSIBLE_PROCEDURES => 'SQLCHAR' # 20 +, SQL_ACCESSIBLE_TABLES => 'SQLCHAR' # 19 +, SQL_ACTIVE_CONNECTIONS => 'SQLUSMALLINT' # 0 => +, SQL_ACTIVE_ENVIRONMENTS => 'SQLUSMALLINT' # 116 +, SQL_ACTIVE_STATEMENTS => 'SQLUSMALLINT' # 1 => +, SQL_AGGREGATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 169 +, SQL_ALTER_DOMAIN => 'SQLUINTEGER bitmask' # 117 +, SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # 86 +, SQL_ASYNC_MODE => 'SQLUINTEGER' # 10021 +, SQL_BATCH_ROW_COUNT => 'SQLUINTEGER bitmask' # 120 +, SQL_BATCH_SUPPORT => 'SQLUINTEGER bitmask' # 121 +, SQL_BOOKMARK_PERSISTENCE => 'SQLUINTEGER bitmask' # 82 +, SQL_CATALOG_LOCATION => 'SQLUSMALLINT' # 114 +, SQL_CATALOG_NAME => 'SQLCHAR' # 10003 +, SQL_CATALOG_NAME_SEPARATOR => 'SQLCHAR' # 41 +, SQL_CATALOG_TERM => 'SQLCHAR' # 42 +, SQL_CATALOG_USAGE => 'SQLUINTEGER bitmask' # 92 +, SQL_COLLATION_SEQ => 'SQLCHAR' # 10004 +, SQL_COLUMN_ALIAS => 'SQLCHAR' # 87 +, SQL_CONCAT_NULL_BEHAVIOR => 'SQLUSMALLINT' # 22 +, SQL_CONVERT_BIGINT => 'SQLUINTEGER bitmask' # 53 +, SQL_CONVERT_BINARY => 'SQLUINTEGER bitmask' # 54 +, SQL_CONVERT_BIT => 'SQLUINTEGER bitmask' # 55 +, SQL_CONVERT_CHAR => 'SQLUINTEGER bitmask' # 56 +, SQL_CONVERT_DATE => 'SQLUINTEGER bitmask' # 57 +, SQL_CONVERT_DECIMAL => 'SQLUINTEGER bitmask' # 58 +, SQL_CONVERT_DOUBLE => 'SQLUINTEGER bitmask' # 59 +, SQL_CONVERT_FLOAT => 'SQLUINTEGER bitmask' # 60 +, SQL_CONVERT_FUNCTIONS => 'SQLUINTEGER bitmask' # 48 +, SQL_CONVERT_GUID => 'SQLUINTEGER bitmask' # 173 +, SQL_CONVERT_INTEGER => 'SQLUINTEGER bitmask' # 61 +, SQL_CONVERT_INTERVAL_DAY_TIME => 'SQLUINTEGER bitmask' # 123 +, SQL_CONVERT_INTERVAL_YEAR_MONTH => 'SQLUINTEGER bitmask' # 124 +, SQL_CONVERT_LONGVARBINARY => 'SQLUINTEGER bitmask' # 71 +, SQL_CONVERT_LONGVARCHAR => 'SQLUINTEGER bitmask' # 62 +, SQL_CONVERT_NUMERIC => 'SQLUINTEGER bitmask' # 63 +, SQL_CONVERT_REAL => 'SQLUINTEGER bitmask' # 64 +, SQL_CONVERT_SMALLINT => 'SQLUINTEGER bitmask' # 65 +, SQL_CONVERT_TIME => 'SQLUINTEGER bitmask' # 66 +, SQL_CONVERT_TIMESTAMP => 'SQLUINTEGER bitmask' # 67 +, SQL_CONVERT_TINYINT => 'SQLUINTEGER bitmask' # 68 +, SQL_CONVERT_VARBINARY => 'SQLUINTEGER bitmask' # 69 +, SQL_CONVERT_VARCHAR => 'SQLUINTEGER bitmask' # 70 +, SQL_CONVERT_WCHAR => 'SQLUINTEGER bitmask' # 122 => !!! +, SQL_CONVERT_WLONGVARCHAR => 'SQLUINTEGER bitmask' # 125 => !!! +, SQL_CONVERT_WVARCHAR => 'SQLUINTEGER bitmask' # 126 => !!! +, SQL_CORRELATION_NAME => 'SQLUSMALLINT' # 74 +, SQL_CREATE_ASSERTION => 'SQLUINTEGER bitmask' # 127 +, SQL_CREATE_CHARACTER_SET => 'SQLUINTEGER bitmask' # 128 +, SQL_CREATE_COLLATION => 'SQLUINTEGER bitmask' # 129 +, SQL_CREATE_DOMAIN => 'SQLUINTEGER bitmask' # 130 +, SQL_CREATE_SCHEMA => 'SQLUINTEGER bitmask' # 131 +, SQL_CREATE_TABLE => 'SQLUINTEGER bitmask' # 132 +, SQL_CREATE_TRANSLATION => 'SQLUINTEGER bitmask' # 133 +, SQL_CREATE_VIEW => 'SQLUINTEGER bitmask' # 134 +, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # 23 +, SQL_CURSOR_ROLLBACK_BEHAVIOR => 'SQLUSMALLINT' # 24 +, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # 10001 +, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # 2 +, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # 25 +, SQL_DATABASE_NAME => 'SQLCHAR' # 16 +, SQL_DATETIME_LITERALS => 'SQLUINTEGER bitmask' # 119 +, SQL_DBMS_NAME => 'SQLCHAR' # 17 +, SQL_DBMS_VER => 'SQLCHAR' # 18 +, SQL_DDL_INDEX => 'SQLUINTEGER bitmask' # 170 +, SQL_DEFAULT_TXN_ISOLATION => 'SQLUINTEGER' # 26 +, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # 10002 +, SQL_DM_VER => 'SQLCHAR' # 171 +, SQL_DRIVER_HDBC => 'SQLUINTEGER' # 3 +, SQL_DRIVER_HDESC => 'SQLUINTEGER' # 135 +, SQL_DRIVER_HENV => 'SQLUINTEGER' # 4 +, SQL_DRIVER_HLIB => 'SQLUINTEGER' # 76 +, SQL_DRIVER_HSTMT => 'SQLUINTEGER' # 5 +, SQL_DRIVER_NAME => 'SQLCHAR' # 6 +, SQL_DRIVER_ODBC_VER => 'SQLCHAR' # 77 +, SQL_DRIVER_VER => 'SQLCHAR' # 7 +, SQL_DROP_ASSERTION => 'SQLUINTEGER bitmask' # 136 +, SQL_DROP_CHARACTER_SET => 'SQLUINTEGER bitmask' # 137 +, SQL_DROP_COLLATION => 'SQLUINTEGER bitmask' # 138 +, SQL_DROP_DOMAIN => 'SQLUINTEGER bitmask' # 139 +, SQL_DROP_SCHEMA => 'SQLUINTEGER bitmask' # 140 +, SQL_DROP_TABLE => 'SQLUINTEGER bitmask' # 141 +, SQL_DROP_TRANSLATION => 'SQLUINTEGER bitmask' # 142 +, SQL_DROP_VIEW => 'SQLUINTEGER bitmask' # 143 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 144 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 145 +, SQL_EXPRESSIONS_IN_ORDERBY => 'SQLCHAR' # 27 +, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # 8 => !!! +, SQL_FILE_USAGE => 'SQLUSMALLINT' # 84 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 146 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 147 +, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # 81 +, SQL_GROUP_BY => 'SQLUSMALLINT' # 88 +, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # 28 +, SQL_IDENTIFIER_QUOTE_CHAR => 'SQLCHAR' # 29 +, SQL_INDEX_KEYWORDS => 'SQLUINTEGER bitmask' # 148 +# SQL_INFO_DRIVER_START => '' # 1000 => +# SQL_INFO_FIRST => 'SQLUSMALLINT' # 0 => +# SQL_INFO_LAST => 'SQLUSMALLINT' # 114 => +, SQL_INFO_SCHEMA_VIEWS => 'SQLUINTEGER bitmask' # 149 +, SQL_INSERT_STATEMENT => 'SQLUINTEGER bitmask' # 172 +, SQL_INTEGRITY => 'SQLCHAR' # 73 +, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 150 +, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 151 +, SQL_KEYWORDS => 'SQLCHAR' # 89 +, SQL_LIKE_ESCAPE_CLAUSE => 'SQLCHAR' # 113 +, SQL_LOCK_TYPES => 'SQLUINTEGER bitmask' # 78 => !!! +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # 34 => +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 => +, SQL_MAXIMUM_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 => +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 => +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 => +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # 30 => +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 => +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # 31 => +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 => +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # 10005 => +, SQL_MAXIMUM_INDEX_SIZE => 'SQLUINTEGER' # 102 => +, SQL_MAXIMUM_ROW_SIZE => 'SQLUINTEGER' # 104 => +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # 32 => +, SQL_MAXIMUM_STATEMENT_LENGTH => 'SQLUINTEGER' # 105 => +, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 => +, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # 107 => +, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 'SQLUINTEGER' # 10022 +, SQL_MAX_BINARY_LITERAL_LEN => 'SQLUINTEGER' # 112 +, SQL_MAX_CATALOG_NAME_LEN => 'SQLUSMALLINT' # 34 +, SQL_MAX_CHAR_LITERAL_LEN => 'SQLUINTEGER' # 108 +, SQL_MAX_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 +, SQL_MAX_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 +, SQL_MAX_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 +, SQL_MAX_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 +, SQL_MAX_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # 101 +, SQL_MAX_COLUMN_NAME_LEN => 'SQLUSMALLINT' # 30 +, SQL_MAX_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 +, SQL_MAX_CURSOR_NAME_LEN => 'SQLUSMALLINT' # 31 +, SQL_MAX_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 +, SQL_MAX_IDENTIFIER_LEN => 'SQLUSMALLINT' # 10005 +, SQL_MAX_INDEX_SIZE => 'SQLUINTEGER' # 102 +, SQL_MAX_OWNER_NAME_LEN => 'SQLUSMALLINT' # 32 => +, SQL_MAX_PROCEDURE_NAME_LEN => 'SQLUSMALLINT' # 33 +, SQL_MAX_QUALIFIER_NAME_LEN => 'SQLUSMALLINT' # 34 => +, SQL_MAX_ROW_SIZE => 'SQLUINTEGER' # 104 +, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 'SQLCHAR' # 103 +, SQL_MAX_SCHEMA_NAME_LEN => 'SQLUSMALLINT' # 32 +, SQL_MAX_STATEMENT_LEN => 'SQLUINTEGER' # 105 +, SQL_MAX_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 +, SQL_MAX_TABLE_NAME_LEN => 'SQLUSMALLINT' # 35 +, SQL_MAX_USER_NAME_LEN => 'SQLUSMALLINT' # 107 +, SQL_MULTIPLE_ACTIVE_TXN => 'SQLCHAR' # 37 +, SQL_MULT_RESULT_SETS => 'SQLCHAR' # 36 +, SQL_NEED_LONG_DATA_LEN => 'SQLCHAR' # 111 +, SQL_NON_NULLABLE_COLUMNS => 'SQLUSMALLINT' # 75 +, SQL_NULL_COLLATION => 'SQLUSMALLINT' # 85 +, SQL_NUMERIC_FUNCTIONS => 'SQLUINTEGER bitmask' # 49 +, SQL_ODBC_API_CONFORMANCE => 'SQLUSMALLINT' # 9 => !!! +, SQL_ODBC_INTERFACE_CONFORMANCE => 'SQLUINTEGER' # 152 +, SQL_ODBC_SAG_CLI_CONFORMANCE => 'SQLUSMALLINT' # 12 => !!! +, SQL_ODBC_SQL_CONFORMANCE => 'SQLUSMALLINT' # 15 => !!! +, SQL_ODBC_SQL_OPT_IEF => 'SQLCHAR' # 73 => +, SQL_ODBC_VER => 'SQLCHAR' # 10 +, SQL_OJ_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # 90 +, SQL_OUTER_JOINS => 'SQLCHAR' # 38 => !!! +, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 => +, SQL_OWNER_TERM => 'SQLCHAR' # 39 => +, SQL_OWNER_USAGE => 'SQLUINTEGER bitmask' # 91 => +, SQL_PARAM_ARRAY_ROW_COUNTS => 'SQLUINTEGER' # 153 +, SQL_PARAM_ARRAY_SELECTS => 'SQLUINTEGER' # 154 +, SQL_POSITIONED_STATEMENTS => 'SQLUINTEGER bitmask' # 80 => !!! +, SQL_POS_OPERATIONS => 'SQLINTEGER bitmask' # 79 +, SQL_PROCEDURES => 'SQLCHAR' # 21 +, SQL_PROCEDURE_TERM => 'SQLCHAR' # 40 +, SQL_QUALIFIER_LOCATION => 'SQLUSMALLINT' # 114 => +, SQL_QUALIFIER_NAME_SEPARATOR => 'SQLCHAR' # 41 => +, SQL_QUALIFIER_TERM => 'SQLCHAR' # 42 => +, SQL_QUALIFIER_USAGE => 'SQLUINTEGER bitmask' # 92 => +, SQL_QUOTED_IDENTIFIER_CASE => 'SQLUSMALLINT' # 93 +, SQL_ROW_UPDATES => 'SQLCHAR' # 11 +, SQL_SCHEMA_TERM => 'SQLCHAR' # 39 +, SQL_SCHEMA_USAGE => 'SQLUINTEGER bitmask' # 91 +, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # 43 => !!! +, SQL_SCROLL_OPTIONS => 'SQLUINTEGER bitmask' # 44 +, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # 14 +, SQL_SERVER_NAME => 'SQLCHAR' # 13 +, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # 94 +, SQL_SQL92_DATETIME_FUNCTIONS => 'SQLUINTEGER bitmask' # 155 +, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 'SQLUINTEGER bitmask' # 156 +, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 'SQLUINTEGER bitmask' # 157 +, SQL_SQL92_GRANT => 'SQLUINTEGER bitmask' # 158 +, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 'SQLUINTEGER bitmask' # 159 +, SQL_SQL92_PREDICATES => 'SQLUINTEGER bitmask' # 160 +, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 'SQLUINTEGER bitmask' # 161 +, SQL_SQL92_REVOKE => 'SQLUINTEGER bitmask' # 162 +, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 'SQLUINTEGER bitmask' # 163 +, SQL_SQL92_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 164 +, SQL_SQL92_VALUE_EXPRESSIONS => 'SQLUINTEGER bitmask' # 165 +, SQL_SQL_CONFORMANCE => 'SQLUINTEGER' # 118 +, SQL_STANDARD_CLI_CONFORMANCE => 'SQLUINTEGER bitmask' # 166 +, SQL_STATIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 167 +, SQL_STATIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 168 +, SQL_STATIC_SENSITIVITY => 'SQLUINTEGER bitmask' # 83 => !!! +, SQL_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 50 +, SQL_SUBQUERIES => 'SQLUINTEGER bitmask' # 95 +, SQL_SYSTEM_FUNCTIONS => 'SQLUINTEGER bitmask' # 51 +, SQL_TABLE_TERM => 'SQLCHAR' # 45 +, SQL_TIMEDATE_ADD_INTERVALS => 'SQLUINTEGER bitmask' # 109 +, SQL_TIMEDATE_DIFF_INTERVALS => 'SQLUINTEGER bitmask' # 110 +, SQL_TIMEDATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 52 +, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # 46 => +, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 => +, SQL_TXN_CAPABLE => 'SQLUSMALLINT' # 46 +, SQL_TXN_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 +, SQL_UNION => 'SQLUINTEGER bitmask' # 96 +, SQL_UNION_STATEMENT => 'SQLUINTEGER bitmask' # 96 => +, SQL_USER_NAME => 'SQLCHAR' # 47 +, SQL_XOPEN_CLI_YEAR => 'SQLCHAR' # 10000 +); + +=head2 %ReturnValues + +See: sql.h, sqlext.h +Edited: + SQL_TXN_ISOLATION_OPTION + +=cut + +$ReturnValues{SQL_AGGREGATE_FUNCTIONS} = +{ + SQL_AF_AVG => 0x00000001 +, SQL_AF_COUNT => 0x00000002 +, SQL_AF_MAX => 0x00000004 +, SQL_AF_MIN => 0x00000008 +, SQL_AF_SUM => 0x00000010 +, SQL_AF_DISTINCT => 0x00000020 +, SQL_AF_ALL => 0x00000040 +}; +$ReturnValues{SQL_ALTER_DOMAIN} = +{ + SQL_AD_CONSTRAINT_NAME_DEFINITION => 0x00000001 +, SQL_AD_ADD_DOMAIN_CONSTRAINT => 0x00000002 +, SQL_AD_DROP_DOMAIN_CONSTRAINT => 0x00000004 +, SQL_AD_ADD_DOMAIN_DEFAULT => 0x00000008 +, SQL_AD_DROP_DOMAIN_DEFAULT => 0x00000010 +, SQL_AD_ADD_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_AD_ADD_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_AD_ADD_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_AD_ADD_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +}; +$ReturnValues{SQL_ALTER_TABLE} = +{ + SQL_AT_ADD_COLUMN => 0x00000001 +, SQL_AT_DROP_COLUMN => 0x00000002 +, SQL_AT_ADD_CONSTRAINT => 0x00000008 +, SQL_AT_ADD_COLUMN_SINGLE => 0x00000020 +, SQL_AT_ADD_COLUMN_DEFAULT => 0x00000040 +, SQL_AT_ADD_COLUMN_COLLATION => 0x00000080 +, SQL_AT_SET_COLUMN_DEFAULT => 0x00000100 +, SQL_AT_DROP_COLUMN_DEFAULT => 0x00000200 +, SQL_AT_DROP_COLUMN_CASCADE => 0x00000400 +, SQL_AT_DROP_COLUMN_RESTRICT => 0x00000800 +, SQL_AT_ADD_TABLE_CONSTRAINT => 0x00001000 +, SQL_AT_DROP_TABLE_CONSTRAINT_CASCADE => 0x00002000 +, SQL_AT_DROP_TABLE_CONSTRAINT_RESTRICT => 0x00004000 +, SQL_AT_CONSTRAINT_NAME_DEFINITION => 0x00008000 +, SQL_AT_CONSTRAINT_INITIALLY_DEFERRED => 0x00010000 +, SQL_AT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00020000 +, SQL_AT_CONSTRAINT_DEFERRABLE => 0x00040000 +, SQL_AT_CONSTRAINT_NON_DEFERRABLE => 0x00080000 +}; +$ReturnValues{SQL_ASYNC_MODE} = +{ + SQL_AM_NONE => 0 +, SQL_AM_CONNECTION => 1 +, SQL_AM_STATEMENT => 2 +}; +$ReturnValues{SQL_ATTR_MAX_ROWS} = +{ + SQL_CA2_MAX_ROWS_SELECT => 0x00000080 +, SQL_CA2_MAX_ROWS_INSERT => 0x00000100 +, SQL_CA2_MAX_ROWS_DELETE => 0x00000200 +, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 +, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 +# SQL_CA2_MAX_ROWS_AFFECTS_ALL => +}; +$ReturnValues{SQL_ATTR_SCROLL_CONCURRENCY} = +{ + SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 +, SQL_CA2_LOCK_CONCURRENCY => 0x00000002 +, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 +, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 +, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 +, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 +, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 +}; +$ReturnValues{SQL_BATCH_ROW_COUNT} = +{ + SQL_BRC_PROCEDURES => 0x0000001 +, SQL_BRC_EXPLICIT => 0x0000002 +, SQL_BRC_ROLLED_UP => 0x0000004 +}; +$ReturnValues{SQL_BATCH_SUPPORT} = +{ + SQL_BS_SELECT_EXPLICIT => 0x00000001 +, SQL_BS_ROW_COUNT_EXPLICIT => 0x00000002 +, SQL_BS_SELECT_PROC => 0x00000004 +, SQL_BS_ROW_COUNT_PROC => 0x00000008 +}; +$ReturnValues{SQL_BOOKMARK_PERSISTENCE} = +{ + SQL_BP_CLOSE => 0x00000001 +, SQL_BP_DELETE => 0x00000002 +, SQL_BP_DROP => 0x00000004 +, SQL_BP_TRANSACTION => 0x00000008 +, SQL_BP_UPDATE => 0x00000010 +, SQL_BP_OTHER_HSTMT => 0x00000020 +, SQL_BP_SCROLL => 0x00000040 +}; +$ReturnValues{SQL_CATALOG_LOCATION} = +{ + SQL_CL_START => 0x0001 # SQL_QL_START +, SQL_CL_END => 0x0002 # SQL_QL_END +}; +$ReturnValues{SQL_CATALOG_USAGE} = +{ + SQL_CU_DML_STATEMENTS => 0x00000001 # SQL_QU_DML_STATEMENTS +, SQL_CU_PROCEDURE_INVOCATION => 0x00000002 # SQL_QU_PROCEDURE_INVOCATION +, SQL_CU_TABLE_DEFINITION => 0x00000004 # SQL_QU_TABLE_DEFINITION +, SQL_CU_INDEX_DEFINITION => 0x00000008 # SQL_QU_INDEX_DEFINITION +, SQL_CU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_QU_PRIVILEGE_DEFINITION +}; +$ReturnValues{SQL_CONCAT_NULL_BEHAVIOR} = +{ + SQL_CB_NULL => 0x0000 +, SQL_CB_NON_NULL => 0x0001 +}; +$ReturnValues{SQL_CONVERT_} = +{ + SQL_CVT_CHAR => 0x00000001 +, SQL_CVT_NUMERIC => 0x00000002 +, SQL_CVT_DECIMAL => 0x00000004 +, SQL_CVT_INTEGER => 0x00000008 +, SQL_CVT_SMALLINT => 0x00000010 +, SQL_CVT_FLOAT => 0x00000020 +, SQL_CVT_REAL => 0x00000040 +, SQL_CVT_DOUBLE => 0x00000080 +, SQL_CVT_VARCHAR => 0x00000100 +, SQL_CVT_LONGVARCHAR => 0x00000200 +, SQL_CVT_BINARY => 0x00000400 +, SQL_CVT_VARBINARY => 0x00000800 +, SQL_CVT_BIT => 0x00001000 +, SQL_CVT_TINYINT => 0x00002000 +, SQL_CVT_BIGINT => 0x00004000 +, SQL_CVT_DATE => 0x00008000 +, SQL_CVT_TIME => 0x00010000 +, SQL_CVT_TIMESTAMP => 0x00020000 +, SQL_CVT_LONGVARBINARY => 0x00040000 +, SQL_CVT_INTERVAL_YEAR_MONTH => 0x00080000 +, SQL_CVT_INTERVAL_DAY_TIME => 0x00100000 +, SQL_CVT_WCHAR => 0x00200000 +, SQL_CVT_WLONGVARCHAR => 0x00400000 +, SQL_CVT_WVARCHAR => 0x00800000 +, SQL_CVT_GUID => 0x01000000 +}; +$ReturnValues{SQL_CONVERT_BIGINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_BINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_BIT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_CHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DATE } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DECIMAL } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DOUBLE } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_FLOAT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_GUID } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTEGER } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTERVAL_DAY_TIME } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTERVAL_YEAR_MONTH} = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_LONGVARBINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_LONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_NUMERIC } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_REAL } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_SMALLINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TIME } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TIMESTAMP } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TINYINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_VARBINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_VARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WLONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WVARCHAR } = $ReturnValues{SQL_CONVERT_}; + +$ReturnValues{SQL_CONVERT_FUNCTIONS} = +{ + SQL_FN_CVT_CONVERT => 0x00000001 +, SQL_FN_CVT_CAST => 0x00000002 +}; +$ReturnValues{SQL_CORRELATION_NAME} = +{ + SQL_CN_NONE => 0x0000 +, SQL_CN_DIFFERENT => 0x0001 +, SQL_CN_ANY => 0x0002 +}; +$ReturnValues{SQL_CREATE_ASSERTION} = +{ + SQL_CA_CREATE_ASSERTION => 0x00000001 +, SQL_CA_CONSTRAINT_INITIALLY_DEFERRED => 0x00000010 +, SQL_CA_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000020 +, SQL_CA_CONSTRAINT_DEFERRABLE => 0x00000040 +, SQL_CA_CONSTRAINT_NON_DEFERRABLE => 0x00000080 +}; +$ReturnValues{SQL_CREATE_CHARACTER_SET} = +{ + SQL_CCS_CREATE_CHARACTER_SET => 0x00000001 +, SQL_CCS_COLLATE_CLAUSE => 0x00000002 +, SQL_CCS_LIMITED_COLLATION => 0x00000004 +}; +$ReturnValues{SQL_CREATE_COLLATION} = +{ + SQL_CCOL_CREATE_COLLATION => 0x00000001 +}; +$ReturnValues{SQL_CREATE_DOMAIN} = +{ + SQL_CDO_CREATE_DOMAIN => 0x00000001 +, SQL_CDO_DEFAULT => 0x00000002 +, SQL_CDO_CONSTRAINT => 0x00000004 +, SQL_CDO_COLLATION => 0x00000008 +, SQL_CDO_CONSTRAINT_NAME_DEFINITION => 0x00000010 +, SQL_CDO_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_CDO_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_CDO_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_CDO_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +}; +$ReturnValues{SQL_CREATE_SCHEMA} = +{ + SQL_CS_CREATE_SCHEMA => 0x00000001 +, SQL_CS_AUTHORIZATION => 0x00000002 +, SQL_CS_DEFAULT_CHARACTER_SET => 0x00000004 +}; +$ReturnValues{SQL_CREATE_TABLE} = +{ + SQL_CT_CREATE_TABLE => 0x00000001 +, SQL_CT_COMMIT_PRESERVE => 0x00000002 +, SQL_CT_COMMIT_DELETE => 0x00000004 +, SQL_CT_GLOBAL_TEMPORARY => 0x00000008 +, SQL_CT_LOCAL_TEMPORARY => 0x00000010 +, SQL_CT_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_CT_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_CT_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +, SQL_CT_COLUMN_CONSTRAINT => 0x00000200 +, SQL_CT_COLUMN_DEFAULT => 0x00000400 +, SQL_CT_COLUMN_COLLATION => 0x00000800 +, SQL_CT_TABLE_CONSTRAINT => 0x00001000 +, SQL_CT_CONSTRAINT_NAME_DEFINITION => 0x00002000 +}; +$ReturnValues{SQL_CREATE_TRANSLATION} = +{ + SQL_CTR_CREATE_TRANSLATION => 0x00000001 +}; +$ReturnValues{SQL_CREATE_VIEW} = +{ + SQL_CV_CREATE_VIEW => 0x00000001 +, SQL_CV_CHECK_OPTION => 0x00000002 +, SQL_CV_CASCADED => 0x00000004 +, SQL_CV_LOCAL => 0x00000008 +}; +$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = +{ + SQL_CB_DELETE => 0 +, SQL_CB_CLOSE => 1 +, SQL_CB_PRESERVE => 2 +}; +$ReturnValues{SQL_CURSOR_ROLLBACK_BEHAVIOR} = $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR}; + +$ReturnValues{SQL_CURSOR_SENSITIVITY} = +{ + SQL_UNSPECIFIED => 0 +, SQL_INSENSITIVE => 1 +, SQL_SENSITIVE => 2 +}; +$ReturnValues{SQL_DATETIME_LITERALS} = +{ + SQL_DL_SQL92_DATE => 0x00000001 +, SQL_DL_SQL92_TIME => 0x00000002 +, SQL_DL_SQL92_TIMESTAMP => 0x00000004 +, SQL_DL_SQL92_INTERVAL_YEAR => 0x00000008 +, SQL_DL_SQL92_INTERVAL_MONTH => 0x00000010 +, SQL_DL_SQL92_INTERVAL_DAY => 0x00000020 +, SQL_DL_SQL92_INTERVAL_HOUR => 0x00000040 +, SQL_DL_SQL92_INTERVAL_MINUTE => 0x00000080 +, SQL_DL_SQL92_INTERVAL_SECOND => 0x00000100 +, SQL_DL_SQL92_INTERVAL_YEAR_TO_MONTH => 0x00000200 +, SQL_DL_SQL92_INTERVAL_DAY_TO_HOUR => 0x00000400 +, SQL_DL_SQL92_INTERVAL_DAY_TO_MINUTE => 0x00000800 +, SQL_DL_SQL92_INTERVAL_DAY_TO_SECOND => 0x00001000 +, SQL_DL_SQL92_INTERVAL_HOUR_TO_MINUTE => 0x00002000 +, SQL_DL_SQL92_INTERVAL_HOUR_TO_SECOND => 0x00004000 +, SQL_DL_SQL92_INTERVAL_MINUTE_TO_SECOND => 0x00008000 +}; +$ReturnValues{SQL_DDL_INDEX} = +{ + SQL_DI_CREATE_INDEX => 0x00000001 +, SQL_DI_DROP_INDEX => 0x00000002 +}; +$ReturnValues{SQL_DIAG_CURSOR_ROW_COUNT} = +{ + SQL_CA2_CRC_EXACT => 0x00001000 +, SQL_CA2_CRC_APPROXIMATE => 0x00002000 +, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 +, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 +, SQL_CA2_SIMULATE_UNIQUE => 0x00010000 +}; +$ReturnValues{SQL_DROP_ASSERTION} = +{ + SQL_DA_DROP_ASSERTION => 0x00000001 +}; +$ReturnValues{SQL_DROP_CHARACTER_SET} = +{ + SQL_DCS_DROP_CHARACTER_SET => 0x00000001 +}; +$ReturnValues{SQL_DROP_COLLATION} = +{ + SQL_DC_DROP_COLLATION => 0x00000001 +}; +$ReturnValues{SQL_DROP_DOMAIN} = +{ + SQL_DD_DROP_DOMAIN => 0x00000001 +, SQL_DD_RESTRICT => 0x00000002 +, SQL_DD_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_SCHEMA} = +{ + SQL_DS_DROP_SCHEMA => 0x00000001 +, SQL_DS_RESTRICT => 0x00000002 +, SQL_DS_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_TABLE} = +{ + SQL_DT_DROP_TABLE => 0x00000001 +, SQL_DT_RESTRICT => 0x00000002 +, SQL_DT_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_TRANSLATION} = +{ + SQL_DTR_DROP_TRANSLATION => 0x00000001 +}; +$ReturnValues{SQL_DROP_VIEW} = +{ + SQL_DV_DROP_VIEW => 0x00000001 +, SQL_DV_RESTRICT => 0x00000002 +, SQL_DV_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_CURSOR_ATTRIBUTES1} = +{ + SQL_CA1_NEXT => 0x00000001 +, SQL_CA1_ABSOLUTE => 0x00000002 +, SQL_CA1_RELATIVE => 0x00000004 +, SQL_CA1_BOOKMARK => 0x00000008 +, SQL_CA1_LOCK_NO_CHANGE => 0x00000040 +, SQL_CA1_LOCK_EXCLUSIVE => 0x00000080 +, SQL_CA1_LOCK_UNLOCK => 0x00000100 +, SQL_CA1_POS_POSITION => 0x00000200 +, SQL_CA1_POS_UPDATE => 0x00000400 +, SQL_CA1_POS_DELETE => 0x00000800 +, SQL_CA1_POS_REFRESH => 0x00001000 +, SQL_CA1_POSITIONED_UPDATE => 0x00002000 +, SQL_CA1_POSITIONED_DELETE => 0x00004000 +, SQL_CA1_SELECT_FOR_UPDATE => 0x00008000 +, SQL_CA1_BULK_ADD => 0x00010000 +, SQL_CA1_BULK_UPDATE_BY_BOOKMARK => 0x00020000 +, SQL_CA1_BULK_DELETE_BY_BOOKMARK => 0x00040000 +, SQL_CA1_BULK_FETCH_BY_BOOKMARK => 0x00080000 +}; +$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; + +$ReturnValues{SQL_CURSOR_ATTRIBUTES2} = +{ + SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 +, SQL_CA2_LOCK_CONCURRENCY => 0x00000002 +, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 +, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 +, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 +, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 +, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 +, SQL_CA2_MAX_ROWS_SELECT => 0x00000080 +, SQL_CA2_MAX_ROWS_INSERT => 0x00000100 +, SQL_CA2_MAX_ROWS_DELETE => 0x00000200 +, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 +, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 +, SQL_CA2_CRC_EXACT => 0x00001000 +, SQL_CA2_CRC_APPROXIMATE => 0x00002000 +, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 +, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 +, SQL_CA2_SIMULATE_UNIQUE => 0x00010000 +}; +$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; + +$ReturnValues{SQL_FETCH_DIRECTION} = +{ + SQL_FD_FETCH_NEXT => 0x00000001 +, SQL_FD_FETCH_FIRST => 0x00000002 +, SQL_FD_FETCH_LAST => 0x00000004 +, SQL_FD_FETCH_PRIOR => 0x00000008 +, SQL_FD_FETCH_ABSOLUTE => 0x00000010 +, SQL_FD_FETCH_RELATIVE => 0x00000020 +, SQL_FD_FETCH_RESUME => 0x00000040 +, SQL_FD_FETCH_BOOKMARK => 0x00000080 +}; +$ReturnValues{SQL_FILE_USAGE} = +{ + SQL_FILE_NOT_SUPPORTED => 0x0000 +, SQL_FILE_TABLE => 0x0001 +, SQL_FILE_QUALIFIER => 0x0002 +, SQL_FILE_CATALOG => 0x0002 # SQL_FILE_QUALIFIER +}; +$ReturnValues{SQL_GETDATA_EXTENSIONS} = +{ + SQL_GD_ANY_COLUMN => 0x00000001 +, SQL_GD_ANY_ORDER => 0x00000002 +, SQL_GD_BLOCK => 0x00000004 +, SQL_GD_BOUND => 0x00000008 +}; +$ReturnValues{SQL_GROUP_BY} = +{ + SQL_GB_NOT_SUPPORTED => 0x0000 +, SQL_GB_GROUP_BY_EQUALS_SELECT => 0x0001 +, SQL_GB_GROUP_BY_CONTAINS_SELECT => 0x0002 +, SQL_GB_NO_RELATION => 0x0003 +, SQL_GB_COLLATE => 0x0004 +}; +$ReturnValues{SQL_IDENTIFIER_CASE} = +{ + SQL_IC_UPPER => 1 +, SQL_IC_LOWER => 2 +, SQL_IC_SENSITIVE => 3 +, SQL_IC_MIXED => 4 +}; +$ReturnValues{SQL_INDEX_KEYWORDS} = +{ + SQL_IK_NONE => 0x00000000 +, SQL_IK_ASC => 0x00000001 +, SQL_IK_DESC => 0x00000002 +# SQL_IK_ALL => +}; +$ReturnValues{SQL_INFO_SCHEMA_VIEWS} = +{ + SQL_ISV_ASSERTIONS => 0x00000001 +, SQL_ISV_CHARACTER_SETS => 0x00000002 +, SQL_ISV_CHECK_CONSTRAINTS => 0x00000004 +, SQL_ISV_COLLATIONS => 0x00000008 +, SQL_ISV_COLUMN_DOMAIN_USAGE => 0x00000010 +, SQL_ISV_COLUMN_PRIVILEGES => 0x00000020 +, SQL_ISV_COLUMNS => 0x00000040 +, SQL_ISV_CONSTRAINT_COLUMN_USAGE => 0x00000080 +, SQL_ISV_CONSTRAINT_TABLE_USAGE => 0x00000100 +, SQL_ISV_DOMAIN_CONSTRAINTS => 0x00000200 +, SQL_ISV_DOMAINS => 0x00000400 +, SQL_ISV_KEY_COLUMN_USAGE => 0x00000800 +, SQL_ISV_REFERENTIAL_CONSTRAINTS => 0x00001000 +, SQL_ISV_SCHEMATA => 0x00002000 +, SQL_ISV_SQL_LANGUAGES => 0x00004000 +, SQL_ISV_TABLE_CONSTRAINTS => 0x00008000 +, SQL_ISV_TABLE_PRIVILEGES => 0x00010000 +, SQL_ISV_TABLES => 0x00020000 +, SQL_ISV_TRANSLATIONS => 0x00040000 +, SQL_ISV_USAGE_PRIVILEGES => 0x00080000 +, SQL_ISV_VIEW_COLUMN_USAGE => 0x00100000 +, SQL_ISV_VIEW_TABLE_USAGE => 0x00200000 +, SQL_ISV_VIEWS => 0x00400000 +}; +$ReturnValues{SQL_INSERT_STATEMENT} = +{ + SQL_IS_INSERT_LITERALS => 0x00000001 +, SQL_IS_INSERT_SEARCHED => 0x00000002 +, SQL_IS_SELECT_INTO => 0x00000004 +}; +$ReturnValues{SQL_LOCK_TYPES} = +{ + SQL_LCK_NO_CHANGE => 0x00000001 +, SQL_LCK_EXCLUSIVE => 0x00000002 +, SQL_LCK_UNLOCK => 0x00000004 +}; +$ReturnValues{SQL_NON_NULLABLE_COLUMNS} = +{ + SQL_NNC_NULL => 0x0000 +, SQL_NNC_NON_NULL => 0x0001 +}; +$ReturnValues{SQL_NULL_COLLATION} = +{ + SQL_NC_HIGH => 0 +, SQL_NC_LOW => 1 +, SQL_NC_START => 0x0002 +, SQL_NC_END => 0x0004 +}; +$ReturnValues{SQL_NUMERIC_FUNCTIONS} = +{ + SQL_FN_NUM_ABS => 0x00000001 +, SQL_FN_NUM_ACOS => 0x00000002 +, SQL_FN_NUM_ASIN => 0x00000004 +, SQL_FN_NUM_ATAN => 0x00000008 +, SQL_FN_NUM_ATAN2 => 0x00000010 +, SQL_FN_NUM_CEILING => 0x00000020 +, SQL_FN_NUM_COS => 0x00000040 +, SQL_FN_NUM_COT => 0x00000080 +, SQL_FN_NUM_EXP => 0x00000100 +, SQL_FN_NUM_FLOOR => 0x00000200 +, SQL_FN_NUM_LOG => 0x00000400 +, SQL_FN_NUM_MOD => 0x00000800 +, SQL_FN_NUM_SIGN => 0x00001000 +, SQL_FN_NUM_SIN => 0x00002000 +, SQL_FN_NUM_SQRT => 0x00004000 +, SQL_FN_NUM_TAN => 0x00008000 +, SQL_FN_NUM_PI => 0x00010000 +, SQL_FN_NUM_RAND => 0x00020000 +, SQL_FN_NUM_DEGREES => 0x00040000 +, SQL_FN_NUM_LOG10 => 0x00080000 +, SQL_FN_NUM_POWER => 0x00100000 +, SQL_FN_NUM_RADIANS => 0x00200000 +, SQL_FN_NUM_ROUND => 0x00400000 +, SQL_FN_NUM_TRUNCATE => 0x00800000 +}; +$ReturnValues{SQL_ODBC_API_CONFORMANCE} = +{ + SQL_OAC_NONE => 0x0000 +, SQL_OAC_LEVEL1 => 0x0001 +, SQL_OAC_LEVEL2 => 0x0002 +}; +$ReturnValues{SQL_ODBC_INTERFACE_CONFORMANCE} = +{ + SQL_OIC_CORE => 1 +, SQL_OIC_LEVEL1 => 2 +, SQL_OIC_LEVEL2 => 3 +}; +$ReturnValues{SQL_ODBC_SAG_CLI_CONFORMANCE} = +{ + SQL_OSCC_NOT_COMPLIANT => 0x0000 +, SQL_OSCC_COMPLIANT => 0x0001 +}; +$ReturnValues{SQL_ODBC_SQL_CONFORMANCE} = +{ + SQL_OSC_MINIMUM => 0x0000 +, SQL_OSC_CORE => 0x0001 +, SQL_OSC_EXTENDED => 0x0002 +}; +$ReturnValues{SQL_OJ_CAPABILITIES} = +{ + SQL_OJ_LEFT => 0x00000001 +, SQL_OJ_RIGHT => 0x00000002 +, SQL_OJ_FULL => 0x00000004 +, SQL_OJ_NESTED => 0x00000008 +, SQL_OJ_NOT_ORDERED => 0x00000010 +, SQL_OJ_INNER => 0x00000020 +, SQL_OJ_ALL_COMPARISON_OPS => 0x00000040 +}; +$ReturnValues{SQL_OWNER_USAGE} = +{ + SQL_OU_DML_STATEMENTS => 0x00000001 +, SQL_OU_PROCEDURE_INVOCATION => 0x00000002 +, SQL_OU_TABLE_DEFINITION => 0x00000004 +, SQL_OU_INDEX_DEFINITION => 0x00000008 +, SQL_OU_PRIVILEGE_DEFINITION => 0x00000010 +}; +$ReturnValues{SQL_PARAM_ARRAY_ROW_COUNTS} = +{ + SQL_PARC_BATCH => 1 +, SQL_PARC_NO_BATCH => 2 +}; +$ReturnValues{SQL_PARAM_ARRAY_SELECTS} = +{ + SQL_PAS_BATCH => 1 +, SQL_PAS_NO_BATCH => 2 +, SQL_PAS_NO_SELECT => 3 +}; +$ReturnValues{SQL_POSITIONED_STATEMENTS} = +{ + SQL_PS_POSITIONED_DELETE => 0x00000001 +, SQL_PS_POSITIONED_UPDATE => 0x00000002 +, SQL_PS_SELECT_FOR_UPDATE => 0x00000004 +}; +$ReturnValues{SQL_POS_OPERATIONS} = +{ + SQL_POS_POSITION => 0x00000001 +, SQL_POS_REFRESH => 0x00000002 +, SQL_POS_UPDATE => 0x00000004 +, SQL_POS_DELETE => 0x00000008 +, SQL_POS_ADD => 0x00000010 +}; +$ReturnValues{SQL_QUALIFIER_LOCATION} = +{ + SQL_QL_START => 0x0001 +, SQL_QL_END => 0x0002 +}; +$ReturnValues{SQL_QUALIFIER_USAGE} = +{ + SQL_QU_DML_STATEMENTS => 0x00000001 +, SQL_QU_PROCEDURE_INVOCATION => 0x00000002 +, SQL_QU_TABLE_DEFINITION => 0x00000004 +, SQL_QU_INDEX_DEFINITION => 0x00000008 +, SQL_QU_PRIVILEGE_DEFINITION => 0x00000010 +}; +$ReturnValues{SQL_QUOTED_IDENTIFIER_CASE} = $ReturnValues{SQL_IDENTIFIER_CASE}; + +$ReturnValues{SQL_SCHEMA_USAGE} = +{ + SQL_SU_DML_STATEMENTS => 0x00000001 # SQL_OU_DML_STATEMENTS +, SQL_SU_PROCEDURE_INVOCATION => 0x00000002 # SQL_OU_PROCEDURE_INVOCATION +, SQL_SU_TABLE_DEFINITION => 0x00000004 # SQL_OU_TABLE_DEFINITION +, SQL_SU_INDEX_DEFINITION => 0x00000008 # SQL_OU_INDEX_DEFINITION +, SQL_SU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_OU_PRIVILEGE_DEFINITION +}; +$ReturnValues{SQL_SCROLL_CONCURRENCY} = +{ + SQL_SCCO_READ_ONLY => 0x00000001 +, SQL_SCCO_LOCK => 0x00000002 +, SQL_SCCO_OPT_ROWVER => 0x00000004 +, SQL_SCCO_OPT_VALUES => 0x00000008 +}; +$ReturnValues{SQL_SCROLL_OPTIONS} = +{ + SQL_SO_FORWARD_ONLY => 0x00000001 +, SQL_SO_KEYSET_DRIVEN => 0x00000002 +, SQL_SO_DYNAMIC => 0x00000004 +, SQL_SO_MIXED => 0x00000008 +, SQL_SO_STATIC => 0x00000010 +}; +$ReturnValues{SQL_SQL92_DATETIME_FUNCTIONS} = +{ + SQL_SDF_CURRENT_DATE => 0x00000001 +, SQL_SDF_CURRENT_TIME => 0x00000002 +, SQL_SDF_CURRENT_TIMESTAMP => 0x00000004 +}; +$ReturnValues{SQL_SQL92_FOREIGN_KEY_DELETE_RULE} = +{ + SQL_SFKD_CASCADE => 0x00000001 +, SQL_SFKD_NO_ACTION => 0x00000002 +, SQL_SFKD_SET_DEFAULT => 0x00000004 +, SQL_SFKD_SET_NULL => 0x00000008 +}; +$ReturnValues{SQL_SQL92_FOREIGN_KEY_UPDATE_RULE} = +{ + SQL_SFKU_CASCADE => 0x00000001 +, SQL_SFKU_NO_ACTION => 0x00000002 +, SQL_SFKU_SET_DEFAULT => 0x00000004 +, SQL_SFKU_SET_NULL => 0x00000008 +}; +$ReturnValues{SQL_SQL92_GRANT} = +{ + SQL_SG_USAGE_ON_DOMAIN => 0x00000001 +, SQL_SG_USAGE_ON_CHARACTER_SET => 0x00000002 +, SQL_SG_USAGE_ON_COLLATION => 0x00000004 +, SQL_SG_USAGE_ON_TRANSLATION => 0x00000008 +, SQL_SG_WITH_GRANT_OPTION => 0x00000010 +, SQL_SG_DELETE_TABLE => 0x00000020 +, SQL_SG_INSERT_TABLE => 0x00000040 +, SQL_SG_INSERT_COLUMN => 0x00000080 +, SQL_SG_REFERENCES_TABLE => 0x00000100 +, SQL_SG_REFERENCES_COLUMN => 0x00000200 +, SQL_SG_SELECT_TABLE => 0x00000400 +, SQL_SG_UPDATE_TABLE => 0x00000800 +, SQL_SG_UPDATE_COLUMN => 0x00001000 +}; +$ReturnValues{SQL_SQL92_NUMERIC_VALUE_FUNCTIONS} = +{ + SQL_SNVF_BIT_LENGTH => 0x00000001 +, SQL_SNVF_CHAR_LENGTH => 0x00000002 +, SQL_SNVF_CHARACTER_LENGTH => 0x00000004 +, SQL_SNVF_EXTRACT => 0x00000008 +, SQL_SNVF_OCTET_LENGTH => 0x00000010 +, SQL_SNVF_POSITION => 0x00000020 +}; +$ReturnValues{SQL_SQL92_PREDICATES} = +{ + SQL_SP_EXISTS => 0x00000001 +, SQL_SP_ISNOTNULL => 0x00000002 +, SQL_SP_ISNULL => 0x00000004 +, SQL_SP_MATCH_FULL => 0x00000008 +, SQL_SP_MATCH_PARTIAL => 0x00000010 +, SQL_SP_MATCH_UNIQUE_FULL => 0x00000020 +, SQL_SP_MATCH_UNIQUE_PARTIAL => 0x00000040 +, SQL_SP_OVERLAPS => 0x00000080 +, SQL_SP_UNIQUE => 0x00000100 +, SQL_SP_LIKE => 0x00000200 +, SQL_SP_IN => 0x00000400 +, SQL_SP_BETWEEN => 0x00000800 +, SQL_SP_COMPARISON => 0x00001000 +, SQL_SP_QUANTIFIED_COMPARISON => 0x00002000 +}; +$ReturnValues{SQL_SQL92_RELATIONAL_JOIN_OPERATORS} = +{ + SQL_SRJO_CORRESPONDING_CLAUSE => 0x00000001 +, SQL_SRJO_CROSS_JOIN => 0x00000002 +, SQL_SRJO_EXCEPT_JOIN => 0x00000004 +, SQL_SRJO_FULL_OUTER_JOIN => 0x00000008 +, SQL_SRJO_INNER_JOIN => 0x00000010 +, SQL_SRJO_INTERSECT_JOIN => 0x00000020 +, SQL_SRJO_LEFT_OUTER_JOIN => 0x00000040 +, SQL_SRJO_NATURAL_JOIN => 0x00000080 +, SQL_SRJO_RIGHT_OUTER_JOIN => 0x00000100 +, SQL_SRJO_UNION_JOIN => 0x00000200 +}; +$ReturnValues{SQL_SQL92_REVOKE} = +{ + SQL_SR_USAGE_ON_DOMAIN => 0x00000001 +, SQL_SR_USAGE_ON_CHARACTER_SET => 0x00000002 +, SQL_SR_USAGE_ON_COLLATION => 0x00000004 +, SQL_SR_USAGE_ON_TRANSLATION => 0x00000008 +, SQL_SR_GRANT_OPTION_FOR => 0x00000010 +, SQL_SR_CASCADE => 0x00000020 +, SQL_SR_RESTRICT => 0x00000040 +, SQL_SR_DELETE_TABLE => 0x00000080 +, SQL_SR_INSERT_TABLE => 0x00000100 +, SQL_SR_INSERT_COLUMN => 0x00000200 +, SQL_SR_REFERENCES_TABLE => 0x00000400 +, SQL_SR_REFERENCES_COLUMN => 0x00000800 +, SQL_SR_SELECT_TABLE => 0x00001000 +, SQL_SR_UPDATE_TABLE => 0x00002000 +, SQL_SR_UPDATE_COLUMN => 0x00004000 +}; +$ReturnValues{SQL_SQL92_ROW_VALUE_CONSTRUCTOR} = +{ + SQL_SRVC_VALUE_EXPRESSION => 0x00000001 +, SQL_SRVC_NULL => 0x00000002 +, SQL_SRVC_DEFAULT => 0x00000004 +, SQL_SRVC_ROW_SUBQUERY => 0x00000008 +}; +$ReturnValues{SQL_SQL92_STRING_FUNCTIONS} = +{ + SQL_SSF_CONVERT => 0x00000001 +, SQL_SSF_LOWER => 0x00000002 +, SQL_SSF_UPPER => 0x00000004 +, SQL_SSF_SUBSTRING => 0x00000008 +, SQL_SSF_TRANSLATE => 0x00000010 +, SQL_SSF_TRIM_BOTH => 0x00000020 +, SQL_SSF_TRIM_LEADING => 0x00000040 +, SQL_SSF_TRIM_TRAILING => 0x00000080 +}; +$ReturnValues{SQL_SQL92_VALUE_EXPRESSIONS} = +{ + SQL_SVE_CASE => 0x00000001 +, SQL_SVE_CAST => 0x00000002 +, SQL_SVE_COALESCE => 0x00000004 +, SQL_SVE_NULLIF => 0x00000008 +}; +$ReturnValues{SQL_SQL_CONFORMANCE} = +{ + SQL_SC_SQL92_ENTRY => 0x00000001 +, SQL_SC_FIPS127_2_TRANSITIONAL => 0x00000002 +, SQL_SC_SQL92_INTERMEDIATE => 0x00000004 +, SQL_SC_SQL92_FULL => 0x00000008 +}; +$ReturnValues{SQL_STANDARD_CLI_CONFORMANCE} = +{ + SQL_SCC_XOPEN_CLI_VERSION1 => 0x00000001 +, SQL_SCC_ISO92_CLI => 0x00000002 +}; +$ReturnValues{SQL_STATIC_SENSITIVITY} = +{ + SQL_SS_ADDITIONS => 0x00000001 +, SQL_SS_DELETIONS => 0x00000002 +, SQL_SS_UPDATES => 0x00000004 +}; +$ReturnValues{SQL_STRING_FUNCTIONS} = +{ + SQL_FN_STR_CONCAT => 0x00000001 +, SQL_FN_STR_INSERT => 0x00000002 +, SQL_FN_STR_LEFT => 0x00000004 +, SQL_FN_STR_LTRIM => 0x00000008 +, SQL_FN_STR_LENGTH => 0x00000010 +, SQL_FN_STR_LOCATE => 0x00000020 +, SQL_FN_STR_LCASE => 0x00000040 +, SQL_FN_STR_REPEAT => 0x00000080 +, SQL_FN_STR_REPLACE => 0x00000100 +, SQL_FN_STR_RIGHT => 0x00000200 +, SQL_FN_STR_RTRIM => 0x00000400 +, SQL_FN_STR_SUBSTRING => 0x00000800 +, SQL_FN_STR_UCASE => 0x00001000 +, SQL_FN_STR_ASCII => 0x00002000 +, SQL_FN_STR_CHAR => 0x00004000 +, SQL_FN_STR_DIFFERENCE => 0x00008000 +, SQL_FN_STR_LOCATE_2 => 0x00010000 +, SQL_FN_STR_SOUNDEX => 0x00020000 +, SQL_FN_STR_SPACE => 0x00040000 +, SQL_FN_STR_BIT_LENGTH => 0x00080000 +, SQL_FN_STR_CHAR_LENGTH => 0x00100000 +, SQL_FN_STR_CHARACTER_LENGTH => 0x00200000 +, SQL_FN_STR_OCTET_LENGTH => 0x00400000 +, SQL_FN_STR_POSITION => 0x00800000 +}; +$ReturnValues{SQL_SUBQUERIES} = +{ + SQL_SQ_COMPARISON => 0x00000001 +, SQL_SQ_EXISTS => 0x00000002 +, SQL_SQ_IN => 0x00000004 +, SQL_SQ_QUANTIFIED => 0x00000008 +, SQL_SQ_CORRELATED_SUBQUERIES => 0x00000010 +}; +$ReturnValues{SQL_SYSTEM_FUNCTIONS} = +{ + SQL_FN_SYS_USERNAME => 0x00000001 +, SQL_FN_SYS_DBNAME => 0x00000002 +, SQL_FN_SYS_IFNULL => 0x00000004 +}; +$ReturnValues{SQL_TIMEDATE_ADD_INTERVALS} = +{ + SQL_FN_TSI_FRAC_SECOND => 0x00000001 +, SQL_FN_TSI_SECOND => 0x00000002 +, SQL_FN_TSI_MINUTE => 0x00000004 +, SQL_FN_TSI_HOUR => 0x00000008 +, SQL_FN_TSI_DAY => 0x00000010 +, SQL_FN_TSI_WEEK => 0x00000020 +, SQL_FN_TSI_MONTH => 0x00000040 +, SQL_FN_TSI_QUARTER => 0x00000080 +, SQL_FN_TSI_YEAR => 0x00000100 +}; +$ReturnValues{SQL_TIMEDATE_FUNCTIONS} = +{ + SQL_FN_TD_NOW => 0x00000001 +, SQL_FN_TD_CURDATE => 0x00000002 +, SQL_FN_TD_DAYOFMONTH => 0x00000004 +, SQL_FN_TD_DAYOFWEEK => 0x00000008 +, SQL_FN_TD_DAYOFYEAR => 0x00000010 +, SQL_FN_TD_MONTH => 0x00000020 +, SQL_FN_TD_QUARTER => 0x00000040 +, SQL_FN_TD_WEEK => 0x00000080 +, SQL_FN_TD_YEAR => 0x00000100 +, SQL_FN_TD_CURTIME => 0x00000200 +, SQL_FN_TD_HOUR => 0x00000400 +, SQL_FN_TD_MINUTE => 0x00000800 +, SQL_FN_TD_SECOND => 0x00001000 +, SQL_FN_TD_TIMESTAMPADD => 0x00002000 +, SQL_FN_TD_TIMESTAMPDIFF => 0x00004000 +, SQL_FN_TD_DAYNAME => 0x00008000 +, SQL_FN_TD_MONTHNAME => 0x00010000 +, SQL_FN_TD_CURRENT_DATE => 0x00020000 +, SQL_FN_TD_CURRENT_TIME => 0x00040000 +, SQL_FN_TD_CURRENT_TIMESTAMP => 0x00080000 +, SQL_FN_TD_EXTRACT => 0x00100000 +}; +$ReturnValues{SQL_TXN_CAPABLE} = +{ + SQL_TC_NONE => 0 +, SQL_TC_DML => 1 +, SQL_TC_ALL => 2 +, SQL_TC_DDL_COMMIT => 3 +, SQL_TC_DDL_IGNORE => 4 +}; +$ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION} = +{ + SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 # SQL_TXN_READ_UNCOMMITTED +, SQL_TRANSACTION_READ_COMMITTED => 0x00000002 # SQL_TXN_READ_COMMITTED +, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 # SQL_TXN_REPEATABLE_READ +, SQL_TRANSACTION_SERIALIZABLE => 0x00000008 # SQL_TXN_SERIALIZABLE +}; +$ReturnValues{SQL_DEFAULT_TRANSACTION_ISOLATION} = $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION}; + +$ReturnValues{SQL_TXN_ISOLATION_OPTION} = +{ + SQL_TXN_READ_UNCOMMITTED => 0x00000001 +, SQL_TXN_READ_COMMITTED => 0x00000002 +, SQL_TXN_REPEATABLE_READ => 0x00000004 +, SQL_TXN_SERIALIZABLE => 0x00000008 +}; +$ReturnValues{SQL_DEFAULT_TXN_ISOLATION} = $ReturnValues{SQL_TXN_ISOLATION_OPTION}; + +$ReturnValues{SQL_TXN_VERSIONING} = +{ + SQL_TXN_VERSIONING => 0x00000010 +}; +$ReturnValues{SQL_UNION} = +{ + SQL_U_UNION => 0x00000001 +, SQL_U_UNION_ALL => 0x00000002 +}; +$ReturnValues{SQL_UNION_STATEMENT} = +{ + SQL_US_UNION => 0x00000001 # SQL_U_UNION +, SQL_US_UNION_ALL => 0x00000002 # SQL_U_UNION_ALL +}; + +1; + +=head1 TODO + + Corrections? + SQL_NULL_COLLATION: ODBC vs ANSI + Unique values for $ReturnValues{...}?, e.g. SQL_FILE_USAGE + +=cut diff --git a/lib/DBI/Const/GetInfoReturn.pm b/lib/DBI/Const/GetInfoReturn.pm new file mode 100644 index 0000000..d07b7ac --- /dev/null +++ b/lib/DBI/Const/GetInfoReturn.pm @@ -0,0 +1,105 @@ +# $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing return values from the DBI getinfo function. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfoReturn; + +use strict; + +use Exporter (); + +use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoReturnTypes %GetInfoReturnValues); + +@ISA = qw(Exporter); +@EXPORT = qw(%GetInfoReturnTypes %GetInfoReturnValues); + +my +$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +=head1 NAME + +DBI::Const::GetInfoReturn - Data and functions for describing GetInfo results + +=head1 SYNOPSIS + +The interface to this module is undocumented and liable to change. + +=head1 DESCRIPTION + +Data and functions for describing GetInfo results + +=cut + +use DBI::Const::GetInfoType; + +use DBI::Const::GetInfo::ANSI (); +use DBI::Const::GetInfo::ODBC (); + +%GetInfoReturnTypes = +( + %DBI::Const::GetInfo::ANSI::ReturnTypes +, %DBI::Const::GetInfo::ODBC::ReturnTypes +); + +%GetInfoReturnValues = (); +{ + my $A = \%DBI::Const::GetInfo::ANSI::ReturnValues; + my $O = \%DBI::Const::GetInfo::ODBC::ReturnValues; + while ( my ($k, $v) = each %$A ) { + my %h = ( exists $O->{$k} ) ? ( %$v, %{$O->{$k}} ) : %$v; + $GetInfoReturnValues{$k} = \%h; + } + while ( my ($k, $v) = each %$O ) { + next if exists $A->{$k}; + my %h = %$v; + $GetInfoReturnValues{$k} = \%h; + } +} + +# ----------------------------------------------------------------------------- + +sub Format { + my $InfoType = shift; + my $Value = shift; + + return '' unless defined $Value; + + my $ReturnType = $GetInfoReturnTypes{$InfoType}; + + return sprintf '0x%08X', $Value if $ReturnType eq 'SQLUINTEGER bitmask'; + return sprintf '0x%08X', $Value if $ReturnType eq 'SQLINTEGER bitmask'; +# return '"' . $Value . '"' if $ReturnType eq 'SQLCHAR'; + return $Value; +} + + +sub Explain { + my $InfoType = shift; + my $Value = shift; + + return '' unless defined $Value; + return '' unless exists $GetInfoReturnValues{$InfoType}; + + $Value = int $Value; + my $ReturnType = $GetInfoReturnTypes{$InfoType}; + my %h = reverse %{$GetInfoReturnValues{$InfoType}}; + + if ( $ReturnType eq 'SQLUINTEGER bitmask'|| $ReturnType eq 'SQLINTEGER bitmask') { + my @a = (); + for my $k ( sort { $a <=> $b } keys %h ) { + push @a, $h{$k} if $Value & $k; + } + return wantarray ? @a : join(' ', @a ); + } + else { + return $h{$Value} ||'?'; + } +} + +1; diff --git a/lib/DBI/Const/GetInfoType.pm b/lib/DBI/Const/GetInfoType.pm new file mode 100644 index 0000000..7c01778 --- /dev/null +++ b/lib/DBI/Const/GetInfoType.pm @@ -0,0 +1,54 @@ +# $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing info type codes for the DBI getinfo function. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfoType; + +use strict; + +use Exporter (); + +use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoType); + +@ISA = qw(Exporter); +@EXPORT = qw(%GetInfoType); + +my +$VERSION = sprintf("2.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +=head1 NAME + +DBI::Const::GetInfoType - Data describing GetInfo type codes + +=head1 SYNOPSIS + + use DBI::Const::GetInfoType; + +=head1 DESCRIPTION + +Imports a %GetInfoType hash which maps names for GetInfo Type Codes +into their corresponding numeric values. For example: + + $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} ); + +The interface to this module is new and nothing beyond what is +written here is guaranteed. + +=cut + +use DBI::Const::GetInfo::ANSI (); # liable to change +use DBI::Const::GetInfo::ODBC (); # liable to change + +%GetInfoType = +( + %DBI::Const::GetInfo::ANSI::InfoTypes # liable to change +, %DBI::Const::GetInfo::ODBC::InfoTypes # liable to change +); + +1; diff --git a/lib/DBI/DBD.pm b/lib/DBI/DBD.pm new file mode 100644 index 0000000..6f8bf8c --- /dev/null +++ b/lib/DBI/DBD.pm @@ -0,0 +1,3489 @@ +package DBI::DBD; +# vim:ts=8:sw=4 + +use vars qw($VERSION); # set $VERSION early so we don't confuse PAUSE/CPAN etc + +# don't use Revision here because that's not in svn:keywords so that the +# examples that use it below won't be messed up +$VERSION = sprintf("12.%06d", q$Id: DBD.pm 15128 2012-02-04 20:51:39Z timbo $ =~ /(\d+)/o); + + +# $Id: DBD.pm 15128 2012-02-04 20:51:39Z timbo $ +# +# Copyright (c) 1997-2006 Jonathan Leffler, Jochen Wiedmann, Steffen +# Goeldner and Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +=head1 NAME + +DBI::DBD - Perl DBI Database Driver Writer's Guide + +=head1 SYNOPSIS + + perldoc DBI::DBD + +=head2 Version and volatility + +This document is I<still> a minimal draft which is in need of further work. + +The changes will occur both because the B<DBI> specification is changing +and hence the requirements on B<DBD> drivers change, and because feedback +from people reading this document will suggest improvements to it. + +Please read the B<DBI> documentation first and fully, including the B<DBI> FAQ. +Then reread the B<DBI> specification again as you're reading this. It'll help. + +This document is a patchwork of contributions from various authors. +More contributions (preferably as patches) are very welcome. + +=head1 DESCRIPTION + +This document is primarily intended to help people writing new +database drivers for the Perl Database Interface (Perl DBI). +It may also help others interested in discovering why the internals of +a B<DBD> driver are written the way they are. + +This is a guide. Few (if any) of the statements in it are completely +authoritative under all possible circumstances. This means you will +need to use judgement in applying the guidelines in this document. +If in I<any> doubt at all, please do contact the I<dbi-dev> mailing list +(details given below) where Tim Bunce and other driver authors can help. + +=head1 CREATING A NEW DRIVER + +The first rule for creating a new database driver for the Perl DBI is +very simple: B<DON'T!> + +There is usually a driver already available for the database you want +to use, almost regardless of which database you choose. Very often, the +database will provide an ODBC driver interface, so you can often use +B<DBD::ODBC> to access the database. This is typically less convenient +on a Unix box than on a Microsoft Windows box, but there are numerous +options for ODBC driver managers on Unix too, and very often the ODBC +driver is provided by the database supplier. + +Before deciding that you need to write a driver, do your homework to +ensure that you are not wasting your energies. + +[As of December 2002, the consensus is that if you need an ODBC driver +manager on Unix, then the unixODBC driver (available from +L<http://www.unixodbc.org/>) is the way to go.] + +The second rule for creating a new database driver for the Perl DBI is +also very simple: B<Don't -- get someone else to do it for you!> + +Nevertheless, there are occasions when it is necessary to write a new +driver, often to use a proprietary language or API to access the +database more swiftly, or more comprehensively, than an ODBC driver can. +Then you should read this document very carefully, but with a suitably +sceptical eye. + +If there is something in here that does not make any sense, question it. +You might be right that the information is bogus, but don't come to that +conclusion too quickly. + +=head2 URLs and mailing lists + +The primary web-site for locating B<DBI> software and information is + + http://dbi.perl.org/ + +There are two main and one auxiliary mailing lists for people working +with B<DBI>. The primary lists are I<dbi-users@perl.org> for general users +of B<DBI> and B<DBD> drivers, and I<dbi-dev@perl.org> mainly for B<DBD> driver +writers (don't join the I<dbi-dev> list unless you have a good reason). +The auxiliary list is I<dbi-announce@perl.org> for announcing new +releases of B<DBI> or B<DBD> drivers. + +You can join these lists by accessing the web-site L<http://dbi.perl.org/>. +The lists are closed so you cannot send email to any of the lists +unless you join the list first. + +You should also consider monitoring the I<comp.lang.perl.*> newsgroups, +especially I<comp.lang.perl.modules>. + +=head2 The Cheetah book + +The definitive book on Perl DBI is the Cheetah book, so called because +of the picture on the cover. Its proper title is 'I<Programming the +Perl DBI: Database programming with Perl>' by Alligator Descartes +and Tim Bunce, published by O'Reilly Associates, February 2000, ISBN +1-56592-699-4. Buy it now if you have not already done so, and read it. + +=head2 Locating drivers + +Before writing a new driver, it is in your interests to find out +whether there already is a driver for your database. If there is such +a driver, it would be much easier to make use of it than to write your +own! + +The primary web-site for locating Perl software is +L<http://search.cpan.org/>. You should look under the various +modules listings for the software you are after. For example: + + http://search.cpan.org/modlist/Database_Interfaces + +Follow the B<DBD::> and B<DBIx::> links at the top to see those subsets. + +See the B<DBI> docs for information on B<DBI> web sites and mailing lists. + +=head2 Registering a new driver + +Before going through any official registration process, you will need +to establish that there is no driver already in the works. You'll do +that by asking the B<DBI> mailing lists whether there is such a driver +available, or whether anybody is working on one. + +When you get the go ahead, you will need to establish the name of the +driver and a prefix for the driver. Typically, the name is based on the +name of the database software it uses, and the prefix is a contraction +of that. Hence, B<DBD::Oracle> has the name I<Oracle> and the prefix +'I<ora_>'. The prefix must be lowercase and contain no underscores other +than the one at the end. + +This information will be recorded in the B<DBI> module. Apart from +documentation purposes, registration is a prerequisite for +L<installing private methods|DBI/install_method>. + +If you are writing a driver which will not be distributed on CPAN, then +you should choose a prefix beginning with 'I<x_>', to avoid potential +prefix collisions with drivers registered in the future. Thus, if you +wrote a non-CPAN distributed driver called B<DBD::CustomDB>, the prefix +might be 'I<x_cdb_>'. + +This document assumes you are writing a driver called B<DBD::Driver>, and +that the prefix 'I<drv_>' is assigned to the driver. + +=head2 Two styles of database driver + +There are two distinct styles of database driver that can be written to +work with the Perl DBI. + +Your driver can be written in pure Perl, requiring no C compiler. +When feasible, this is the best solution, but most databases are not +written in such a way that this can be done. Some examples of pure +Perl drivers are B<DBD::File> and B<DBD::CSV>. + +Alternatively, and most commonly, your driver will need to use some C +code to gain access to the database. This will be classified as a C/XS +driver. + +=head2 What code will you write? + +There are a number of files that need to be written for either a pure +Perl driver or a C/XS driver. There are no extra files needed only by +a pure Perl driver, but there are several extra files needed only by a +C/XS driver. + +=head3 Files common to pure Perl and C/XS drivers + +Assuming that your driver is called B<DBD::Driver>, these files are: + +=over 4 + +=item * F<Makefile.PL> + +=item * F<META.yml> + +=item * F<README> + +=item * F<MANIFEST> + +=item * F<Driver.pm> + +=item * F<lib/Bundle/DBD/Driver.pm> + +=item * F<lib/DBD/Driver/Summary.pm> + +=item * F<t/*.t> + +=back + +The first four files are mandatory. F<Makefile.PL> is used to control +how the driver is built and installed. The F<README> file tells people +who download the file about how to build the module and any prerequisite +software that must be installed. The F<MANIFEST> file is used by the +standard Perl module distribution mechanism. It lists all the source +files that need to be distributed with your module. F<Driver.pm> is what +is loaded by the B<DBI> code; it contains the methods peculiar to your +driver. + +Although the F<META.yml> file is not B<required> you are advised to +create one. Of particular importance are the I<build_requires> and +I<configure_requires> attributes which newer CPAN modules understand. +You use these to tell the CPAN module (and CPANPLUS) that your build +and configure mechanisms require DBI. The best reference for META.yml +(at the time of writing) is +L<http://module-build.sourceforge.net/META-spec-v1.4.html>. You can find +a reasonable example of a F<META.yml> in DBD::ODBC. + +The F<lib/Bundle/DBD/Driver.pm> file allows you to specify other Perl +modules on which yours depends in a format that allows someone to type a +simple command and ensure that all the pre-requisites are in place as +well as building your driver. + +The F<lib/DBD/Driver/Summary.pm> file contains (an updated version of) the +information that was included - or that would have been included - in +the appendices of the Cheetah book as a summary of the abilities of your +driver and the associated database. + +The files in the F<t> subdirectory are unit tests for your driver. +You should write your tests as stringently as possible, while taking +into account the diversity of installations that you can encounter: + +=over 4 + +=item * + +Your tests should not casually modify operational databases. + +=item * + +You should never damage existing tables in a database. + +=item * + +You should code your tests to use a constrained name space within the +database. For example, the tables (and all other named objects) that are +created could all begin with 'I<dbd_drv_>'. + +=item * + +At the end of a test run, there should be no testing objects left behind +in the database. + +=item * + +If you create any databases, you should remove them. + +=item * + +If your database supports temporary tables that are automatically +removed at the end of a session, then exploit them as often as possible. + +=item * + +Try to make your tests independent of each other. If you have a +test F<t/t11dowhat.t> that depends upon the successful running +of F<t/t10thingamy.t>, people cannot run the single test case +F<t/t11dowhat.t>. Further, running F<t/t11dowhat.t> twice in a row is +likely to fail (at least, if F<t/t11dowhat.t> modifies the database at +all) because the database at the start of the second run is not what you +saw at the start of the first run. + +=item * + +Document in your F<README> file what you do, and what privileges people +need to do it. + +=item * + +You can, and probably should, sequence your tests by including a test +number before an abbreviated version of the test name; the tests are run +in the order in which the names are expanded by shell-style globbing. + +=item * + +It is in your interests to ensure that your tests work as widely +as possible. + +=back + +Many drivers also install sub-modules B<DBD::Driver::SubModule> +for any of a variety of different reasons, such as to support +the metadata methods (see the discussion of L</METADATA METHODS> +below). Such sub-modules are conventionally stored in the directory +F<lib/DBD/Driver>. The module itself would usually be in a file +F<SubModule.pm>. All such sub-modules should themselves be version +stamped (see the discussions far below). + +=head3 Extra files needed by C/XS drivers + +The software for a C/XS driver will typically contain at least four +extra files that are not relevant to a pure Perl driver. + +=over 4 + +=item * F<Driver.xs> + +=item * F<Driver.h> + +=item * F<dbdimp.h> + +=item * F<dbdimp.c> + +=back + +The F<Driver.xs> file is used to generate C code that Perl can call to gain +access to the C functions you write that will, in turn, call down onto +your database software. + +The F<Driver.h> header is a stylized header that ensures you can access the +necessary Perl and B<DBI> macros, types, and function declarations. + +The F<dbdimp.h> is used to specify which functions have been implemented by +your driver. + +The F<dbdimp.c> file is where you write the C code that does the real work +of translating between Perl-ish data types and what the database expects +to use and return. + +There are some (mainly small, but very important) differences between +the contents of F<Makefile.PL> and F<Driver.pm> for pure Perl and C/XS +drivers, so those files are described both in the section on creating a +pure Perl driver and in the section on creating a C/XS driver. + +Obviously, you can add extra source code files to the list. + +=head2 Requirements on a driver and driver writer + +To be remotely useful, your driver must be implemented in a format that +allows it to be distributed via CPAN, the Comprehensive Perl Archive +Network (L<http://www.cpan.org/> and L<http://search.cpan.org>). +Of course, it is easier if you do not have to meet this criterion, but +you will not be able to ask for much help if you do not do so, and +no-one is likely to want to install your module if they have to learn a +new installation mechanism. + +=head1 CREATING A PURE PERL DRIVER + +Writing a pure Perl driver is surprisingly simple. However, there are +some problems you should be aware of. The best option is of course +picking up an existing driver and carefully modifying one method +after the other. + +Also look carefully at B<DBD::AnyData> and B<DBD::Template>. + +As an example we take a look at the B<DBD::File> driver, a driver for +accessing plain files as tables, which is part of the B<DBD::CSV> package. + +The minimal set of files we have to implement are F<Makefile.PL>, +F<README>, F<MANIFEST> and F<Driver.pm>. + +=head2 Pure Perl version of Makefile.PL + +You typically start with writing F<Makefile.PL>, a Makefile +generator. The contents of this file are described in detail in +the L<ExtUtils::MakeMaker> man pages. It is definitely a good idea +if you start reading them. At least you should know about the +variables I<CONFIGURE>, I<DEFINED>, I<PM>, I<DIR>, I<EXE_FILES>, +I<INC>, I<LIBS>, I<LINKTYPE>, I<NAME>, I<OPTIMIZE>, I<PL_FILES>, +I<VERSION>, I<VERSION_FROM>, I<clean>, I<depend>, I<realclean> from +the L<ExtUtils::MakeMaker> man page: these are used in almost any +F<Makefile.PL>. + +Additionally read the section on I<Overriding MakeMaker Methods> and the +descriptions of the I<distcheck>, I<disttest> and I<dist> targets: They +will definitely be useful for you. + +Of special importance for B<DBI> drivers is the I<postamble> method from +the L<ExtUtils::MM_Unix> man page. + +For Emacs users, I recommend the I<libscan> method, which removes +Emacs backup files (file names which end with a tilde '~') from lists of +files. + +Now an example, I use the word C<Driver> wherever you should insert +your driver's name: + + # -*- perl -*- + + use ExtUtils::MakeMaker; + + WriteMakefile( + dbd_edit_mm_attribs( { + 'NAME' => 'DBD::Driver', + 'VERSION_FROM' => 'Driver.pm', + 'INC' => '', + 'dist' => { 'SUFFIX' => '.gz', + 'COMPRESS' => 'gzip -9f' }, + 'realclean' => { FILES => '*.xsi' }, + 'PREREQ_PM' => '1.03', + 'CONFIGURE' => sub { + eval {require DBI::DBD;}; + if ($@) { + warn $@; + exit 0; + } + my $dbi_arch_dir = dbd_dbi_arch_dir(); + if (exists($opts{INC})) { + return {INC => "$opts{INC} -I$dbi_arch_dir"}; + } else { + return {INC => "-I$dbi_arch_dir"}; + } + } + }, + { create_pp_tests => 1}) + ); + + package MY; + sub postamble { return main::dbd_postamble(@_); } + sub libscan { + my ($self, $path) = @_; + ($path =~ m/\~$/) ? undef : $path; + } + +Note the calls to C<dbd_edit_mm_attribs()> and C<dbd_postamble()>. + +The second hash reference in the call to C<dbd_edit_mm_attribs()> +(containing C<create_pp_tests()>) is optional; you should not use it +unless your driver is a pure Perl driver (that is, it does not use C and +XS code). Therefore, the call to C<dbd_edit_mm_attribs()> is not +relevant for C/XS drivers and may be omitted; simply use the (single) +hash reference containing NAME etc as the only argument to C<WriteMakefile()>. + +Note that the C<dbd_edit_mm_attribs()> code will fail if you do not have a +F<t> sub-directory containing at least one test case. + +I<PREREQ_PM> tells MakeMaker that DBI (version 1.03 in this case) is +required for this module. This will issue a warning that DBI 1.03 is +missing if someone attempts to install your DBD without DBI 1.03. See +I<CONFIGURE> below for why this does not work reliably in stopping cpan +testers failing your module if DBI is not installed. + +I<CONFIGURE> is a subroutine called by MakeMaker during +C<WriteMakefile>. By putting the C<require DBI::DBD> in this section +we can attempt to load DBI::DBD but if it is missing we exit with +success. As we exit successfully without creating a Makefile when +DBI::DBD is missing cpan testers will not report a failure. This may +seem at odds with I<PREREQ_PM> but I<PREREQ_PM> does not cause +C<WriteMakefile> to fail (unless you also specify PREREQ_FATAL which +is strongly discouraged by MakeMaker) so C<WriteMakefile> would +continue to call C<dbd_dbi_arch_dir> and fail. + +All drivers must use C<dbd_postamble()> or risk running into problems. + +Note the specification of I<VERSION_FROM>; the named file +(F<Driver.pm>) will be scanned for the first line that looks like an +assignment to I<$VERSION>, and the subsequent text will be used to +determine the version number. Note the commentary in +L<ExtUtils::MakeMaker> on the subject of correctly formatted version +numbers. + +If your driver depends upon external software (it usually will), you +will need to add code to ensure that your environment is workable +before the call to C<WriteMakefile()>. If you need to check for the +existence of an external library and perhaps modify I<INC> to include +the paths to where the external library header files are located and +you cannot find the library or header files make sure you output a +message saying they cannot be found but C<exit 0> (success) B<before> +calling C<WriteMakefile> or CPAN testers will fail your module if the +external library is not found. + +A full-fledged I<Makefile.PL> can be quite large (for example, the +files for B<DBD::Oracle> and B<DBD::Informix> are both over 1000 lines +long, and the Informix one uses - and creates - auxiliary modules +too). + +See also L<ExtUtils::MakeMaker> and L<ExtUtils::MM_Unix>. Consider using +L<CPAN::MakeMaker> in place of I<ExtUtils::MakeMaker>. + +=head2 README + +The L<README> file should describe what the driver is for, the +pre-requisites for the build process, the actual build process, how to +report errors, and who to report them to. + +Users will find ways of breaking the driver build and test process +which you would never even have dreamed to be possible in your worst +nightmares. Therefore, you need to write this document defensively, +precisely and concisely. + +As always, use the F<README> from one of the established drivers as a basis +for your own; the version in B<DBD::Informix> is worth a look as it has +been quite successful in heading off problems. + +=over 4 + +=item * + +Note that users will have versions of Perl and B<DBI> that are both older +and newer than you expected, but this will seldom cause much trouble. +When it does, it will be because you are using features of B<DBI> that are +not supported in the version they are using. + +=item * + +Note that users will have versions of the database software that are +both older and newer than you expected. You will save yourself time in +the long run if you can identify the range of versions which have been +tested and warn about versions which are not known to be OK. + +=item * + +Note that many people trying to install your driver will not be experts +in the database software. + +=item * + +Note that many people trying to install your driver will not be experts +in C or Perl. + +=back + +=head2 MANIFEST + +The F<MANIFEST> will be used by the Makefile's dist target to build the +distribution tar file that is uploaded to CPAN. It should list every +file that you want to include in your distribution, one per line. + +=head2 lib/Bundle/DBD/Driver.pm + +The CPAN module provides an extremely powerful bundle mechanism that +allows you to specify pre-requisites for your driver. + +The primary pre-requisite is B<Bundle::DBI>; you may want or need to add +some more. With the bundle set up correctly, the user can type: + + perl -MCPAN -e 'install Bundle::DBD::Driver' + +and Perl will download, compile, test and install all the Perl modules +needed to build your driver. + +The prerequisite modules are listed in the C<CONTENTS> section, with the +official name of the module followed by a dash and an informal name or +description. + +=over 4 + +=item * + +Listing B<Bundle::DBI> as the main pre-requisite simplifies life. + +=item * + +Don't forget to list your driver. + +=item * + +Note that unless the DBMS is itself a Perl module, you cannot list it as +a pre-requisite in this file. + +=item * + +You should keep the version of the bundle the same as the version of +your driver. + +=item * + +You should add configuration management, copyright, and licencing +information at the top. + +=back + +A suitable skeleton for this file is shown below. + + package Bundle::DBD::Driver; + + $VERSION = '0.01'; + + 1; + + __END__ + + =head1 NAME + + Bundle::DBD::Driver - A bundle to install all DBD::Driver related modules + + =head1 SYNOPSIS + + C<perl -MCPAN -e 'install Bundle::DBD::Driver'> + + =head1 CONTENTS + + Bundle::DBI - Bundle for DBI by TIMB (Tim Bunce) + + DBD::Driver - DBD::Driver by YOU (Your Name) + + =head1 DESCRIPTION + + This bundle includes all the modules used by the Perl Database + Interface (DBI) driver for Driver (DBD::Driver), assuming the + use of DBI version 1.13 or later, created by Tim Bunce. + + If you've not previously used the CPAN module to install any + bundles, you will be interrogated during its setup phase. + But when you've done it once, it remembers what you told it. + You could start by running: + + C<perl -MCPAN -e 'install Bundle::CPAN'> + + =head1 SEE ALSO + + Bundle::DBI + + =head1 AUTHOR + + Your Name E<lt>F<you@yourdomain.com>E<gt> + + =head1 THANKS + + This bundle was created by ripping off Bundle::libnet created by + Graham Barr E<lt>F<gbarr@ti.com>E<gt>, and radically simplified + with some information from Jochen Wiedmann E<lt>F<joe@ispsoft.de>E<gt>. + The template was then included in the DBI::DBD documentation by + Jonathan Leffler E<lt>F<jleffler@informix.com>E<gt>. + + =cut + +=head2 lib/DBD/Driver/Summary.pm + +There is no substitute for taking the summary file from a driver that +was documented in the Perl book (such as B<DBD::Oracle> or B<DBD::Informix> or +B<DBD::ODBC>, to name but three), and adapting it to describe the +facilities available via B<DBD::Driver> when accessing the Driver database. + +=head2 Pure Perl version of Driver.pm + +The F<Driver.pm> file defines the Perl module B<DBD::Driver> for your driver. +It will define a package B<DBD::Driver> along with some version information, +some variable definitions, and a function C<driver()> which will have a more +or less standard structure. + +It will also define three sub-packages of B<DBD::Driver>: + +=over 4 + +=item DBD::Driver::dr + +with methods C<connect()>, C<data_sources()> and C<disconnect_all()>; + +=item DBD::Driver::db + +with methods such as C<prepare()>; + +=item DBD::Driver::st + +with methods such as C<execute()> and C<fetch()>. + +=back + +The F<Driver.pm> file will also contain the documentation specific to +B<DBD::Driver> in the format used by perldoc. + +In a pure Perl driver, the F<Driver.pm> file is the core of the +implementation. You will need to provide all the key methods needed by B<DBI>. + +Now let's take a closer look at an excerpt of F<File.pm> as an example. +We ignore things that are common to any module (even non-DBI modules) +or really specific to the B<DBD::File> package. + +=head3 The DBD::Driver package + +=head4 The header + + package DBD::File; + + use strict; + use vars qw($VERSION $drh); + + $VERSION = "1.23.00" # Version number of DBD::File + +This is where the version number of your driver is specified, and is +where F<Makefile.PL> looks for this information. Please ensure that any +other modules added with your driver are also version stamped so that +CPAN does not get confused. + +It is recommended that you use a two-part (1.23) or three-part (1.23.45) +version number. Also consider the CPAN system, which gets confused and +considers version 1.10 to precede version 1.9, so that using a raw CVS, +RCS or SCCS version number is probably not appropriate (despite being +very common). + +For Subversion you could use: + + $VERSION = sprintf("12.%06d", q$Revision: 12345 $ =~ /(\d+)/o); + +(use lots of leading zeros on the second portion so if you move the code to a +shared repository like svn.perl.org the much larger revision numbers won't +cause a problem, at least not for a few years). For RCS or CVS you can use: + + $VERSION = sprintf "%d.%02d", '$Revision: 11.21 $ ' =~ /(\d+)\.(\d+)/; + +which pads out the fractional part with leading zeros so all is well +(so long as you don't go past x.99) + + $drh = undef; # holds driver handle once initialized + +This is where the driver handle will be stored, once created. +Note that you may assume there is only one handle for your driver. + +=head4 The driver constructor + +The C<driver()> method is the driver handle constructor. Note that +the C<driver()> method is in the B<DBD::Driver> package, not in +one of the sub-packages B<DBD::Driver::dr>, B<DBD::Driver::db>, or +B<DBD::Driver::db>. + + sub driver + { + return $drh if $drh; # already created - return same one + my ($class, $attr) = @_; + + $class .= "::dr"; + + DBD::Driver::db->install_method('drv_example_dbh_method'); + DBD::Driver::st->install_method('drv_example_sth_method'); + + # not a 'my' since we use it above to prevent multiple drivers + $drh = DBI::_new_drh($class, { + 'Name' => 'File', + 'Version' => $VERSION, + 'Attribution' => 'DBD::File by Jochen Wiedmann', + }) + or return undef; + + return $drh; + } + +This is a reasonable example of how B<DBI> implements its handles. There +are three kinds: B<driver handles> (typically stored in I<$drh>; from +now on called I<drh> or I<$drh>), B<database handles> (from now on +called I<dbh> or I<$dbh>) and B<statement handles> (from now on called +I<sth> or I<$sth>). + +The prototype of C<DBI::_new_drh()> is + + $drh = DBI::_new_drh($class, $public_attrs, $private_attrs); + +with the following arguments: + +=over 4 + +=item I<$class> + +is typically the class for your driver, (for example, "DBD::File::dr"), +passed as the first argument to the C<driver()> method. + +=item I<$public_attrs> + +is a hash ref to attributes like I<Name>, I<Version>, and I<Attribution>. +These are processed and used by B<DBI>. You had better not make any +assumptions about them nor should you add private attributes here. + +=item I<$private_attrs> + +This is another (optional) hash ref with your private attributes. +B<DBI> will store them and otherwise leave them alone. + +=back + +The C<DBI::_new_drh()> method and the C<driver()> method both return C<undef> +for failure (in which case you must look at I<$DBI::err> and I<$DBI::errstr> +for the failure information, because you have no driver handle to use). + + +=head4 Using install_method() to expose driver-private methods + + DBD::Foo::db->install_method($method_name, \%attr); + +Installs the driver-private method named by $method_name into the +DBI method dispatcher so it can be called directly, avoiding the +need to use the func() method. + +It is called as a static method on the driver class to which the +method belongs. The method name must begin with the corresponding +registered driver-private prefix. For example, for DBD::Oracle +$method_name must being with 'C<ora_>', and for DBD::AnyData it +must begin with 'C<ad_>'. + +The C<\%attr> attributes can be used to provide fine control over how the DBI +dispatcher handles the dispatching of the method. However it's undocumented +at the moment. See the IMA_* #define's in DBI.xs and the O=>0x000x values in +the initialization of %DBI::DBI_methods in DBI.pm. (Volunteers to polish up +and document the interface are very welcome to get in touch via dbi-dev@perl.org). + +Methods installed using install_method default to the standard error +handling behaviour for DBI methods: clearing err and errstr before +calling the method, and checking for errors to trigger RaiseError +etc. on return. This differs from the default behaviour of func(). + +Note for driver authors: The DBD::Foo::xx->install_method call won't +work until the class-hierarchy has been setup. Normally the DBI +looks after that just after the driver is loaded. This means +install_method() can't be called at the time the driver is loaded +unless the class-hierarchy is set up first. The way to do that is +to call the setup_driver() method: + + DBI->setup_driver('DBD::Foo'); + +before using install_method(). + + +=head4 The CLONE special subroutine + +Also needed here, in the B<DBD::Driver> package, is a C<CLONE()> method +that will be called by perl when an interpreter is cloned. All your +C<CLONE()> method needs to do, currently, is clear the cached I<$drh> so +the new interpreter won't start using the cached I<$drh> from the old +interpreter: + + sub CLONE { + undef $drh; + } + +See L<http://search.cpan.org/dist/perl/pod/perlmod.pod#Making_your_module_threadsafe> +for details. + +=head3 The DBD::Driver::dr package + +The next lines of code look as follows: + + package DBD::Driver::dr; # ====== DRIVER ====== + + $DBD::Driver::dr::imp_data_size = 0; + +Note that no I<@ISA> is needed here, or for the other B<DBD::Driver::*> +classes, because the B<DBI> takes care of that for you when the driver is +loaded. + + *FIX ME* Explain what the imp_data_size is, so that implementors aren't + practicing cargo-cult programming. + +=head4 The database handle constructor + +The database handle constructor is the driver's (hence the changed +namespace) C<connect()> method: + + sub connect + { + my ($drh, $dr_dsn, $user, $auth, $attr) = @_; + + # Some database specific verifications, default settings + # and the like can go here. This should only include + # syntax checks or similar stuff where it's legal to + # 'die' in case of errors. + # For example, many database packages requires specific + # environment variables to be set; this could be where you + # validate that they are set, or default them if they are not set. + + my $driver_prefix = "drv_"; # the assigned prefix for this driver + + # Process attributes from the DSN; we assume ODBC syntax + # here, that is, the DSN looks like var1=val1;...;varN=valN + foreach my $var ( split /;/, $dr_dsn ) { + my ($attr_name, $attr_value) = split '=', $var, 2; + return $drh->set_err($DBI::stderr, "Can't parse DSN part '$var'") + unless defined $attr_value; + + # add driver prefix to attribute name if it doesn't have it already + $attr_name = $driver_prefix.$attr_name + unless $attr_name =~ /^$driver_prefix/o; + + # Store attribute into %$attr, replacing any existing value. + # The DBI will STORE() these into $dbh after we've connected + $attr->{$attr_name} = $attr_value; + } + + # Get the attributes we'll use to connect. + # We use delete here because these no need to STORE them + my $db = delete $attr->{drv_database} || delete $attr->{drv_db} + or return $drh->set_err($DBI::stderr, "No database name given in DSN '$dr_dsn'"); + my $host = delete $attr->{drv_host} || 'localhost'; + my $port = delete $attr->{drv_port} || 123456; + + # Assume you can attach to your database via drv_connect: + my $connection = drv_connect($db, $host, $port, $user, $auth) + or return $drh->set_err($DBI::stderr, "Can't connect to $dr_dsn: ..."); + + # create a 'blank' dbh (call superclass constructor) + my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dr_dsn }); + + $dbh->STORE('Active', 1 ); + $dbh->{drv_connection} = $connection; + + return $outer; + } + +This is mostly the same as in the I<driver handle constructor> above. +The arguments are described in L<DBI>. + +The constructor C<DBI::_new_dbh()> is called, returning a database handle. +The constructor's prototype is: + + ($outer, $inner) = DBI::_new_dbh($drh, $public_attr, $private_attr); + +with similar arguments to those in the I<driver handle constructor>, +except that the I<$class> is replaced by I<$drh>. The I<Name> attribute +is a standard B<DBI> attribute (see L<DBI/Database Handle Attributes>). + +In scalar context, only the outer handle is returned. + +Note the use of the C<STORE()> method for setting the I<dbh> attributes. +That's because within the driver code, the handle object you have is +the 'inner' handle of a tied hash, not the outer handle that the +users of your driver have. + +Because you have the inner handle, tie magic doesn't get invoked +when you get or set values in the hash. This is often very handy for +speed when you want to get or set simple non-special driver-specific +attributes. + +However, some attribute values, such as those handled by the B<DBI> like +I<PrintError>, don't actually exist in the hash and must be read via +C<$h-E<gt>FETCH($attrib)> and set via C<$h-E<gt>STORE($attrib, $value)>. +If in any doubt, use these methods. + +=head4 The data_sources() method + +The C<data_sources()> method must populate and return a list of valid data +sources, prefixed with the "I<dbi:Driver>" incantation that allows them to +be used in the first argument of the C<DBI-E<gt>connect()> method. +An example of this might be scanning the F<$HOME/.odbcini> file on Unix +for ODBC data sources (DSNs). + +As a trivial example, consider a fixed list of data sources: + + sub data_sources + { + my($drh, $attr) = @_; + my(@list) = (); + # You need more sophisticated code than this to set @list... + push @list, "dbi:Driver:abc"; + push @list, "dbi:Driver:def"; + push @list, "dbi:Driver:ghi"; + # End of code to set @list + return @list; + } + +=head4 The disconnect_all() method + +If you need to release any resources when the driver is unloaded, you +can provide a disconnect_all method. + +=head4 Other driver handle methods + +If you need any other driver handle methods, they can follow here. + +=head4 Error handling + +It is quite likely that something fails in the connect method. +With B<DBD::File> for example, you might catch an error when setting the +current directory to something not existent by using the +(driver-specific) I<f_dir> attribute. + +To report an error, you use the C<set_err()> method: + + $h->set_err($err, $errmsg, $state); + +This will ensure that the error is recorded correctly and that +I<RaiseError> and I<PrintError> etc are handled correctly. + +Typically you'll always use the method instance, aka your method's first +argument. + +As C<set_err()> always returns C<undef> your error handling code can +usually be simplified to something like this: + + return $h->set_err($err, $errmsg, $state) if ...; + +=head3 The DBD::Driver::db package + + package DBD::Driver::db; # ====== DATABASE ====== + + $DBD::Driver::db::imp_data_size = 0; + +=head4 The statement handle constructor + +There's nothing much new in the statement handle constructor, which +is the C<prepare()> method: + + sub prepare + { + my ($dbh, $statement, @attribs) = @_; + + # create a 'blank' sth + my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement }); + + $sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//)); + + $sth->{drv_params} = []; + + return $outer; + } + +This is still the same -- check the arguments and call the super class +constructor C<DBI::_new_sth()>. Again, in scalar context, only the outer +handle is returned. The I<Statement> attribute should be cached as +shown. + +Note the prefix I<drv_> in the attribute names: it is required that +all your private attributes use a lowercase prefix unique to your driver. +As mentioned earlier in this document, the B<DBI> contains a registry of +known driver prefixes and may one day warn about unknown attributes +that don't have a registered prefix. + +Note that we parse the statement here in order to set the attribute +I<NUM_OF_PARAMS>. The technique illustrated is not very reliable; it can +be confused by question marks appearing in quoted strings, delimited +identifiers or in SQL comments that are part of the SQL statement. We +could set I<NUM_OF_PARAMS> in the C<execute()> method instead because +the B<DBI> specification explicitly allows a driver to defer this, but then +the user could not call C<bind_param()>. + +=head4 Transaction handling + +Pure Perl drivers will rarely support transactions. Thus your C<commit()> +and C<rollback()> methods will typically be quite simple: + + sub commit + { + my ($dbh) = @_; + if ($dbh->FETCH('Warn')) { + warn("Commit ineffective while AutoCommit is on"); + } + 0; + } + + sub rollback { + my ($dbh) = @_; + if ($dbh->FETCH('Warn')) { + warn("Rollback ineffective while AutoCommit is on"); + } + 0; + } + +Or even simpler, just use the default methods provided by the B<DBI> that +do nothing except return C<undef>. + +The B<DBI>'s default C<begin_work()> method can be used by inheritance. + +=head4 The STORE() and FETCH() methods + +These methods (that we have already used, see above) are called for +you, whenever the user does a: + + $dbh->{$attr} = $val; + +or, respectively, + + $val = $dbh->{$attr}; + +See L<perltie> for details on tied hash refs to understand why these +methods are required. + +The B<DBI> will handle most attributes for you, in particular attributes +like I<RaiseError> or I<PrintError>. All you have to do is handle your +driver's private attributes and any attributes, like I<AutoCommit> and +I<ChopBlanks>, that the B<DBI> can't handle for you. + +A good example might look like this: + + sub STORE + { + my ($dbh, $attr, $val) = @_; + if ($attr eq 'AutoCommit') { + # AutoCommit is currently the only standard attribute we have + # to consider. + if (!$val) { die "Can't disable AutoCommit"; } + return 1; + } + if ($attr =~ m/^drv_/) { + # Handle only our private attributes here + # Note that we could trigger arbitrary actions. + # Ideally we should warn about unknown attributes. + $dbh->{$attr} = $val; # Yes, we are allowed to do this, + return 1; # but only for our private attributes + } + # Else pass up to DBI to handle for us + $dbh->SUPER::STORE($attr, $val); + } + + sub FETCH + { + my ($dbh, $attr) = @_; + if ($attr eq 'AutoCommit') { return 1; } + if ($attr =~ m/^drv_/) { + # Handle only our private attributes here + # Note that we could trigger arbitrary actions. + return $dbh->{$attr}; # Yes, we are allowed to do this, + # but only for our private attributes + } + # Else pass up to DBI to handle + $dbh->SUPER::FETCH($attr); + } + +The B<DBI> will actually store and fetch driver-specific attributes (with all +lowercase names) without warning or error, so there's actually no need to +implement driver-specific any code in your C<FETCH()> and C<STORE()> +methods unless you need extra logic/checks, beyond getting or setting +the value. + +Unless your driver documentation indicates otherwise, the return value of +the C<STORE()> method is unspecified and the caller shouldn't use that value. + +=head4 Other database handle methods + +As with the driver package, other database handle methods may follow here. +In particular you should consider a (possibly empty) C<disconnect()> +method and possibly a C<quote()> method if B<DBI>'s default isn't correct for +you. You may also need the C<type_info_all()> and C<get_info()> methods, +as described elsewhere in this document. + +Where reasonable use C<$h-E<gt>SUPER::foo()> to call the B<DBI>'s method in +some or all cases and just wrap your custom behavior around that. + +If you want to use private trace flags you'll probably want to be +able to set them by name. To do that you'll need to define a +C<parse_trace_flag()> method (note that's "parse_trace_flag", singular, +not "parse_trace_flags", plural). + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + +All private flag names must be lowercase, and all private flags +must be in the top 8 of the 32 bits. + +=head3 The DBD::Driver::st package + +This package follows the same pattern the others do: + + package DBD::Driver::st; + + $DBD::Driver::st::imp_data_size = 0; + +=head4 The execute() and bind_param() methods + +This is perhaps the most difficult method because we have to consider +parameter bindings here. In addition to that, there are a number of +statement attributes which must be set for inherited B<DBI> methods to +function correctly (see L</Statement attributes> below). + +We present a simplified implementation by using the I<drv_params> +attribute from above: + + sub bind_param + { + my ($sth, $pNum, $val, $attr) = @_; + my $type = (ref $attr) ? $attr->{TYPE} : $attr; + if ($type) { + my $dbh = $sth->{Database}; + $val = $dbh->quote($sth, $type); + } + my $params = $sth->{drv_params}; + $params->[$pNum-1] = $val; + 1; + } + + sub execute + { + my ($sth, @bind_values) = @_; + + # start of by finishing any previous execution if still active + $sth->finish if $sth->FETCH('Active'); + + my $params = (@bind_values) ? + \@bind_values : $sth->{drv_params}; + my $numParam = $sth->FETCH('NUM_OF_PARAMS'); + return $sth->set_err($DBI::stderr, "Wrong number of parameters") + if @$params != $numParam; + my $statement = $sth->{'Statement'}; + for (my $i = 0; $i < $numParam; $i++) { + $statement =~ s/?/$params->[$i]/; # XXX doesn't deal with quoting etc! + } + # Do anything ... we assume that an array ref of rows is + # created and store it: + $sth->{'drv_data'} = $data; + $sth->{'drv_rows'} = @$data; # number of rows + $sth->STORE('NUM_OF_FIELDS') = $numFields; + $sth->{Active} = 1; + @$data || '0E0'; + } + +There are a number of things you should note here. + +We initialize the I<NUM_OF_FIELDS> and I<Active> attributes here, +because they are essential for C<bind_columns()> to work. + +We use attribute C<$sth-E<gt>{Statement}> which we created +within C<prepare()>. The attribute C<$sth-E<gt>{Database}>, which is +nothing else than the I<dbh>, was automatically created by B<DBI>. + +Finally, note that (as specified in the B<DBI> specification) we return the +string C<'0E0'> instead of the number 0, so that the result tests true but +equal to zero. + + $sth->execute() or die $sth->errstr; + +=head4 The execute_array(), execute_for_fetch() and bind_param_array() methods + +In general, DBD's only need to implement C<execute_for_fetch()> and +C<bind_param_array>. DBI's default C<execute_array()> will invoke the +DBD's C<execute_for_fetch()> as needed. + +The following sequence describes the interaction between +DBI C<execute_array> and a DBD's C<execute_for_fetch>: + +=over + +=item 1 + +App calls C<$sth-E<gt>execute_array(\%attrs, @array_of_arrays)> + +=item 2 + +If C<@array_of_arrays> was specified, DBI processes C<@array_of_arrays> by calling +DBD's C<bind_param_array()>. Alternately, App may have directly called +C<bind_param_array()> + +=item 3 + +DBD validates and binds each array + +=item 4 + +DBI retrieves the validated param arrays from DBD's ParamArray attribute + +=item 5 + +DBI calls DBD's C<execute_for_fetch($fetch_tuple_sub, \@tuple_status)>, +where C<&$fetch_tuple_sub> is a closure to iterate over the +returned ParamArray values, and C<\@tuple_status> is an array to receive +the disposition status of each tuple. + +=item 6 + +DBD iteratively calls C<&$fetch_tuple_sub> to retrieve parameter tuples +to be added to its bulk database operation/request. + +=item 7 + +when DBD reaches the limit of tuples it can handle in a single database +operation/request, or the C<&$fetch_tuple_sub> indicates no more +tuples by returning undef, the DBD executes the bulk operation, and +reports the disposition of each tuple in \@tuple_status. + +=item 8 + +DBD repeats steps 6 and 7 until all tuples are processed. + +=back + +E.g., here's the essence of L<DBD::Oracle>'s execute_for_fetch: + + while (1) { + my @tuple_batch; + for (my $i = 0; $i < $batch_size; $i++) { + push @tuple_batch, [ @{$fetch_tuple_sub->() || last} ]; + } + last unless @tuple_batch; + my $res = ora_execute_array($sth, \@tuple_batch, + scalar(@tuple_batch), $tuple_batch_status); + push @$tuple_status, @$tuple_batch_status; + } + +Note that DBI's default execute_array()/execute_for_fetch() implementation +requires the use of positional (i.e., '?') placeholders. Drivers +which B<require> named placeholders must either emulate positional +placeholders (e.g., see L<DBD::Oracle>), or must implement their own +execute_array()/execute_for_fetch() methods to properly sequence bound +parameter arrays. + +=head4 Fetching data + +Only one method needs to be written for fetching data, C<fetchrow_arrayref()>. +The other methods, C<fetchrow_array()>, C<fetchall_arrayref()>, etc, as well +as the database handle's C<select*> methods are part of B<DBI>, and call +C<fetchrow_arrayref()> as necessary. + + sub fetchrow_arrayref + { + my ($sth) = @_; + my $data = $sth->{drv_data}; + my $row = shift @$data; + if (!$row) { + $sth->STORE(Active => 0); # mark as no longer active + return undef; + } + if ($sth->FETCH('ChopBlanks')) { + map { $_ =~ s/\s+$//; } @$row; + } + return $sth->_set_fbav($row); + } + *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref + +Note the use of the method C<_set_fbav()> -- this is required so that +C<bind_col()> and C<bind_columns()> work. + +If an error occurs which leaves the I<$sth> in a state where remaining rows +can't be fetched then I<Active> should be turned off before the method returns. + +The C<rows()> method for this driver can be implemented like this: + + sub rows { shift->{drv_rows} } + +because it knows in advance how many rows it has fetched. +Alternatively you could delete that method and so fallback +to the B<DBI>'s own method which does the right thing based +on the number of calls to C<_set_fbav()>. + +=head4 The more_results method + +If your driver doesn't support multiple result sets, then don't even implement this method. + +Otherwise, this method needs to get the statement handle ready to fetch results +from the next result set, if there is one. Typically you'd start with: + + $sth->finish; + +then you should delete all the attributes from the attribute cache that may no +longer be relevant for the new result set: + + delete $sth->{$_} + for qw(NAME TYPE PRECISION SCALE ...); + +for drivers written in C use: + + hv_delete((HV*)SvRV(sth), "NAME", 4, G_DISCARD); + hv_delete((HV*)SvRV(sth), "NULLABLE", 8, G_DISCARD); + hv_delete((HV*)SvRV(sth), "NUM_OF_FIELDS", 13, G_DISCARD); + hv_delete((HV*)SvRV(sth), "PRECISION", 9, G_DISCARD); + hv_delete((HV*)SvRV(sth), "SCALE", 5, G_DISCARD); + hv_delete((HV*)SvRV(sth), "TYPE", 4, G_DISCARD); + +Don't forget to also delete, or update, any driver-private attributes that may +not be correct for the next resultset. + +The NUM_OF_FIELDS attribute is a special case. It should be set using STORE: + + $sth->STORE(NUM_OF_FIELDS => 0); /* for DBI <= 1.53 */ + $sth->STORE(NUM_OF_FIELDS => $new_value); + +for drivers written in C use this incantation: + + /* Adjust NUM_OF_FIELDS - which also adjusts the row buffer size */ + DBIc_NUM_FIELDS(imp_sth) = 0; /* for DBI <= 1.53 */ + DBIc_STATE(imp_xxh)->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS",13)), 0, + sv_2mortal(newSViv(mysql_num_fields(imp_sth->result))) + ); + +For DBI versions prior to 1.54 you'll also need to explicitly adjust the +number of elements in the row buffer array (C<DBIc_FIELDS_AV(imp_sth)>) +to match the new result set. Fill any new values with newSV(0) not &sv_undef. +Alternatively you could free DBIc_FIELDS_AV(imp_sth) and set it to null, +but that would mean bind_columns() wouldn't work across result sets. + + +=head4 Statement attributes + +The main difference between I<dbh> and I<sth> attributes is, that you +should implement a lot of attributes here that are required by +the B<DBI>, such as I<NAME>, I<NULLABLE>, I<TYPE>, etc. See +L<DBI/Statement Handle Attributes> for a complete list. + +Pay attention to attributes which are marked as read only, such as +I<NUM_OF_PARAMS>. These attributes can only be set the first time +a statement is executed. If a statement is prepared, then executed +multiple times, warnings may be generated. + +You can protect against these warnings, and prevent the recalculation +of attributes which might be expensive to calculate (such as the +I<NAME> and I<NAME_*> attributes): + + my $storedNumParams = $sth->FETCH('NUM_OF_PARAMS'); + if (!defined $storedNumParams or $storedNumFields < 0) { + $sth->STORE('NUM_OF_PARAMS') = $numParams; + + # Set other useful attributes that only need to be set once + # for a statement, like $sth->{NAME} and $sth->{TYPE} + } + +One particularly important attribute to set correctly (mentioned in +L<DBI/ATTRIBUTES COMMON TO ALL HANDLES> is I<Active>. Many B<DBI> methods, +including C<bind_columns()>, depend on this attribute. + +Besides that the C<STORE()> and C<FETCH()> methods are mainly the same +as above for I<dbh>'s. + +=head4 Other statement methods + +A trivial C<finish()> method to discard stored data, reset any attributes +(such as I<Active>) and do C<$sth-E<gt>SUPER::finish()>. + +If you've defined a C<parse_trace_flag()> method in B<::db> you'll also want +it in B<::st>, so just alias it in: + + *parse_trace_flag = \&DBD::foo:db::parse_trace_flag; + +And perhaps some other methods that are not part of the B<DBI> +specification, in particular to make metadata available. +Remember that they must have names that begin with your drivers +registered prefix so they can be installed using C<install_method()>. + +If C<DESTROY()> is called on a statement handle that's still active +(C<$sth-E<gt>{Active}> is true) then it should effectively call C<finish()>. + + sub DESTROY { + my $sth = shift; + $sth->finish if $sth->FETCH('Active'); + } + +=head2 Tests + +The test process should conform as closely as possibly to the Perl +standard test harness. + +In particular, most (all) of the tests should be run in the F<t> sub-directory, +and should simply produce an C<ok> when run under C<make test>. +For details on how this is done, see the Camel book and the section in +Chapter 7, "The Standard Perl Library" on L<Test::Harness>. + +The tests may need to adapt to the type of database which is being used +for testing, and to the privileges of the user testing the driver. For +example, the B<DBD::Informix> test code has to adapt in a number of +places to the type of database to which it is connected as different +Informix databases have different capabilities: some of the tests are +for databases without transaction logs; others are for databases with a +transaction log; some versions of the server have support for blobs, or +stored procedures, or user-defined data types, and others do not. + +When a complete file of tests must be skipped, you can provide a reason +in a pseudo-comment: + + if ($no_transactions_available) + { + print "1..0 # Skip: No transactions available\n"; + exit 0; + } + +Consider downloading the B<DBD::Informix> code and look at the code in +F<DBD/Informix/TestHarness.pm> which is used throughout the +B<DBD::Informix> tests in the F<t> sub-directory. + +=head1 CREATING A C/XS DRIVER + +Please also see the section under L<CREATING A PURE PERL DRIVER> +regarding the creation of the F<Makefile.PL>. + +Creating a new C/XS driver from scratch will always be a daunting task. +You can and should greatly simplify your task by taking a good +reference driver implementation and modifying that to match the +database product for which you are writing a driver. + +The de facto reference driver has been the one for B<DBD::Oracle> written +by Tim Bunce, who is also the author of the B<DBI> package. The B<DBD::Oracle> +module is a good example of a driver implemented around a C-level API. + +Nowadays it it seems better to base on B<DBD::ODBC>, another driver +maintained by Tim and Jeff Urlwin, because it offers a lot of metadata +and seems to become the guideline for the future development. (Also as +B<DBD::Oracle> digs deeper into the Oracle 8 OCI interface it'll get even +more hairy than it is now.) + +The B<DBD::Informix> driver is one driver implemented using embedded SQL +instead of a function-based API. +B<DBD::Ingres> may also be worth a look. + +=head2 C/XS version of Driver.pm + +A lot of the code in the F<Driver.pm> file is very similar to the code for pure Perl modules +- see above. However, +there are also some subtle (and not so subtle) differences, including: + +=over 8 + +=item * + +The variables I<$DBD::Driver::{dr|db|st}::imp_data_size> are not defined +here, but in the XS code, because they declare the size of certain +C structures. + +=item * + +Some methods are typically moved to the XS code, in particular +C<prepare()>, C<execute()>, C<disconnect()>, C<disconnect_all()> and the +C<STORE()> and C<FETCH()> methods. + +=item * + +Other methods are still part of F<Driver.pm>, but have callbacks to +the XS code. + +=item * + +If the driver-specific parts of the I<imp_drh_t> structure need to be +formally initialized (which does not seem to be a common requirement), +then you need to add a call to an appropriate XS function in the driver +method of C<DBD::Driver::driver()>, and you define the corresponding function +in F<Driver.xs>, and you define the C code in F<dbdimp.c> and the prototype in +F<dbdimp.h>. + +For example, B<DBD::Informix> has such a requirement, and adds the +following call after the call to C<_new_drh()> in F<Informix.pm>: + + DBD::Informix::dr::driver_init($drh); + +and the following code in F<Informix.xs>: + + # Initialize the DBD::Informix driver data structure + void + driver_init(drh) + SV *drh + CODE: + ST(0) = dbd_ix_dr_driver_init(drh) ? &sv_yes : &sv_no; + +and the code in F<dbdimp.h> declares: + + extern int dbd_ix_dr_driver_init(SV *drh); + +and the code in F<dbdimp.ec> (equivalent to F<dbdimp.c>) defines: + + /* Formally initialize the DBD::Informix driver structure */ + int + dbd_ix_dr_driver(SV *drh) + { + D_imp_drh(drh); + imp_drh->n_connections = 0; /* No active connections */ + imp_drh->current_connection = 0; /* No current connection */ + imp_drh->multipleconnections = (ESQLC_VERSION >= 600) ? True : False; + dbd_ix_link_newhead(&imp_drh->head); /* Empty linked list of connections */ + return 1; + } + +B<DBD::Oracle> has a similar requirement but gets around it by checking +whether the private data part of the driver handle is all zeroed out, +rather than add extra functions. + +=back + +Now let's take a closer look at an excerpt from F<Oracle.pm> (revised +heavily to remove idiosyncrasies) as an example, ignoring things that +were already discussed for pure Perl drivers. + +=head3 The connect method + +The connect method is the database handle constructor. +You could write either of two versions of this method: either one which +takes connection attributes (new code) and one which ignores them (old +code only). + +If you ignore the connection attributes, then you omit all mention of +the I<$auth> variable (which is a reference to a hash of attributes), and +the XS system manages the differences for you. + + sub connect + { + my ($drh, $dbname, $user, $auth, $attr) = @_; + + # Some database specific verifications, default settings + # and the like following here. This should only include + # syntax checks or similar stuff where it's legal to + # 'die' in case of errors. + + my $dbh = DBI::_new_dbh($drh, { + 'Name' => $dbname, + }) + or return undef; + + # Call the driver-specific function _login in Driver.xs file which + # calls the DBMS-specific function(s) to connect to the database, + # and populate internal handle data. + DBD::Driver::db::_login($dbh, $dbname, $user, $auth, $attr) + or return undef; + + $dbh; + } + +This is mostly the same as in the pure Perl case, the exception being +the use of the private C<_login()> callback, which is the function +that will really connect to the database. It is implemented in +F<Driver.xst> (you should not implement it) and calls +C<dbd_db_login6()> or C<dbd_db_login6_sv> from F<dbdimp.c>. See below +for details. + +If your driver has driver-specific attributes which may be passed in the +connect method and hence end up in C<$attr> in C<dbd_db_login6> then it +is best to delete any you process so DBI does not send them again +via STORE after connect. You can do this in C like this: + + DBD_ATTRIB_DELETE(attr, "my_attribute_name", + strlen("my_attribute_name")); + +However, prior to DBI subversion version 11605 (and fixed post 1.607) +DBD_ATTRIB_DELETE segfaulted so if you cannot guarantee the DBI version +will be post 1.607 you need to use: + + hv_delete((HV*)SvRV(attr), "my_attribute_name", + strlen("my_attribute_name"), G_DISCARD); + + *FIX ME* Discuss removing attributes in Perl code. + +=head3 The disconnect_all method + + *FIX ME* T.B.S + +=head3 The data_sources method + +If your C<data_sources()> method can be implemented in pure Perl, then do +so because it is easier than doing it in XS code (see the section above +for pure Perl drivers). + +If your C<data_sources()> method must call onto compiled functions, then +you will need to define I<dbd_dr_data_sources> in your F<dbdimp.h> file, which +will trigger F<Driver.xst> (in B<DBI> v1.33 or greater) to generate the XS +code that calls your actual C function (see the discussion below for +details) and you do not code anything in F<Driver.pm> to handle it. + +=head3 The prepare method + +The prepare method is the statement handle constructor, and most of it +is not new. Like the C<connect()> method, it now has a C callback: + + package DBD::Driver::db; # ====== DATABASE ====== + use strict; + + sub prepare + { + my ($dbh, $statement, $attribs) = @_; + + # create a 'blank' sth + my $sth = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }) + or return undef; + + # Call the driver-specific function _prepare in Driver.xs file + # which calls the DBMS-specific function(s) to prepare a statement + # and populate internal handle data. + DBD::Driver::st::_prepare($sth, $statement, $attribs) + or return undef; + $sth; + } + +=head3 The execute method + + *FIX ME* T.B.S + +=head3 The fetchrow_arrayref method + + *FIX ME* T.B.S + +=head3 Other methods? + + *FIX ME* T.B.S + +=head2 Driver.xs + +F<Driver.xs> should look something like this: + + #include "Driver.h" + + DBISTATE_DECLARE; + + INCLUDE: Driver.xsi + + MODULE = DBD::Driver PACKAGE = DBD::Driver::dr + + /* Non-standard drh XS methods following here, if any. */ + /* If none (the usual case), omit the MODULE line above too. */ + + MODULE = DBD::Driver PACKAGE = DBD::Driver::db + + /* Non-standard dbh XS methods following here, if any. */ + /* Currently this includes things like _list_tables from */ + /* DBD::mSQL and DBD::mysql. */ + + MODULE = DBD::Driver PACKAGE = DBD::Driver::st + + /* Non-standard sth XS methods following here, if any. */ + /* In particular this includes things like _list_fields from */ + /* DBD::mSQL and DBD::mysql for accessing metadata. */ + +Note especially the include of F<Driver.xsi> here: B<DBI> inserts stub +functions for almost all private methods here which will typically do +much work for you. + +Wherever you really have to implement something, it will call a private +function in F<dbdimp.c>, and this is what you have to implement. + +You need to set up an extra routine if your driver needs to export +constants of its own, analogous to the SQL types available when you say: + + use DBI qw(:sql_types); + + *FIX ME* T.B.S + +=head2 Driver.h + +F<Driver.h> is very simple and the operational contents should look like this: + + #ifndef DRIVER_H_INCLUDED + #define DRIVER_H_INCLUDED + + #define NEED_DBIXS_VERSION 93 /* 93 for DBI versions 1.00 to 1.51+ */ + #define PERL_NO_GET_CONTEXT /* if used require DBI 1.51+ */ + + #include <DBIXS.h> /* installed by the DBI module */ + + #include "dbdimp.h" + + #include "dbivport.h" /* see below */ + + #include <dbd_xsh.h> /* installed by the DBI module */ + + #endif /* DRIVER_H_INCLUDED */ + +The F<DBIXS.h> header defines most of the interesting information that +the writer of a driver needs. + +The file F<dbd_xsh.h> header provides prototype declarations for the C +functions that you might decide to implement. Note that you should +normally only define one of C<dbd_db_login()>, C<dbd_db_login6()> or +C<dbd_db_login6_sv> unless you are intent on supporting really old +versions of B<DBI> (prior to B<DBI> 1.06) as well as modern +versions. The only standard, B<DBI>-mandated functions that you need +write are those specified in the F<dbd_xsh.h> header. You might also +add extra driver-specific functions in F<Driver.xs>. + +The F<dbivport.h> file should be I<copied> from the latest B<DBI> release +into your distribution each time you modify your driver. Its job is to +allow you to enhance your code to work with the latest B<DBI> API while +still allowing your driver to be compiled and used with older versions +of the B<DBI> (for example, when the C<DBIh_SET_ERR_CHAR()> macro was added +to B<DBI> 1.41, an emulation of it was added to F<dbivport.h>). This makes +users happy and your life easier. Always read the notes in F<dbivport.h> +to check for any limitations in the emulation that you should be aware +of. + +With B<DBI> v1.51 or better I recommend that the driver defines +I<PERL_NO_GET_CONTEXT> before F<DBIXS.h> is included. This can significantly +improve efficiency when running under a thread enabled perl. (Remember that +the standard perl in most Linux distributions is built with threads enabled. +So is ActiveState perl for Windows, and perl built for Apache mod_perl2.) +If you do this there are some things to keep in mind: + +=over 4 + +=item * + +If I<PERL_NO_GET_CONTEXT> is defined, then every function that calls the Perl +API will need to start out with a C<dTHX;> declaration. + +=item * + +You'll know which functions need this, because the C compiler will +complain that the undeclared identifier C<my_perl> is used if I<and only if> +the perl you are using to develop and test your driver has threads enabled. + +=item * + +If you don't remember to test with a thread-enabled perl before making +a release it's likely that you'll get failure reports from users who are. + +=item * + +For driver private functions it is possible to gain even more +efficiency by replacing C<dTHX;> with C<pTHX_> prepended to the +parameter list and then C<aTHX_> prepended to the argument list where +the function is called. + +=back + +See L<perlguts/How multiple interpreters and concurrency are supported> for +additional information about I<PERL_NO_GET_CONTEXT>. + +=head2 Implementation header dbdimp.h + +This header file has two jobs: + +First it defines data structures for your private part of the handles. + +Second it defines macros that rename the generic names like +C<dbd_db_login()> to database specific names like C<ora_db_login()>. This +avoids name clashes and enables use of different drivers when you work +with a statically linked perl. + +It also will have the important task of disabling XS methods that you +don't want to implement. + +Finally, the macros will also be used to select alternate +implementations of some functions. For example, the C<dbd_db_login()> +function is not passed the attribute hash. + +Since B<DBI> v1.06, if a C<dbd_db_login6()> macro is defined (for a function +with 6 arguments), it will be used instead with the attribute hash +passed as the sixth argument. + +Since B<DBI> post v1.607, if a C<dbd_db_login6_sv()> macro is defined (for +a function like dbd_db_login6 but with scalar pointers for the dbname, +username and password), it will be used instead. This will allow your +login6 function to see if there are any Unicode characters in the +dbname. + +People used to just pick Oracle's F<dbdimp.c> and use the same names, +structures and types. I strongly recommend against that. At first glance +this saves time, but your implementation will be less readable. It was +just hell when I had to separate B<DBI> specific parts, Oracle specific +parts, mSQL specific parts and mysql specific parts in B<DBD::mysql>'s +I<dbdimp.h> and I<dbdimp.c>. (B<DBD::mysql> was a port of B<DBD::mSQL> +which was based on B<DBD::Oracle>.) [Seconded, based on the experience +taking B<DBD::Informix> apart, even though the version inherited in 1996 +was only based on B<DBD::Oracle>.] + +This part of the driver is I<your exclusive part>. Rewrite it from +scratch, so it will be clean and short: in other words, a better piece +of code. (Of course keep an eye on other people's work.) + + struct imp_drh_st { + dbih_drc_t com; /* MUST be first element in structure */ + /* Insert your driver handle attributes here */ + }; + + struct imp_dbh_st { + dbih_dbc_t com; /* MUST be first element in structure */ + /* Insert your database handle attributes here */ + }; + + struct imp_sth_st { + dbih_stc_t com; /* MUST be first element in structure */ + /* Insert your statement handle attributes here */ + }; + + /* Rename functions for avoiding name clashes; prototypes are */ + /* in dbd_xsh.h */ + #define dbd_init drv_dr_init + #define dbd_db_login6_sv drv_db_login_sv + #define dbd_db_do drv_db_do + ... many more here ... + +These structures implement your private part of the handles. + +You I<have> to use the name C<imp_dbh_{dr|db|st}> and the first field +I<must> be of type I<dbih_drc_t|_dbc_t|_stc_t> and I<must> be called +C<com>. + +You should never access these fields directly, except by using the +I<DBIc_xxx()> macros below. + +=head2 Implementation source dbdimp.c + +Conventionally, F<dbdimp.c> is the main implementation file (but +B<DBD::Informix> calls the file F<dbdimp.ec>). This section includes a +short note on each function that is used in the F<Driver.xsi> template +and thus I<has> to be implemented. + +Of course, you will probably also need to implement other support +functions, which should usually be file static if they are placed in +F<dbdimp.c>. If they are placed in other files, you need to list those +files in F<Makefile.PL> (and F<MANIFEST>) to handle them correctly. + +It is wise to adhere to a namespace convention for your functions to +avoid conflicts. For example, for a driver with prefix I<drv_>, you +might call externally visible functions I<dbd_drv_xxxx>. You should also +avoid non-constant global variables as much as possible to improve the +support for threading. + +Since Perl requires support for function prototypes (ANSI or ISO or +Standard C), you should write your code using function prototypes too. + +It is possible to use either the unmapped names such as C<dbd_init()> or +the mapped names such as C<dbd_ix_dr_init()> in the F<dbdimp.c> file. +B<DBD::Informix> uses the mapped names which makes it easier to identify +where to look for linkage problems at runtime (which will report errors +using the mapped names). + +Most other drivers, and in particular B<DBD::Oracle>, use the unmapped +names in the source code which makes it a little easier to compare code +between drivers and eases discussions on the I<dbi-dev> mailing list. +The majority of the code fragments here will use the unmapped names. + +Ultimately, you should provide implementations for most of the +functions listed in the F<dbd_xsh.h> header. The exceptions are +optional functions (such as C<dbd_st_rows()>) and those functions with +alternative signatures, such as C<dbd_db_login6_sv>, +C<dbd_db_login6()> and I<dbd_db_login()>. Then you should only +implement one of the alternatives, and generally the newer one of the +alternatives. + +=head3 The dbd_init method + + #include "Driver.h" + + DBISTATE_DECLARE; + + void dbd_init(dbistate_t* dbistate) + { + DBISTATE_INIT; /* Initialize the DBI macros */ + } + +The C<dbd_init()> function will be called when your driver is first +loaded; the bootstrap command in C<DBD::Driver::dr::driver()> triggers this, +and the call is generated in the I<BOOT> section of F<Driver.xst>. +These statements are needed to allow your driver to use the B<DBI> macros. +They will include your private header file F<dbdimp.h> in turn. +Note that I<DBISTATE_INIT> requires the name of the argument to C<dbd_init()> +to be called C<dbistate()>. + +=head3 The dbd_drv_error method + +You need a function to record errors so B<DBI> can access them properly. +You can call it whatever you like, but we'll call it C<dbd_drv_error()> +here. + +The argument list depends on your database software; different systems +provide different ways to get at error information. + + static void dbd_drv_error(SV *h, int rc, const char *what) + { + +Note that I<h> is a generic handle, may it be a driver handle, a +database or a statement handle. + + D_imp_xxh(h); + +This macro will declare and initialize a variable I<imp_xxh> with +a pointer to your private handle pointer. You may cast this to +to I<imp_drh_t>, I<imp_dbh_t> or I<imp_sth_t>. + +To record the error correctly, equivalent to the C<set_err()> method, +use one of the C<DBIh_SET_ERR_CHAR(...)> or C<DBIh_SET_ERR_SV(...)> macros, +which were added in B<DBI> 1.41: + + DBIh_SET_ERR_SV(h, imp_xxh, err, errstr, state, method); + DBIh_SET_ERR_CHAR(h, imp_xxh, err_c, err_i, errstr, state, method); + +For C<DBIh_SET_ERR_SV> the I<err>, I<errstr>, I<state>, and I<method> +parameters are C<SV*> (use &sv_undef instead of NULL). + +For C<DBIh_SET_ERR_CHAR> the I<err_c>, I<errstr>, I<state>, I<method> +parameters are C<char*>. + +The I<err_i> parameter is an C<IV> that's used instead of I<err_c> if +I<err_c> is C<Null>. + +The I<method> parameter can be ignored. + +The C<DBIh_SET_ERR_CHAR> macro is usually the simplest to use when you +just have an integer error code and an error message string: + + DBIh_SET_ERR_CHAR(h, imp_xxh, Nullch, rc, what, Nullch, Nullch); + +As you can see, any parameters that aren't relevant to you can be C<Null>. + +To make drivers compatible with B<DBI> < 1.41 you should be using F<dbivport.h> +as described in L</Driver.h> above. + +The (obsolete) macros such as C<DBIh_EVENT2> should be removed from drivers. + +The names C<dbis> and C<DBIS>, which were used in previous versions of +this document, should be replaced with the C<DBIc_DBISTATE(imp_xxh)> macro. + +The name C<DBILOGFP>, which was also used in previous versions of this +document, should be replaced by C<DBIc_LOGPIO(imp_xxh)>. + +Your code should not call the C C<E<lt>stdio.hE<gt>> I/O functions; you +should use C<PerlIO_printf()> as shown: + + if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) + PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar %s: %s\n", + foo, neatsvpv(errstr,0)); + +That's the first time we see how tracing works within a B<DBI> driver. Make +use of this as often as you can, but don't output anything at a trace +level less than 3. Levels 1 and 2 are reserved for the B<DBI>. + +You can define up to 8 private trace flags using the top 8 bits +of C<DBIc_TRACE_FLAGS(imp)>, that is: C<0xFF000000>. See the +C<parse_trace_flag()> method elsewhere in this document. + +=head3 The dbd_dr_data_sources method + +This method is optional; the support for it was added in B<DBI> v1.33. + +As noted in the discussion of F<Driver.pm>, if the data sources +can be determined by pure Perl code, do it that way. If, as in +B<DBD::Informix>, the information is obtained by a C function call, then +you need to define a function that matches the prototype: + + extern AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attrs); + +An outline implementation for B<DBD::Informix> follows, assuming that the +C<sqgetdbs()> function call shown will return up to 100 databases names, +with the pointers to each name in the array dbsname and the name strings +themselves being stores in dbsarea. + + AV *dbd_dr_data_sources(SV *drh, imp_drh_t *imp_drh, SV *attr) + { + int ndbs; + int i; + char *dbsname[100]; + char dbsarea[10000]; + AV *av = Nullav; + + if (sqgetdbs(&ndbs, dbsname, 100, dbsarea, sizeof(dbsarea)) == 0) + { + av = NewAV(); + av_extend(av, (I32)ndbs); + sv_2mortal((SV *)av); + for (i = 0; i < ndbs; i++) + av_store(av, i, newSVpvf("dbi:Informix:%s", dbsname[i])); + } + return(av); + } + +The actual B<DBD::Informix> implementation has a number of extra lines of +code, logs function entry and exit, reports the error from C<sqgetdbs()>, +and uses C<#define>'d constants for the array sizes. + +=head3 The dbd_db_login6 method + + int dbd_db_login6_sv(SV* dbh, imp_dbh_t* imp_dbh, SV* dbname, + SV* user, SV* auth, SV *attr); + + or + + int dbd_db_login6(SV* dbh, imp_dbh_t* imp_dbh, char* dbname, + char* user, char* auth, SV *attr); + +This function will really connect to the database. The argument I<dbh> +is the database handle. I<imp_dbh> is the pointer to the handles private +data, as is I<imp_xxx> in C<dbd_drv_error()> above. The arguments +I<dbname>, I<user>, I<auth> and I<attr> correspond to the arguments of +the driver handle's C<connect()> method. + +You will quite often use database specific attributes here, that are +specified in the DSN. I recommend you parse the DSN (using Perl) within +the C<connect()> method and pass the segments of the DSN via the +attributes parameter through C<_login()> to C<dbd_db_login6()>. + +Here's how you fetch them; as an example we use I<hostname> attribute, +which can be up to 12 characters long excluding null terminator: + + SV** svp; + STRLEN len; + char* hostname; + + if ( (svp = DBD_ATTRIB_GET_SVP(attr, "drv_hostname", 12)) && SvTRUE(*svp)) { + hostname = SvPV(*svp, len); + DBD_ATTRIB_DELETE(attr, "drv_hostname", 12); /* avoid later STORE */ + } else { + hostname = "localhost"; + } + +If you handle any driver specific attributes in the dbd_db_login6 +method you probably want to delete them from C<attr> (as above with +DBD_ATTRIB_DELETE). If you don't delete your handled attributes DBI +will call C<STORE> for each attribute after the connect/login and this +is at best redundant for attributes you have already processed. + +B<Note: Until revision 11605 (post DBI 1.607), there was a problem with +DBD_ATTRIBUTE_DELETE so unless you require a DBI version after 1.607 +you need to replace each DBD_ATTRIBUTE_DELETE call with:> + + hv_delete((HV*)SvRV(attr), key, key_len, G_DISCARD) + +Note that you can also obtain standard attributes such as I<AutoCommit> and +I<ChopBlanks> from the attributes parameter, using C<DBD_ATTRIB_GET_IV> for +integer attributes. + +If, for example, your database does not support transactions but +I<AutoCommit> is set off (requesting transaction support), then you can +emulate a 'failure to connect'. + +Now you should really connect to the database. In general, if the +connection fails, it is best to ensure that all allocated resources are +released so that the handle does not need to be destroyed separately. If +you are successful (and possibly even if you fail but you have allocated +some resources), you should use the following macros: + + DBIc_IMPSET_on(imp_dbh); + +This indicates that the driver (implementor) has allocated resources in +the I<imp_dbh> structure and that the implementors private C<dbd_db_destroy()> +function should be called when the handle is destroyed. + + DBIc_ACTIVE_on(imp_dbh); + +This indicates that the handle has an active connection to the server +and that the C<dbd_db_disconnect()> function should be called before the +handle is destroyed. + +Note that if you do need to fail, you should report errors via the I<drh> +or I<imp_drh> rather than via I<dbh> or I<imp_dbh> because I<imp_dbh> will be +destroyed by the failure, so errors recorded in that handle will not be +visible to B<DBI>, and hence not the user either. + +Note too, that the function is passed I<dbh> and I<imp_dbh>, and there +is a macro C<D_imp_drh_from_dbh> which can recover the I<imp_drh> from +the I<imp_dbh>. However, there is no B<DBI> macro to provide you with the +I<drh> given either the I<imp_dbh> or the I<dbh> or the I<imp_drh> (and +there's no way to recover the I<dbh> given just the I<imp_dbh>). + +This suggests that, despite the above notes about C<dbd_drv_error()> +taking an C<SV *>, it may be better to have two error routines, one +taking I<imp_dbh> and one taking I<imp_drh> instead. With care, you can +factor most of the formatting code out so that these are small routines +calling a common error formatter. See the code in B<DBD::Informix> +1.05.00 for more information. + +The C<dbd_db_login6()> function should return I<TRUE> for success, +I<FALSE> otherwise. + +Drivers implemented long ago may define the five-argument function +C<dbd_db_login()> instead of C<dbd_db_login6()>. The missing argument is +the attributes. There are ways to work around the missing attributes, +but they are ungainly; it is much better to use the 6-argument form. +Even later drivers will use C<dbd_db_login6_sv()> which provides the +dbname, username and password as SVs. + +=head3 The dbd_db_commit and dbd_db_rollback methods + + int dbd_db_commit(SV *dbh, imp_dbh_t *imp_dbh); + int dbd_db_rollback(SV* dbh, imp_dbh_t* imp_dbh); + +These are used for commit and rollback. They should return I<TRUE> for +success, I<FALSE> for error. + +The arguments I<dbh> and I<imp_dbh> are the same as for C<dbd_db_login6()> +above; I will omit describing them in what follows, as they appear +always. + +These functions should return I<TRUE> for success, I<FALSE> otherwise. + +=head3 The dbd_db_disconnect method + +This is your private part of the C<disconnect()> method. Any I<dbh> with +the I<ACTIVE> flag on must be disconnected. (Note that you have to set +it in C<dbd_db_connect()> above.) + + int dbd_db_disconnect(SV* dbh, imp_dbh_t* imp_dbh); + +The database handle will return I<TRUE> for success, I<FALSE> otherwise. +In any case it should do a: + + DBIc_ACTIVE_off(imp_dbh); + +before returning so B<DBI> knows that C<dbd_db_disconnect()> was executed. + +Note that there's nothing to stop a I<dbh> being I<disconnected> while +it still have active children. If your database API reacts badly to +trying to use an I<sth> in this situation then you'll need to add code +like this to all I<sth> methods: + + if (!DBIc_ACTIVE(DBIc_PARENT_COM(imp_sth))) + return 0; + +Alternatively, you can add code to your driver to keep explicit track of +the statement handles that exist for each database handle and arrange +to destroy those handles before disconnecting from the database. There +is code to do this in B<DBD::Informix>. Similar comments apply to the +driver handle keeping track of all the database handles. + +Note that the code which destroys the subordinate handles should only +release the associated database resources and mark the handles inactive; +it does not attempt to free the actual handle structures. + +This function should return I<TRUE> for success, I<FALSE> otherwise, but +it is not clear what anything can do about a failure. + +=head3 The dbd_db_discon_all method + + int dbd_discon_all (SV *drh, imp_drh_t *imp_drh); + +This function may be called at shutdown time. It should make +best-efforts to disconnect all database handles - if possible. Some +databases don't support that, in which case you can do nothing +but return 'success'. + +This function should return I<TRUE> for success, I<FALSE> otherwise, but +it is not clear what anything can do about a failure. + +=head3 The dbd_db_destroy method + +This is your private part of the database handle destructor. Any I<dbh> with +the I<IMPSET> flag on must be destroyed, so that you can safely free +resources. (Note that you have to set it in C<dbd_db_connect()> above.) + + void dbd_db_destroy(SV* dbh, imp_dbh_t* imp_dbh) + { + DBIc_IMPSET_off(imp_dbh); + } + +The B<DBI> F<Driver.xst> code will have called C<dbd_db_disconnect()> for you, +if the handle is still 'active', before calling C<dbd_db_destroy()>. + +Before returning the function must switch I<IMPSET> to off, so B<DBI> knows +that the destructor was called. + +A B<DBI> handle doesn't keep references to its children. But children +do keep references to their parents. So a database handle won't be +C<DESTROY>'d until all its children have been C<DESTROY>'d. + +=head3 The dbd_db_STORE_attrib method + +This function handles + + $dbh->{$key} = $value; + +Its prototype is: + + int dbd_db_STORE_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv, + SV* valuesv); + +You do not handle all attributes; on the contrary, you should not handle +B<DBI> attributes here: leave this to B<DBI>. (There are two exceptions, +I<AutoCommit> and I<ChopBlanks>, which you should care about.) + +The return value is I<TRUE> if you have handled the attribute or I<FALSE> +otherwise. If you are handling an attribute and something fails, you +should call C<dbd_drv_error()>, so B<DBI> can raise exceptions, if desired. +If C<dbd_drv_error()> returns, however, you have a problem: the user will +never know about the error, because he typically will not check +C<$dbh-E<gt>errstr()>. + +I cannot recommend a general way of going on, if C<dbd_drv_error()> returns, +but there are examples where even the B<DBI> specification expects that +you C<croak()>. (See the I<AutoCommit> method in L<DBI>.) + +If you have to store attributes, you should either use your private +data structure I<imp_xxx>, the handle hash (via C<(HV*)SvRV(dbh)>), or use +the private I<imp_data>. + +The first is best for internal C values like integers or pointers and +where speed is important within the driver. The handle hash is best for +values the user may want to get/set via driver-specific attributes. +The private I<imp_data> is an additional C<SV> attached to the handle. You +could think of it as an unnamed handle attribute. It's not normally used. + +=head3 The dbd_db_FETCH_attrib method + +This is the counterpart of C<dbd_db_STORE_attrib()>, needed for: + + $value = $dbh->{$key}; + +Its prototype is: + + SV* dbd_db_FETCH_attrib(SV* dbh, imp_dbh_t* imp_dbh, SV* keysv); + +Unlike all previous methods this returns an C<SV> with the value. Note +that you should normally execute C<sv_2mortal()>, if you return a nonconstant +value. (Constant values are C<&sv_undef>, C<&sv_no> and C<&sv_yes>.) + +Note, that B<DBI> implements a caching algorithm for attribute values. +If you think, that an attribute may be fetched, you store it in the +I<dbh> itself: + + if (cacheit) /* cache value for later DBI 'quick' fetch? */ + hv_store((HV*)SvRV(dbh), key, kl, cachesv, 0); + +=head3 The dbd_st_prepare method + +This is the private part of the C<prepare()> method. Note that you +B<must not> really execute the statement here. You may, however, +preparse and validate the statement, or do similar things. + + int dbd_st_prepare(SV* sth, imp_sth_t* imp_sth, char* statement, + SV* attribs); + +A typical, simple, possibility is to do nothing and rely on the perl +C<prepare()> code that set the I<Statement> attribute on the handle. This +attribute can then be used by C<dbd_st_execute()>. + +If the driver supports placeholders then the I<NUM_OF_PARAMS> attribute +must be set correctly by C<dbd_st_prepare()>: + + DBIc_NUM_PARAMS(imp_sth) = ... + +If you can, you should also setup attributes like I<NUM_OF_FIELDS>, I<NAME>, +etc. here, but B<DBI> doesn't require that - they can be deferred until +execute() is called. However, if you do, document it. + +In any case you should set the I<IMPSET> flag, as you did in +C<dbd_db_connect()> above: + + DBIc_IMPSET_on(imp_sth); + +=head3 The dbd_st_execute method + +This is where a statement will really be executed. + + int dbd_st_execute(SV* sth, imp_sth_t* imp_sth); + +C<dbd_st_execute> should return -2 for any error, -1 if the number of +rows affected is unknown else it should be the number of affected +(updated, inserted) rows. + +Note that you must be aware a statement may be executed repeatedly. +Also, you should not expect that C<finish()> will be called between two +executions, so you might need code, like the following, near the start +of the function: + + if (DBIc_ACTIVE(imp_sth)) + dbd_st_finish(h, imp_sth); + +If your driver supports the binding of parameters (it should!), but the +database doesn't, you must do it here. This can be done as follows: + + SV *svp; + char* statement = DBD_ATTRIB_GET_PV(h, "Statement", 9, svp, ""); + int numParam = DBIc_NUM_PARAMS(imp_sth); + int i; + + for (i = 0; i < numParam; i++) + { + char* value = dbd_db_get_param(sth, imp_sth, i); + /* It is your drivers task to implement dbd_db_get_param, */ + /* it must be setup as a counterpart of dbd_bind_ph. */ + /* Look for '?' and replace it with 'value'. Difficult */ + /* task, note that you may have question marks inside */ + /* quotes and comments the like ... :-( */ + /* See DBD::mysql for an example. (Don't look too deep into */ + /* the example, you will notice where I was lazy ...) */ + } + +The next thing is to really execute the statement. + +Note that you must set the attributes I<NUM_OF_FIELDS>, I<NAME>, etc +when the statement is successfully executed if the driver has not +already done so: they may be used even before a potential C<fetchrow()>. +In particular you have to tell B<DBI> the number of fields that the +statement has, because it will be used by B<DBI> internally. Thus the +function will typically ends with: + + if (isSelectStatement) { + DBIc_NUM_FIELDS(imp_sth) = numFields; + DBIc_ACTIVE_on(imp_sth); + } + +It is important that the I<ACTIVE> flag only be set for C<SELECT> +statements (or any other statements that can return many +values from the database using a cursor-like mechanism). See +C<dbd_db_connect()> above for more explanations. + +There plans for a preparse function to be provided by B<DBI>, but this has +not reached fruition yet. +Meantime, if you want to know how ugly it can get, try looking at the +C<dbd_ix_preparse()> in B<DBD::Informix> F<dbdimp.ec> and the related +functions in F<iustoken.c> and F<sqltoken.c>. + +=head3 The dbd_st_fetch method + +This function fetches a row of data. The row is stored in in an array, +of C<SV>'s that B<DBI> prepares for you. This has two advantages: it is fast +(you even reuse the C<SV>'s, so they don't have to be created after the +first C<fetchrow()>), and it guarantees that B<DBI> handles C<bind_cols()> for +you. + +What you do is the following: + + AV* av; + int numFields = DBIc_NUM_FIELDS(imp_sth); /* Correct, if NUM_FIELDS + is constant for this statement. There are drivers where this is + not the case! */ + int chopBlanks = DBIc_is(imp_sth, DBIcf_ChopBlanks); + int i; + + if (!fetch_new_row_of_data(...)) { + ... /* check for error or end-of-data */ + DBIc_ACTIVE_off(imp_sth); /* turn off Active flag automatically */ + return Nullav; + } + /* get the fbav (field buffer array value) for this row */ + /* it is very important to only call this after you know */ + /* that you have a row of data to return. */ + av = DBIc_DBISTATE(imp_sth)->get_fbav(imp_sth); + for (i = 0; i < numFields; i++) { + SV* sv = fetch_a_field(..., i); + if (chopBlanks && SvOK(sv) && type_is_blank_padded(field_type[i])) { + /* Remove white space from end (only) of sv */ + } + sv_setsv(AvARRAY(av)[i], sv); /* Note: (re)use! */ + } + return av; + +There's no need to use a C<fetch_a_field()> function returning an C<SV*>. +It's more common to use your database API functions to fetch the +data as character strings and use code like this: + + sv_setpvn(AvARRAY(av)[i], char_ptr, char_count); + +C<NULL> values must be returned as C<undef>. You can use code like this: + + SvOK_off(AvARRAY(av)[i]); + +The function returns the C<AV> prepared by B<DBI> for success or C<Nullav> +otherwise. + + *FIX ME* Discuss what happens when there's no more data to fetch. + Are errors permitted if another fetch occurs after the first fetch + that reports no more data. (Permitted, not required.) + +If an error occurs which leaves the I<$sth> in a state where remaining +rows can't be fetched then I<Active> should be turned off before the +method returns. + +=head3 The dbd_st_finish3 method + +The C<$sth-E<gt>finish()> method can be called if the user wishes to +indicate that no more rows will be fetched even if the database has more +rows to offer, and the B<DBI> code can call the function when handles are +being destroyed. See the B<DBI> specification for more background details. + +In both circumstances, the B<DBI> code ends up calling the +C<dbd_st_finish3()> method (if you provide a mapping for +C<dbd_st_finish3()> in F<dbdimp.h>), or C<dbd_st_finish()> otherwise. +The difference is that C<dbd_st_finish3()> takes a third argument which +is an C<int> with the value 1 if it is being called from a C<destroy()> +method and 0 otherwise. + +Note that B<DBI> v1.32 and earlier test on C<dbd_db_finish3()> to call +C<dbd_st_finish3()>; if you provide C<dbd_st_finish3()>, either define +C<dbd_db_finish3()> too, or insist on B<DBI> v1.33 or later. + +All it I<needs> to do is turn off the I<Active> flag for the I<sth>. +It will only be called by F<Driver.xst> code, if the driver has set I<ACTIVE> +to on for the I<sth>. + +Outline example: + + int dbd_st_finish3(SV* sth, imp_sth_t* imp_sth, int from_destroy) { + if (DBIc_ACTIVE(imp_sth)) + { + /* close cursor or equivalent action */ + DBIc_ACTIVE_off(imp_sth); + } + return 1; + } + +The from_destroy parameter is true if C<dbd_st_finish3()> is being called +from C<DESTROY()> - and so the statement is about to be destroyed. +For many drivers there is no point in doing anything more than turning off +the I<Active> flag in this case. + +The function returns I<TRUE> for success, I<FALSE> otherwise, but there isn't +a lot anyone can do to recover if there is an error. + +=head3 The dbd_st_destroy method + +This function is the private part of the statement handle destructor. + + void dbd_st_destroy(SV* sth, imp_sth_t* imp_sth) { + ... /* any clean-up that's needed */ + DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ + } + +The B<DBI> F<Driver.xst> code will call C<dbd_st_finish()> for you, if the +I<sth> has the I<ACTIVE> flag set, before calling C<dbd_st_destroy()>. + +=head3 The dbd_st_STORE_attrib and dbd_st_FETCH_attrib methods + +These functions correspond to C<dbd_db_STORE()> and C<dbd_db_FETCH()> attrib +above, except that they are for statement handles. +See above. + + 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); + +=head3 The dbd_bind_ph method + +This function is internally used by the C<bind_param()> method, the +C<bind_param_inout()> method and by the B<DBI> F<Driver.xst> code if +C<execute()> is called with any bind parameters. + + 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); + +The I<param> argument holds an C<IV> with the parameter number (1, 2, ...). +The I<value> argument is the parameter value and I<sql_type> is its type. + +If your driver does not support C<bind_param_inout()> then you should +ignore I<maxlen> and croak if I<is_inout> is I<TRUE>. + +If your driver I<does> support C<bind_param_inout()> then you should +note that I<value> is the C<SV> I<after> dereferencing the reference +passed to C<bind_param_inout()>. + +In drivers of simple databases the function will, for example, store +the value in a parameter array and use it later in C<dbd_st_execute()>. +See the B<DBD::mysql> driver for an example. + +=head3 Implementing bind_param_inout support + +To provide support for parameters bound by reference rather than by +value, the driver must do a number of things. First, and most +importantly, it must note the references and stash them in its own +driver structure. Secondly, when a value is bound to a column, the +driver must discard any previous reference bound to the column. On +each execute, the driver must evaluate the references and internally +bind the values resulting from the references. This is only applicable +if the user writes: + + $sth->execute; + +If the user writes: + + $sth->execute(@values); + +then B<DBI> automatically calls the binding code for each element of +I<@values>. These calls are indistinguishable from explicit user calls to +C<bind_param()>. + +=head2 C/XS version of Makefile.PL + +The F<Makefile.PL> file for a C/XS driver is similar to the code needed +for a pure Perl driver, but there are a number of extra bits of +information needed by the build system. + +For example, the attributes list passed to C<WriteMakefile()> needs +to specify the object files that need to be compiled and built into +the shared object (DLL). This is often, but not necessarily, just +F<dbdimp.o> (unless that should be F<dbdimp.obj> because you're building +on MS Windows). + +Note that you can reliably determine the extension of the object files +from the I<$Config{obj_ext}> values, and there are many other useful pieces +of configuration information lurking in that hash. +You get access to it with: + + use Config; + +=head2 Methods which do not need to be written + +The B<DBI> code implements the majority of the methods which are accessed +using the notation C<DBI-E<gt>function()>, the only exceptions being +C<DBI-E<gt>connect()> and C<DBI-E<gt>data_sources()> which require +support from the driver. + +The B<DBI> code implements the following documented driver, database and +statement functions which do not need to be written by the B<DBD> driver +writer. + +=over 4 + +=item $dbh->do() + +The default implementation of this function prepares, executes and +destroys the statement. This can be replaced if there is a better +way to implement this, such as C<EXECUTE IMMEDIATE> which can +sometimes be used if there are no parameters. + +=item $h->errstr() + +=item $h->err() + +=item $h->state() + +=item $h->trace() + +The B<DBD> driver does not need to worry about these routines at all. + +=item $h->{ChopBlanks} + +This attribute needs to be honored during C<fetch()> operations, but does +not need to be handled by the attribute handling code. + +=item $h->{RaiseError} + +The B<DBD> driver does not need to worry about this attribute at all. + +=item $h->{PrintError} + +The B<DBD> driver does not need to worry about this attribute at all. + +=item $sth->bind_col() + +Assuming the driver uses the C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()> +function (C drivers, see below), or the C<$sth-E<gt>_set_fbav($data)> +method (Perl drivers) the driver does not need to do anything about this +routine. + +=item $sth->bind_columns() + +Regardless of whether the driver uses +C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()>, the driver does not need +to do anything about this routine as it simply iteratively calls +C<$sth-E<gt>bind_col()>. + +=back + +The B<DBI> code implements a default implementation of the following +functions which do not need to be written by the B<DBD> driver writer +unless the default implementation is incorrect for the Driver. + +=over 4 + +=item $dbh->quote() + +This should only be written if the database does not accept the ANSI +SQL standard for quoting strings, with the string enclosed in single +quotes and any embedded single quotes replaced by two consecutive +single quotes. + +For the two argument form of quote, you need to implement the +C<type_info()> method to provide the information that quote needs. + +=item $dbh->ping() + +This should be implemented as a simple efficient way to determine +whether the connection to the database is still alive. Typically +code like this: + + sub ping { + my $dbh = shift; + $sth = $dbh->prepare_cached(q{ + select * from A_TABLE_NAME where 1=0 + }) or return 0; + $sth->execute or return 0; + $sth->finish; + return 1; + } + +where I<A_TABLE_NAME> is the name of a table that always exists (such as a +database system catalogue). + +=item $drh->default_user + +The default implementation of default_user will get the database +username and password fields from C<$ENV{DBI_USER}> and +C<$ENV{DBI_PASS}>. You can override this method. It is called as +follows: + + ($user, $pass) = $drh->default_user($user, $pass, $attr) + +=back + +=head1 METADATA METHODS + +The exposition above ignores the B<DBI> MetaData methods. +The metadata methods are all associated with a database handle. + +=head2 Using DBI::DBD::Metadata + +The B<DBI::DBD::Metadata> module is a good semi-automatic way for the +developer of a B<DBD> module to write the C<get_info()> and C<type_info()> +functions quickly and accurately. + +=head3 Generating the get_info method + +Prior to B<DBI> v1.33, this existed as the method C<write_getinfo_pm()> +in the B<DBI::DBD> module. From B<DBI> v1.33, it exists as the method +C<write_getinfo_pm()> in the B<DBI::DBD::Metadata> module. This +discussion assumes you have B<DBI> v1.33 or later. + +You examine the documentation for C<write_getinfo_pm()> using: + + perldoc DBI::DBD::Metadata + +To use it, you need a Perl B<DBI> driver for your database which implements +the C<get_info()> method. In practice, this means you need to install +B<DBD::ODBC>, an ODBC driver manager, and an ODBC driver for your +database. + +With the pre-requisites in place, you might type: + + perl -MDBI::DBD::Metadata -we \ + "write_getinfo_pm (qw{ dbi:ODBC:foo_db username password Driver })" + +The procedure writes to standard output the code that should be added to +your F<Driver.pm> file and the code that should be written to +F<lib/DBD/Driver/GetInfo.pm>. + +You should review the output to ensure that it is sensible. + +=head3 Generating the type_info method + +Given the idea of the C<write_getinfo_pm()> method, it was not hard +to devise a parallel method, C<write_typeinfo_pm()>, which does the +analogous job for the B<DBI> C<type_info_all()> metadata method. The +C<write_typeinfo_pm()> method was added to B<DBI> v1.33. + +You examine the documentation for C<write_typeinfo_pm()> using: + + perldoc DBI::DBD::Metadata + +The setup is exactly analogous to the mechanism described in +L</Generating the get_info method>. + +With the pre-requisites in place, you might type: + + perl -MDBI::DBD::Metadata -we \ + "write_typeinfo (qw{ dbi:ODBC:foo_db username password Driver })" + +The procedure writes to standard output the code that should be added to +your F<Driver.pm> file and the code that should be written to +F<lib/DBD/Driver/TypeInfo.pm>. + +You should review the output to ensure that it is sensible. + +=head2 Writing DBD::Driver::db::get_info + +If you use the B<DBI::DBD::Metadata> module, then the code you need is +generated for you. + +If you decide not to use the B<DBI::DBD::Metadata> module, you +should probably borrow the code from a driver that has done so (eg +B<DBD::Informix> from version 1.05 onwards) and crib the code from +there, or look at the code that generates that module and follow +that. The method in F<Driver.pm> will be very simple; the method in +F<lib/DBD/Driver/GetInfo.pm> is not very much more complex unless your +DBMS itself is much more complex. + +Note that some of the B<DBI> utility methods rely on information from the +C<get_info()> method to perform their operations correctly. See, for +example, the C<quote_identifier()> and quote methods, discussed below. + +=head2 Writing DBD::Driver::db::type_info_all + +If you use the C<DBI::DBD::Metadata> module, then the code you need is +generated for you. + +If you decide not to use the C<DBI::DBD::Metadata> module, you +should probably borrow the code from a driver that has done so (eg +C<DBD::Informix> from version 1.05 onwards) and crib the code from +there, or look at the code that generates that module and follow +that. The method in F<Driver.pm> will be very simple; the method in +F<lib/DBD/Driver/TypeInfo.pm> is not very much more complex unless your +DBMS itself is much more complex. + +=head2 Writing DBD::Driver::db::type_info + +The guidelines on writing this method are still not really clear. +No sample implementation is available. + +=head2 Writing DBD::Driver::db::table_info + + *FIX ME* The guidelines on writing this method have not been written yet. + No sample implementation is available. + +=head2 Writing DBD::Driver::db::column_info + + *FIX ME* The guidelines on writing this method have not been written yet. + No sample implementation is available. + +=head2 Writing DBD::Driver::db::primary_key_info + + *FIX ME* The guidelines on writing this method have not been written yet. + No sample implementation is available. + +=head2 Writing DBD::Driver::db::primary_key + + *FIX ME* The guidelines on writing this method have not been written yet. + No sample implementation is available. + +=head2 Writing DBD::Driver::db::foreign_key_info + + *FIX ME* The guidelines on writing this method have not been written yet. + No sample implementation is available. + +=head2 Writing DBD::Driver::db::tables + +This method generates an array of names in a format suitable for being +embedded in SQL statements in places where a table name is expected. + +If your database hews close enough to the SQL standard or if you have +implemented an appropriate C<table_info()> function and and the appropriate +C<quote_identifier()> function, then the B<DBI> default version of this method +will work for your driver too. + +Otherwise, you have to write a function yourself, such as: + + sub tables + { + my($dbh, $cat, $sch, $tab, $typ) = @_; + my(@res); + my($sth) = $dbh->table_info($cat, $sch, $tab, $typ); + my(@arr); + while (@arr = $sth->fetchrow_array) + { + push @res, $dbh->quote_identifier($arr[0], $arr[1], $arr[2]); + } + return @res; + } + +See also the default implementation in F<DBI.pm>. + +=head2 Writing DBD::Driver::db::quote + +This method takes a value and converts it into a string suitable for +embedding in an SQL statement as a string literal. + +If your DBMS accepts the SQL standard notation for strings (single +quotes around the string as a whole with any embedded single quotes +doubled up), then you do not need to write this method as B<DBI> provides a +default method that does it for you. + +If your DBMS uses an alternative notation or escape mechanism, then you +need to provide an equivalent function. For example, suppose your DBMS +used C notation with double quotes around the string and backslashes +escaping both double quotes and backslashes themselves. Then you might +write the function as: + + sub quote + { + my($dbh, $str) = @_; + $str =~ s/["\\]/\\$&/gmo; + return qq{"$str"}; + } + +Handling newlines and other control characters is left as an exercise +for the reader. + +This sample method ignores the I<$data_type> indicator which is the +optional second argument to the method. + +=head2 Writing DBD::Driver::db::quote_identifier + +This method is called to ensure that the name of the given table (or +other database object) can be embedded into an SQL statement without +danger of misinterpretation. The result string should be usable in the +text of an SQL statement as the identifier for a table. + +If your DBMS accepts the SQL standard notation for quoted identifiers +(which uses double quotes around the identifier as a whole, with any +embedded double quotes doubled up) and accepts I<"schema"."identifier"> +(and I<"catalog"."schema"."identifier"> when a catalog is specified), then +you do not need to write this method as B<DBI> provides a default method +that does it for you. + +In fact, even if your DBMS does not handle exactly that notation but +you have implemented the C<get_info()> method and it gives the correct +responses, then it will work for you. If your database is fussier, then +you need to implement your own version of the function. + +For example, B<DBD::Informix> has to deal with an environment variable +I<DELIMIDENT>. If it is not set, then the DBMS treats names enclosed in +double quotes as strings rather than names, which is usually a syntax +error. Additionally, the catalog portion of the name is separated from +the schema and table by a different delimiter (colon instead of dot), +and the catalog portion is never enclosed in quotes. (Fortunately, +valid strings for the catalog will never contain weird characters that +might need to be escaped, unless you count dots, dashes, slashes and +at-signs as weird.) Finally, an Informix database can contain objects +that cannot be accessed because they were created by a user with the +I<DELIMIDENT> environment variable set, but the current user does not +have it set. By design choice, the C<quote_identifier()> method encloses +those identifiers in double quotes anyway, which generally triggers a +syntax error, and the metadata methods which generate lists of tables +etc omit those identifiers from the result sets. + + sub quote_identifier + { + my($dbh, $cat, $sch, $obj) = @_; + my($rv) = ""; + my($qq) = (defined $ENV{DELIMIDENT}) ? '"' : ''; + $rv .= qq{$cat:} if (defined $cat); + if (defined $sch) + { + if ($sch !~ m/^\w+$/o) + { + $qq = '"'; + $sch =~ s/$qq/$qq$qq/gm; + } + $rv .= qq{$qq$sch$qq.}; + } + if (defined $obj) + { + if ($obj !~ m/^\w+$/o) + { + $qq = '"'; + $obj =~ s/$qq/$qq$qq/gm; + } + $rv .= qq{$qq$obj$qq}; + } + return $rv; + } + +Handling newlines and other control characters is left as an exercise +for the reader. + +Note that there is an optional fourth parameter to this function which +is a reference to a hash of attributes; this sample implementation +ignores that. + +This sample implementation also ignores the single-argument variant of +the method. + +=head1 TRACING + +Tracing in DBI is controlled with a combination of a trace level and a +set of flags which together are known as the trace settings. The trace +settings are stored in a single integer and divided into levels and +flags by a set of masks (C<DBIc_TRACE_LEVEL_MASK> and +C<DBIc_TRACE_FLAGS_MASK>). + +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 Level + +The trace level is the first 4 bits of the trace settings (masked by +C<DBIc_TRACE_FLAGS_MASK>) and represents trace levels of 1 to 15. Do +not output anything at trace levels less than 3 as they are reserved +for DBI. + +For advice on what to output at each level see "Trace Levels" in +L<DBI>. + +To test for a trace level you can use the C<DBIc_TRACE_LEVEL> macro +like this: + + if (DBIc_TRACE_LEVEL(imp_xxh) >= 2) { + PerlIO_printf(DBIc_LOGPIO(imp_xxh), "foobar"); + } + +Also B<note> the use of PerlIO_printf which you should always use for +tracing and never the C C<stdio.h> I/O functions. + +=head2 Trace Flags + +Trace flags are used to enable tracing of specific activities within +the DBI and drivers. The DBI defines some trace flags and drivers can +define others. DBI trace flag names begin with a capital letter and +driver specific names begin with a lowercase letter. For a list of DBI +defined trace flags see "Trace Flags" in L<DBI>. + +If you want to use private trace flags you'll probably want to be able +to set them by name. Drivers are expected to override the +parse_trace_flag (note the singular) and check if $trace_flag_name is +a driver specific trace flags and, if not, then call the DBIs default +parse_trace_flag(). To do that you'll need to define a +parse_trace_flag() method like this: + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + +All private flag names must be lowercase, and all private flags must +be in the top 8 of the 32 bits of C<DBIc_TRACE_FLAGS(imp)> i.e., +0xFF000000. + +If you've defined a parse_trace_flag() method in ::db you'll also want +it in ::st, so just alias it in: + + *parse_trace_flag = \&DBD::foo:db::parse_trace_flag; + +You may want to act on the current 'SQL' trace flag that DBI defines +to output SQL prepared/executed as DBI currently does not do SQL +tracing. + +=head2 Trace Macros + +Access to the trace level and trace flags is via a set of macros. + + DBIc_TRACE_SETTINGS(imp) returns the trace settings + DBIc_TRACE_LEVEL(imp) returns the trace level + DBIc_TRACE_FLAGS(imp) returns the trace flags + DBIc_TRACE(imp, flags, flaglevel, level) + + e.g., + + 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 + +=head1 WRITING AN EMULATION LAYER FOR AN OLD PERL INTERFACE + +Study F<Oraperl.pm> (supplied with B<DBD::Oracle>) and F<Ingperl.pm> (supplied +with B<DBD::Ingres>) and the corresponding I<dbdimp.c> files for ideas. + +Note that the emulation code sets C<$dbh-E<gt>{CompatMode} = 1;> for each +connection so that the internals of the driver can implement behaviour +compatible with the old interface when dealing with those handles. + +=head2 Setting emulation perl variables + +For example, ingperl has a I<$sql_rowcount> variable. Rather than try +to manually update this in F<Ingperl.pm> it can be done faster in C code. +In C<dbd_init()>: + + sql_rowcount = perl_get_sv("Ingperl::sql_rowcount", GV_ADDMULTI); + +In the relevant places do: + + if (DBIc_COMPAT(imp_sth)) /* only do this for compatibility mode handles */ + sv_setiv(sql_rowcount, the_row_count); + +=head1 OTHER MISCELLANEOUS INFORMATION + +=head2 The imp_xyz_t types + +Any handle has a corresponding C structure filled with private data. +Some of this data is reserved for use by B<DBI> (except for using the +DBIc macros below), some is for you. See the description of the +F<dbdimp.h> file above for examples. Most functions in F<dbdimp.c> +are passed both the handle C<xyz> and a pointer to C<imp_xyz>. In +rare cases, however, you may use the following macros: + +=over 4 + +=item D_imp_dbh(dbh) + +Given a function argument I<dbh>, declare a variable I<imp_dbh> and +initialize it with a pointer to the handles private data. Note: This +must be a part of the function header, because it declares a variable. + +=item D_imp_sth(sth) + +Likewise for statement handles. + +=item D_imp_xxx(h) + +Given any handle, declare a variable I<imp_xxx> and initialize it +with a pointer to the handles private data. It is safe, for example, +to cast I<imp_xxx> to C<imp_dbh_t*>, if C<DBIc_TYPE(imp_xxx) == DBIt_DB>. +(You can also call C<sv_derived_from(h, "DBI::db")>, but that's much +slower.) + +=item D_imp_dbh_from_sth + +Given a I<imp_sth>, declare a variable I<imp_dbh> and initialize it with a +pointer to the parent database handle's implementors structure. + +=back + +=head2 Using DBIc_IMPSET_on + +The driver code which initializes a handle should use C<DBIc_IMPSET_on()> +as soon as its state is such that the cleanup code must be called. +When this happens is determined by your driver code. + +B<Failure to call this can lead to corruption of data structures.> + +For example, B<DBD::Informix> maintains a linked list of database +handles in the driver, and within each handle, a linked list of +statements. Once a statement is added to the linked list, it is crucial +that it is cleaned up (removed from the list). When I<DBIc_IMPSET_on()> +was being called too late, it was able to cause all sorts of problems. + +=head2 Using DBIc_is(), DBIc_has(), DBIc_on() and DBIc_off() + +Once upon a long time ago, the only way of handling the internal B<DBI> +boolean flags/attributes was through macros such as: + + DBIc_WARN DBIc_WARN_on DBIc_WARN_off + DBIc_COMPAT DBIc_COMPAT_on DBIc_COMPAT_off + +Each of these took an I<imp_xxh> pointer as an argument. + +Since then, new attributes have been added such as I<ChopBlanks>, +I<RaiseError> and I<PrintError>, and these do not have the full set of +macros. The approved method for handling these is now the four macros: + + DBIc_is(imp, flag) + DBIc_has(imp, flag) an alias for DBIc_is + DBIc_on(imp, flag) + DBIc_off(imp, flag) + DBIc_set(imp, flag, on) set if on is true, else clear + +Consequently, the C<DBIc_XXXXX> family of macros is now mostly deprecated +and new drivers should avoid using them, even though the older drivers +will probably continue to do so for quite a while yet. However... + +There is an I<important exception> to that. The I<ACTIVE> and I<IMPSET> +flags should be set via the C<DBIc_ACTIVE_on()> and C<DBIc_IMPSET_on()> macros, +and unset via the C<DBIc_ACTIVE_off()> and C<DBIc_IMPSET_off()> macros. + +=head2 Using the get_fbav() method + +B<THIS IS CRITICAL for C/XS drivers>. + +The C<$sth-E<gt>bind_col()> and C<$sth-E<gt>bind_columns()> documented +in the B<DBI> specification do not have to be implemented by the driver +writer because B<DBI> takes care of the details for you. + +However, the key to ensuring that bound columns work is to call the +function C<DBIc_DBISTATE(imp_xxh)-E<gt>get_fbav()> in the code which +fetches a row of data. + +This returns an C<AV>, and each element of the C<AV> contains the C<SV> which +should be set to contain the returned data. + +The pure Perl equivalent is the C<$sth-E<gt>_set_fbav($data)> method, as +described in the part on pure Perl drivers. + +=head2 Casting strings to Perl types based on a SQL type + +DBI from 1.611 (and DBIXS_REVISION 13606) defines the +sql_type_cast_svpv method which may be used to cast a string +representation of a value to a more specific Perl type based on a SQL +type. You should consider using this method when processing bound +column data as it provides some support for the TYPE bind_col +attribute which is rarely used in drivers. + + int sql_type_cast_svpv(pTHX_ SV *sv, int sql_type, U32 flags, void *v) + +C<sv> is what you would like cast, C<sql_type> is one of the DBI defined +SQL types (e.g., C<SQL_INTEGER>) and C<flags> is a bitmask as follows: + +=over + +=item DBIstcf_STRICT + +If set this indicates you want an error state returned if the cast +cannot be performed. + +=item DBIstcf_DISCARD_STRING + +If set and the pv portion of the C<sv> is cast then this will cause +sv's pv to be freed up. + +=back + +sql_type_cast_svpv returns the following states: + + -2 sql_type is not handled - sv not changed + -1 sv is undef, sv not changed + 0 sv could not be cast cleanly and DBIstcf_STRICT was specified + 1 sv could not be case cleanly and DBIstcf_STRICT was not specified + 2 sv was cast ok + +The current implementation of sql_type_cast_svpv supports +C<SQL_INTEGER>, C<SQL_DOUBLE> and C<SQL_NUMERIC>. C<SQL_INTEGER> uses +sv_2iv and hence may set IV, UV or NV depending on the +number. C<SQL_DOUBLE> uses sv_2nv so may set NV and C<SQL_NUMERIC> +will set IV or UV or NV. + +DBIstcf_STRICT should be implemented as the StrictlyTyped attribute +and DBIstcf_DISCARD_STRING implemented as the DiscardString attribute +to the bind_col method and both default to off. + +See DBD::Oracle for an example of how this is used. + +=head1 SUBCLASSING DBI DRIVERS + +This is definitely an open subject. It can be done, as demonstrated by +the B<DBD::File> driver, but it is not as simple as one might think. + +(Note that this topic is different from subclassing the B<DBI>. For an +example of that, see the F<t/subclass.t> file supplied with the B<DBI>.) + +The main problem is that the I<dbh>'s and I<sth>'s that your C<connect()> and +C<prepare()> methods return are not instances of your B<DBD::Driver::db> +or B<DBD::Driver::st> packages, they are not even derived from it. +Instead they are instances of the B<DBI::db> or B<DBI::st> classes or +a derived subclass. Thus, if you write a method C<mymethod()> and do a + + $dbh->mymethod() + +then the autoloader will search for that method in the package B<DBI::db>. +Of course you can instead to a + + $dbh->func('mymethod') + +and that will indeed work, even if C<mymethod()> is inherited, but not +without additional work. Setting I<@ISA> is not sufficient. + +=head2 Overwriting methods + +The first problem is, that the C<connect()> method has no idea of +subclasses. For example, you cannot implement base class and subclass +in the same file: The C<install_driver()> method wants to do a + + require DBD::Driver; + +In particular, your subclass B<has> to be a separate driver, from +the view of B<DBI>, and you cannot share driver handles. + +Of course that's not much of a problem. You should even be able +to inherit the base classes C<connect()> method. But you cannot +simply overwrite the method, unless you do something like this, +quoted from B<DBD::CSV>: + + sub connect ($$;$$$) { + my ($drh, $dbname, $user, $auth, $attr) = @_; + + my $this = $drh->DBD::File::dr::connect($dbname, $user, $auth, $attr); + if (!exists($this->{csv_tables})) { + $this->{csv_tables} = {}; + } + + $this; + } + +Note that we cannot do a + + $drh->SUPER::connect($dbname, $user, $auth, $attr); + +as we would usually do in a an OO environment, because I<$drh> is an instance +of B<DBI::dr>. And note, that the C<connect()> method of B<DBD::File> is +able to handle subclass attributes. See the description of Pure Perl +drivers above. + +It is essential that you always call superclass method in the above +manner. However, that should do. + +=head2 Attribute handling + +Fortunately the B<DBI> specifications allow a simple, but still +performant way of handling attributes. The idea is based on the +convention that any driver uses a prefix I<driver_> for its private +methods. Thus it's always clear whether to pass attributes to the super +class or not. For example, consider this C<STORE()> method from the +B<DBD::CSV> class: + + sub STORE { + my ($dbh, $attr, $val) = @_; + if ($attr !~ /^driver_/) { + return $dbh->DBD::File::db::STORE($attr, $val); + } + if ($attr eq 'driver_foo') { + ... + } + +=cut + +use Exporter (); +use Config qw(%Config); +use Carp; +use Cwd; +use File::Spec; +use strict; +use vars qw( + @ISA @EXPORT + $is_dbi +); + +BEGIN { + if ($^O eq 'VMS') { + require vmsish; + import vmsish; + require VMS::Filespec; + import VMS::Filespec; + } + else { + *vmsify = sub { return $_[0] }; + *unixify = sub { return $_[0] }; + } +} + +@ISA = qw(Exporter); + +@EXPORT = qw( + dbd_dbi_dir + dbd_dbi_arch_dir + dbd_edit_mm_attribs + dbd_postamble +); + +BEGIN { + $is_dbi = (-r 'DBI.pm' && -r 'DBI.xs' && -r 'DBIXS.h'); + require DBI unless $is_dbi; +} + +my $done_inst_checks; + +sub _inst_checks { + return if $done_inst_checks++; + my $cwd = cwd(); + if ($cwd =~ /\Q$Config{path_sep}/) { + warn "*** Warning: Path separator characters (`$Config{path_sep}') ", + "in the current directory path ($cwd) may cause problems\a\n\n"; + sleep 2; + } + if ($cwd =~ /\s/) { + warn "*** Warning: whitespace characters ", + "in the current directory path ($cwd) may cause problems\a\n\n"; + sleep 2; + } + if ( $^O eq 'MSWin32' + && $Config{cc} eq 'cl' + && !(exists $ENV{'LIB'} && exists $ENV{'INCLUDE'})) + { + die <<EOT; +*** You're using Microsoft Visual C++ compiler or similar but + the LIB and INCLUDE environment variables are not both set. + + You need to run the VCVARS32.BAT batch file that was supplied + with the compiler before you can use it. + + A copy of vcvars32.bat can typically be found in the following + directories under your Visual Studio install directory: + Visual C++ 6.0: vc98\\bin + Visual Studio .NET: vc7\\bin + + Find it, run it, then retry this. + + If you think this error is not correct then just set the LIB and + INCLUDE environment variables to some value to disable the check. +EOT + } +} + +sub dbd_edit_mm_attribs { + # this both edits the attribs in-place and returns the flattened attribs + my $mm_attr = shift; + my $dbd_attr = shift || {}; + croak "dbd_edit_mm_attribs( \%makemaker [, \%other ]): too many parameters" + if @_; + _inst_checks(); + + # what can be done + my %test_variants = ( + p => { name => "DBI::PurePerl", + match => qr/^\d/, + add => [ '$ENV{DBI_PUREPERL} = 2', + 'END { delete $ENV{DBI_PUREPERL}; }' ], + }, + g => { name => "DBD::Gofer", + match => qr/^\d/, + add => [ q{$ENV{DBI_AUTOPROXY} = 'dbi:Gofer:transport=null;policy=pedantic'}, + q|END { delete $ENV{DBI_AUTOPROXY}; }| ], + }, + n => { name => "DBI::SQL::Nano", + match => qr/^(?:48dbi_dbd_sqlengine|49dbd_file|5\ddbm_\w+|85gofer)\.t$/, + add => [ q{$ENV{DBI_SQL_NANO} = 1}, + q|END { delete $ENV{DBI_SQL_NANO}; }| ], + }, + # mx => { name => "DBD::Multiplex", + # add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Multiplex:';} ], + # } + # px => { name => "DBD::Proxy", + # need mechanism for starting/stopping the proxy server + # add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Proxy:XXX';} ], + # } + ); + + # decide what needs doing + $dbd_attr->{create_pp_tests} or delete $test_variants{p}; + $dbd_attr->{create_nano_tests} or delete $test_variants{n}; + $dbd_attr->{create_gap_tests} or delete $test_variants{g}; + + # expand for all combinations + my @all_keys = my @tv_keys = sort keys %test_variants; + while( @tv_keys ) { + my $cur_key = shift @tv_keys; + last if( 1 < length $cur_key ); + my @new_keys; + foreach my $remain (@tv_keys) { + push @new_keys, $cur_key . $remain unless $remain =~ /$cur_key/; + } + push @tv_keys, @new_keys; + push @all_keys, @new_keys; + } + + my %uniq_keys; + foreach my $key (@all_keys) { + @tv_keys = sort split //, $key; + my $ordered = join( '', @tv_keys ); + $uniq_keys{$ordered} = 1; + } + @all_keys = sort { length $a <=> length $b or $a cmp $b } keys %uniq_keys; + + # do whatever needs doing + if( keys %test_variants ) { + # XXX need to convert this to work within the generated Makefile + # so 'make' creates them and 'make clean' deletes them + opendir DIR, 't' or die "Can't read 't' directory: $!"; + my @tests = grep { /\.t$/ } readdir DIR; + closedir DIR; + + foreach my $test_combo (@all_keys) { + @tv_keys = split //, $test_combo; + my @test_names = map { $test_variants{$_}->{name} } @tv_keys; + printf "Creating test wrappers for " . join( " + ", @test_names ) . ":\n"; + my @test_matches = map { $test_variants{$_}->{match} } @tv_keys; + my @test_adds; + foreach my $test_add ( map { $test_variants{$_}->{add} } @tv_keys) { + push @test_adds, @$test_add; + } + my $v_type = $test_combo; + $v_type = 'x' . $v_type if length( $v_type ) > 1; + + TEST: + foreach my $test (sort @tests) { + foreach my $match (@test_matches) { + next TEST if $test !~ $match; + } + my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 && $Config{useithreads}); + my $v_test = "t/zv${v_type}_$test"; + my $v_perl = ($test =~ /taint/) ? "perl -wT" : "perl -w"; + printf "%s %s\n", $v_test, ($usethr) ? "(use threads)" : ""; + open PPT, ">$v_test" or warn "Can't create $v_test: $!"; + print PPT "#!$v_perl\n"; + print PPT "use threads;\n" if $usethr; + print PPT "$_;\n" foreach @test_adds; + print PPT "require './t/$test'; # or warn \$!;\n"; + close PPT or warn "Error writing $v_test: $!"; + } + } + } + return %$mm_attr; +} + +sub dbd_dbi_dir { + _inst_checks(); + return '.' if $is_dbi; + my $dbidir = $INC{'DBI.pm'} || die "DBI.pm not in %INC!"; + $dbidir =~ s:/DBI\.pm$::; + return $dbidir; +} + +sub dbd_dbi_arch_dir { + _inst_checks(); + return '$(INST_ARCHAUTODIR)' if $is_dbi; + my $dbidir = dbd_dbi_dir(); + my %seen; + my @try = grep { not $seen{$_}++ } map { vmsify( unixify($_) . "/auto/DBI/" ) } @INC; + my @xst = grep { -f vmsify( unixify($_) . "/Driver.xst" ) } @try; + Carp::croak("Unable to locate Driver.xst in @try") unless @xst; + Carp::carp( "Multiple copies of Driver.xst found in: @xst") if @xst > 1; + print "Using DBI $DBI::VERSION (for perl $] on $Config{archname}) installed in $xst[0]\n"; + return File::Spec->canonpath($xst[0]); +} + +sub dbd_postamble { + my $self = shift; + _inst_checks(); + my $dbi_instarch_dir = ($is_dbi) ? "." : dbd_dbi_arch_dir(); + my $dbi_driver_xst= File::Spec->catfile($dbi_instarch_dir, 'Driver.xst'); + my $xstf_h = File::Spec->catfile($dbi_instarch_dir, 'Driver_xst.h'); + + # we must be careful of quotes, expecially for Win32 here. + return ' +# --- This section was generated by DBI::DBD::dbd_postamble() +DBI_INSTARCH_DIR='.$dbi_instarch_dir.' +DBI_DRIVER_XST='.$dbi_driver_xst.' + +# The main dependancy (technically correct but probably not used) +$(BASEEXT).c: $(BASEEXT).xsi + +# This dependancy is needed since MakeMaker uses the .xs.o rule +$(BASEEXT)$(OBJ_EXT): $(BASEEXT).xsi + +$(BASEEXT).xsi: $(DBI_DRIVER_XST) '.$xstf_h.' + $(PERL) -p -e "s/~DRIVER~/$(BASEEXT)/g" $(DBI_DRIVER_XST) > $(BASEEXT).xsi + +# --- +'; +} + +package DBDI; # just to reserve it via PAUSE for the future + +1; + +__END__ + +=head1 AUTHORS + +Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>), +Jochen Wiedmann <joe@ispsoft.de>, +Steffen Goeldner <sgoeldner@cpan.org>, +and Tim Bunce <dbi-users@perl.org>. + +=cut diff --git a/lib/DBI/DBD/Metadata.pm b/lib/DBI/DBD/Metadata.pm new file mode 100644 index 0000000..75f5b89 --- /dev/null +++ b/lib/DBI/DBD/Metadata.pm @@ -0,0 +1,493 @@ +package DBI::DBD::Metadata; + +# $Id: Metadata.pm 14213 2010-06-30 19:29:18Z mjevans $ +# +# Copyright (c) 1997-2003 Jonathan Leffler, Jochen Wiedmann, +# Steffen Goeldner and Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use Exporter (); +use Carp; + +use DBI; +use DBI::Const::GetInfoType qw(%GetInfoType); + +# Perl 5.005_03 does not recognize 'our' +@ISA = qw(Exporter); +@EXPORT = qw(write_getinfo_pm write_typeinfo_pm); + +$VERSION = sprintf("2.%06d", q$Revision: 14213 $ =~ /(\d+)/o); + + +use strict; + +=head1 NAME + +DBI::DBD::Metadata - Generate the code and data for some DBI metadata methods + +=head1 SYNOPSIS + +The idea is to extract metadata information from a good quality +ODBC driver and use it to generate code and data to use in your own +DBI driver for the same database. + +To generate code to support the get_info method: + + perl -MDBI::DBD::Metadata -e "write_getinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_getinfo_pm dbi:ODBC:foo_db username password Driver + +To generate code to support the type_info method: + + perl -MDBI::DBD::Metadata -e "write_typeinfo_pm('dbi:ODBC:dsn-name','user','pass','Driver')" + + perl -MDBI::DBD::Metadata -e write_typeinfo_pm dbi:ODBC:dsn-name user pass Driver + +Where C<dbi:ODBC:dsn-name> is the connection to use to extract the +data, and C<Driver> is the name of the driver you want the code +generated for (the driver name gets embedded into the output in +numerous places). + +=head1 Generating a GetInfo package for a driver + +The C<write_getinfo_pm> in the DBI::DBD::Metadata module generates a +DBD::Driver::GetInfo package on standard output. + +This method generates a DBD::Driver::GetInfo package from the data +source you specified in the parameter list or in the environment +variable DBI_DSN. +DBD::Driver::GetInfo should help a DBD author implement the DBI +get_info() method. +Because you are just creating this package, it is very unlikely that +DBD::Driver already provides a good implementation for get_info(). +Thus you will probably connect via DBD::ODBC. + +Once you are sure that it is producing reasonably sane data, you should +typically redirect the standard output to lib/DBD/Driver/GetInfo.pm, and +then hand edit the result. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +If you connect via DBD::ODBC, you should use version 0.38 or greater; + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that most values are static and places these +values directly in the %info hash. +A few examples show the use of CODE references and the implementation +via subroutines. +It is very likely that you will have to write additional subroutines for +values depending on the session state or server version, e.g. +SQL_DBMS_VER. + +A possible implementation of DBD::Driver::db::get_info() may look like: + + sub get_info { + my($dbh, $info_type) = @_; + require DBD::Driver::GetInfo; + my $v = $DBD::Driver::GetInfo::info{int($info_type)}; + $v = $v->($dbh) if ref $v eq 'CODE'; + return $v; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by write_getinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + +sub write_getinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The get_info function was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub get_info { + my(\$dbh, \$info_type) = \@_; + require DBD::${driver}::GetInfo; + my \$v = \$DBD::${driver}::GetInfo::info{int(\$info_type)}; + \$v = \$v->(\$dbh) if ref \$v eq 'CODE'; + return \$v; + } + +# Transfer this to lib/DBD/${driver}/GetInfo.pm + +# The \%info hash was automatically generated by +# DBI::DBD::Metadata::write_getinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::GetInfo; + +use strict; +use DBD::${driver}; + +# Beware: not officially documented interfaces... +# use DBI::Const::GetInfoType qw(\%GetInfoType); +# use DBI::Const::GetInfoReturn qw(\%GetInfoReturnTypes \%GetInfoReturnValues); + +my \$sql_driver = '${driver}'; +my \$sql_ver_fmt = '%02d.%02d.%04d'; # ODBC version string: ##.##.##### +my \$sql_driver_ver = sprintf \$sql_ver_fmt, split (/\\./, \$DBD::${driver}::VERSION); +PERL + +my $kw_map = 0; +{ +# Informix CLI (ODBC) v3.81.0000 does not return a list of keywords. + local $\ = "\n"; + local $, = "\n"; + my ($kw) = $dbh->get_info($GetInfoType{SQL_KEYWORDS}); + if ($kw) + { + print "\nmy \@Keywords = qw(\n"; + print sort split /,/, $kw; + print ");\n\n"; + print "sub sql_keywords {\n"; + print q% return join ',', @Keywords;%; + print "\n}\n\n"; + $kw_map = 1; + } +} + + print <<'PERL'; + +sub sql_data_source_name { + my $dbh = shift; + return "dbi:$sql_driver:" . $dbh->{Name}; +} + +sub sql_user_name { + my $dbh = shift; + # CURRENT_USER is a non-standard attribute, probably undef + # Username is a standard DBI attribute + return $dbh->{CURRENT_USER} || $dbh->{Username}; +} + +PERL + + print "\nour \%info = (\n"; + foreach my $key (sort keys %GetInfoType) + { + my $num = $GetInfoType{$key}; + my $val = eval { $dbh->get_info($num); }; + if ($key eq 'SQL_DATA_SOURCE_NAME') { + $val = '\&sql_data_source_name'; + } + elsif ($key eq 'SQL_KEYWORDS') { + $val = ($kw_map) ? '\&sql_keywords' : 'undef'; + } + elsif ($key eq 'SQL_DRIVER_NAME') { + $val = "\$INC{'DBD/$driver.pm'}"; + } + elsif ($key eq 'SQL_DRIVER_VER') { + $val = '$sql_driver_ver'; + } + elsif ($key eq 'SQL_USER_NAME') { + $val = '\&sql_user_name'; + } + elsif (not defined $val) { + $val = 'undef'; + } + elsif ($val eq '') { + $val = "''"; + } + elsif ($val =~ /\D/) { + $val =~ s/\\/\\\\/g; + $val =~ s/'/\\'/g; + $val = "'$val'"; + } + printf "%s %5d => %-30s # %s\n", (($val eq 'undef') ? '#' : ' '), $num, "$val,", $key; + } + print ");\n\n1;\n\n__END__\n"; +} + + + +=head1 Generating a TypeInfo package for a driver + +The C<write_typeinfo_pm> function in the DBI::DBD::Metadata module generates +on standard output the data needed for a driver's type_info_all method. +It also provides default implementations of the type_info_all +method for inclusion in the driver's main implementation file. + +The driver parameter is the name of the driver for which the methods +will be generated; for the sake of examples, this will be "Driver". +Typically, the dsn parameter will be of the form "dbi:ODBC:odbc_dsn", +where the odbc_dsn is a DSN for one of the driver's databases. +The user and pass parameters are the other optional connection +parameters that will be provided to the DBI connect method. + +Once you are sure that it is producing reasonably sane data, you should +typically redirect the standard output to lib/DBD/Driver/TypeInfo.pm, +and then hand edit the result if necessary. +Do not forget to update your Makefile.PL and MANIFEST to include this as +an extra PM file that should be installed. + +Please take a critical look at the data returned! +ODBC drivers vary dramatically in their quality. + +The generator assumes that all the values are static and places these +values directly in the %info hash. + +A possible implementation of DBD::Driver::type_info_all() may look like: + + sub type_info_all { + my ($dbh) = @_; + require DBD::Driver::TypeInfo; + return [ @$DBD::Driver::TypeInfo::type_info_all ]; + } + +Please replace Driver (or "<foo>") with the name of your driver. +Note that this stub function is generated for you by the write_typeinfo_pm +function, but you must manually transfer the code to Driver.pm. + +=cut + + +# These two are used by fmt_value... +my %dbi_inv; +my %sql_type_inv; + +#-DEBUGGING-# +#sub print_hash +#{ +# my ($name, %hash) = @_; +# print "Hash: $name\n"; +# foreach my $key (keys %hash) +# { +# print "$key => $hash{$key}\n"; +# } +#} +#-DEBUGGING-# + +sub inverse_hash +{ + my (%hash) = @_; + my (%inv); + foreach my $key (keys %hash) + { + my $val = $hash{$key}; + die "Double mapping for key value $val ($inv{$val}, $key)!" + if (defined $inv{$val}); + $inv{$val} = $key; + } + return %inv; +} + +sub fmt_value +{ + my ($num, $val) = @_; + if (!defined $val) + { + $val = "undef"; + } + elsif ($val !~ m/^[-+]?\d+$/) + { + # All the numbers in type_info_all are integers! + # Anything that isn't an integer is a string. + # Ensure that no double quotes screw things up. + $val =~ s/"/\\"/g if ($val =~ m/"/o); + $val = qq{"$val"}; + } + elsif ($dbi_inv{$num} =~ m/^(SQL_)?DATA_TYPE$/) + { + # All numeric... + $val = $sql_type_inv{$val} + if (defined $sql_type_inv{$val}); + } + return $val; +} + +sub write_typeinfo_pm +{ + my ($dsn, $user, $pass, $driver) = @_ ? @_ : @ARGV; + my $dbh = DBI->connect($dsn, $user, $pass, {AutoCommit=>1, RaiseError=>1}); + $driver = "<foo>" unless defined $driver; + + print <<PERL; + +# Transfer this to ${driver}.pm + +# The type_info_all function was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::db; # This line can be removed once transferred. + + sub type_info_all + { + my (\$dbh) = \@_; + require DBD::${driver}::TypeInfo; + return [ \@\$DBD::${driver}::TypeInfo::type_info_all ]; + } + +# Transfer this to lib/DBD/${driver}/TypeInfo.pm. +# Don't forget to add version and intellectual property control information. + +# The \%type_info_all hash was automatically generated by +# DBI::DBD::Metadata::write_typeinfo_pm v$DBI::DBD::Metadata::VERSION. + +package DBD::${driver}::TypeInfo; + +{ + require Exporter; + require DynaLoader; + \@ISA = qw(Exporter DynaLoader); + \@EXPORT = qw(type_info_all); + use DBI qw(:sql_types); + +PERL + + # Generate SQL type name mapping hashes. + # See code fragment in DBI specification. + my %sql_type_map; + foreach (@{$DBI::EXPORT_TAGS{sql_types}}) + { + no strict 'refs'; + $sql_type_map{$_} = &{"DBI::$_"}(); + $sql_type_inv{$sql_type_map{$_}} = $_; + } + #-DEBUG-# print_hash("sql_type_map", %sql_type_map); + #-DEBUG-# print_hash("sql_type_inv", %sql_type_inv); + + my %dbi_map = + ( + TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + FIXED_PREC_SCALE => 10, + AUTO_UNIQUE_VALUE => 11, + 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, + ); + + #-DEBUG-# print_hash("dbi_map", %dbi_map); + + %dbi_inv = inverse_hash(%dbi_map); + + #-DEBUG-# print_hash("dbi_inv", %dbi_inv); + + my $maxlen = 0; + foreach my $key (keys %dbi_map) + { + $maxlen = length($key) if length($key) > $maxlen; + } + + # Print the name/value mapping entry in the type_info_all array; + my $fmt = " \%-${maxlen}s => \%2d,\n"; + my $numkey = 0; + my $maxkey = 0; + print " \$type_info_all = [\n {\n"; + foreach my $i (sort { $a <=> $b } keys %dbi_inv) + { + printf($fmt, $dbi_inv{$i}, $i); + $numkey++; + $maxkey = $i; + } + print " },\n"; + + print STDERR "### WARNING - Non-dense set of keys ($numkey keys, $maxkey max key)\n" + unless $numkey = $maxkey + 1; + + my $h = $dbh->type_info_all; + my @tia = @$h; + my %odbc_map = map { uc $_ => $tia[0]->{$_} } keys %{$tia[0]}; + shift @tia; # Remove the mapping reference. + my $numtyp = $#tia; + + #-DEBUG-# print_hash("odbc_map", %odbc_map); + + # In theory, the key/number mapping sequence for %dbi_map + # should be the same as the one from the ODBC driver. However, to + # prevent the possibility of mismatches, and to deal with older + # missing attributes or unexpected new ones, we chase back through + # the %dbi_inv and %odbc_map hashes, generating @dbi_to_odbc + # to map our new key number to the old one. + # Report if @dbi_to_odbc is not an identity mapping. + my @dbi_to_odbc; + foreach my $num (sort { $a <=> $b } keys %dbi_inv) + { + # Find the name in %dbi_inv that matches this index number. + my $dbi_key = $dbi_inv{$num}; + #-DEBUG-# print "dbi_key = $dbi_key\n"; + #-DEBUG-# print "odbc_key = $odbc_map{$dbi_key}\n"; + # Find the index in %odbc_map that has this key. + $dbi_to_odbc[$num] = (defined $odbc_map{$dbi_key}) ? $odbc_map{$dbi_key} : undef; + } + + # Determine the length of the longest formatted value in each field + my @len; + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + #-DEBUG-# print "val = $val\n"; + $val = "$val,"; + $len[$num] = length($val) if !defined $len[$num] || length($val) > $len[$num]; + } + } + + # Generate format strings to left justify each string in maximum field width. + my @fmt; + for (my $i = 0; $i <= $maxkey; $i++) + { + $fmt[$i] = "%-$len[$i]s"; + #-DEBUG-# print "fmt[$i] = $fmt[$i]\n"; + } + + # Format the data from type_info_all + for (my $i = 0; $i <= $numtyp; $i++) + { + my @odbc_val = @{$tia[$i]}; + print " [ "; + for (my $num = 0; $num <= $maxkey; $num++) + { + # Find the value of the entry in the @odbc_val array. + my $val = (defined $dbi_to_odbc[$num]) ? $odbc_val[$dbi_to_odbc[$num]] : undef; + $val = fmt_value($num, $val); + printf $fmt[$num], "$val,"; + } + print " ],\n"; + } + + print " ];\n\n 1;\n}\n\n__END__\n"; + +} + +1; + +__END__ + +=head1 AUTHORS + +Jonathan Leffler <jleffler@us.ibm.com> (previously <jleffler@informix.com>), +Jochen Wiedmann <joe@ispsoft.de>, +Steffen Goeldner <sgoeldner@cpan.org>, +and Tim Bunce <dbi-users@perl.org>. + +=cut diff --git a/lib/DBI/DBD/SqlEngine.pm b/lib/DBI/DBD/SqlEngine.pm new file mode 100644 index 0000000..ae5c115 --- /dev/null +++ b/lib/DBI/DBD/SqlEngine.pm @@ -0,0 +1,1232 @@ +# -*- perl -*- +# +# DBI::DBD::SqlEngine - A base class for implementing DBI drivers that +# have not an own SQL engine +# +# This module is currently maintained by +# +# H.Merijn Brand & Jens Rehsack +# +# The original author is Jochen Wiedmann. +# +# Copyright (C) 2009,2010 by H.Merijn Brand & Jens Rehsack +# Copyright (C) 2004 by Jeff Zucker +# Copyright (C) 1998 by Jochen Wiedmann +# +# All rights reserved. +# +# You may distribute this module under the terms of either the GNU +# General Public License or the Artistic License, as specified in +# the Perl README file. + +require 5.008; + +use strict; + +use DBI (); +require DBI::SQL::Nano; + +package DBI::DBD::SqlEngine; + +use strict; + +use Carp; +use vars qw( @ISA $VERSION $drh %methods_installed); + +$VERSION = "0.03"; + +$drh = undef; # holds driver handle(s) once initialized + +DBI->setup_driver("DBI::DBD::SqlEngine"); # only needed once but harmless to repeat + +my %accessors = ( versions => "get_driver_versions", ); + +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + + # Drivers typically use a singleton object for the $drh + # We use a hash here to have one singleton per subclass. + # (Otherwise DBD::CSV and DBD::DBM, for example, would + # share the same driver object which would cause problems.) + # An alternative would be not not cache the $drh here at all + # and require that subclasses do that. Subclasses should do + # their own caching, so caching here just provides extra safety. + $drh->{$class} and return $drh->{$class}; + + $attr ||= {}; + { + no strict "refs"; + unless ( $attr->{Attribution} ) + { + $class eq "DBI::DBD::SqlEngine" + and $attr->{Attribution} = "$class by Jens Rehsack"; + $attr->{Attribution} ||= ${ $class . "::ATTRIBUTION" } + || "oops the author of $class forgot to define this"; + } + $attr->{Version} ||= ${ $class . "::VERSION" }; + $attr->{Name} or ( $attr->{Name} = $class ) =~ s/^DBD\:\://; + } + + $drh->{$class} = DBI::_new_drh( $class . "::dr", $attr ); + $drh->{$class}->STORE( ShowErrorStatement => 1 ); + + my $prefix = DBI->driver_prefix($class); + if ($prefix) + { + my $dbclass = $class . "::db"; + while ( my ( $accessor, $funcname ) = each %accessors ) + { + my $method = $prefix . $accessor; + $dbclass->can($method) and next; + my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname; +sub %s::%s +{ + my $func = %s->can (q{%s}); + goto &$func; + } +EOI + eval $inject; + $dbclass->install_method($method); + } + } + + # XXX inject DBD::XXX::Statement unless exists + + my $stclass = $class . "::st"; + $stclass->install_method("sql_get_colnames") unless ( $methods_installed{$class}++ ); + + return $drh->{$class}; +} # driver + +sub CLONE +{ + undef $drh; +} # CLONE + +# ====== DRIVER ================================================================ + +package DBI::DBD::SqlEngine::dr; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +$imp_data_size = 0; + +sub connect ($$;$$$) +{ + my ( $drh, $dbname, $user, $auth, $attr ) = @_; + + # create a 'blank' dbh + my $dbh = DBI::_new_dbh( + $drh, + { + Name => $dbname, + USER => $user, + CURRENT_USER => $user, + } + ); + + if ($dbh) + { + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->func( 0, "init_default_attributes" ); + my $two_phased_init; + defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase}; + my %second_phase_attrs; + + my ( $var, $val ); + while ( length $dbname ) + { + if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s ) + { + $var = $1; + } + else + { + $var = $dbname; + $dbname = ""; + } + if ( $var =~ m/^(.+?)=(.*)/s ) + { + $var = $1; + ( $val = $2 ) =~ s/\\(.)/$1/g; + if ($two_phased_init) + { + eval { $dbh->STORE( $var, $val ); }; + $@ and $second_phase_attrs{$var} = $val; + } + else + { + $dbh->STORE( $var, $val ); + } + } + elsif ( $var =~ m/^(.+?)=>(.*)/s ) + { + $var = $1; + ( $val = $2 ) =~ s/\\(.)/$1/g; + my $ref = eval $val; + $dbh->$var($ref); + } + } + + if ($two_phased_init) + { + foreach $a (qw(Profile RaiseError PrintError AutoCommit)) + { # do these first + exists $attr->{$a} or next; + eval { + $dbh->{$a} = $attr->{$a}; + delete $attr->{$a}; + }; + $@ and $second_phase_attrs{$a} = delete $attr->{$a}; + } + while ( my ( $a, $v ) = each %$attr ) + { + eval { $dbh->{$a} = $v }; + $@ and $second_phase_attrs{$a} = $v; + } + + $dbh->func( 1, "init_default_attributes" ); + %$attr = %second_phase_attrs; + } + + $dbh->func("init_done"); + + $dbh->STORE( Active => 1 ); + } + + return $dbh; +} # connect + +sub disconnect_all +{ +} # disconnect_all + +sub DESTROY +{ + undef; +} # DESTROY + +# ====== DATABASE ============================================================== + +package DBI::DBD::SqlEngine::db; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +use Carp; + +if ( eval { require Clone; } ) +{ + Clone->import("clone"); +} +else +{ + require Storable; # in CORE since 5.7.3 + *clone = \&Storable::dclone; +} + +$imp_data_size = 0; + +sub ping +{ + ( $_[0]->FETCH("Active") ) ? 1 : 0; +} # ping + +sub prepare ($$;@) +{ + my ( $dbh, $statement, @attribs ) = @_; + + # create a 'blank' sth + my $sth = DBI::_new_sth( $dbh, { Statement => $statement } ); + + if ($sth) + { + my $class = $sth->FETCH("ImplementorClass"); + $class =~ s/::st$/::Statement/; + my $stmt; + + # if using SQL::Statement version > 1 + # cache the parser object if the DBD supports parser caching + # SQL::Nano and older SQL::Statements don't support this + + if ( $class->isa("SQL::Statement") ) + { + my $parser = $dbh->{sql_parser_object}; + $parser ||= eval { $dbh->func("sql_parser_object") }; + if ($@) + { + $stmt = eval { $class->new($statement) }; + } + else + { + $stmt = eval { $class->new( $statement, $parser ) }; + } + } + else + { + $stmt = eval { $class->new($statement) }; + } + if ($@ || $stmt->{errstr}) + { + $dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} ); + undef $sth; + } + else + { + $sth->STORE( "sql_stmt", $stmt ); + $sth->STORE( "sql_params", [] ); + $sth->STORE( "NUM_OF_PARAMS", scalar( $stmt->params() ) ); + my @colnames = $sth->sql_get_colnames(); + $sth->STORE( "NUM_OF_FIELDS", scalar @colnames ); + } + } + return $sth; +} # prepare + +sub set_versions +{ + my $dbh = $_[0]; + $dbh->{sql_engine_version} = $DBI::DBD::SqlEngine::VERSION; + for (qw( nano_version statement_version )) + { + defined $DBI::SQL::Nano::versions->{$_} or next; + $dbh->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_}; + } + $dbh->{sql_handler} = + $dbh->{sql_statement_version} + ? "SQL::Statement" + : "DBI::SQL::Nano"; + + return $dbh; +} # set_versions + +sub init_valid_attributes +{ + my $dbh = $_[0]; + + $dbh->{sql_valid_attrs} = { + sql_engine_version => 1, # DBI::DBD::SqlEngine version + sql_handler => 1, # Nano or S:S + sql_nano_version => 1, # Nano version + sql_statement_version => 1, # S:S version + sql_flags => 1, # flags for SQL::Parser + sql_dialect => 1, # dialect for SQL::Parser + sql_quoted_identifier_case => 1, # case for quoted identifiers + sql_identifier_case => 1, # case for non-quoted identifiers + sql_parser_object => 1, # SQL::Parser instance + sql_sponge_driver => 1, # Sponge driver for table_info () + sql_valid_attrs => 1, # SQL valid attributes + sql_readonly_attrs => 1, # SQL readonly attributes + sql_init_phase => 1, # Only during initialization + }; + $dbh->{sql_readonly_attrs} = { + sql_engine_version => 1, # DBI::DBD::SqlEngine version + sql_handler => 1, # Nano or S:S + sql_nano_version => 1, # Nano version + sql_statement_version => 1, # S:S version + sql_quoted_identifier_case => 1, # case for quoted identifiers + sql_parser_object => 1, # SQL::Parser instance + sql_sponge_driver => 1, # Sponge driver for table_info () + sql_valid_attrs => 1, # SQL valid attributes + sql_readonly_attrs => 1, # SQL readonly attributes + }; + + return $dbh; +} # init_valid_attributes + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + my $given_phase = $phase; + + unless ( defined($phase) ) + { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if ( 0 == $phase ) + { + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->func("init_valid_attributes"); + + $dbh->func("set_versions"); + + $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER + $dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE + + $dbh->{sql_dialect} = "CSV"; + + $dbh->{sql_init_phase} = $given_phase; + + # complete derived attributes, if required + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + my $valid_attrs = $drv_prefix . "valid_attrs"; + my $ro_attrs = $drv_prefix . "readonly_attrs"; + + my @comp_attrs = qw(valid_attrs version readonly_attrs); + + foreach my $comp_attr (@comp_attrs) + { + my $attr = $drv_prefix . $comp_attr; + defined $dbh->{$valid_attrs} + and !defined $dbh->{$valid_attrs}{$attr} + and $dbh->{$valid_attrs}{$attr} = 1; + defined $dbh->{$ro_attrs} + and !defined $dbh->{$ro_attrs}{$attr} + and $dbh->{$ro_attrs}{$attr} = 1; + } + } + + return $dbh; +} # init_default_attributes + +sub init_done +{ + defined $_[0]->{sql_init_phase} and delete $_[0]->{sql_init_phase}; + delete $_[0]->{sql_valid_attrs}->{sql_init_phase}; + return; +} + +sub sql_parser_object +{ + my $dbh = $_[0]; + my $dialect = $dbh->{sql_dialect} || "CSV"; + my $parser = { + RaiseError => $dbh->FETCH("RaiseError"), + PrintError => $dbh->FETCH("PrintError"), + }; + my $sql_flags = $dbh->FETCH("sql_flags") || {}; + %$parser = ( %$parser, %$sql_flags ); + $parser = SQL::Parser->new( $dialect, $parser ); + $dbh->{sql_parser_object} = $parser; + return $parser; +} # sql_parser_object + +sub sql_sponge_driver +{ + my $dbh = $_[0]; + my $dbh2 = $dbh->{sql_sponge_driver}; + unless ($dbh2) + { + $dbh2 = $dbh->{sql_sponge_driver} = DBI->connect("DBI:Sponge:"); + unless ($dbh2) + { + $dbh->set_err( $DBI::stderr, $DBI::errstr ); + return; + } + } +} + +sub disconnect ($) +{ + $_[0]->STORE( Active => 0 ); + return 1; +} # disconnect + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + return $attrib; +} + +sub FETCH ($$) +{ + my ( $dbh, $attrib ) = @_; + $attrib eq "AutoCommit" + and return 1; + + # Driver private attributes are lower cased + if ( $attrib eq ( lc $attrib ) ) + { + # first let the implementation deliver an alias for the attribute to fetch + # after it validates the legitimation of the fetch request + $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return; + + my $attr_prefix; + $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; + unless ($attr_prefix) + { + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + $attr_prefix = DBI->driver_prefix($drv_class); + $attrib = $attr_prefix . $attrib; + } + my $valid_attrs = $attr_prefix . "valid_attrs"; + my $ro_attrs = $attr_prefix . "readonly_attrs"; + + exists $dbh->{$valid_attrs} + and ( $dbh->{$valid_attrs}{$attrib} + or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); + exists $dbh->{$ro_attrs} + and $dbh->{$ro_attrs}{$attrib} + and defined $dbh->{$attrib} + and refaddr( $dbh->{$attrib} ) + and return clone( $dbh->{$attrib} ); + + return $dbh->{$attrib}; + } + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); +} # FETCH + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "sql_identifier_case" || $attrib eq "sql_quoted_identifier_case" + and $value < 1 || $value > 4 ) + { + croak "attribute '$attrib' must have a value from 1 .. 4 (SQL_IC_UPPER .. SQL_IC_MIXED)"; + # XXX correctly a remap of all entries in f_meta/f_meta_map is required here + } + + return ( $attrib, $value ); +} + +# the ::db::STORE method is what gets called when you set +# a lower-cased database handle attribute such as $dbh->{somekey}=$someval; +# +# STORE should check to make sure that "somekey" is a valid attribute name +# but only if it is really one of our attributes (starts with dbm_ or foo_) +# You can also check for valid values for the attributes if needed +# and/or perform other operations +# +sub STORE ($$$) +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "AutoCommit" ) + { + $value and return 1; # is already set + croak "Can't disable AutoCommit"; + } + + if ( $attrib eq lc $attrib ) + { + # Driver private attributes are lower cased + + my $attr_prefix; + $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; + unless ($attr_prefix) + { + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + $attr_prefix = DBI->driver_prefix($drv_class); + $attrib = $attr_prefix . $attrib; + } + my $valid_attrs = $attr_prefix . "valid_attrs"; + my $ro_attrs = $attr_prefix . "readonly_attrs"; + + ( $attrib, $value ) = $dbh->func( $attrib, $value, "validate_STORE_attr" ); + $attrib or return; + + exists $dbh->{$valid_attrs} + and ( $dbh->{$valid_attrs}{$attrib} + or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); + exists $dbh->{$ro_attrs} + and $dbh->{$ro_attrs}{$attrib} + and defined $dbh->{$attrib} + and return $dbh->set_err( $DBI::stderr, + "attribute '$attrib' is readonly and must not be modified" ); + + $dbh->{$attrib} = $value; + return 1; + } + + return $dbh->SUPER::STORE( $attrib, $value ); +} # STORE + +sub get_driver_versions +{ + my ( $dbh, $table ) = @_; + my %vsn = ( + OS => "$^O ($Config::Config{osvers})", + Perl => "$] ($Config::Config{archname})", + DBI => $DBI::VERSION, + ); + my %vmp; + + my $sql_engine_verinfo = + join " ", + $dbh->{sql_engine_version}, "using", $dbh->{sql_handler}, + $dbh->{sql_handler} eq "SQL::Statement" + ? $dbh->{sql_statement_version} + : $dbh->{sql_nano_version}; + + my $indent = 0; + my @deriveds = ( $dbh->{ImplementorClass} ); + while (@deriveds) + { + my $derived = shift @deriveds; + $derived eq "DBI::DBD::SqlEngine::db" and last; + $derived->isa("DBI::DBD::SqlEngine::db") or next; + #no strict 'refs'; + eval "push \@deriveds, \@${derived}::ISA"; + #use strict; + ( my $drv_class = $derived ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + my $ddgv = $dbh->{ImplementorClass}->can("get_${drv_prefix}versions"); + my $drv_version = $ddgv ? &$ddgv( $dbh, $table ) : $dbh->{ $drv_prefix . "version" }; + $drv_version ||= eval { $derived->VERSION() }; # XXX access $drv_class::VERSION via symbol table + $vsn{$drv_class} = $drv_version; + $indent and $vmp{$drv_class} = " " x $indent . $drv_class; + $indent += 2; + } + + $vsn{"DBI::DBD::SqlEngine"} = $sql_engine_verinfo; + $indent and $vmp{"DBI::DBD::SqlEngine"} = " " x $indent . "DBI::DBD::SqlEngine"; + + $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION; + + $indent += 20; + my @versions = map { sprintf "%-${indent}s %s", $vmp{$_} || $_, $vsn{$_} } + sort { + $a->isa($b) and return -1; + $b->isa($a) and return 1; + $a->isa("DBI::DBD::SqlEngine") and return -1; + $b->isa("DBI::DBD::SqlEngine") and return 1; + return $a cmp $b; + } keys %vsn; + + return wantarray ? @versions : join "\n", @versions; +} # get_versions + +sub DESTROY ($) +{ + my $dbh = shift; + $dbh->SUPER::FETCH("Active") and $dbh->disconnect; + undef $dbh->{sql_parser_object}; +} # DESTROY + +sub type_info_all ($) +{ + [ + { + TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ "VARCHAR", DBI::SQL_VARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + [ "CHAR", DBI::SQL_CHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + [ "INTEGER", DBI::SQL_INTEGER(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], + [ "REAL", DBI::SQL_REAL(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], + [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + [ "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + [ "TEXT", DBI::SQL_LONGVARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + ]; +} # type_info_all + +sub get_avail_tables +{ + my $dbh = $_[0]; + my @tables = (); + + if ( $dbh->{sql_handler} eq "SQL::Statement" and $dbh->{sql_ram_tables} ) + { + foreach my $table ( keys %{ $dbh->{sql_ram_tables} } ) + { + push @tables, [ undef, undef, $table, "TABLE", "TEMP" ]; + } + } + + return @tables; +} # get_avail_tables + +{ + my $names = [qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )]; + + sub table_info ($) + { + my $dbh = shift; + + my @tables = $dbh->func("get_avail_tables"); + + # Temporary kludge: DBD::Sponge dies if @tables is empty. :-( + @tables or return; + + my $dbh2 = $dbh->func("sql_sponge_driver"); + my $sth = $dbh2->prepare( + "TABLE_INFO", + { + rows => \@tables, + NAMES => $names, + } + ); + $sth or $dbh->set_err( $DBI::stderr, $dbh2->errstr ); + return $sth; + } # table_info +} + +sub list_tables ($) +{ + my $dbh = shift; + my @table_list; + + my @tables = $dbh->func("get_avail_tables") or return; + foreach my $ref (@tables) + { + # rt69260 and rt67223 - the same issue in 2 different queues + push @table_list, $ref->[2]; + } + + return @table_list; +} # list_tables + +sub quote ($$;$) +{ + my ( $self, $str, $type ) = @_; + defined $str or return "NULL"; + defined $type && ( $type == DBI::SQL_NUMERIC() + || $type == DBI::SQL_DECIMAL() + || $type == DBI::SQL_INTEGER() + || $type == DBI::SQL_SMALLINT() + || $type == DBI::SQL_FLOAT() + || $type == DBI::SQL_REAL() + || $type == DBI::SQL_DOUBLE() + || $type == DBI::SQL_TINYINT() ) + and return $str; + + $str =~ s/\\/\\\\/sg; + $str =~ s/\0/\\0/sg; + $str =~ s/\'/\\\'/sg; + $str =~ s/\n/\\n/sg; + $str =~ s/\r/\\r/sg; + return "'$str'"; +} # quote + +sub commit ($) +{ + my $dbh = shift; + $dbh->FETCH("Warn") + and carp "Commit ineffective while AutoCommit is on", -1; + return 1; +} # commit + +sub rollback ($) +{ + my $dbh = shift; + $dbh->FETCH("Warn") + and carp "Rollback ineffective while AutoCommit is on", -1; + return 0; +} # rollback + +# ====== STATEMENT ============================================================= + +package DBI::DBD::SqlEngine::st; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +$imp_data_size = 0; + +sub bind_param ($$$;$) +{ + my ( $sth, $pNum, $val, $attr ) = @_; + if ( $attr && defined $val ) + { + my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr; + if ( $type == DBI::SQL_BIGINT() + || $type == DBI::SQL_INTEGER() + || $type == DBI::SQL_SMALLINT() + || $type == DBI::SQL_TINYINT() ) + { + $val += 0; + } + elsif ( $type == DBI::SQL_DECIMAL() + || $type == DBI::SQL_DOUBLE() + || $type == DBI::SQL_FLOAT() + || $type == DBI::SQL_NUMERIC() + || $type == DBI::SQL_REAL() ) + { + $val += 0.; + } + else + { + $val = "$val"; + } + } + $sth->{sql_params}[ $pNum - 1 ] = $val; + return 1; +} # bind_param + +sub execute +{ + my $sth = shift; + my $params = @_ ? ( $sth->{sql_params} = [@_] ) : $sth->{sql_params}; + + $sth->finish; + my $stmt = $sth->{sql_stmt}; + unless ( $sth->{sql_params_checked}++ ) + { + # bug in SQL::Statement 1.20 and below causes breakage + # on all but the first call + unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) ) + { + my $msg = "You passed $nparm parameters where $req_prm required"; + $sth->set_err( $DBI::stderr, $msg ); + return; + } + } + my @err; + my $result; + eval { + local $SIG{__WARN__} = sub { push @err, @_ }; + $result = $stmt->execute( $sth, $params ); + }; + unless ( defined $result ) + { + $sth->set_err( $DBI::stderr, $@ || $stmt->{errstr} || $err[0] ); + return; + } + + if ( $stmt->{NUM_OF_FIELDS} ) + { # is a SELECT statement + $sth->STORE( Active => 1 ); + $sth->FETCH("NUM_OF_FIELDS") + or $sth->STORE( "NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS} ); + } + return $result; +} # execute + +sub finish +{ + my $sth = $_[0]; + $sth->SUPER::STORE( Active => 0 ); + delete $sth->{sql_stmt}{data}; + return 1; +} # finish + +sub fetch ($) +{ + my $sth = $_[0]; + my $data = $sth->{sql_stmt}{data}; + if ( !$data || ref $data ne "ARRAY" ) + { + $sth->set_err( + $DBI::stderr, + "Attempt to fetch row without a preceeding execute () call or from a non-SELECT statement" + ); + return; + } + my $dav = shift @$data; + unless ($dav) + { + $sth->finish; + return; + } + if ( $sth->FETCH("ChopBlanks") ) # XXX: (TODO) Only chop on CHAR fields, + { # not on VARCHAR or NUMERIC (see DBI docs) + $_ && $_ =~ s/ +$// for @$dav; + } + return $sth->_set_fbav($dav); +} # fetch + +no warnings 'once'; +*fetchrow_arrayref = \&fetch; + +use warnings; + +sub sql_get_colnames +{ + my $sth = $_[0]; + # Being a bit dirty here, as neither SQL::Statement::Structure nor + # DBI::SQL::Nano::Statement_ does not offer an interface to the + # required data + my @colnames; + if ( $sth->{sql_stmt}->{NAME} and "ARRAY" eq ref( $sth->{sql_stmt}->{NAME} ) ) + { + @colnames = @{ $sth->{sql_stmt}->{NAME} }; + } + elsif ( $sth->{sql_stmt}->isa('SQL::Statement') ) + { + my $stmt = $sth->{sql_stmt} || {}; + my @coldefs = @{ $stmt->{column_defs} || [] }; + @colnames = map { $_->{name} || $_->{value} } @coldefs; + } + @colnames = $sth->{sql_stmt}->column_names() unless (@colnames); + + @colnames = () if ( grep { m/\*/ } @colnames ); + + return @colnames; +} + +sub FETCH ($$) +{ + my ( $sth, $attrib ) = @_; + + $attrib eq "NAME" and return [ $sth->sql_get_colnames() ]; + + $attrib eq "TYPE" and return [ (DBI::SQL_VARCHAR()) x scalar $sth->sql_get_colnames() ]; + $attrib eq "TYPE_NAME" and return [ ("VARCHAR") x scalar $sth->sql_get_colnames() ]; + $attrib eq "PRECISION" and return [ (0) x scalar $sth->sql_get_colnames() ]; + $attrib eq "NULLABLE" and return [ (1) x scalar $sth->sql_get_colnames() ]; + + if ( $attrib eq lc $attrib ) + { + # Private driver attributes are lower cased + return $sth->{$attrib}; + } + + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); +} # FETCH + +sub STORE ($$$) +{ + my ( $sth, $attrib, $value ) = @_; + if ( $attrib eq lc $attrib ) # Private driver attributes are lower cased + { + $sth->{$attrib} = $value; + return 1; + } + return $sth->SUPER::STORE( $attrib, $value ); +} # STORE + +sub DESTROY ($) +{ + my $sth = shift; + $sth->SUPER::FETCH("Active") and $sth->finish; + undef $sth->{sql_stmt}; + undef $sth->{sql_params}; +} # DESTROY + +sub rows ($) +{ + return $_[0]->{sql_stmt}{NUM_OF_ROWS}; +} # rows + +# ====== SQL::STATEMENT ======================================================== + +package DBI::DBD::SqlEngine::Statement; + +use strict; +use warnings; + +use Carp; + +@DBI::DBD::SqlEngine::Statement::ISA = qw(DBI::SQL::Nano::Statement); + +# ====== SQL::TABLE ============================================================ + +package DBI::DBD::SqlEngine::Table; + +use strict; +use warnings; + +@DBI::DBD::SqlEngine::Table::ISA = qw(DBI::SQL::Nano::Table); + +=pod + +=head1 NAME + +DBI::DBD::SqlEngine - Base class for DBI drivers without their own SQL engine + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBI::DBD::SqlEngine); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + package DBD::myDriver::dr; + + @ISA = qw(DBI::DBD::SqlEngine::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBI::DBD::SqlEngine::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + sub get_avail_tables { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBI::DBD::SqlEngine::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + sub open_table { ... } + + package DBD::myDriver::Table; + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + sub new { ... } + +=head1 DESCRIPTION + +DBI::DBD::SqlEngine abstracts the usage of SQL engines from the +DBD. DBD authors can concentrate on the data retrieval they want to +provide. + +It is strongly recommended that you read L<DBD::File::Developers> and +L<DBD::File::Roadmap>, because many of the DBD::File API is provided +by DBI::DBD::SqlEngine. + +Currently the API of DBI::DBD::SqlEngine is experimental and will +likely change in the near future to provide the table meta data basics +like DBD::File. + +=head2 Metadata + +The following attributes are handled by DBI itself and not by +DBI::DBD::SqlEngine, thus they all work as expected: + + Active + ActiveKids + CachedKids + CompatMode (Not used) + InactiveDestroy + AutoInactiveDestroy + Kids + PrintError + RaiseError + Warn (Not used) + +=head3 The following DBI attributes are handled by DBI::DBD::SqlEngine: + +=head4 AutoCommit + +Always on. + +=head4 ChopBlanks + +Works. + +=head4 NUM_OF_FIELDS + +Valid after C<< $sth->execute >>. + +=head4 NUM_OF_PARAMS + +Valid after C<< $sth->prepare >>. + +=head4 NAME + +Valid after C<< $sth->execute >>; probably undef for Non-Select statements. + +=head4 NULLABLE + +Not really working, always returns an array ref of ones, as DBD::CSV +does not verify input data. Valid after C<< $sth->execute >>; undef for +non-select statements. + +=head3 The following DBI attributes and methods are not supported: + +=over 4 + +=item bind_param_inout + +=item CursorName + +=item LongReadLen + +=item LongTruncOk + +=back + +=head3 DBI::DBD::SqlEngine specific attributes + +In addition to the DBI attributes, you can use the following dbh +attributes: + +=head4 sql_engine_version + +Contains the module version of this driver (B<readonly>) + +=head4 sql_nano_version + +Contains the module version of DBI::SQL::Nano (B<readonly>) + +=head4 sql_statement_version + +Contains the module version of SQL::Statement, if available (B<readonly>) + +=head4 sql_handler + +Contains the SQL Statement engine, either DBI::SQL::Nano or SQL::Statement +(B<readonly>). + +=head4 sql_parser_object + +Contains an instantiated instance of SQL::Parser (B<readonly>). +This is filled when used first time (only when used with SQL::Statement). + +=head4 sql_sponge_driver + +Contains an internally used DBD::Sponge handle (B<readonly>). + +=head4 sql_valid_attrs + +Contains the list of valid attributes for each DBI::DBD::SqlEngine based +driver (B<readonly>). + +=head4 sql_readonly_attrs + +Contains the list of those attributes which are readonly (B<readonly>). + +=head4 sql_identifier_case + +Contains how DBI::DBD::SqlEngine deals with non-quoted SQL identifiers: + + * SQL_IC_UPPER (1) means all identifiers are internally converted + into upper-cased pendants + * SQL_IC_LOWER (2) means all identifiers are internally converted + into lower-cased pendants + * SQL_IC_MIXED (4) means all identifiers are taken as they are + +These conversions happen if (and only if) no existing identifier matches. +Once existing identifier is used as known. + +The SQL statement execution classes doesn't have to care, so don't expect +C<sql_identifier_case> affects column names in statements like + + SELECT * FROM foo + +=head4 sql_quoted_identifier_case + +Contains how DBI::DBD::SqlEngine deals with quoted SQL identifiers +(B<readonly>). It's fixated to SQL_IC_SENSITIVE (3), which is interpreted +as SQL_IC_MIXED. + +=head4 sql_flags + +Contains additional flags to instantiate an SQL::Parser. Because an +SQL::Parser is instantiated only once, it's recommended to set this flag +before any statement is executed. + +=head4 sql_dialect + +Controls the dialect understood by SQL::Parser. Possible values (delivery +state of SQL::Statement): + + * ANSI + * CSV + * AnyData + +Defaults to "CSV". Because an SQL::Parser is instantiated only once and +SQL::Parser doesn't allow to modify the dialect once instantiated, +it's strongly recommended to set this flag before any statement is +executed (best place is connect attribute hash). + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc DBI::DBD::SqlEngine + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBI> +L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=SQL-Statement> + +=item * AnnoCPAN: Annotated CPAN documentation + +L<http://annocpan.org/dist/DBI> +L<http://annocpan.org/dist/SQL-Statement> + +=item * CPAN Ratings + +L<http://cpanratings.perl.org/d/DBI> + +=item * Search CPAN + +L<http://search.cpan.org/dist/DBI/> + +=back + +=head2 Where can I go for more help? + +For questions about installation or usage, please ask on the +dbi-dev@perl.org mailing list. + +If you have a bug report, patch or suggestion, please open +a new report ticket on CPAN, if there is not already one for +the issue you want to report. Of course, you can mail any of the +module maintainers, but it is less likely to be missed if +it is reported on RT. + +Report tickets should contain a detailed description of the bug or +enhancement request you want to report and at least an easy way to +verify/reproduce the issue and any supplied fix. Patches are always +welcome, too. + +=head1 ACKNOWLEDGEMENTS + +Thanks to Tim Bunce, Martin Evans and H.Merijn Brand for their continued +support while developing DBD::File, DBD::DBM and DBD::AnyData. +Their support, hints and feedback helped to design and implement this +module. + +=head1 AUTHOR + +This module is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +The original authors are Jochen Wiedmann and Jeff Zucker. + +=head1 COPYRIGHT AND LICENSE + + Copyright (C) 2009-2010 by H.Merijn Brand & Jens Rehsack + Copyright (C) 2004-2009 by Jeff Zucker + Copyright (C) 1998-2004 by Jochen Wiedmann + +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. + +=head1 SEE ALSO + +L<DBI>, L<DBD::File>, L<DBD::AnyData> and L<DBD::Sys>. + +=cut diff --git a/lib/DBI/DBD/SqlEngine/Developers.pod b/lib/DBI/DBD/SqlEngine/Developers.pod new file mode 100644 index 0000000..2ee3a5f --- /dev/null +++ b/lib/DBI/DBD/SqlEngine/Developers.pod @@ -0,0 +1,422 @@ +=head1 NAME + +DBI::DBD::SqlEngine::Developers - Developers documentation for DBI::DBD::SqlEngine + +=head1 SYNOPSIS + + package DBD::myDriver; + + use base qw(DBI::DBD::SqlEngine); + + sub driver + { + ... + my $drh = $proto->SUPER::driver($attr); + ... + return $drh->{class}; + } + + sub CLONE { ... } + + package DBD::myDriver::dr; + + @ISA = qw(DBI::DBD::SqlEngine::dr); + + sub data_sources { ... } + ... + + package DBD::myDriver::db; + + @ISA = qw(DBI::DBD::SqlEngine::db); + + sub init_valid_attributes { ... } + sub init_default_attributes { ... } + sub set_versions { ... } + sub validate_STORE_attr { my ($dbh, $attrib, $value) = @_; ... } + sub validate_FETCH_attr { my ($dbh, $attrib) = @_; ... } + sub get_myd_versions { ... } + sub get_avail_tables { ... } + + package DBD::myDriver::st; + + @ISA = qw(DBI::DBD::SqlEngine::st); + + sub FETCH { ... } + sub STORE { ... } + + package DBD::myDriver::Statement; + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + sub open_table { ... } + + package DBD::myDriver::Table; + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + sub new { ... } + + sub fetch_row { ... } + sub push_row { ... } + sub push_names { ... } + sub seek { ... } + sub truncate { ... } + sub drop { ... } + + # optimize the SQL engine by add one or more of + sub update_current_row { ... } + # or + sub update_specific_row { ... } + # or + sub update_one_row { ... } + # or + sub insert_new_row { ... } + # or + sub delete_current_row { ... } + # or + sub delete_one_row { ... } + +=head1 DESCRIPTION + +This document describes the interface of DBI::DBD::SqlEngine for DBD +developers who write DBI::DBD::SqlEngine based DBI drivers. It supplements +L<DBI::DBD> and L<DBI::DBD::SqlEngine::HowTo>, which you should read first. + +=head1 CLASSES + +Each DBI driver must provide a package global C<< driver >> method and +three DBI related classes: + +=over 4 + +=item DBI::DBD::SqlEngine::dr + +Driver package, contains the methods DBI calls indirectly via DBI +interface: + + DBI->connect ('DBI:DBM:', undef, undef, {}) + + # invokes + package DBD::DBM::dr; + @DBD::DBM::dr::ISA = qw(DBI::DBD::SqlEngine::dr); + + sub connect ($$;$$$) + { + ... + } + +Similar for C<< data_sources () >> and C<< disconnect_all() >>. + +Pure Perl DBI drivers derived from DBI::DBD::SqlEngine do not usually need to +override any of the methods provided through the DBD::XXX::dr package +however if you need additional initialization in the connect method +you may need to. + +=item DBI::DBD::SqlEngine::db + +Contains the methods which are called through DBI database handles +(C<< $dbh >>). e.g., + + $sth = $dbh->prepare ("select * from foo"); + # returns the f_encoding setting for table foo + $dbh->csv_get_meta ("foo", "f_encoding"); + +DBI::DBD::SqlEngine provides the typical methods required here. Developers who +write DBI drivers based on DBI::DBD::SqlEngine need to override the methods +C<< set_versions >> and C<< init_valid_attributes >>. + +=item DBI::DBD::SqlEngine::st + +Contains the methods to deal with prepared statement handles. e.g., + + $sth->execute () or die $sth->errstr; + +=back + +=head2 DBI::DBD::SqlEngine + +This is the main package containing the routines to initialize +DBI::DBD::SqlEngine based DBI drivers. Primarily the +C<< DBI::DBD::SqlEngine::driver >> method is invoked, either directly +from DBI when the driver is initialized or from the derived class. + + package DBD::DBM; + + use base qw( DBI::DBD::SqlEngine ); + + sub driver + { + my ( $class, $attr ) = @_; + ... + my $drh = $class->SUPER::driver( $attr ); + ... + return $drh; + } + +It is not necessary to implement your own driver method as long as +additional initialization (e.g. installing more private driver +methods) is not required. You do not need to call C<< setup_driver >> +as DBI::DBD::SqlEngine takes care of it. + +=head2 DBI::DBD::SqlEngine::dr + +The driver package contains the methods DBI calls indirectly via the DBI +interface (see L<DBI/DBI Class Methods>). + +DBI::DBD::SqlEngine based DBI drivers usually do not need to implement anything here, +it is enough to do the basic initialization: + + package DBD:XXX::dr; + + @DBD::XXX::dr::ISA = qw (DBI::DBD::SqlEngine::dr); + $DBD::XXX::dr::imp_data_size = 0; + $DBD::XXX::dr::data_sources_attr = undef; + $DBD::XXX::ATTRIBUTION = "DBD::XXX $DBD::XXX::VERSION by Hans Mustermann"; + +=head2 DBI::DBD::SqlEngine::db + +This package defines the database methods, which are called via the DBI +database handle C<< $dbh >>. + +Methods provided by DBI::DBD::SqlEngine: + +=over 4 + +=item ping + +Simply returns the content of the C<< Active >> attribute. Override +when your driver needs more complicated actions here. + +=item prepare + +Prepares a new SQL statement to execute. Returns a statement handle, +C<< $sth >> - instance of the DBD:XXX::st. It is neither required nor +recommended to override this method. + +=item FETCH + +Fetches an attribute of a DBI database object. Private handle attributes +must have a prefix (this is mandatory). If a requested attribute is +detected as a private attribute without a valid prefix, the driver prefix +(written as C<$drv_prefix>) is added. + +The driver prefix is extracted from the attribute name and verified against +C<< $dbh->{ $drv_prefix . "valid_attrs" } >> (when it exists). If the +requested attribute value is not listed as a valid attribute, this method +croaks. If the attribute is valid and readonly (listed in C<< $dbh->{ +$drv_prefix . "readonly_attrs" } >> when it exists), a real copy of the +attribute value is returned. So it's not possible to modify +C<f_valid_attrs> from outside of DBI::DBD::SqlEngine::db or a derived class. + +=item STORE + +Stores a database private attribute. Private handle attributes must have a +prefix (this is mandatory). If a requested attribute is detected as a private +attribute without a valid prefix, the driver prefix (written as +C<$drv_prefix>) is added. If the database handle has an attribute +C<${drv_prefix}_valid_attrs> - for attribute names which are not listed in +that hash, this method croaks. If the database handle has an attribute +C<${drv_prefix}_readonly_attrs>, only attributes which are not listed there +can be stored (once they are initialized). Trying to overwrite such an +immutable attribute forces this method to croak. + +An example of a valid attributes list can be found in +C<< DBI::DBD::SqlEngine::db::init_valid_attributes >>. + +=item set_versions + +This method sets the attributes C<< f_version >>, C<< sql_nano_version >>, +C<< sql_statement_version >> and (if not prohibited by a restrictive +C<< ${prefix}_valid_attrs >>) C<< ${prefix}_version >>. + +This method is called at the end of the C<< connect () >> phase. + +When overriding this method, do not forget to invoke the superior one. + +=item init_valid_attributes + +This method is called after the database handle is instantiated as the +first attribute initialization. + +C<< DBI::DBD::SqlEngine::db::init_valid_attributes >> initializes the +attributes C<sql_valid_attrs> and C<sql_readonly_attrs>. + +When overriding this method, do not forget to invoke the superior one, +preferably before doing anything else. + +=item init_default_attributes + +This method is called after the database handle is instantiated to +initialize the default attributes. + +C<< DBI::DBD::SqlEngine::db::init_default_attributes >> initializes the +attributes C<sql_identifier_case>, C<sql_quoted_identifier_case>, +C<sql_handler>, C<sql_engine_version>, C<sql_nano_version> and +C<sql_statement_version> when L<SQL::Statement> is available. + +When the derived implementor class provides the attribute to validate +attributes (e.g. C<< $dbh->{dbm_valid_attrs} = {...}; >>) or the attribute +containing the immutable attributes (e.g. C<< $dbh->{dbm_readonly_attrs} += {...}; >>), the attributes C<drv_valid_attrs>, C<drv_readonly_attrs> and +C<drv_version> are added (when available) to the list of valid and +immutable attributes (where C<drv_> is interpreted as the driver prefix). + +=item get_versions + +This method is called by the code injected into the instantiated driver to +provide the user callable driver method C<< ${prefix}versions >> (e.g. +C<< dbm_versions >>, C<< csv_versions >>, ...). + +The DBI::DBD::SqlEngine implementation returns all version information known by +DBI::DBD::SqlEngine (e.g. DBI version, Perl version, DBI::DBD::SqlEngine version and +the SQL handler version). + +C<get_versions> takes the C<$dbh> as the first argument and optionally a +second argument containing a table name. The second argument is not +evaluated in C<< DBI::DBD::SqlEngine::db::get_versions >> itself - but +might be in the future. + +If the derived implementor class provides a method named +C<get_${drv_prefix}versions>, this is invoked and the return value of +it is associated to the derived driver name: + + if (my $dgv = $dbh->{ImplementorClass}->can ("get_" . $drv_prefix . "versions") { + (my $derived_driver = $dbh->{ImplementorClass}) =~ s/::db$//; + $versions{$derived_driver} = &$dgv ($dbh, $table); + } + +Override it to add more version information about your module, (e.g. +some kind of parser version in case of DBD::CSV, ...), if one line is not +enough room to provide all relevant information. + +=item sql_parser_object + +Returns a L<SQL::Parser> instance, when C<< sql_handler >> is set to +"SQL::Statement". The parser instance is stored in C<< sql_parser_object >>. + +It is not recommended to override this method. + +=item disconnect + +Disconnects from a database. All local table information is discarded and +the C<< Active >> attribute is set to 0. + +=item type_info_all + +Returns information about all the types supported by DBI::DBD::SqlEngine. + +=item table_info + +Returns a statement handle which is prepared to deliver information about +all known tables. + +=item list_tables + +Returns a list of all known table names. + +=item quote + +Quotes a string for use in SQL statements. + +=item commit + +Warns about a useless call (if warnings enabled) and returns. +DBI::DBD::SqlEngine is typically a driver which commits every action instantly when +executed. + +=item rollback + +Warns about a useless call (if warnings enabled) and returns. +DBI::DBD::SqlEngine is typically a driver which commits every action instantly when +executed. + +=back + +=head2 DBI::DBD::SqlEngine::st + +Contains the methods to deal with prepared statement handles: + +=over 4 + +=item bind_param + +Common routine to bind placeholders to a statement for execution. It +is dangerous to override this method without detailed knowledge about +the DBI::DBD::SqlEngine internal storage structure. + +=item execute + +Executes a previously prepared statement (with placeholders, if any). + +=item finish + +Finishes a statement handle, discards all buffered results. The prepared +statement is not discarded so the statement can be executed again. + +=item fetch + +Fetches the next row from the result-set. This method may be rewritten +in a later version and if it's overridden in a derived class, the +derived implementation should not rely on the storage details. + +=item fetchrow_arrayref + +Alias for C<< fetch >>. + +=item FETCH + +Fetches statement handle attributes. Supported attributes (for full overview +see L<DBI/Statement Handle Attributes>) are C<NAME>, C<TYPE>, C<PRECISION> +and C<NULLABLE>. Each column is returned as C<NULLABLE> which might be wrong +depending on the derived backend storage. If the statement handle has +private attributes, they can be fetched using this method, too. B<Note> that +statement attributes are not associated with any table used in this statement. + +This method usually requires extending in a derived implementation. +See L<DBD::CSV> or L<DBD::DBM> for some example. + +=item STORE + +Allows storing of statement private attributes. No special handling is +currently implemented here. + +=item rows + +Returns the number of rows affected by the last execute. This method might +return C<undef>. + +=back + +=head2 DBI::DBD::SqlEngine::Statement + +Derives from DBI::SQL::Nano::Statement for unified naming when deriving +new drivers. No additional feature is provided from here. + +=head2 DBI::DBD::SqlEngine::Table + +Derives from DBI::SQL::Nano::Table for unified naming when deriving +new drivers. No additional feature is provided from here. + +You should consult the documentation of C<< SQL::Eval::Table >> (see +L<SQL::Eval>) to get more information about the abstract methods of the +table's base class you have to override and a description of the table +meta information expected by the SQL engines. + +=head1 AUTHOR + +The module DBI::DBD::SqlEngine is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +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. + +=cut diff --git a/lib/DBI/DBD/SqlEngine/HowTo.pod b/lib/DBI/DBD/SqlEngine/HowTo.pod new file mode 100644 index 0000000..764dd08 --- /dev/null +++ b/lib/DBI/DBD/SqlEngine/HowTo.pod @@ -0,0 +1,218 @@ +=head1 NAME + +DBI::DBD::SqlEngine::HowTo - Guide to create DBI::DBD::SqlEngine based driver + +=head1 SYNOPSIS + + perldoc DBI::DBD::SqlEngine::HowTo + perldoc DBI + perldoc DBI::DBD + perldoc DBI::DBD::SqlEngine::Developers + perldoc SQL::Eval + perldoc DBI::DBD::SqlEngine + perldoc DBI::DBD::SqlEngine::HowTo + perldoc SQL::Statement::Embed + +=head1 DESCRIPTION + +This document provides a step-by-step guide, how to create a new +C<DBI::DBD::SqlEngine> based DBD. It expects that you carefully read the +L<DBI> documentation and that you're familiar with L<DBI::DBD> and had +read and understood L<DBD::ExampleP>. + +This document addresses experienced developers who are really sure that +they need to invest time when writing a new DBI Driver. Writing a DBI +Driver is neither a weekend project nor an easy job for hobby coders +after work. Expect one or two man-month of time for the first start. + +Those who are still reading, should be able to sing the rules of +L<DBI::DBD/CREATING A NEW DRIVER>. + +=head1 CREATING DRIVER CLASSES + +Do you have an entry in DBI's DBD registry? For this guide, a prefix of +C<foo_> is assumed. + +=head2 Sample Skeleton + + package DBD::Foo; + + use strict; + use warnings; + use vars qw($VERSION); + use base qw(DBI::DBD::SqlEngine); + + use DBI (); + + $VERSION = "0.001"; + + package DBD::Foo::dr; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::dr); + $imp_data_size = 0; + + package DBD::Foo::db; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::db); + $imp_data_size = 0; + + package DBD::Foo::st; + + use vars qw(@ISA $imp_data_size); + + @ISA = qw(DBI::DBD::SqlEngine::st); + $imp_data_size = 0; + + package DBD::Foo::Statement; + + use vars qw(@ISA); + + @ISA = qw(DBI::DBD::SqlEngine::Statement); + + package DBD::Foo::Table; + + use vars qw(@ISA); + + @ISA = qw(DBI::DBD::SqlEngine::Table); + + 1; + +Tiny, eh? And all you have now is a DBD named foo which will is able to +deal with temporary tables, as long as you use L<SQL::Statement>. In +L<DBI::SQL::Nano> environments, this DBD can do nothing. + +=head2 Deal with own attributes + +Before we start doing usable stuff with our DBI driver, we need to think +about what we want to do and how we want to do it. + +Do we need tunable knobs accessible by users? Do we need status +information? All this is handled in attributes of the database handles (be +careful when your DBD is running "behind" a L<DBD::Gofer> proxy). + +How come the attributes into the DBD and how are they fetchable by the +user? Good question, but you should know because you've read the L<DBI> +documentation. + +C<DBI::DBD::SqlEngine::db::FETCH> and C<DBI::DBD::SqlEngine::db::STORE> +taking care for you - all they need to know is which attribute names +are valid and mutable or immutable. Tell them by adding +C<init_valid_attributes> to your db class: + + sub init_valid_attributes + { + my $dbh = $_[0]; + + $dbh->SUPER::init_valid_attributes (); + + $dbh->{foo_valid_attrs} = { + foo_version => 1, # contains version of this driver + foo_valid_attrs => 1, # contains the valid attributes of foo drivers + foo_readonly_attrs => 1, # contains immutable attributes of foo drivers + foo_bar => 1, # contains the bar attribute + foo_baz => 1, # contains the baz attribute + foo_manager => 1, # contains the manager of the driver instance + foo_manager_type => 1, # contains the manager class of the driver instance + }; + $dbh->{foo_readonly_attrs} = { + foo_version => 1, # ensure no-one modifies the driver version + foo_valid_attrs => 1, # do not permit to add more valid attributes ... + foo_readonly_attrs => 1, # ... or make the immutable mutable + foo_manager => 1, # manager is set internally only + }; + + return $dbh; + } + +Woooho - but now the user cannot assign new managers? This is intended, +overwrite C<STORE> to handle it! + + sub STORE ($$$) + { + my ( $dbh, $attrib, $value ) = @_; + + $dbh->SUPER::STORE( $attrib, $value ); + + # we're still alive, so no exception is thrown ... + # by DBI::DBD::SqlEngine::db::STORE + if ( $attrib eq "foo_manager_type" ) + { + $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); + # ... probably correct some states based on the new + # foo_manager_type - see DBD::Sys for an example + } + } + +But ... my driver runs without a manager until someone first assignes +a C<foo_manager_type>. Well, no - there're two places where you can +initialize defaults: + + sub init_default_attributes + { + my ($dbh, $phase) = @_; + + $dbh->SUPER::init_default_attributes($phase); + + if( 0 == $phase ) + { + # init all attributes which have no knowledge about + # user settings from DSN or the attribute hash + $dbh->{foo_manager_type} = "DBD::Foo::Manager"; + } + elsif( 1 == $phase ) + { + # init phase with more knowledge from DSN or attribute + # hash + $dbh->{foo_manager} = $dbh->{foo_manager_type}->new(); + } + + return $dbh; + } + +So far we can prevent the users to use our database driver as data +storage for anything and everything. We care only about the real important +stuff for peace on earth and alike attributes. But in fact, the driver +still can't do anything. It can do less than nothing - meanwhile it's +not a stupid storage area anymore. + +=head2 Dealing with Tables + +Let's put some life into it - it's going to be time for it. + +This is a good point where a quick side step to L<SQL::Statement::Embed> +will help to shorten the next paragraph. The documentation in +SQL::Statement::Embed regarding embedding in own DBD's works pretty +fine with SQL::Statement and DBI::SQL::Nano. + +=head2 Testing + +Now you should have your first own DBD. Was easy, wasn't it? But does +it work well? Prove it by writing tests and remember to use +dbd_edit_mm_attribs from L<DBI::DBD> to ensure testing even rare cases. + +=head1 AUTHOR + +This guide is written by Jens Rehsack. DBI::DBD::SqlEngine is written by +Jens Rehsack using code from DBD::File originally written by Jochen +Wiedmann and Jeff Zucker. + +The module DBI::DBD::SqlEngine is currently maintained by + +H.Merijn Brand < h.m.brand at xs4all.nl > and +Jens Rehsack < rehsack at googlemail.com > + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2010 by H.Merijn Brand & Jens Rehsack + +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. + +=cut diff --git a/lib/DBI/FAQ.pm b/lib/DBI/FAQ.pm new file mode 100644 index 0000000..1ad760b --- /dev/null +++ b/lib/DBI/FAQ.pm @@ -0,0 +1,966 @@ +### +### $Id: FAQ.pm 14934 2011-09-14 10:02:25Z timbo $ +### +### DBI Frequently Asked Questions POD +### +### Copyright section reproduced from below. +### +### This document is Copyright (c)1994-2000 Alligator Descartes, with portions +### Copyright (c)1994-2000 their original authors. This module is released under +### the 'Artistic' license which you can find in the perl distribution. +### +### This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved. +### Permission to distribute this document, in full or in part, via email, +### Usenet, ftp archives or http is granted providing that no charges are involved, +### reasonable attempt is made to use the most current version and all credits +### and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ). +### Requests for other distribution rights, including incorporation into +### commercial products, such as books, magazine articles or CD-ROMs should be +### made to Alligator Descartes. +### + +package DBI::FAQ; + +our $VERSION = sprintf("1.%06d", q$Revision: 14934 $ =~ /(\d+)/o); + + +=head1 NAME + +DBI::FAQ -- The Frequently Asked Questions for the Perl5 Database Interface + +=for html +<BODY BGCOLOR="#ffffff" TEXT="#000000" LINK="#3a15ff" ALINK="#ff0000" VLINK="#ff282d"> +<!--#include virtual="/technology/perl/DBI/templatetop.html" --> +<CENTER> +<FONT SIZE="+2"> +DBI Frequently Asked Questions v.0.38 +</FONT> +<BR> +<FONT SIZE="-1"> +<I>Last updated: February 8th, 2000</I> +</FONT> +</CENTER> +<P> + +=head1 SYNOPSIS + + perldoc DBI::FAQ + +=head1 VERSION + +This document is currently at version I<0.38>, as of I<February 8th, 2000>. + +That's B<very> old. A newer FAQ can be found at L<http://faq.dbi-support.com/> + +Neither this document nor that web site are actively maintained. +Volunteers are welcome. + +=head1 DESCRIPTION + +This document serves to answer the most frequently asked questions on both +the DBI Mailing Lists and personally to members of the DBI development team. + +=head1 Basic Information & Information Sources + +=head2 1.1 What is DBI, DBperl, Oraperl and *perl? + +To quote Tim Bunce, the architect and author of DBI: + + DBI is a database access Application Programming Interface (API) + for the Perl Language. The DBI API Specification defines a set + of functions, variables and conventions that provide a consistent + database interface independent of the actual database being used. + +In simple language, the DBI interface allows users to access multiple database +types transparently. So, if you connecting to an Oracle, Informix, mSQL, Sybase +or whatever database, you don't need to know the underlying mechanics of the +3GL layer. The API defined by DBI will work on I<all> these database types. + +A similar benefit is gained by the ability to connect to two I<different> +databases of different vendor within the one perl script, I<ie>, I want +to read data from an Oracle database and insert it back into an Informix +database all within one program. The DBI layer allows you to do this simply +and powerfully. + + +=for html +Here's a diagram that demonstrates the principle: +<P> +<CENTER> +<IMG SRC="img/dbiarch.gif" WIDTH=451 HEIGHT=321 ALT="[ DBI Architecture ]"> +</CENTER> +<P> + +I<DBperl> is the old name for the interface specification. It's usually +now used to denote perlI<4> modules on database interfacing, such as, +I<oraperl>, I<isqlperl>, I<ingperl> and so on. These interfaces +didn't have a standard API and are generally I<not> supported. + +Here's a list of DBperl modules, their corresponding DBI counterparts and +support information. I<Please note>, the author's listed here generally +I<do not> maintain the DBI module for the same database. These email +addresses are unverified and should only be used for queries concerning the +perl4 modules listed below. DBI driver queries should be directed to the +I<dbi-users> mailing list. + + Module Name Database Required Author DBI + ----------- ----------------- ------ --- + Sybperl Sybase Michael Peppler DBD::Sybase + <mpeppler@itf.ch> + Oraperl Oracle 6 & 7 Kevin Stock DBD::Oracle + <dbi-users@perl.org> + Ingperl Ingres Tim Bunce & DBD::Ingres + Ted Lemon + <dbi-users@perl.org> + Interperl Interbase Buzz Moschetti DBD::Interbase + <buzz@bear.com> + Uniperl Unify 5.0 Rick Wargo None + <rickers@coe.drexel.edu> + Pgperl Postgres Igor Metz DBD::Pg + <metz@iam.unibe.ch> + Btreeperl NDBM John Conover SDBM? + <john@johncon.com> + Ctreeperl C-Tree John Conover None + <john@johncon.com> + Cisamperl Informix C-ISAM Mathias Koerber None + <mathias@unicorn.swi.com.sg> + Duaperl X.500 Directory Eric Douglas None + User Agent + +However, some DBI modules have DBperl emulation layers, so, I<DBD::Oracle> +comes with an Oraperl emulation layer, which allows you to run legacy oraperl +scripts without modification. The emulation layer translates the oraperl API +calls into DBI calls and executes them through the DBI switch. + +Here's a table of emulation layer information: + + Module Emulation Layer Status + ------ --------------- ------ + DBD::Oracle Oraperl Complete + DBD::Informix Isqlperl Under development + DBD::Ingres Ingperl Complete? + DBD::Sybase Sybperl Working? ( Needs verification ) + DBD::mSQL Msqlperl Experimentally released with + DBD::mSQL-0.61 + +The I<Msqlperl> emulation is a special case. I<Msqlperl> is a perl5 driver +for I<mSQL> databases, but does not conform to the DBI Specification. It's +use is being deprecated in favour of I<DBD::mSQL>. I<Msqlperl> may be downloaded +from CPAN I<via>: + + http://www.perl.com/cgi-bin/cpan_mod?module=Msqlperl + +=head2 1.2. Where can I get it from? + +The Comprehensive Perl Archive Network +resources should be used for retrieving up-to-date versions of the DBI +and drivers. CPAN may be accessed I<via> Tom Christiansen's splendid +I<CPAN multiplexer> program located at: + + http://www.perl.com/CPAN/ + +For more specific version information and exact URLs of drivers, please see +the DBI drivers list and the DBI module pages which can be found on: + + http://dbi.perl.org/ + +This list is automatically generated on a nightly basis from CPAN and should +be up-to-date. + +=head2 1.3. Where can I get more information? + +There are a few information sources on DBI. + +=over 4 + +=item I<"Programming the Perl DBI"> + +"Programming the Perl DBI" is the I<official> book on the DBI written by +Alligator Descartes and Tim Bunce and published by O'Reilly & Associates. +The book was released on February 9th, 2000. + +The table of contents is: + + Preface + 1. Introduction + From Mainframes to Workstations + Perl + DBI in the Real World + A Historical Interlude and Standing Stones + 2. Basic Non-DBI Databases + Storage Managers and Layers + Query Languages and Data Functions + Standing Stones and the Sample Database + Flat-File Databases + Putting Complex Data into Flat Files + Concurrent Database Access and Locking + DBM Files and the Berkeley Database Manager + The MLDBM Module + Summary + 3. SQL and Relational Databases + The Relational Database Methodology + Datatypes and NULL Values + Querying Data + Modifying Data Within Tables + Creating and Destroying Tables + 4. Programming with the DBI + DBI Architecture + Handles + Data Source Names + Connection and Disconnection + Error Handling + Utility Methods and Functions + 5. Interacting with the Database + Issuing Simple Queries + Executing Non-SELECT Statements + Binding Parameters to Statements + Binding Output Columns + do() Versus prepare() + Atomic and Batch Fetching + 6. Advanced DBI + Handle Attributes and Metadata + Handling LONG/LOB Data + Transactions, Locking, and Isolation + 7. ODBC and the DBI + ODBC -- Embraced and Extended + DBI -- Thrashed and Mutated + The Nuts and Bolts of ODBC + ODBC from Perl + The Marriage of DBI and ODBC + Questions and Choices + Moving Between Win32::ODBC and the DBI + And What About ADO? + 8. DBI Shell and Database Proxying + dbish -- The DBI Shell + Database Proxying + A. DBI Specification + B. Driver and Database Characteristics + C. ASLaN Sacred Site Charter + Index + +The book should be available from all good bookshops and can be ordered online +either <I>via</I> O'Reilly & Associates + + http://www.oreilly.com/catalog/perldbi + +or Amazon + + http://www.amazon.com/exec/obidos/ASIN/1565926994/dbi + +=item I<POD documentation> + +I<POD>s are chunks of documentation usually embedded within perl programs +that document the code ``I<in place>'', providing a useful resource for +programmers and users of modules. POD for DBI and drivers is beginning to +become more commonplace, and documentation for these modules can be read +with the C<perldoc> program included with Perl. + +=over 4 + +=item The DBI Specification + +The POD for the DBI Specification can be read with the: + + perldoc DBI + +command. The Specification also forms Appendix A of "Programming the Perl +DBI". + +=item Oraperl + +Users of the Oraperl emulation layer bundled with I<DBD::Oracle>, may read +up on how to program with the Oraperl interface by typing: + + perldoc Oraperl + +This will produce an updated copy of the original oraperl man page written by +Kevin Stock for perl4. The oraperl API is fully listed and described there. + +=item Drivers + +Users of the DBD modules may read about some of the private functions +and quirks of that driver by typing: + + perldoc <driver> + +For example, the I<DBD::mSQL> driver is bundled with driver-specific +documentation that can be accessed by typing + + perldoc DBD::mSQL + +=item Frequently Asked Questions + +This document, the I<Frequently Asked Questions> is also available as POD +documentation! You can read this on your own system by typing: + + perldoc DBI::FAQ + +This may be more convenient to persons not permanently, or conveniently, +connected to the Internet. The I<DBI::FAQ> module should be downloaded and +installed for the more up-to-date version. + +The version of I<DBI::FAQ> shipped with the C<DBI> module may be slightly out +of date. + +=item POD in general + +Information on writing POD, and on the philosophy of POD in general, can be +read by typing: + + perldoc perlpod + +Users with the Tk module installed may be interested to learn there is a +Tk-based POD reader available called C<tkpod>, which formats POD in a convenient +and readable way. This is available I<via> CPAN as the module called +I<Tk::POD> and is highly recommended. + +=back + +=item I<Driver and Database Characteristics> + +The driver summaries that were produced for Appendix B of "Programming the +Perl DBI" are available online at: + + http://dbi.perl.org/ + +in the driver information table. These summaries contain standardised +information on each driver and database which should aid you in selecting +a database to use. It will also inform you quickly of any issues within +drivers or whether a driver is not fully compliant with the DBI Specification. + +=item I<Rambles, Tidbits and Observations> + + http://dbi.perl.org/tidbits + +There are a series of occasional rambles from various people on the +DBI mailing lists who, in an attempt to clear up a simple point, end up +drafting fairly comprehensive documents. These are quite often varying in +quality, but do provide some insights into the workings of the interfaces. + +=item I<Articles> + +A list of articles discussing the DBI can be found on the DBI WWW page at: + + http://dbi.perl.org/ + +These articles are of varying quality and age, from the original Perl Journal +article written by Alligator and Tim, to more recent debacles published online +from about.com. + +=item I<README files> + +The I<README> files included with each driver occasionally contains +some useful information ( no, really! ) that may be pertinent to the user. +Please read them. It makes our worthless existences more bearable. These +can all be read from the main DBI WWW page at: + + http://dbi.perl.org/ + +=item I<Mailing Lists> + +There are three mailing lists for DBI: + + dbi-announce@perl.org -- for announcements, very low traffic + dbi-users@perl.org -- general user support + dbi-dev@perl.org -- for driver developers (no user support) + +For information on how to subscribe, set digest mode etc, and unsubscribe, +send an email message (the content will be ignored) to: + + dbi-announce-help@perl.org + dbi-users-help@perl.org + dbi-dev-help@perl.org + +=item I<Mailing List Archives> + +=over 4 + +=item I<US Mailing List Archives> + + http://outside.organic.com/mail-archives/dbi-users/ + +Searchable hypermail archives of the three mailing lists, and some of the +much older traffic have been set up for users to browse. + +=item I<European Mailing List Archives> + + http://www.rosat.mpe-garching.mpg.de/mailing-lists/PerlDB-Interest + +As per the US archive above. + +=back + +=back + +=head1 Compilation Problems + +=head2 2.1. Compilation problems or "It fails the test!" + +First off, consult the README for that driver in case there is useful +information about the problem. It may be a known problem for your given +architecture and operating system or database. You can check the README +files for each driver in advance online at: + + http://dbi.perl.org/ + +If it's a known problem, you'll probably have to wait till it gets fixed. If +you're I<really> needing it fixed, try the following: + +=over 4 + +=item I<Attempt to fix it yourself> + +This technique is generally I<not> recommended to the faint-hearted. +If you do think you have managed to fix it, then, send a patch file +( context diff ) to the author with an explanation of: + +=over 4 + +=item * + +What the problem was, and test cases, if possible. + +=item * + +What you needed to do to fix it. Please make sure you mention everything. + +=item * + +Platform information, database version, perl version, module version and +DBI version. + +=back + +=item I<Email the author> Do I<NOT> whinge! + +Please email the address listed in the WWW pages for whichever driver you +are having problems with. Do I<not> directly email the author at a +known address unless it corresponds with the one listed. + +We tend to have real jobs to do, and we do read the mailing lists for +problems. Besides, we may not have access to <I<insert your +favourite brain-damaged platform here>> and couldn't be of any +assistance anyway! Apologies for sounding harsh, but that's the way of it! + +However, you might catch one of these creative genii at 3am when we're +doing this sort of stuff anyway, and get a patch within 5 minutes. The +atmosphere in the DBI circle is that we I<do> appreciate the users' +problems, since we work in similar environments. + +If you are planning to email the author, please furnish as much information +as possible, I<ie>: + +=over 4 + +=item * + +I<ALL> the information asked for in the README file in +the problematic module. And we mean I<ALL> of it. We don't +put lines like that in documentation for the good of our health, or +to meet obscure README file standards of length. + +=item * + +If you have a core dump, try the I<Devel::CoreStack> module for +generating a stack trace from the core dump. Send us that too. +I<Devel::CoreStack> can be found on CPAN at: + + http://www.perl.com/cgi-bin/cpan_mod?module=Devel::CoreStack + +=item * + +Module versions, perl version, test cases, operating system versions +and I<any other pertinent information>. + +=back + +Remember, the more information you send us, the quicker we can track +problems down. If you send us no useful information, expect nothing back. + +Finally, please be aware that some authors, including Tim Bunce, specifically +request that you do I<not> mail them directly. Please respect their wishes and +use the email addresses listed in the appropriate module C<README> file. + +=item I<Email the dbi-users Mailing List> + +It's usually a fairly intelligent idea to I<cc> the mailing list +anyway with problems. The authors all read the lists, so you lose nothing +by mailing there. + +=back + +=head1 Platform and Driver Issues + +=head2 3.1 What's the difference between ODBC and DBI? + +In terms of architecture - not much: Both define programming +interfaces. Both allow multiple drivers to be loaded to do the +actual work. + +In terms of ease of use - much: The DBI is a 'high level' interface +that, like Perl itself, strives to make the simple things easy while +still making the hard things possible. The ODBC is a 'low level' +interface. All nuts-bolts-knobs-and-dials. + +Now there's an ODBC driver for the DBI (DBD::ODBC) the "What's the +difference" question is more usefully rephrased as: + +Chapter 7 of "Programming the Perl DBI" covers this topic in far more +detail and should be consulted. + +=head2 3.2 What's the difference between Win32::ODBC and DBD::ODBC? + +The DBI, and thus DBD::ODBC, has a different philosophy from the +Win32::ODBC module: + +The Win32::ODBC module is a 'thin' layer over the low-level ODBC API. +The DBI defines a simpler 'higher level' interface. + +The Win32::ODBC module gives you access to more of the ODBC API. +The DBI and DBD::ODBC give you access to only the essentials. +(But, unlike Win32::ODBC, the DBI and DBD::ODBC do support parameter +binding and multiple prepared statements which reduces the load on +the database server and can dramatically increase performance.) + +The Win32::ODBC module only works on Win32 systems. +The DBI and DBD::ODBC are very portable and work on Win32 and Unix. + +The DBI and DBD::ODBC modules are supplied as a standard part of the +Perl 5.004 binary distribution for Win32 (they don't work with the +older, non-standard, ActiveState port). + +Scripts written with the DBI and DBD::ODBC are faster than Win32::ODBC +on Win32 and are trivially portable to other supported database types. + +The DBI offers optional automatic printing or die()ing on errors which +makes applications simpler and more robust. + +The current DBD::ODBC driver version 0.16 is new and not yet fully stable. +A new release is due soon [relative to the date of the next TPJ issue :-] +and will be much improved and offer more ODBC functionality. + +To summarise: The Win32::ODBC module is your best choice if you need +access to more of the ODBC API than the DBI gives you. Otherwise, the +DBI and DBD::ODBC combination may be your best bet. + +Chapter 7 of "Programming the Perl DBI" covers this topic in far more +detail and should be consulted. + +=head2 3.3 Is DBI supported under Windows 95 / NT platforms? + +Finally, yes! Jeff Urlwin has been working diligently on building +I<DBI> and I<DBD::ODBC> under these platforms, and, with the +advent of a stabler perl and a port of I<MakeMaker>, the project has +come on by great leaps and bounds. + +The I<DBI> and I<DBD::Oracle> Win32 ports are now a standard part of DBI, +so, downloading I<DBI> of version higher than I<0.81> should work fine as +should using the most recent I<DBD::Oracle> version. + +=head2 3.4 Can I access Microsoft Access or SQL-Server databases with DBI? + +Yes, use the I<DBD::ODBC> driver. + +=head2 3.5 Is there a DBD for <I<insert favourite database here>>? + +First check if a driver is available on CPAN by searching for the name of the +database (including common abbreviations and aliases). + +Here's a general query that'll match all distributions: + + http://search.cpan.org/search?query=DBD&mode=dist + +If you can't find a driver that way, you could check if the database supports +ODBC drivers. If so then you could probably use the DBD::ODBC driver: + + http://search.cpan.org/dist/DBD-ODBC/ + +If not, then try asking on the dbi-users mailing list. + +=head2 3.6 What's DBM? And why should I use DBI instead? + +Extracted from ``I<DBI - The Database Interface for Perl 5>'': + + ``UNIX was originally blessed with simple file-based ``databases'', namely + the dbm system. dbm lets you store data in files, and retrieve + that data quickly. However, it also has serious drawbacks. + + File Locking + + The dbm systems did not allow particularly robust file locking + capabilities, nor any capability for correcting problems arising through + simultaneous writes [ to the database ]. + + Arbitrary Data Structures + + The dbm systems only allows a single fixed data structure: + key-value pairs. That value could be a complex object, such as a + [ C ] struct, but the key had to be unique. This was a large + limitation on the usefulness of dbm systems. + + However, dbm systems still provide a useful function for users with + simple datasets and limited resources, since they are fast, robust and + extremely well-tested. Perl modules to access dbm systems have now + been integrated into the core Perl distribution via the + AnyDBM_File module.'' + +To sum up, DBM is a perfectly satisfactory solution for essentially read-only +databases, or small and simple datasets. However, for more +scaleable dataset handling, not to mention robust transactional locking, +users are recommended to use a more powerful database engine I<via> I<DBI>. + +Chapter 2 of "Programming the Perl DBI" discusses DBM files in detail. + +=head2 3.7 What database do you recommend me using? + +This is a particularly thorny area in which an objective answer is difficult +to come by, since each dataset, proposed usage and system configuration +differs from person to person. + +From the current author's point of view, if the dataset is relatively +small, being tables of less than 1 million rows, and less than 1000 tables +in a given database, then I<mSQL> is a perfectly acceptable solution +to your problem. This database is extremely cheap, is wonderfully robust +and has excellent support. More information is available on the Hughes +Technology WWW site at: + + http://www.hughes.com.au + +You may also wish to look at MySQL which is a more powerful database engine +that has a similar feel to mSQL. + + http://www.tcx.se + +If the dataset is larger than 1 million row tables or 1000 tables, or if you +have either more money, or larger machines, I would recommend I<Oracle RDBMS>. +Oracle's WWW site is an excellent source of more information. + + http://www.oracle.com + +I<Informix> is another high-end RDBMS that is worth considering. There are +several differences between Oracle and Informix which are too complex for +this document to detail. Information on Informix can be found on their +WWW site at: + + http://www.informix.com + +In the case of WWW fronted applications, I<mSQL> may be a better option +due to slow connection times between a CGI script and the Oracle RDBMS and +also the amount of resource each Oracle connection will consume. I<mSQL> +is lighter resource-wise and faster. + +These views are not necessarily representative of anyone else's opinions, +and do not reflect any corporate sponsorship or views. They are provided +I<as-is>. + +=head2 3.8 Is <I<insert feature here>> supported in DBI? + +Given that we're making the assumption that the feature you have requested +is a non-standard database-specific feature, then the answer will be I<no>. + +DBI reflects a I<generic> API that will work for most databases, and has +no database-specific functionality. + +However, driver authors may, if they so desire, include hooks to database-specific +functionality through the C<func()> method defined in the DBI API. +Script developers should note that use of functionality provided I<via> +the C<func()> methods is very unlikely to be portable across databases. + +=head1 Programming Questions + +=head2 4.1 Is DBI any use for CGI programming? + +In a word, yes! DBI is hugely useful for CGI programming! In fact, I would +tentatively say that CGI programming is one of two top uses for DBI. + +DBI confers the ability to CGI programmers to power WWW-fronted databases +to their users, which provides users with vast quantities of ordered +data to play with. DBI also provides the possibility that, if a site is +receiving far too much traffic than their database server can cope with, they +can upgrade the database server behind the scenes with no alterations to +the CGI scripts. + +=head2 4.2 How do I get faster connection times with DBD::Oracle and CGI? + + Contributed by John D. Groenveld + +The Apache C<httpd> maintains a pool of C<httpd> children to service client +requests. + +Using the Apache I<mod_perl> module by I<Doug MacEachern>, the perl +interpreter is embedded with the C<httpd> children. The CGI, DBI, and your +other favorite modules can be loaded at the startup of each child. These +modules will not be reloaded unless changed on disk. + +For more information on Apache, see the Apache Project's WWW site: + + http://www.apache.org + +The I<mod_perl> module can be downloaded from CPAN I<via>: + + http://www.perl.com/cgi-bin/cpan_mod?module=Apache + +=head2 4.3 How do I get persistent connections with DBI and CGI? + + Contributed by John D. Groenveld + +Using Edmund Mergl's I<Apache::DBI> module, database logins are stored in a +hash with each of these C<httpd> child. If your application is based on a +single database user, this connection can be started with each child. +Currently, database connections cannot be shared between C<httpd> children. + +I<Apache::DBI> can be downloaded from CPAN I<via>: + + http://www.perl.com/cgi-bin/cpan_mod?module=Apache::DBI + +=head2 4.4 ``When I run a perl script from the command line, it works, but, when I run it under the C<httpd>, it fails!'' Why? + +Basically, a good chance this is occurring is due to the fact that the user +that you ran it from the command line as has a correctly configured set of +environment variables, in the case of I<DBD::Oracle>, variables like +C<ORACLE_HOME>, C<ORACLE_SID> or C<TWO_TASK>. + +The C<httpd> process usually runs under the user id of C<nobody>, +which implies there is no configured environment. Any scripts attempting to +execute in this situation will correctly fail. + +One way to solve this problem is to set the environment for your database in a +C<BEGIN { }> block at the top of your script. Another technique is to configure +your WWW server to pass-through certain environment variables to your CGI +scripts. + +Similarly, you should check your C<httpd> error logfile for any clues, +as well as the ``Idiot's Guide To Solving Perl / CGI Problems'' and +``Perl CGI Programming FAQ'' for further information. It is +unlikely the problem is DBI-related. + +The ``Idiot's Guide To Solving Perl / CGI Problems'' can be located at: + + http://www.perl.com/perl/faq/index.html + +as can the ``Perl CGI Programming FAQ''. Read I<BOTH> these documents +carefully! + +=head2 4.5 How do I get the number of rows returned from a C<SELECT> statement? + +Count them. Read the DBI docs for the C<rows()> method. + +=head1 Miscellaneous Questions + +=head2 5.1 Can I do multi-threading with DBI? + +Perl version 5.005 and later can be built to support multi-threading. +The DBI, as of version 1.02, does not yet support multi-threading +so it would be unsafe to let more than one thread enter the DBI at +the same time. + +It is expected that some future version of the DBI will at least be +thread-safe (but not thread-hot) by automatically blocking threads +intering the DBI while it's already in use. + +=head2 5.2 How do I handle BLOB data with DBI? + +Handling BLOB data with the DBI is very straight-forward. BLOB columns are +specified in a SELECT statement as per normal columns. However, you also +need to specify a maximum BLOB size that the <I>database handle</I> can +fetch using the C<LongReadLen> attribute. + +For example: + + ### $dbh is a connected database handle + $sth = $dbh->prepare( "SELECT blob_column FROM blobby_table" ); + $sth->execute; + +would fail. + + ### $dbh is a connected database handle + ### Set the maximum BLOB size... + $dbh->{LongReadLen} = 16384; ### 16Kb...Not much of a BLOB! + + $sth = $dbh->prepare( "..." ); + +would succeed <I>provided no column values were larger than the specified +value</I>. + +If the BLOB data is longer than the value of C<LongReadLen>, then an +error will occur. However, the DBI provides an additional piece of +functionality that will automatically truncate the fetched BLOB to the +size of C<LongReadLen> if it is longer. This does not cause an error to +occur, but may make your fetched BLOB data useless. + +This behaviour is regulated by the C<LongTruncOk> attribute which is +defaultly set to a false value ( thus making overlong BLOB fetches fail ). + + ### Set BLOB handling such that it's 16Kb and can be truncated + $dbh->{LongReadLen} = 16384; + $dbh->{LongTruncOk} = 1; + +Truncation of BLOB data may not be a big deal in cases where the BLOB +contains run-length encoded data, but data containing checksums at the end, +for example, a ZIP file, would be rendered useless. + +=head2 5.3 How can I invoke stored procedures with DBI? + +The DBI does not define a database-independent way of calling stored procedures. + +However, most database that support them also provide a way to call +them from SQL statements - and the DBI certainly supports that. + +So, assuming that you have created a stored procedure within the target +database, I<eg>, an Oracle database, you can use C<$dbh>->C<do()> to +immediately execute the procedure. For example, + + $dbh->do( "BEGIN someProcedure; END;" ); # Oracle-specific + +You should also be able to C<prepare> and C<execute>, which is +the recommended way if you'll be calling the procedure often. + +=head2 5.4 How can I get return values from stored procedures with DBI? + + Contributed by Jeff Urlwin + + $sth = $dbh->prepare( "BEGIN foo(:1, :2, :3); END;" ); + $sth->bind_param(1, $a); + $sth->bind_param_inout(2, \$path, 2000); + $sth->bind_param_inout(3, \$success, 2000); + $sth->execute; + +Remember to perform error checking, though! ( Or use the C<RaiseError> +attribute ). + +=head2 5.5 How can I create or drop a database with DBI? + +Database creation and deletion are concepts that are entirely too abstract +to be adequately supported by DBI. For example, Oracle does not support the +concept of dropping a database at all! Also, in Oracle, the database +I<server> essentially I<is> the database, whereas in mSQL, the +server process runs happily without any databases created in it. The +problem is too disparate to attack in a worthwhile way. + +Some drivers, therefore, support database creation and deletion through +the private C<func()> methods. You should check the documentation for +the drivers you are using to see if they support this mechanism. + +=head2 5.6 How can I C<commit> or C<rollback> a statement with DBI? + +See the C<commit()> and C<rollback()> methods in the DBI Specification. + +Chapter 6 of "Programming the Perl DBI" discusses transaction handling within +the context of DBI in more detail. + +=head2 5.7 How are C<NULL> values handled by DBI? + +C<NULL> values in DBI are specified to be treated as the value C<undef>. +C<NULL>s can be inserted into databases as C<NULL>, for example: + + $rv = $dbh->do( "INSERT INTO table VALUES( NULL )" ); + +but when queried back, the C<NULL>s should be tested against C<undef>. +This is standard across all drivers. + +=head2 5.8 What are these C<func()> methods all about? + +The C<func()> method is defined within DBI as being an entry point +for database-specific functionality, I<eg>, the ability to create or +drop databases. Invoking these driver-specific methods is simple, for example, +to invoke a C<createDatabase> method that has one argument, we would +write: + + $rv =$dbh->func( 'argument', 'createDatabase' ); + +Software developers should note that the C<func()> methods are +non-portable between databases. + +=head2 5.9 Is DBI Year 2000 Compliant? + +DBI has no knowledge of understanding of what dates are. Therefore, DBI +itself does not have a Year 2000 problem. Individual drivers may use date +handling code internally and therefore be potentially susceptible to the +Year 2000 problem, but this is unlikely. + +You may also wish to read the ``Does Perl have a Year 2000 problem?'' section +of the Perl FAQ at: + + http://www.perl.com/CPAN/doc/FAQs/FAQ/PerlFAQ.html + +=head1 Support and Training + +The Perl5 Database Interface is I<FREE> software. IT COMES WITHOUT WARRANTY +OF ANY KIND. See the DBI README for more details. + +However, some organizations are providing either technical support or +training programs on DBI. The present author has no knowledge as +to the quality of these services. The links are included for reference +purposes only and should not be regarded as recommendations in any way. +I<Caveat emptor>. + +=head2 Commercial Support + +=over 4 + +=item The Perl Clinic + +The Perl Clinic provides commercial support for I<Perl> and Perl +related problems, including the I<DBI> and its drivers. Support is +provided by the company with whom Tim Bunce, author of I<DBI> and +I<DBD::Oracle>, works and ActiveState. For more information on their +services, please see: + + http://www.perlclinic.com + +=back + +=head2 Training + +=over 4 + +=item Westlake Solutions + +A hands-on class for experienced Perl CGI developers that teaches +how to write database-connected CGI scripts using Perl and DBI.pm. This +course, along with four other courses on CGI scripting with Perl, is +taught in Washington, DC; Arlington, Virginia; and on-site worldwide upon +request. + +See: + + http://www.westlake.com/training + +for more details. + +=back + +=head1 Other References + +In this section, we present some miscellaneous WWW links that may be of +some interest to DBI users. These are not verified and may result in +unknown sites or missing documents. + + http://www-ccs.cs.umass.edu/db.html + http://www.odmg.org/odmg93/updates_dbarry.html + http://www.jcc.com/sql_stnd.html + +=head1 AUTHOR + +Alligator Descartes. +Portions are Copyright their original stated authors. + +=head1 COPYRIGHT + +This document is Copyright (c)1994-2000 Alligator Descartes, with portions +Copyright (c)1994-2000 their original authors. This module is released under +the 'Artistic' license which you can find in the perl distribution. + +This document is Copyright (c)1997-2000 Alligator Descartes. All rights reserved. +Permission to distribute this document, in full or in part, via email, +Usenet, ftp archives or http is granted providing that no charges are involved, +reasonable attempt is made to use the most current version and all credits +and copyright notices are retained ( the I<AUTHOR> and I<COPYRIGHT> sections ). +Requests for other distribution rights, including incorporation into +commercial products, such as books, magazine articles or CD-ROMs should be +made to Alligator Descartes. + +=for html +<!--#include virtual="/technology/perl/DBI/templatebottom.html" --> +</BODY> +</HTML> diff --git a/lib/DBI/Gofer/Execute.pm b/lib/DBI/Gofer/Execute.pm new file mode 100644 index 0000000..7d75df2 --- /dev/null +++ b/lib/DBI/Gofer/Execute.pm @@ -0,0 +1,900 @@ +package DBI::Gofer::Execute; + +# $Id: Execute.pm 14282 2010-07-26 00:12:54Z theory $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use Carp; + +use DBI qw(dbi_time); +use DBI::Gofer::Request; +use DBI::Gofer::Response; + +use base qw(DBI::Util::_accessor); + +our $VERSION = sprintf("0.%06d", q$Revision: 14282 $ =~ /(\d+)/o); + +our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common}; +our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods; + +our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr + +our $current_dbh; # the dbh we're using for this request + + +# set trace for server-side gofer +# Could use DBI_TRACE env var when it's an unrelated separate process +# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream) +DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE}; + + +# define valid configuration attributes (args to new()) +# the values here indicate the basic type of values allowed +my %configuration_attributes = ( + gofer_execute_class => 1, + default_connect_dsn => 1, + forced_connect_dsn => 1, + default_connect_attributes => {}, + forced_connect_attributes => {}, + track_recent => 1, + check_request_sub => sub {}, + check_response_sub => sub {}, + forced_single_resultset => 1, + max_cached_dbh_per_drh => 1, + max_cached_sth_per_dbh => 1, + forced_response_attributes => {}, + forced_gofer_random => 1, + stats => {}, +); + +__PACKAGE__->mk_accessors( + keys %configuration_attributes +); + + + +sub new { + my ($self, $args) = @_; + $args->{default_connect_attributes} ||= {}; + $args->{forced_connect_attributes} ||= {}; + $args->{max_cached_sth_per_dbh} ||= 1000; + $args->{stats} ||= {}; + return $self->SUPER::new($args); +} + + +sub valid_configuration_attributes { + my $self = shift; + return { %configuration_attributes }; +} + + +my %extra_attr = ( + # Only referenced if the driver doesn't support private_attribute_info method. + # What driver-specific attributes should be returned for the driver being used? + # keyed by $dbh->{Driver}{Name} + # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others + # which would reduce processing/traffic for non-select statements + mysql => { + dbh => [qw( + mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid + mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id + )], + sth => [qw( + mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment + mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid + )], + # XXX this dbh_after_sth stuff is a temporary, but important, hack. + # should be done via hash instead of arrays where the hash value contains + # flags that can indicate which attributes need to be handled in this way + dbh_after_sth => [qw( + mysql_insertid + )], + }, + Pg => { + dbh => [qw( + pg_protocol pg_lib_version pg_server_version + pg_db pg_host pg_port pg_default_port + pg_options pg_pid + )], + sth => [qw( + pg_size pg_type pg_oid_status pg_cmd_status + )], + }, + Sybase => { + dbh => [qw( + syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string + )], + sth => [qw( + syb_types syb_proc_status syb_result_type + )], + }, + SQLite => { + dbh => [qw( + sqlite_version + )], + sth => [qw( + )], + }, + ExampleP => { + dbh => [qw( + examplep_private_dbh_attrib + )], + sth => [qw( + examplep_private_sth_attrib + )], + dbh_after_sth => [qw( + examplep_insertid + )], + }, +); + + +sub _connect { + my ($self, $request) = @_; + + my $stats = $self->{stats}; + + # discard CachedKids from time to time + if (++$stats->{_requests_served} % 1000 == 0 # XXX config? + and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh} + ) { + my %drivers = DBI->installed_drivers(); + while ( my ($driver, $drh) = each %drivers ) { + next unless my $CK = $drh->{CachedKids}; + next unless keys %$CK > $max_cached_dbh_per_drh; + next if $driver eq 'Gofer'; # ie transport=null when testing + DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver", + scalar keys %$CK, $self->{max_cached_dbh_per_drh}); + $_->{Active} && $_->disconnect for values %$CK; + %$CK = (); + } + } + + # local $ENV{...} can leak, so only do it if required + local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; + + my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; + $connect_method ||= 'connect_cached'; + $stats->{method_calls_dbh}->{$connect_method}++; + + # delete attributes we don't want to affect the server-side + # (Could just do this on client-side and trust the client. DoS?) + delete @{$attr}{qw(Profile InactiveDestroy AutoInactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; + + $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn + or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request"; + + my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; + + my $connect_attr = { + + # the configured default attributes, if any + %{ $self->default_connect_attributes }, + + # pass username and password as attributes + # then they can be overridden by forced_connect_attributes + Username => $username, + Password => $password, + + # the requested attributes + %$attr, + + # force some attributes the way we'd like them + PrintWarn => $local_log, + PrintError => $local_log, + + # the configured default attributes, if any + %{ $self->forced_connect_attributes }, + + # RaiseError must be enabled + RaiseError => 1, + + # reset Executed flag (of the cached handle) so we can use it to tell + # if errors happened before the main part of the request was executed + Executed => 0, + + # ensure this connect_cached doesn't have the same args as the client + # because that causes subtle issues if in the same process (ie transport=null) + # include pid to avoid problems with forking (ie null transport in mod_perl) + # include gofer-random to avoid random behaviour leaking to other handles + dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), + }; + + # XXX implement our own private connect_cached method? (with rate-limited ping) + my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); + + $dbh->{ShowErrorStatement} = 1 if $local_log; + + # XXX should probably just be a Callbacks => arg to connect_cached + # with a cache of pre-built callback hooks (memoized, without $self) + if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) { + $self->_install_rand_callbacks($dbh, $random); + } + + my $CK = $dbh->{CachedKids}; + if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) { + %$CK = (); # clear all statement handles + } + + #$dbh->trace(0); + $current_dbh = $dbh; + return $dbh; +} + + +sub reset_dbh { + my ($self, $dbh) = @_; + $dbh->set_err(undef, undef); # clear any error state +} + + +sub new_response_with_err { + my ($self, $rv, $eval_error, $dbh) = @_; + # this is the usual way to create a response for both success and failure + # capture err+errstr etc and merge in $eval_error ($@) + + my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); + + if ($eval_error) { + $err ||= $DBI::stderr || 1; # ensure err is true + if ($errstr) { + $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; + chomp $errstr; + $errstr .= "; $eval_error"; + } + else { + $errstr = $eval_error; + } + } + chomp $errstr if $errstr; + + my $flags; + # (XXX if we ever add transaction support then we'll need to take extra + # steps because the commit/rollback would reset Executed before we get here) + $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed}; + + my $response = DBI::Gofer::Response->new({ + rv => $rv, + err => $err, + errstr => $errstr, + state => $state, + flags => $flags, + }); + + return $response; +} + + +sub execute_request { + my ($self, $request) = @_; + # should never throw an exception + + DBI->trace_msg("-----> execute_request\n"); + + my @warnings; + local $SIG{__WARN__} = sub { + push @warnings, @_; + warn @_ if $local_log; + }; + + my $response = eval { + + if (my $check_request_sub = $self->check_request_sub) { + $request = $check_request_sub->($request, $self) + or die "check_request_sub failed"; + } + + my $version = $request->version || 0; + die ref($request)." version $version is not supported" + if $version < 0.009116 or $version >= 1; + + ($request->is_sth_request) + ? $self->execute_sth_request($request) + : $self->execute_dbh_request($request); + }; + $response ||= $self->new_response_with_err(undef, $@, $current_dbh); + + if (my $check_response_sub = $self->check_response_sub) { + # not protected with an eval so it can choose to throw an exception + my $new = $check_response_sub->($response, $self, $request); + $response = $new if ref $new; + } + + undef $current_dbh; + + $response->warnings(\@warnings) if @warnings; + DBI->trace_msg("<----- execute_request\n"); + return $response; +} + + +sub execute_dbh_request { + my ($self, $request) = @_; + my $stats = $self->{stats}; + + my $dbh; + my $rv_ref = eval { + $dbh = $self->_connect($request); + my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] + my $wantarray = shift @$args; + my $meth = shift @$args; + $stats->{method_calls_dbh}->{$meth}++; + my @rv = ($wantarray) + ? $dbh->$meth(@$args) + : scalar $dbh->$meth(@$args); + \@rv; + } || []; + my $response = $self->new_response_with_err($rv_ref, $@, $dbh); + + return $response if not $dbh; + + # does this request also want any dbh attributes returned? + if (my $dbh_attributes = $request->dbh_attributes) { + $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) ); + } + + if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) { + $stats->{method_calls_dbh}->{last_insert_id}++; + my $id = $dbh->last_insert_id( @$lid_args ); + $response->last_insert_id( $id ); + } + + if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) { + # dbh_method_call was probably a metadata method like table_info + # that returns a statement handle, so turn the $sth into resultset + my $sth = $rv_ref->[0]; + $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); + $response->rv("(sth)"); # don't try to return actual sth + } + + # we're finished with this dbh for this request + $self->reset_dbh($dbh); + + return $response; +} + + +sub gather_dbh_attributes { + my ($self, $dbh, $dbh_attributes) = @_; + my @req_attr_names = @$dbh_attributes; + if ($req_attr_names[0] eq '*') { # auto include std + private + shift @req_attr_names; + push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) }; + } + my %dbh_attr_values; + @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names); + + # XXX piggyback installed_methods onto dbh_attributes for now + $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods }; + + # XXX piggyback default_methods onto dbh_attributes for now + $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh); + + return \%dbh_attr_values; +} + + +sub _std_response_attribute_names { + my ($self, $h) = @_; + $h = tied(%$h) || $h; # switch to inner handle + + # cache the private_attribute_info data for each handle + # XXX might be better to cache it in the executor + # as it's unlikely to change + # or perhaps at least cache it in the dbh even for sth + # as the sth are typically very short lived + + my ($dbh, $h_type, $driver_name, @attr_names); + + if ($dbh = $h->{Database}) { # is an sth + + # does the dbh already have the answer cached? + return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth}; + + ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name}); + push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE); + } + else { # is a dbh + return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh}; + + ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h); + # explicitly add these because drivers may have different defaults + # add Name so the client gets the real Name of the connection + push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name); + } + + if (my $pai = $h->private_attribute_info) { + push @attr_names, keys %$pai; + } + else { + push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []}; + } + if (my $fra = $self->{forced_response_attributes}) { + push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []} + } + $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n"); + + # cache into the dbh even for sth, as the dbh is usually longer lived + return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names; +} + + +sub execute_sth_request { + my ($self, $request) = @_; + my $dbh; + my $sth; + my $last_insert_id; + my $stats = $self->{stats}; + + my $rv = eval { + $dbh = $self->_connect($request); + + my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] + shift @$args; # discard wantarray + my $meth = shift @$args; + $stats->{method_calls_sth}->{$meth}++; + $sth = $dbh->$meth(@$args); + my $last = '(sth)'; # a true value (don't try to return actual sth) + + # execute methods on the sth, e.g., bind_param & execute + if (my $calls = $request->sth_method_calls) { + for my $meth_call (@$calls) { + my $method = shift @$meth_call; + $stats->{method_calls_sth}->{$method}++; + $last = $sth->$method(@$meth_call); + } + } + + if (my $lid_args = $request->dbh_last_insert_id_args) { + $stats->{method_calls_sth}->{last_insert_id}++; + $last_insert_id = $dbh->last_insert_id( @$lid_args ); + } + + $last; + }; + my $response = $self->new_response_with_err($rv, $@, $dbh); + + return $response if not $dbh; + + $response->last_insert_id( $last_insert_id ) + if defined $last_insert_id; + + # even if the eval failed we still want to try to gather attribute values + # (XXX would be nice to be able to support streaming of results. + # which would reduce memory usage and latency for large results) + if ($sth) { + $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); + $sth->finish; + } + + # does this request also want any dbh attributes returned? + my $dbh_attr_set; + if (my $dbh_attributes = $request->dbh_attributes) { + $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); + } + # XXX needs to be integrated with private_attribute_info() etc + if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { + @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); + } + $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; + + $self->reset_dbh($dbh); + + return $response; +} + + +sub gather_sth_resultsets { + my ($self, $sth, $request, $response) = @_; + my $resultsets = eval { + + my $attr_names = $self->_std_response_attribute_names($sth); + my $sth_attr = {}; + $sth_attr->{$_} = 1 for @$attr_names; + + # let the client add/remove sth atributes + if (my $sth_result_attr = $request->sth_result_attr) { + $sth_attr->{$_} = $sth_result_attr->{$_} + for keys %$sth_result_attr; + } + my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; + + my $row_count = 0; + my $rs_list = []; + while (1) { + my $rs = $self->fetch_result_set($sth, \@sth_attr); + push @$rs_list, $rs; + if (my $rows = $rs->{rowset}) { + $row_count += @$rows; + } + last if $self->{forced_single_resultset}; + last if !($sth->more_results || $sth->{syb_more_results}); + } + + my $stats = $self->{stats}; + $stats->{rows_returned_total} += $row_count; + $stats->{rows_returned_max} = $row_count + if $row_count > ($stats->{rows_returned_max}||0); + + $rs_list; + }; + $response->add_err(1, $@) if $@; + return $resultsets; +} + + +sub fetch_result_set { + my ($self, $sth, $sth_attr) = @_; + my %meta; + eval { + @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); + # we assume @$sth_attr contains NUM_OF_FIELDS + $meta{rowset} = $sth->fetchall_arrayref() + if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT + # the fetchall_arrayref may fail with a 'not executed' kind of error + # because gather_sth_resultsets/fetch_result_set are called even if + # execute() failed, or even if there was no execute() call at all. + # The corresponding error goes into the resultset err, not the top-level + # response err, so in most cases this resultset err is never noticed. + }; + if ($@) { + chomp $@; + $meta{err} = $DBI::err || 1; + $meta{errstr} = $DBI::errstr || $@; + $meta{state} = $DBI::state; + } + return \%meta; +} + + +sub _get_default_methods { + my ($dbh) = @_; + # returns a ref to a hash of dbh method names for methods which the driver + # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. + my $ImplementorClass = $dbh->{ImplementorClass} or die; + my %default_methods; + for my $method (@all_dbh_methods) { + my $dbi_sub = $all_dbh_methods{$method} || 42; + my $imp_sub = $ImplementorClass->can($method) || 42; + next if $imp_sub != $dbi_sub; + #warn("default $method\n"); + $default_methods{$method} = 1; + } + return \%default_methods; +} + + +# XXX would be nice to make this a generic DBI module +sub _install_rand_callbacks { + my ($self, $dbh, $dbi_gofer_random) = @_; + + my $callbacks = $dbh->{Callbacks} || {}; + my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; + + # return if we've already setup this handle with callbacks for these specs + return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); + #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; + $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; + + my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); + my @specs = split /,/, $dbi_gofer_random; + for my $spec (@specs) { + if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { + $fail_percent = $1; + $spec_part{fail} = $spec; + next; + } + if ($spec =~ m/^err=(-?\d+)$/) { + $fail_err = $1; + $spec_part{err} = $spec; + next; + } + if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { + $delay_duration = $1; + $delay_percent = $2; + $spec_part{delay} = $spec; + next; + } + elsif ($spec !~ m/^(\w+|\*)$/) { + warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; + next; + } + + my $method = $spec; + if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { + warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; + next; + } + unless (defined $fail_percent or defined $delay_percent) { + warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceeded by 'fail=N' and/or 'delayN=N'"; + next; + } + + push @spec_note, join(",", values(%spec_part), $method); + $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); + } + warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" + if @spec_note; + $dbh->{Callbacks} = $callbacks; + $dbh->{private_gofer_rand_fail_callbacks} = $callbacks; +} + +my %_mk_rand_callback_seqn; + +sub _mk_rand_callback { + my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; + my ($fail_modrate, $delay_modrate); + $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; + $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; + # note that $method may be "*" but that's not recommended or documented or wise + return sub { + my ($h) = @_; + my $seqn = ++$_mk_rand_callback_seqn{$method}; + my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : + ($delay_percent < 0) ? !($seqn % $delay_modrate): 0; + my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : + ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; + #no warnings 'uninitialized'; + #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; + if ($delay) { + my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; + # Note what's happening in a trace message. If the delay percent is an even + # number then use warn() instead so it's sent back to the client. + ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); + select undef, undef, undef, $delay_duration; # allows floating point value + } + if ($fail) { + undef $_; # tell DBI to not call the method + # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr + # as it's checked for in a few places, such as the gofer retry logic + return $h->set_err($fail_err || $DBI::stderr, + "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); + } + return; + } +} + + +sub update_stats { + my ($self, + $request, $response, + $frozen_request, $frozen_response, + $time_received, + $store_meta, $other_meta, + ) = @_; + + # should always have a response object here + carp("No response object provided") unless $request; + + my $stats = $self->{stats}; + $stats->{frozen_request_max_bytes} = length($frozen_request) + if $frozen_request + && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); + $stats->{frozen_response_max_bytes} = length($frozen_response) + if $frozen_response + && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); + + my $recent; + if (my $track_recent = $self->{track_recent}) { + $recent = { + request => $frozen_request, + response => $frozen_response, + time_received => $time_received, + duration => dbi_time()-$time_received, + # for any other info + ($store_meta) ? (meta => $store_meta) : (), + }; + $recent->{request_object} = $request + if !$frozen_request && $request; + $recent->{response_object} = $response + if !$frozen_response; + my @queues = ($stats->{recent_requests} ||= []); + push @queues, ($stats->{recent_errors} ||= []) + if !$response or $response->err; + for my $queue (@queues) { + push @$queue, $recent; + shift @$queue if @$queue > $track_recent; + } + } + return $recent; +} + + +1; +__END__ + +=head1 NAME + +DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses + +=head1 SYNOPSIS + + $executor = DBI::Gofer::Execute->new( { ...config... }); + + $response = $executor->execute_request( $request ); + +=head1 DESCRIPTION + +Accepts a DBI::Gofer::Request object, executes the requested DBI method calls, +and returns a DBI::Gofer::Response object. + +Any error, including any internal 'fatal' errors are caught and converted into +a DBI::Gofer::Response object. + +This module is usually invoked by a 'server-side' Gofer transport module. +They usually have names in the "C<DBI::Gofer::Transport::*>" namespace. +Examples include: L<DBI::Gofer::Transport::stream> and L<DBI::Gofer::Transport::mod_perl>. + +=head1 CONFIGURATION + +=head2 check_request_sub + +If defined, it must be a reference to a subroutine that will 'check' the request. +It is passed the request object and the executor as its only arguments. + +The subroutine can either return the original request object or die with a +suitable error message (which will be turned into a Gofer response). + +It can also construct and return a new request that should be executed instead +of the original request. + +=head2 check_response_sub + +If defined, it must be a reference to a subroutine that will 'check' the response. +It is passed the response object, the executor, and the request object. +The sub may alter the response object and return undef, or return a new response object. + +This mechanism can be used to, for example, terminate the service if specific +database errors are seen. + +=head2 forced_connect_dsn + +If set, this DSN is always used instead of the one in the request. + +=head2 default_connect_dsn + +If set, this DSN is used if C<forced_connect_dsn> is not set and the request does not contain a DSN itself. + +=head2 forced_connect_attributes + +A reference to a hash of connect() attributes. Individual attributes in +C<forced_connect_attributes> will take precedence over corresponding attributes +in the request. + +=head2 default_connect_attributes + +A reference to a hash of connect() attributes. Individual attributes in the +request take precedence over corresponding attributes in C<default_connect_attributes>. + +=head2 max_cached_dbh_per_drh + +If set, the loaded drivers will be checked to ensure they don't have more than +this number of cached connections. There is no default value. This limit is not +enforced for every request. + +=head2 max_cached_sth_per_dbh + +If set, all the cached statement handles will be cleared once the number of +cached statement handles rises above this limit. The default is 1000. + +=head2 forced_single_resultset + +If true, then only the first result set will be fetched and returned in the response. + +=head2 forced_response_attributes + +A reference to a data structure that can specify extra attributes to be returned in responses. + + forced_response_attributes => { + DriverName => { + dbh => [ qw(dbh_attrib_name) ], + sth => [ qw(sth_attrib_name) ], + }, + }, + +This can be useful in cases where the driver has not implemented the +private_attribute_info() method and DBI::Gofer::Execute's own fallback list of +private attributes doesn't include the driver or attributes you need. + +=head2 track_recent + +If set, specifies the number of recent requests and responses that should be +kept by the update_stats() method for diagnostics. See L<DBI::Gofer::Transport::mod_perl>. + +Note that this setting can significantly increase memory use. Use with caution. + +=head2 forced_gofer_random + +Enable forced random failures and/or delays for testing. See L</DBI_GOFER_RANDOM> below. + +=head1 DRIVER-SPECIFIC ISSUES + +Gofer needs to know about any driver-private attributes that should have their +values sent back to the client. + +If the driver doesn't support private_attribute_info() method, and very few do, +then the module fallsback to using some hard-coded details, if available, for +the driver being used. Currently hard-coded details are available for the +mysql, Pg, Sybase, and SQLite drivers. + +=head1 TESTING + +DBD::Gofer, DBD::Execute and related packages are well tested by executing the +DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer. + +Because Gofer includes timeout and 'retry on error' mechanisms there is a need +for some way to trigger delays and/or errors. This can be done via the +C<forced_gofer_random> configuration item, or else the DBI_GOFER_RANDOM environment +variable. + +=head2 DBI_GOFER_RANDOM + +The value of the C<forced_gofer_random> configuration item (or else the +DBI_GOFER_RANDOM environment variable) is treated as a series of tokens +separated by commas. + +The tokens can be one of three types: + +=over 4 + +=item fail=R% + +Set the current failure rate to R where R is a percentage. +The value R can be floating point, e.g., C<fail=0.05%>. +Negative values for R have special meaning, see below. + +=item err=N + +Sets the current failure err value to N (instead of the DBI's default 'standard +err value' of 2000000000). This is useful when you want to simulate a +specific error. + +=item delayN=R% + +Set the current random delay rate to R where R is a percentage, and set the +current delay duration to N seconds. The values of R and N can be floating point, +e.g., C<delay0.5=0.2%>. Negative values for R have special meaning, see below. + +If R is an odd number (R % 2 == 1) then a message is logged via warn() which +will be returned to, and echoed at, the client. + +=item methodname + +Applies the current fail, err, and delay values to the named method. +If neither a fail nor delay have been set yet then a warning is generated. + +=back + +For example: + + $executor = DBI::Gofer::Execute->new( { + forced_gofer_random => "fail=0.01%,do,delay60=1%,execute", + }); + +will cause the do() method to fail for 0.01% of calls, and the execute() method to +fail 0.01% of calls and be delayed by 60 seconds on 1% of calls. + +If the percentage value (C<R>) is negative then instead of the failures being +triggered randomly (via the rand() function) they are triggered via a sequence +number. In other words "C<fail=-20%>" will mean every fifth call will fail. +Each method has a distinct sequence number. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut diff --git a/lib/DBI/Gofer/Request.pm b/lib/DBI/Gofer/Request.pm new file mode 100644 index 0000000..d6464a6 --- /dev/null +++ b/lib/DBI/Gofer/Request.pm @@ -0,0 +1,200 @@ +package DBI::Gofer::Request; + +# $Id: Request.pm 12536 2009-02-24 22:37:09Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; + +use DBI qw(neat neat_list); + +use base qw(DBI::Util::_accessor); + +our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o); + +use constant GOf_REQUEST_IDEMPOTENT => 0x0001; +use constant GOf_REQUEST_READONLY => 0x0002; + +our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY); + + +__PACKAGE__->mk_accessors(qw( + version + flags + dbh_connect_call + dbh_method_call + dbh_attributes + dbh_last_insert_id_args + sth_method_calls + sth_result_attr +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($self, $args) = @_; + $args->{version} ||= $VERSION; + return $self->SUPER::new($args); +} + + +sub reset { + my ($self, $flags) = @_; + # remove everything except connect and version + %$self = ( + version => $self->{version}, + dbh_connect_call => $self->{dbh_connect_call}, + ); + $self->{flags} = $flags if $flags; +} + + +sub init_request { + my ($self, $method_and_args, $dbh) = @_; + $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 ); + $self->dbh_method_call($method_and_args); +} + + +sub is_sth_request { + return shift->{sth_result_attr}; +} + + +sub statements { + my $self = shift; + my @statements; + if (my $dbh_method_call = $self->dbh_method_call) { + my $statement_method_regex = qr/^(?:do|prepare)$/; + my (undef, $method, $arg1) = @$dbh_method_call; + push @statements, $arg1 if $method && $method =~ $statement_method_regex; + } + return @statements; +} + + +sub is_idempotent { + my $self = shift; + + if (my $flags = $self->flags) { + return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY); + } + + # else check if all statements are SELECT statement that don't include FOR UPDATE + my @statements = $self->statements; + # XXX this is very minimal for now, doesn't even allow comments before the select + # (and can't ever work for "exec stored_procedure_name" kinds of statements) + # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar") + return 1 if @statements == grep { + m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi + } @statements; + + return 0; +} + + +sub summary_as_text { + my $self = shift; + my ($context) = @_; + my @s = ''; + + if ($context && %$context) { + my @keys = sort keys %$context; + push @s, join(", ", map { "$_=>".$context->{$_} } @keys); + } + + my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call }; + $method ||= 'connect_cached'; + $pass = '***' if defined $pass; + my $tmp = ''; + if ($attr) { + $tmp = { %{$attr||{}} }; # copy so we can edit + $tmp->{Password} = '***' if exists $tmp->{Password}; + $tmp = "{ ".neat_list([ %$tmp ])." }"; + } + push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp; + + if (my $flags = $self->flags) { + push @s, sprintf "flags: 0x%x", $flags; + } + + if (my $dbh_attr = $self->dbh_attributes) { + push @s, sprintf "dbh->FETCH: %s", @$dbh_attr + if @$dbh_attr; + } + + my ($wantarray, $meth, @args) = @{ $self->dbh_method_call }; + my $args = neat_list(\@args); + $args =~ s/\n+/ /g; + push @s, sprintf "dbh->%s(%s)", $meth, $args; + + if (my $lii_args = $self->dbh_last_insert_id_args) { + push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args); + } + + for my $call (@{ $self->sth_method_calls || [] }) { + my ($meth, @args) = @$call; + ($args = neat_list(\@args)) =~ s/\n+/ /g; + push @s, sprintf "sth->%s(%s)", $meth, $args; + } + + if (my $sth_attr = $self->sth_result_attr) { + push @s, sprintf "sth->FETCH: %s", %$sth_attr + if %$sth_attr; + } + + return join("\n\t", @s) . "\n"; +} + + +sub outline_as_text { # one-line version of summary_as_text + my $self = shift; + my @s = ''; + my $neatlen = 80; + + if (my $flags = $self->flags) { + push @s, sprintf "flags=0x%x", $flags; + } + + my (undef, $meth, @args) = @{ $self->dbh_method_call }; + push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); + + for my $call (@{ $self->sth_method_calls || [] }) { + my ($meth, @args) = @$call; + push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); + } + + my ($method, $dsn) = @{ $self->dbh_connect_call }; + push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting + + (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines + return $outline; +} + +1; + +=head1 NAME + +DBI::Gofer::Request - Encapsulate a request from DBD::Gofer to DBI::Gofer::Execute + +=head1 DESCRIPTION + +This is an internal class. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut diff --git a/lib/DBI/Gofer/Response.pm b/lib/DBI/Gofer/Response.pm new file mode 100644 index 0000000..b09782e --- /dev/null +++ b/lib/DBI/Gofer/Response.pm @@ -0,0 +1,218 @@ +package DBI::Gofer::Response; + +# $Id: Response.pm 11565 2008-07-22 20:17:33Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; + +use Carp; +use DBI qw(neat neat_list); + +use base qw(DBI::Util::_accessor Exporter); + +our $VERSION = sprintf("0.%06d", q$Revision: 11565 $ =~ /(\d+)/o); + +use constant GOf_RESPONSE_EXECUTED => 0x0001; + +our @EXPORT = qw(GOf_RESPONSE_EXECUTED); + + +__PACKAGE__->mk_accessors(qw( + version + rv + err + errstr + state + flags + last_insert_id + dbh_attributes + sth_resultsets + warnings +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($self, $args) = @_; + $args->{version} ||= $VERSION; + chomp $args->{errstr} if $args->{errstr}; + return $self->SUPER::new($args); +} + + +sub err_errstr_state { + my $self = shift; + return @{$self}{qw(err errstr state)}; +} + +sub executed_flag_set { + my $flags = shift->flags + or return 0; + return $flags & GOf_RESPONSE_EXECUTED; +} + + +sub add_err { + my ($self, $err, $errstr, $state, $trace) = @_; + + # acts like the DBI's set_err method. + # this code copied from DBI::PurePerl's set_err method. + + chomp $errstr if $errstr; + $state ||= ''; + carp ref($self)."->add_err($err, $errstr, $state)" + if $trace and defined($err) || $errstr; + + my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state}); + + if ($r_errstr) { + $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err + if $r_err && $err && $r_err ne $err; + $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state + if $r_state and $r_state ne "S1000" && $state && $r_state ne $state; + $r_errstr .= "\n$errstr" if $r_errstr ne $errstr; + } + else { + $r_errstr = $errstr; + } + + # assign if higher priority: err > "0" > "" > undef + my $err_changed; + if ($err # new error: so assign + or !defined $r_err # no existing warn/info: so assign + # new warn ("0" len 1) > info ("" len 0): so assign + or defined $err && length($err) > length($r_err) + ) { + $r_err = $err; + ++$err_changed; + } + + $r_state = ($state eq "00000") ? "" : $state + if $state && $err_changed; + + ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state); + + return undef; +} + + +sub summary_as_text { + my $self = shift; + my ($context) = @_; + + my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); + + my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); + $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr)) + if defined $err; + $s[-1] .= sprintf(", flags=0x%x", $self->{flags}) + if defined $self->{flags}; + + push @s, "last_insert_id=%s", $self->last_insert_id + if defined $self->last_insert_id; + + if (my $dbh_attr = $self->dbh_attributes) { + my @keys = sort keys %$dbh_attr; + push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys) + if @keys; + } + + for my $rs (@{$self->sth_resultsets || []}) { + my ($rowset, $err, $errstr, $state) + = @{$rs}{qw(rowset err errstr state)}; + my $summary = "rowset: "; + my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; + my $rows = $rowset ? @$rowset : 0; + if ($rowset || $NUM_OF_FIELDS > 0) { + $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS; + } + $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err; + if ($rows) { + my $NAME = $rs->{NAME}; + # generate + my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1; + $summary .= sprintf " [%s]", join ", ", @colinfo; + $summary .= ",..." if $rows > 1; + # we can be a little more helpful for Sybase/MSSQL user + $summary .= " syb_result_type=$rs->{syb_result_type}" + if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040; + } + push @s, $summary; + } + for my $w (@{$self->warnings || []}) { + chomp $w; + push @s, "warning: $w"; + } + if ($context && %$context) { + my @keys = sort keys %$context; + push @s, join(", ", map { "$_=>".$context->{$_} } @keys); + } + return join("\n\t", @s). "\n"; +} + + +sub outline_as_text { # one-line version of summary_as_text + my $self = shift; + my ($context) = @_; + + my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); + + my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); + $s .= sprintf(", err=%s %s", $err, neat($errstr)) + if defined $err; + $s .= sprintf(", flags=0x%x", $self->{flags}) + if $self->{flags}; + + if (my $sth_resultsets = $self->sth_resultsets) { + $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets); + + my @rs; + for my $rs (@{$self->sth_resultsets || []}) { + my $summary = ""; + my ($rowset, $err, $errstr) + = @{$rs}{qw(rowset err errstr)}; + my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; + my $rows = $rowset ? @$rowset : 0; + if ($rowset || $NUM_OF_FIELDS > 0) { + $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS; + } + $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr) + if defined $err; + push @rs, $summary; + } + $s .= join "; ", map { "[$_]" } @rs; + } + + return $s; +} + + +1; + +=head1 NAME + +DBI::Gofer::Response - Encapsulate a response from DBI::Gofer::Execute to DBD::Gofer + +=head1 DESCRIPTION + +This is an internal class. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBI/Gofer/Serializer/Base.pm b/lib/DBI/Gofer/Serializer/Base.pm new file mode 100644 index 0000000..53fc7e7 --- /dev/null +++ b/lib/DBI/Gofer/Serializer/Base.pm @@ -0,0 +1,64 @@ +package DBI::Gofer::Serializer::Base; + +# $Id: Base.pm 9949 2007-09-18 09:38:15Z timbo $ +# +# Copyright (c) 2007, 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. + +=head1 NAME + +DBI::Gofer::Serializer::Base - base class for Gofer serialization + +=head1 SYNOPSIS + + $serializer = $serializer_class->new(); + + $string = $serializer->serialize( $data ); + ($string, $deserializer_class) = $serializer->serialize( $data ); + + $data = $serializer->deserialize( $string ); + +=head1 DESCRIPTION + +DBI::Gofer::Serializer::* classes implement a very minimal subset of the L<Data::Serializer> API. + +Gofer serializers are expected to be very fast and are not required to deal +with anything other than non-blessed references to arrays and hashes, and plain scalars. + +=cut + + +use strict; +use warnings; + +use Carp qw(croak); + +our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o); + + +sub new { + my $class = shift; + my $deserializer_class = $class->deserializer_class; + return bless { deserializer_class => $deserializer_class } => $class; +} + +sub deserializer_class { + my $self = shift; + my $class = ref($self) || $self; + $class =~ s/^DBI::Gofer::Serializer:://; + return $class; +} + +sub serialize { + my $self = shift; + croak ref($self)." has not implemented the serialize method"; +} + +sub deserialize { + my $self = shift; + croak ref($self)." has not implemented the deserialize method"; +} + +1; diff --git a/lib/DBI/Gofer/Serializer/DataDumper.pm b/lib/DBI/Gofer/Serializer/DataDumper.pm new file mode 100644 index 0000000..c6fc3a1 --- /dev/null +++ b/lib/DBI/Gofer/Serializer/DataDumper.pm @@ -0,0 +1,53 @@ +package DBI::Gofer::Serializer::DataDumper; + +use strict; +use warnings; + +our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o); + +# $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z timbo $ +# +# Copyright (c) 2007, 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. + +=head1 NAME + +DBI::Gofer::Serializer::DataDumper - Gofer serialization using DataDumper + +=head1 SYNOPSIS + + $serializer = DBI::Gofer::Serializer::DataDumper->new(); + + $string = $serializer->serialize( $data ); + +=head1 DESCRIPTION + +Uses DataDumper to serialize. Deserialization is not supported. +The output of this class is only meant for human consumption. + +See also L<DBI::Gofer::Serializer::Base>. + +=cut + +use Data::Dumper; + +use base qw(DBI::Gofer::Serializer::Base); + + +sub serialize { + my $self = shift; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 0; # enabling this disables xs + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Purity = 0; + my $frozen = Data::Dumper::Dumper(shift); + return $frozen unless wantarray; + return ($frozen, $self->{deserializer_class}); +} + +1; diff --git a/lib/DBI/Gofer/Serializer/Storable.pm b/lib/DBI/Gofer/Serializer/Storable.pm new file mode 100644 index 0000000..9a571bd --- /dev/null +++ b/lib/DBI/Gofer/Serializer/Storable.pm @@ -0,0 +1,59 @@ +package DBI::Gofer::Serializer::Storable; + +use strict; +use warnings; + +use base qw(DBI::Gofer::Serializer::Base); + +# $Id: Storable.pm 9949 2007-09-18 09:38:15Z timbo $ +# +# Copyright (c) 2007, 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. + +=head1 NAME + +DBI::Gofer::Serializer::Storable - Gofer serialization using Storable + +=head1 SYNOPSIS + + $serializer = DBI::Gofer::Serializer::Storable->new(); + + $string = $serializer->serialize( $data ); + ($string, $deserializer_class) = $serializer->serialize( $data ); + + $data = $serializer->deserialize( $string ); + +=head1 DESCRIPTION + +Uses Storable::nfreeze() to serialize and Storable::thaw() to deserialize. + +The serialize() method sets local $Storable::forgive_me = 1; so it doesn't +croak if it encounters any data types that can't be serialized, such as code refs. + +See also L<DBI::Gofer::Serializer::Base>. + +=cut + +use Storable qw(nfreeze thaw); + +our $VERSION = sprintf("0.%06d", q$Revision: 9949 $ =~ /(\d+)/o); + +use base qw(DBI::Gofer::Serializer::Base); + + +sub serialize { + my $self = shift; + local $Storable::forgive_me = 1; # for CODE refs etc + my $frozen = nfreeze(shift); + return $frozen unless wantarray; + return ($frozen, $self->{deserializer_class}); +} + +sub deserialize { + my $self = shift; + return thaw(shift); +} + +1; diff --git a/lib/DBI/Gofer/Transport/Base.pm b/lib/DBI/Gofer/Transport/Base.pm new file mode 100644 index 0000000..b688689 --- /dev/null +++ b/lib/DBI/Gofer/Transport/Base.pm @@ -0,0 +1,176 @@ +package DBI::Gofer::Transport::Base; + +# $Id: Base.pm 12536 2009-02-24 22:37:09Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use DBI; + +use base qw(DBI::Util::_accessor); + +use DBI::Gofer::Serializer::Storable; +use DBI::Gofer::Serializer::DataDumper; + + +our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o); + + +__PACKAGE__->mk_accessors(qw( + trace + keep_meta_frozen + serializer_obj +)); + + +# see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute +sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] } + + +sub new { + my ($class, $args) = @_; + $args->{trace} ||= $class->_init_trace; + $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new(); + my $self = bless {}, $class; + $self->$_( $args->{$_} ) for keys %$args; + $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace; + return $self; +} + +my $packet_header_text = "GoFER1:"; +my $packet_header_regex = qr/^GoFER(\d+):/; + + +sub _freeze_data { + my ($self, $data, $serializer, $skip_trace) = @_; + my $frozen = eval { + $self->_dump("freezing $self->{trace} ".ref($data), $data) + if !$skip_trace and $self->trace; + + local $data->{meta}; # don't include meta in serialization + $serializer ||= $self->{serializer_obj}; + my ($data, $deserializer_class) = $serializer->serialize($data); + + $packet_header_text . $data; + }; + if ($@) { + chomp $@; + die "Error freezing ".ref($data)." object: $@"; + } + + # stash the frozen data into the data structure itself + # to make life easy for the client caching code in DBD::Gofer::Transport::Base + $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen; + + return $frozen; +} +# public aliases used by subclasses +*freeze_request = \&_freeze_data; +*freeze_response = \&_freeze_data; + + +sub _thaw_data { + my ($self, $frozen_data, $serializer, $skip_trace) = @_; + my $data; + eval { + # check for and extract our gofer header and the info it contains + (my $frozen = $frozen_data) =~ s/$packet_header_regex//o + or die "does not have gofer header\n"; + my ($t_version) = $1; + $serializer ||= $self->{serializer_obj}; + $data = $serializer->deserialize($frozen); + die ref($serializer)."->deserialize didn't return a reference" + unless ref $data; + $data->{_transport}{version} = $t_version; + + $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen; + }; + if ($@) { + chomp(my $err = $@); + # remove extra noise from Storable + $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{}; + my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50); + Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace; + die $msg; + } + $self->_dump("thawing $self->{trace} ".ref($data), $data) + if !$skip_trace and $self->trace; + + return $data; +} +# public aliases used by subclasses +*thaw_request = \&_thaw_data; +*thaw_response = \&_thaw_data; + + +# this should probably live in the request and response classes +# and the tace level passed in +sub _dump { + my ($self, $label, $data) = @_; + + # don't dump the binary + local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen}; + + my $trace_level = $self->trace; + my $summary; + if ($trace_level >= 4) { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Purity = 0; + $summary = Data::Dumper::Dumper($data); + } + elsif ($trace_level >= 2) { + $summary = eval { $data->summary_as_text } || $@ || "no summary available\n"; + } + else { + $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n"; + } + $self->trace_msg("$label: $summary"); +} + + +sub trace_msg { + my ($self, $msg, $min_level) = @_; + $min_level = 1 unless defined $min_level; + # transport trace level can override DBI's trace level + $min_level = 0 if $self->trace >= $min_level; + return DBI->trace_msg("gofer ".$msg, $min_level); +} + +1; + +=head1 NAME + +DBI::Gofer::Transport::Base - Base class for Gofer transports + +=head1 DESCRIPTION + +This is the base class for server-side Gofer transports. + +It's also the base class for the client-side base class L<DBD::Gofer::Transport::Base>. + +This is an internal class. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBI/Gofer/Transport/pipeone.pm b/lib/DBI/Gofer/Transport/pipeone.pm new file mode 100644 index 0000000..d79c2eb --- /dev/null +++ b/lib/DBI/Gofer/Transport/pipeone.pm @@ -0,0 +1,61 @@ +package DBI::Gofer::Transport::pipeone; + +# $Id: pipeone.pm 12536 2009-02-24 22:37:09Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use DBI::Gofer::Execute; + +use base qw(DBI::Gofer::Transport::Base Exporter); + +our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o); + +our @EXPORT = qw(run_one_stdio); + +my $executor = DBI::Gofer::Execute->new(); + +sub run_one_stdio { + + my $transport = DBI::Gofer::Transport::pipeone->new(); + + my $frozen_request = do { local $/; <STDIN> }; + + my $response = $executor->execute_request( $transport->thaw_request($frozen_request) ); + + my $frozen_response = $transport->freeze_response($response); + + print $frozen_response; + + # no point calling $executor->update_stats(...) for pipeONE +} + +1; +__END__ + +=head1 NAME + +DBI::Gofer::Transport::pipeone - DBD::Gofer server-side transport for pipeone + +=head1 SYNOPSIS + +See L<DBD::Gofer::Transport::pipeone>. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut + diff --git a/lib/DBI/Gofer/Transport/stream.pm b/lib/DBI/Gofer/Transport/stream.pm new file mode 100644 index 0000000..49de550 --- /dev/null +++ b/lib/DBI/Gofer/Transport/stream.pm @@ -0,0 +1,76 @@ +package DBI::Gofer::Transport::stream; + +# $Id: stream.pm 12536 2009-02-24 22:37:09Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +use DBI qw(dbi_time); +use DBI::Gofer::Execute; + +use base qw(DBI::Gofer::Transport::pipeone Exporter); + +our $VERSION = sprintf("0.%06d", q$Revision: 12536 $ =~ /(\d+)/o); + +our @EXPORT = qw(run_stdio_hex); + +my $executor = DBI::Gofer::Execute->new(); + +sub run_stdio_hex { + + my $transport = DBI::Gofer::Transport::stream->new(); + local $| = 1; + + DBI->trace_msg("$0 started (pid $$)\n"); + + local $\; # OUTPUT_RECORD_SEPARATOR + local $/ = "\012"; # INPUT_RECORD_SEPARATOR + while ( defined( my $encoded_request = <STDIN> ) ) { + my $time_received = dbi_time(); + $encoded_request =~ s/\015?\012$//; + + my $frozen_request = pack "H*", $encoded_request; + my $request = $transport->thaw_request( $frozen_request ); + + my $response = $executor->execute_request( $request ); + + my $frozen_response = $transport->freeze_response($response); + my $encoded_response = unpack "H*", $frozen_response; + + print $encoded_response, "\015\012"; # autoflushed due to $|=1 + + # there's no way to access the stats currently + # so this just serves as a basic test and illustration of update_stats() + $executor->update_stats($request, $response, $frozen_request, $frozen_response, $time_received, 1); + } + DBI->trace_msg("$0 ending (pid $$)\n"); +} + +1; +__END__ + +=head1 NAME + +DBI::Gofer::Transport::stream - DBD::Gofer server-side transport for stream + +=head1 SYNOPSIS + +See L<DBD::Gofer::Transport::stream>. + +=head1 AUTHOR + +Tim Bunce, L<http://www.tim.bunce.name> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L<perlartistic>. + +=cut diff --git a/lib/DBI/Profile.pm b/lib/DBI/Profile.pm new file mode 100644 index 0000000..a468c05 --- /dev/null +++ b/lib/DBI/Profile.pm @@ -0,0 +1,949 @@ +package DBI::Profile; + +=head1 NAME + +DBI::Profile - Performance profiling and benchmarking for the DBI + +=head1 SYNOPSIS + +The easiest way to enable DBI profiling is to set the DBI_PROFILE +environment variable to 2 and then run your code as usual: + + DBI_PROFILE=2 prog.pl + +This will profile your program and then output a textual summary +grouped by query when the program exits. You can also enable profiling by +setting the Profile attribute of any DBI handle: + + $dbh->{Profile} = 2; + +Then the summary will be printed when the handle is destroyed. + +Many other values apart from are possible - see L<"ENABLING A PROFILE"> below. + +=head1 DESCRIPTION + +The DBI::Profile module provides a simple interface to collect and +report performance and benchmarking data from the DBI. + +For a more elaborate interface, suitable for larger programs, see +L<DBI::ProfileDumper|DBI::ProfileDumper> and L<dbiprof|dbiprof>. +For Apache/mod_perl applications see +L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>. + +=head1 OVERVIEW + +Performance data collection for the DBI is built around several +concepts which are important to understand clearly. + +=over 4 + +=item Method Dispatch + +Every method call on a DBI handle passes through a single 'dispatch' +function which manages all the common aspects of DBI method calls, +such as handling the RaiseError attribute. + +=item Data Collection + +If profiling is enabled for a handle then the dispatch code takes +a high-resolution timestamp soon after it is entered. Then, after +calling the appropriate method and just before returning, it takes +another high-resolution timestamp and calls a function to record +the information. That function is passed the two timestamps +plus the DBI handle and the name of the method that was called. +That data about a single DBI method call is called a I<profile sample>. + +=item Data Filtering + +If the method call was invoked by the DBI or by a driver then the call is +ignored for profiling because the time spent will be accounted for by the +original 'outermost' call for your code. + +For example, the calls that the selectrow_arrayref() method makes +to prepare() and execute() etc. are not counted individually +because the time spent in those methods is going to be allocated +to the selectrow_arrayref() method when it returns. If this was not +done then it would be very easy to double count time spent inside +the DBI. + +=item Data Storage Tree + +The profile data is accumulated as 'leaves on a tree'. The 'path' through the +branches of the tree to a particular leaf is determined dynamically for each sample. +This is a key feature of DBI profiling. + +For each profiled method call the DBI walks along the Path and uses each value +in the Path to step into and grow the Data tree. + +For example, if the Path is + + [ 'foo', 'bar', 'baz' ] + +then the new profile sample data will be I<merged> into the tree at + + $h->{Profile}->{Data}->{foo}->{bar}->{baz} + +But it's not very useful to merge all the call data into one leaf node (except +to get an overall 'time spent inside the DBI' total). It's more common to want +the Path to include dynamic values such as the current statement text and/or +the name of the method called to show what the time spent inside the DBI was for. + +The Path can contain some 'magic cookie' values that are automatically replaced +by corresponding dynamic values when they're used. These magic cookies always +start with a punctuation character. + +For example a value of 'C<!MethodName>' in the Path causes the corresponding +entry in the Data to be the name of the method that was called. +For example, if the Path was: + + [ 'foo', '!MethodName', 'bar' ] + +and the selectall_arrayref() method was called, then the profile sample data +for that call will be merged into the tree at: + + $h->{Profile}->{Data}->{foo}->{selectall_arrayref}->{bar} + +=item Profile Data + +Profile data is stored at the 'leaves' of the tree as references +to an array of numeric values. For example: + + [ + 106, # 0: count of samples at this node + 0.0312958955764771, # 1: total duration + 0.000490069389343262, # 2: first duration + 0.000176072120666504, # 3: shortest duration + 0.00140702724456787, # 4: longest duration + 1023115819.83019, # 5: time of first sample + 1023115819.86576, # 6: time of last sample + ] + +After the first sample, later samples always update elements 0, 1, and 6, and +may update 3 or 4 depending on the duration of the sampled call. + +=back + +=head1 ENABLING A PROFILE + +Profiling is enabled for a handle by assigning to the Profile +attribute. For example: + + $h->{Profile} = DBI::Profile->new(); + +The Profile attribute holds a blessed reference to a hash object +that contains the profile data and attributes relating to it. + +The class the Profile object is blessed into is expected to +provide at least a DESTROY method which will dump the profile data +to the DBI trace file handle (STDERR by default). + +All these examples have the same effect as each other: + + $h->{Profile} = 0; + $h->{Profile} = "/DBI::Profile"; + $h->{Profile} = DBI::Profile->new(); + $h->{Profile} = {}; + $h->{Profile} = { Path => [] }; + +Similarly, these examples have the same effect as each other: + + $h->{Profile} = 6; + $h->{Profile} = "6/DBI::Profile"; + $h->{Profile} = "!Statement:!MethodName/DBI::Profile"; + $h->{Profile} = { Path => [ '!Statement', '!MethodName' ] }; + +If a non-blessed hash reference is given then the DBI::Profile +module is automatically C<require>'d and the reference is blessed +into that class. + +If a string is given then it is processed like this: + + ($path, $module, $args) = split /\//, $string, 3 + + @path = split /:/, $path + @args = split /:/, $args + + eval "require $module" if $module + $module ||= "DBI::Profile" + + $module->new( Path => \@Path, @args ) + +So the first value is used to select the Path to be used (see below). +The second value, if present, is used as the name of a module which +will be loaded and it's C<new> method called. If not present it +defaults to DBI::Profile. Any other values are passed as arguments +to the C<new> method. For example: "C<2/DBIx::OtherProfile/Foo:42>". + +Numbers can be used as a shorthand way to enable common Path values. +The simplest way to explain how the values are interpreted is to show the code: + + push @Path, "DBI" if $path_elem & 0x01; + push @Path, "!Statement" if $path_elem & 0x02; + push @Path, "!MethodName" if $path_elem & 0x04; + push @Path, "!MethodClass" if $path_elem & 0x08; + push @Path, "!Caller2" if $path_elem & 0x10; + +So "2" is the same as "!Statement" and "6" (2+4) is the same as +"!Statement:!Method". Those are the two most commonly used values. Using a +negative number will reverse the path. Thus "-6" will group by method name then +statement. + +The splitting and parsing of string values assigned to the Profile +attribute may seem a little odd, but there's a good reason for it. +Remember that attributes can be embedded in the Data Source Name +string which can be passed in to a script as a parameter. For +example: + + dbi:DriverName(Profile=>2):dbname + dbi:DriverName(Profile=>{Username}:!Statement/MyProfiler/Foo:42):dbname + +And also, if the C<DBI_PROFILE> environment variable is set then +The DBI arranges for every driver handle to share the same profile +object. When perl exits a single profile summary will be generated +that reflects (as nearly as practical) the total use of the DBI by +the application. + + +=head1 THE PROFILE OBJECT + +The DBI core expects the Profile attribute value to be a hash +reference and if the following values don't exist it will create +them as needed: + +=head2 Data + +A reference to a hash containing the collected profile data. + +=head2 Path + +The Path value is a reference to an array. Each element controls the +value to use at the corresponding level of the profile Data tree. + +If the value of Path is anything other than an array reference, +it is treated as if it was: + + [ '!Statement' ] + +The elements of Path array can be one of the following types: + +=head3 Special Constant + +B<!Statement> + +Use the current Statement text. Typically that's the value of the Statement +attribute for the handle the method was called with. Some methods, like +commit() and rollback(), are unrelated to a particular statement. For those +methods !Statement records an empty string. + +For statement handles this is always simply the string that was +given to prepare() when the handle was created. For database handles +this is the statement that was last prepared or executed on that +database handle. That can lead to a little 'fuzzyness' because, for +example, calls to the quote() method to build a new statement will +typically be associated with the previous statement. In practice +this isn't a significant issue and the dynamic Path mechanism can +be used to setup your own rules. + +B<!MethodName> + +Use the name of the DBI method that the profile sample relates to. + +B<!MethodClass> + +Use the fully qualified name of the DBI method, including +the package, that the profile sample relates to. This shows you +where the method was implemented. For example: + + 'DBD::_::db::selectrow_arrayref' => + 0.022902s + 'DBD::mysql::db::selectrow_arrayref' => + 2.244521s / 99 = 0.022445s avg (first 0.022813s, min 0.022051s, max 0.028932s) + +The "DBD::_::db::selectrow_arrayref" shows that the driver has +inherited the selectrow_arrayref method provided by the DBI. + +But you'll note that there is only one call to +DBD::_::db::selectrow_arrayref but another 99 to +DBD::mysql::db::selectrow_arrayref. Currently the first +call doesn't record the true location. That may change. + +B<!Caller> + +Use a string showing the filename and line number of the code calling the method. + +B<!Caller2> + +Use a string showing the filename and line number of the code calling the +method, as for !Caller, but also include filename and line number of the code +that called that. Calls from DBI:: and DBD:: packages are skipped. + +B<!File> + +Same as !Caller above except that only the filename is included, not the line number. + +B<!File2> + +Same as !Caller2 above except that only the filenames are included, not the line number. + +B<!Time> + +Use the current value of time(). Rarely used. See the more useful C<!Time~N> below. + +B<!Time~N> + +Where C<N> is an integer. Use the current value of time() but with reduced precision. +The value used is determined in this way: + + int( time() / N ) * N + +This is a useful way to segregate a profile into time slots. For example: + + [ '!Time~60', '!Statement' ] + +=head3 Code Reference + +The subroutine is passed the handle it was called on and the DBI method name. +The current Statement is in $_. The statement string should not be modified, +so most subs start with C<local $_ = $_;>. + +The list of values it returns is used at that point in the Profile Path. + +The sub can 'veto' (reject) a profile sample by including a reference to undef +in the returned list. That can be useful when you want to only profile +statements that match a certain pattern, or only profile certain methods. + +=head3 Subroutine Specifier + +A Path element that begins with 'C<&>' is treated as the name of a subroutine +in the DBI::ProfileSubs namespace and replaced with the corresponding code reference. + +Currently this only works when the Path is specified by the C<DBI_PROFILE> +environment variable. + +Also, currently, the only subroutine in the DBI::ProfileSubs namespace is +C<'&norm_std_n3'>. That's a very handy subroutine when profiling code that +doesn't use placeholders. See L<DBI::ProfileSubs> for more information. + +=head3 Attribute Specifier + +A string enclosed in braces, such as 'C<{Username}>', specifies that the current +value of the corresponding database handle attribute should be used at that +point in the Path. + +=head3 Reference to a Scalar + +Specifies that the current value of the referenced scalar be used at that point +in the Path. This provides an efficient way to get 'contextual' values into +your profile. + +=head3 Other Values + +Any other values are stringified and used literally. + +(References, and values that begin with punctuation characters are reserved.) + + +=head1 REPORTING + +=head2 Report Format + +The current accumulated profile data can be formatted and output using + + print $h->{Profile}->format; + +To discard the profile data and start collecting fresh data +you can do: + + $h->{Profile}->{Data} = undef; + + +The default results format looks like this: + + DBI::Profile: 0.001015s 42.7% (5 calls) programname @ YYYY-MM-DD HH:MM:SS + '' => + 0.000024s / 2 = 0.000012s avg (first 0.000015s, min 0.000009s, max 0.000015s) + 'SELECT mode,size,name FROM table' => + 0.000991s / 3 = 0.000330s avg (first 0.000678s, min 0.000009s, max 0.000678s) + +Which shows the total time spent inside the DBI, with a count of +the total number of method calls and the name of the script being +run, then a formatted version of the profile data tree. + +If the results are being formatted when the perl process is exiting +(which is usually the case when the DBI_PROFILE environment variable +is used) then the percentage of time the process spent inside the +DBI is also shown. If the process is not exiting then the percentage is +calculated using the time between the first and last call to the DBI. + +In the example above the paths in the tree are only one level deep and +use the Statement text as the value (that's the default behaviour). + +The merged profile data at the 'leaves' of the tree are presented +as total time spent, count, average time spent (which is simply total +time divided by the count), then the time spent on the first call, +the time spent on the fastest call, and finally the time spent on +the slowest call. + +The 'avg', 'first', 'min' and 'max' times are not particularly +useful when the profile data path only contains the statement text. +Here's an extract of a more detailed example using both statement +text and method name in the path: + + 'SELECT mode,size,name FROM table' => + 'FETCH' => + 0.000076s + 'fetchrow_hashref' => + 0.036203s / 108 = 0.000335s avg (first 0.000490s, min 0.000152s, max 0.002786s) + +Here you can see the 'avg', 'first', 'min' and 'max' for the +108 calls to fetchrow_hashref() become rather more interesting. +Also the data for FETCH just shows a time value because it was only +called once. + +Currently the profile data is output sorted by branch names. That +may change in a later version so the leaf nodes are sorted by total +time per leaf node. + + +=head2 Report Destination + +The default method of reporting is for the DESTROY method of the +Profile object to format the results and write them using: + + DBI->trace_msg($results, 0); # see $ON_DESTROY_DUMP below + +to write them to the DBI trace() filehandle (which defaults to +STDERR). To direct the DBI trace filehandle to write to a file +without enabling tracing the trace() method can be called with a +trace level of 0. For example: + + DBI->trace(0, $filename); + +The same effect can be achieved without changing the code by +setting the C<DBI_TRACE> environment variable to C<0=filename>. + +The $DBI::Profile::ON_DESTROY_DUMP variable holds a code ref +that's called to perform the output of the formatted results. +The default value is: + + $ON_DESTROY_DUMP = sub { DBI->trace_msg($results, 0) }; + +Apart from making it easy to send the dump elsewhere, it can also +be useful as a simple way to disable dumping results. + +=head1 CHILD HANDLES + +Child handles inherit a reference to the Profile attribute value +of their parent. So if profiling is enabled for a database handle +then by default the statement handles created from it all contribute +to the same merged profile data tree. + + +=head1 PROFILE OBJECT METHODS + +=head2 format + +See L</REPORTING>. + +=head2 as_node_path_list + + @ary = $dbh->{Profile}->as_node_path_list(); + @ary = $dbh->{Profile}->as_node_path_list($node, $path); + +Returns the collected data ($dbh->{Profile}{Data}) restructured into a list of +array refs, one for each leaf node in the Data tree. This 'flat' structure is +often much simpler for applications to work with. + +The first element of each array ref is a reference to the leaf node. +The remaining elements are the 'path' through the data tree to that node. + +For example, given a data tree like this: + + {key1a}{key2a}[node1] + {key1a}{key2b}[node2] + {key1b}{key2a}{key3a}[node3] + +The as_node_path_list() method will return this list: + + [ [node1], 'key1a', 'key2a' ] + [ [node2], 'key1a', 'key2b' ] + [ [node3], 'key1b', 'key2a', 'key3a' ] + +The nodes are ordered by key, depth-first. + +The $node argument can be used to focus on a sub-tree. +If not specified it defaults to $dbh->{Profile}{Data}. + +The $path argument can be used to specify a list of path elements that will be +added to each element of the returned list. If not specified it defaults to a a +ref to an empty array. + +=head2 as_text + + @txt = $dbh->{Profile}->as_text(); + $txt = $dbh->{Profile}->as_text({ + node => undef, + path => [], + separator => " > ", + format => '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n"; + sortsub => sub { ... }, + ); + +Returns the collected data ($dbh->{Profile}{Data}) reformatted into a list of formatted strings. +In scalar context the list is returned as a single concatenated string. + +A hashref can be used to pass in arguments, the default values are shown in the example above. + +The C<node> and <path> arguments are passed to as_node_path_list(). + +The C<separator> argument is used to join the elements of the path for each leaf node. + +The C<sortsub> argument is used to pass in a ref to a sub that will order the list. +The subroutine will be passed a reference to the array returned by +as_node_path_list() and should sort the contents of the array in place. +The return value from the sub is ignored. For example, to sort the nodes by the +second level key you could use: + + sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary } + +The C<format> argument is a C<sprintf> format string that specifies the format +to use for each leaf node. It uses the explicit format parameter index +mechanism to specify which of the arguments should appear where in the string. +The arguments to sprintf are: + + 1: path to node, joined with the separator + 2: average duration (total duration/count) + (3 thru 9 are currently unused) + 10: count + 11: total duration + 12: first duration + 13: smallest duration + 14: largest duration + 15: time of first call + 16: time of first call + +=head1 CUSTOM DATA MANIPULATION + +Recall that C<< $h->{Profile}->{Data} >> is a reference to the collected data. +Either to a 'leaf' array (when the Path is empty, i.e., DBI_PROFILE env var is 1), +or a reference to hash containing values that are either further hash +references or leaf array references. + +Sometimes it's useful to be able to summarise some or all of the collected data. +The dbi_profile_merge_nodes() function can be used to merge leaf node values. + +=head2 dbi_profile_merge_nodes + + use DBI qw(dbi_profile_merge_nodes); + + $time_in_dbi = dbi_profile_merge_nodes(my $totals=[], @$leaves); + +Merges profile data node. Given a reference to a destination array, and zero or +more references to profile data, merges the profile data into the destination array. +For example: + + $time_in_dbi = dbi_profile_merge_nodes( + my $totals=[], + [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ], + [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ], + ); + +$totals will then contain + + [ 25, 0.93, 0.11, 0.01, 0.23, 1023110000, 1023110010 ] + +and $time_in_dbi will be 0.93; + +The second argument need not be just leaf nodes. If given a reference to a hash +then the hash is recursively searched for for leaf nodes and all those found +are merged. + +For example, to get the time spent 'inside' the DBI during an http request, +your logging code run at the end of the request (i.e. mod_perl LogHandler) +could use: + + my $time_in_dbi = 0; + if (my $Profile = $dbh->{Profile}) { # if DBI profiling is enabled + $time_in_dbi = dbi_profile_merge_nodes(my $total=[], $Profile->{Data}); + $Profile->{Data} = {}; # reset the profile data + } + +If profiling has been enabled then $time_in_dbi will hold the time spent inside +the DBI for that handle (and any other handles that share the same profile data) +since the last request. + +Prior to DBI 1.56 the dbi_profile_merge_nodes() function was called dbi_profile_merge(). +That name still exists as an alias. + +=head1 CUSTOM DATA COLLECTION + +=head2 Using The Path Attribute + + XXX example to be added later using a selectall_arrayref call + XXX nested inside a fetch loop where the first column of the + XXX outer loop is bound to the profile Path using + XXX bind_column(1, \${ $dbh->{Profile}->{Path}->[0] }) + XXX so you end up with separate profiles for each loop + XXX (patches welcome to add this to the docs :) + +=head2 Adding Your Own Samples + +The dbi_profile() function can be used to add extra sample data +into the profile data tree. For example: + + use DBI; + use DBI::Profile (dbi_profile dbi_time); + + my $t1 = dbi_time(); # floating point high-resolution time + + ... execute code you want to profile here ... + + my $t2 = dbi_time(); + dbi_profile($h, $statement, $method, $t1, $t2); + +The $h parameter is the handle the extra profile sample should be +associated with. The $statement parameter is the string to use where +the Path specifies !Statement. If $statement is undef +then $h->{Statement} will be used. Similarly $method is the string +to use if the Path specifies !MethodName. There is no +default value for $method. + +The $h->{Profile}{Path} attribute is processed by dbi_profile() in +the usual way. + +The $h parameter is usually a DBI handle but it can also be a reference to a +hash, in which case the dbi_profile() acts on each defined value in the hash. +This is an efficient way to update multiple profiles with a single sample, +and is used by the L<DashProfiler> module. + +=head1 SUBCLASSING + +Alternate profile modules must subclass DBI::Profile to help ensure +they work with future versions of the DBI. + + +=head1 CAVEATS + +Applications which generate many different statement strings +(typically because they don't use placeholders) and profile with +!Statement in the Path (the default) will consume memory +in the Profile Data structure for each statement. Use a code ref +in the Path to return an edited (simplified) form of the statement. + +If a method throws an exception itself (not via RaiseError) then +it won't be counted in the profile. + +If a HandleError subroutine throws an exception (rather than returning +0 and letting RaiseError do it) then the method call won't be counted +in the profile. + +Time spent in DESTROY is added to the profile of the parent handle. + +Time spent in DBI->*() methods is not counted. The time spent in +the driver connect method, $drh->connect(), when it's called by +DBI->connect is counted if the DBI_PROFILE environment variable is set. + +Time spent fetching tied variables, $DBI::errstr, is counted. + +Time spent in FETCH for $h->{Profile} is not counted, so getting the profile +data doesn't alter it. + +DBI::PurePerl does not support profiling (though it could in theory). + +For asynchronous queries, time spent while the query is running on the +backend is not counted. + +A few platforms don't support the gettimeofday() high resolution +time function used by the DBI (and available via the dbi_time() function). +In which case you'll get integer resolution time which is mostly useless. + +On Windows platforms the dbi_time() function is limited to millisecond +resolution. Which isn't sufficiently fine for our needs, but still +much better than integer resolution. This limited resolution means +that fast method calls will often register as taking 0 time. And +timings in general will have much more 'jitter' depending on where +within the 'current millisecond' the start and and timing was taken. + +This documentation could be more clear. Probably needs to be reordered +to start with several examples and build from there. Trying to +explain the concepts first seems painful and to lead to just as +many forward references. (Patches welcome!) + +=cut + + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +use Exporter (); +use UNIVERSAL (); +use Carp; + +use DBI qw(dbi_time dbi_profile dbi_profile_merge_nodes dbi_profile_merge); + +$VERSION = sprintf("2.%06d", q$Revision: 15064 $ =~ /(\d+)/o); + + +@ISA = qw(Exporter); +@EXPORT = qw( + DBIprofile_Statement + DBIprofile_MethodName + DBIprofile_MethodClass + dbi_profile + dbi_profile_merge_nodes + dbi_profile_merge + dbi_time +); +@EXPORT_OK = qw( + format_profile_thingy +); + +use constant DBIprofile_Statement => '!Statement'; +use constant DBIprofile_MethodName => '!MethodName'; +use constant DBIprofile_MethodClass => '!MethodClass'; + +our $ON_DESTROY_DUMP = sub { DBI->trace_msg(shift, 0) }; +our $ON_FLUSH_DUMP = sub { DBI->trace_msg(shift, 0) }; + +sub new { + my $class = shift; + my $profile = { @_ }; + return bless $profile => $class; +} + + +sub _auto_new { + my $class = shift; + my ($arg) = @_; + + # This sub is called by DBI internals when a non-hash-ref is + # assigned to the Profile attribute. For example + # dbi:mysql(RaiseError=>1,Profile=>!Statement:!MethodName/DBIx::MyProfile/arg1:arg2):dbname + # This sub works out what to do and returns a suitable hash ref. + + $arg =~ s/^DBI::/2\/DBI::/ + and carp "Automatically changed old-style DBI::Profile specification to $arg"; + + # it's a path/module/k1:v1:k2:v2:... list + my ($path, $package, $args) = split /\//, $arg, 3; + my @args = (defined $args) ? split(/:/, $args, -1) : (); + my @Path; + + for my $element (split /:/, $path) { + if (DBI::looks_like_number($element)) { + my $reverse = ($element < 0) ? ($element=-$element, 1) : 0; + my @p; + # a single "DBI" is special-cased in format() + push @p, "DBI" if $element & 0x01; + push @p, DBIprofile_Statement if $element & 0x02; + push @p, DBIprofile_MethodName if $element & 0x04; + push @p, DBIprofile_MethodClass if $element & 0x08; + push @p, '!Caller2' if $element & 0x10; + push @Path, ($reverse ? reverse @p : @p); + } + elsif ($element =~ m/^&(\w.*)/) { + my $name = "DBI::ProfileSubs::$1"; # capture $1 early + require DBI::ProfileSubs; + my $code = do { no strict; *{$name}{CODE} }; + if (defined $code) { + push @Path, $code; + } + else { + warn "$name: subroutine not found\n"; + push @Path, $element; + } + } + else { + push @Path, $element; + } + } + + eval "require $package" if $package; # sliently ignores errors + $package ||= $class; + + return $package->new(Path => \@Path, @args); +} + + +sub empty { # empty out profile data + my $self = shift; + DBI->trace_msg("profile data discarded\n",0) if $self->{Trace}; + $self->{Data} = undef; +} + +sub filename { # baseclass method, see DBI::ProfileDumper + return undef; +} + +sub flush_to_disk { # baseclass method, see DBI::ProfileDumper & DashProfiler::Core + my $self = shift; + return unless $ON_FLUSH_DUMP; + return unless $self->{Data}; + my $detail = $self->format(); + $ON_FLUSH_DUMP->($detail) if $detail; +} + + +sub as_node_path_list { + my ($self, $node, $path) = @_; + # convert the tree into an array of arrays + # from + # {key1a}{key2a}[node1] + # {key1a}{key2b}[node2] + # {key1b}{key2a}{key3a}[node3] + # to + # [ [node1], 'key1a', 'key2a' ] + # [ [node2], 'key1a', 'key2b' ] + # [ [node3], 'key1b', 'key2a', 'key3a' ] + + $node ||= $self->{Data} or return; + $path ||= []; + if (ref $node eq 'HASH') { # recurse + $path = [ @$path, undef ]; + return map { + $path->[-1] = $_; + ($node->{$_}) ? $self->as_node_path_list($node->{$_}, $path) : () + } sort keys %$node; + } + return [ $node, @$path ]; +} + + +sub as_text { + my ($self, $args_ref) = @_; + my $separator = $args_ref->{separator} || " > "; + my $format_path_element = $args_ref->{format_path_element} + || "%s"; # or e.g., " key%2$d='%s'" + my $format = $args_ref->{format} + || '%1$s: %11$fs / %10$d = %2$fs avg (first %12$fs, min %13$fs, max %14$fs)'."\n"; + + my @node_path_list = $self->as_node_path_list(undef, $args_ref->{path}); + + $args_ref->{sortsub}->(\@node_path_list) if $args_ref->{sortsub}; + + my $eval = "qr/".quotemeta($separator)."/"; + my $separator_re = eval($eval) || quotemeta($separator); + #warn "[$eval] = [$separator_re]"; + my @text; + my @spare_slots = (undef) x 7; + for my $node_path (@node_path_list) { + my ($node, @path) = @$node_path; + my $idx = 0; + for (@path) { + s/[\r\n]+/ /g; + s/$separator_re/ /g; + $_ = sprintf $format_path_element, $_, ++$idx; + } + push @text, sprintf $format, + join($separator, @path), # 1=path + ($node->[0] ? $node->[1]/$node->[0] : 0), # 2=avg + @spare_slots, + @$node; # 10=count, 11=dur, 12=first_dur, 13=min, 14=max, 15=first_called, 16=last_called + } + return @text if wantarray; + return join "", @text; +} + + +sub format { + my $self = shift; + my $class = ref($self) || $self; + + my $prologue = "$class: "; + my $detail = $self->format_profile_thingy( + $self->{Data}, 0, " ", + my $path = [], + my $leaves = [], + )."\n"; + + if (@$leaves) { + dbi_profile_merge_nodes(my $totals=[], @$leaves); + my ($count, $time_in_dbi, undef, undef, undef, $t1, $t2) = @$totals; + (my $progname = $0) =~ s:.*/::; + if ($count) { + $prologue .= sprintf "%fs ", $time_in_dbi; + my $perl_time = ($DBI::PERL_ENDING) ? time() - $^T : $t2-$t1; + $prologue .= sprintf "%.2f%% ", $time_in_dbi/$perl_time*100 if $perl_time; + my @lt = localtime(time); + my $ts = sprintf "%d-%02d-%02d %02d:%02d:%02d", + 1900+$lt[5], $lt[4]+1, @lt[3,2,1,0]; + $prologue .= sprintf "(%d calls) $progname \@ $ts\n", $count; + } + if (@$leaves == 1 && ref($self->{Data}) eq 'HASH' && $self->{Data}->{DBI}) { + $detail = ""; # hide the "DBI" from DBI_PROFILE=1 + } + } + return ($prologue, $detail) if wantarray; + return $prologue.$detail; +} + + +sub format_profile_leaf { + my ($self, $thingy, $depth, $pad, $path, $leaves) = @_; + croak "format_profile_leaf called on non-leaf ($thingy)" + unless UNIVERSAL::isa($thingy,'ARRAY'); + + push @$leaves, $thingy if $leaves; + my ($count, $total_time, $first_time, $min, $max, $first_called, $last_called) = @$thingy; + return sprintf "%s%fs\n", ($pad x $depth), $total_time + if $count <= 1; + return sprintf "%s%fs / %d = %fs avg (first %fs, min %fs, max %fs)\n", + ($pad x $depth), $total_time, $count, $count ? $total_time/$count : 0, + $first_time, $min, $max; +} + + +sub format_profile_branch { + my ($self, $thingy, $depth, $pad, $path, $leaves) = @_; + croak "format_profile_branch called on non-branch ($thingy)" + unless UNIVERSAL::isa($thingy,'HASH'); + my @chunk; + my @keys = sort keys %$thingy; + while ( @keys ) { + my $k = shift @keys; + my $v = $thingy->{$k}; + push @$path, $k; + push @chunk, sprintf "%s'%s' =>\n%s", + ($pad x $depth), $k, + $self->format_profile_thingy($v, $depth+1, $pad, $path, $leaves); + pop @$path; + } + return join "", @chunk; +} + + +sub format_profile_thingy { + my ($self, $thingy, $depth, $pad, $path, $leaves) = @_; + return "undef" if not defined $thingy; + return $self->format_profile_leaf( $thingy, $depth, $pad, $path, $leaves) + if UNIVERSAL::isa($thingy,'ARRAY'); + return $self->format_profile_branch($thingy, $depth, $pad, $path, $leaves) + if UNIVERSAL::isa($thingy,'HASH'); + return "$thingy\n"; +} + + +sub on_destroy { + my $self = shift; + return unless $ON_DESTROY_DUMP; + return unless $self->{Data}; + my $detail = $self->format(); + $ON_DESTROY_DUMP->($detail) if $detail; + $self->{Data} = undef; +} + +sub DESTROY { + my $self = shift; + local $@; + DBI->trace_msg("profile data DESTROY\n",0) + if (($self->{Trace}||0) >= 2); + eval { $self->on_destroy }; + if ($@) { + chomp $@; + my $class = ref($self) || $self; + DBI->trace_msg("$class on_destroy failed: $@", 0); + } +} + +1; + diff --git a/lib/DBI/ProfileData.pm b/lib/DBI/ProfileData.pm new file mode 100644 index 0000000..b2db087 --- /dev/null +++ b/lib/DBI/ProfileData.pm @@ -0,0 +1,737 @@ +package DBI::ProfileData; +use strict; + +=head1 NAME + +DBI::ProfileData - manipulate DBI::ProfileDumper data dumps + +=head1 SYNOPSIS + +The easiest way to use this module is through the dbiprof frontend +(see L<dbiprof> for details): + + dbiprof --number 15 --sort count + +This module can also be used to roll your own profile analysis: + + # load data from dbi.prof + $prof = DBI::ProfileData->new(File => "dbi.prof"); + + # get a count of the records (unique paths) in the data set + $count = $prof->count(); + + # sort by longest overall time + $prof->sort(field => "longest"); + + # sort by longest overall time, least to greatest + $prof->sort(field => "longest", reverse => 1); + + # exclude records with key2 eq 'disconnect' + $prof->exclude(key2 => 'disconnect'); + + # exclude records with key1 matching /^UPDATE/i + $prof->exclude(key1 => qr/^UPDATE/i); + + # remove all records except those where key1 matches /^SELECT/i + $prof->match(key1 => qr/^SELECT/i); + + # produce a formatted report with the given number of items + $report = $prof->report(number => 10); + + # clone the profile data set + $clone = $prof->clone(); + + # get access to hash of header values + $header = $prof->header(); + + # get access to sorted array of nodes + $nodes = $prof->nodes(); + + # format a single node in the same style as report() + $text = $prof->format($nodes->[0]); + + # get access to Data hash in DBI::Profile format + $Data = $prof->Data(); + +=head1 DESCRIPTION + +This module offers the ability to read, manipulate and format +DBI::ProfileDumper profile data. + +Conceptually, a profile consists of a series of records, or nodes, +each of each has a set of statistics and set of keys. Each record +must have a unique set of keys, but there is no requirement that every +record have the same number of keys. + +=head1 METHODS + +The following methods are supported by DBI::ProfileData objects. + +=cut + + +our $VERSION = sprintf("2.%06d", q$Revision: 10007 $ =~ /(\d+)/o); + +use Carp qw(croak); +use Symbol; +use Fcntl qw(:flock); + +use DBI::Profile qw(dbi_profile_merge); + +# some constants for use with node data arrays +sub COUNT () { 0 }; +sub TOTAL () { 1 }; +sub FIRST () { 2 }; +sub SHORTEST () { 3 }; +sub LONGEST () { 4 }; +sub FIRST_AT () { 5 }; +sub LAST_AT () { 6 }; +sub PATH () { 7 }; + + +my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK}) + ? $ENV{DBI_PROFILE_FLOCK} + : do { local $@; eval { flock STDOUT, 0; 1 } }; + + +=head2 $prof = DBI::ProfileData->new(File => "dbi.prof") + +=head2 $prof = DBI::ProfileData->new(File => "dbi.prof", Filter => sub { ... }) + +=head2 $prof = DBI::ProfileData->new(Files => [ "dbi.prof.1", "dbi.prof.2" ]) + +Creates a a new DBI::ProfileData object. Takes either a single file +through the File option or a list of Files in an array ref. If +multiple files are specified then the header data from the first file +is used. + +=head3 Files + +Reference to an array of file names to read. + +=head3 File + +Name of file to read. Takes precedence over C<Files>. + +=head3 DeleteFiles + +If true, the files are deleted after being read. + +Actually the files are renamed with a C.deleteme> suffix before being read, +and then, after reading all the files, they're all deleted together. + +The files are locked while being read which, combined with the rename, makes it +safe to 'consume' files that are still being generated by L<DBI::ProfileDumper>. + +=head3 Filter + +The C<Filter> parameter can be used to supply a code reference that can +manipulate the profile data as it is being read. This is most useful for +editing SQL statements so that slightly different statements in the raw data +will be merged and aggregated in the loaded data. For example: + + Filter => sub { + my ($path_ref, $data_ref) = @_; + s/foo = '.*?'/foo = '...'/ for @$path_ref; + } + +Here's an example that performs some normalization on the SQL. It converts all +numbers to C<N> and all quoted strings to C<S>. It can also convert digits to +N within names. Finally, it summarizes long "IN (...)" clauses. + +It's aggressive and simplistic, but it's often sufficient, and serves as an +example that you can tailor to suit your own needs: + + Filter => sub { + my ($path_ref, $data_ref) = @_; + local $_ = $path_ref->[0]; # whichever element contains the SQL Statement + s/\b\d+\b/N/g; # 42 -> N + s/\b0x[0-9A-Fa-f]+\b/N/g; # 0xFE -> N + s/'.*?'/'S'/g; # single quoted strings (doesn't handle escapes) + s/".*?"/"S"/g; # double quoted strings (doesn't handle escapes) + # convert names like log_20001231 into log_NNNNNNNN, controlled by $opt{n} + s/([a-z_]+)(\d{$opt{n},})/$1.('N' x length($2))/ieg if $opt{n}; + # abbreviate massive "in (...)" statements and similar + s!(([NS],){100,})!sprintf("$2,{repeated %d times}",length($1)/2)!eg; + } + +It's often better to perform this kinds of normalization in the DBI while the +data is being collected, to avoid too much memory being used by storing profile +data for many different SQL statement. See L<DBI::Profile>. + +=cut + +sub new { + my $pkg = shift; + my $self = { + Files => [ "dbi.prof" ], + Filter => undef, + DeleteFiles => 0, + LockFile => $HAS_FLOCK, + _header => {}, + _nodes => [], + _node_lookup => {}, + _sort => 'none', + @_ + }; + bless $self, $pkg; + + # File (singular) overrides Files (plural) + $self->{Files} = [ $self->{File} ] if exists $self->{File}; + + $self->_read_files(); + return $self; +} + +# read files into _header and _nodes +sub _read_files { + my $self = shift; + my $files = $self->{Files}; + my $read_header = 0; + my @files_to_delete; + + my $fh = gensym; + foreach (@$files) { + my $filename = $_; + + if ($self->{DeleteFiles}) { + my $newfilename = $filename . ".deleteme"; + if ($^O eq 'VMS') { + # VMS default filesystem can only have one period + $newfilename = $filename . 'deleteme'; + } + # will clobber an existing $newfilename + rename($filename, $newfilename) + or croak "Can't rename($filename, $newfilename): $!"; + # On a versioned filesystem we want old versions to be removed + 1 while (unlink $filename); + $filename = $newfilename; + } + + open($fh, "<", $filename) + or croak("Unable to read profile file '$filename': $!"); + + # lock the file in case it's still being written to + # (we'll be foced to wait till the write is complete) + flock($fh, LOCK_SH) if $self->{LockFile}; + + if (-s $fh) { # not empty + $self->_read_header($fh, $filename, $read_header ? 0 : 1); + $read_header = 1; + $self->_read_body($fh, $filename); + } + close($fh); # and release lock + + push @files_to_delete, $filename + if $self->{DeleteFiles}; + } + for (@files_to_delete){ + # for versioned file systems + 1 while (unlink $_); + if(-e $_){ + warn "Can't delete '$_': $!"; + } + } + + # discard node_lookup now that all files are read + delete $self->{_node_lookup}; +} + +# read the header from the given $fh named $filename. Discards the +# data unless $keep. +sub _read_header { + my ($self, $fh, $filename, $keep) = @_; + + # get profiler module id + my $first = <$fh>; + chomp $first; + $self->{_profiler} = $first if $keep; + + # collect variables from the header + local $_; + while (<$fh>) { + chomp; + last unless length $_; + /^(\S+)\s*=\s*(.*)/ + or croak("Syntax error in header in $filename line $.: $_"); + # XXX should compare new with existing (from previous file) + # and warn if they differ (diferent program or path) + $self->{_header}{$1} = unescape_key($2) if $keep; + } +} + + +sub unescape_key { # inverse of escape_key() in DBI::ProfileDumper + local $_ = shift; + s/(?<!\\)\\n/\n/g; # expand \n, unless it's a \\n + s/(?<!\\)\\r/\r/g; # expand \r, unless it's a \\r + s/\\\\/\\/g; # \\ to \ + return $_; +} + + +# reads the body of the profile data +sub _read_body { + my ($self, $fh, $filename) = @_; + my $nodes = $self->{_nodes}; + my $lookup = $self->{_node_lookup}; + my $filter = $self->{Filter}; + + # build up node array + my @path = (""); + my (@data, $path_key); + local $_; + while (<$fh>) { + chomp; + if (/^\+\s+(\d+)\s?(.*)/) { + # it's a key + my ($key, $index) = ($2, $1 - 1); + + $#path = $index; # truncate path to new length + $path[$index] = unescape_key($key); # place new key at end + + } + elsif (s/^=\s+//) { + # it's data - file in the node array with the path in index 0 + # (the optional minus is to make it more robust against systems + # with unstable high-res clocks - typically due to poor NTP config + # of kernel SMP behaviour, i.e. min time may be -0.000008)) + + @data = split / /, $_; + + # corrupt data? + croak("Invalid number of fields in $filename line $.: $_") + unless @data == 7; + croak("Invalid leaf node characters $filename line $.: $_") + unless m/^[-+ 0-9eE\.]+$/; + + # hook to enable pre-processing of the data - such as mangling SQL + # so that slightly different statements get treated as the same + # and so merged in the results + $filter->(\@path, \@data) if $filter; + + # elements of @path can't have NULLs in them, so this + # forms a unique string per @path. If there's some way I + # can get this without arbitrarily stripping out a + # character I'd be happy to hear it! + $path_key = join("\0",@path); + + # look for previous entry + if (exists $lookup->{$path_key}) { + # merge in the new data + dbi_profile_merge($nodes->[$lookup->{$path_key}], \@data); + } else { + # insert a new node - nodes are arrays with data in 0-6 + # and path data after that + push(@$nodes, [ @data, @path ]); + + # record node in %seen + $lookup->{$path_key} = $#$nodes; + } + } + else { + croak("Invalid line type syntax error in $filename line $.: $_"); + } + } +} + + + +=head2 $copy = $prof->clone(); + +Clone a profile data set creating a new object. + +=cut + +sub clone { + my $self = shift; + + # start with a simple copy + my $clone = bless { %$self }, ref($self); + + # deep copy nodes + $clone->{_nodes} = [ map { [ @$_ ] } @{$self->{_nodes}} ]; + + # deep copy header + $clone->{_header} = { %{$self->{_header}} }; + + return $clone; +} + +=head2 $header = $prof->header(); + +Returns a reference to a hash of header values. These are the key +value pairs included in the header section of the DBI::ProfileDumper +data format. For example: + + $header = { + Path => [ '!Statement', '!MethodName' ], + Program => 't/42profile_data.t', + }; + +Note that modifying this hash will modify the header data stored +inside the profile object. + +=cut + +sub header { shift->{_header} } + + +=head2 $nodes = $prof->nodes() + +Returns a reference the sorted nodes array. Each element in the array +is a single record in the data set. The first seven elements are the +same as the elements provided by DBI::Profile. After that each key is +in a separate element. For example: + + $nodes = [ + [ + 2, # 0, count + 0.0312958955764771, # 1, total duration + 0.000490069389343262, # 2, first duration + 0.000176072120666504, # 3, shortest duration + 0.00140702724456787, # 4, longest duration + 1023115819.83019, # 5, time of first event + 1023115819.86576, # 6, time of last event + 'SELECT foo FROM bar' # 7, key1 + 'execute' # 8, key2 + # 6+N, keyN + ], + # ... + ]; + +Note that modifying this array will modify the node data stored inside +the profile object. + +=cut + +sub nodes { shift->{_nodes} } + + +=head2 $count = $prof->count() + +Returns the number of items in the profile data set. + +=cut + +sub count { scalar @{shift->{_nodes}} } + + +=head2 $prof->sort(field => "field") + +=head2 $prof->sort(field => "field", reverse => 1) + +Sorts data by the given field. Available fields are: + + longest + total + count + shortest + +The default sort is greatest to smallest, which is the opposite of the +normal Perl meaning. This, however, matches the expected behavior of +the dbiprof frontend. + +=cut + + +# sorts data by one of the available fields +{ + my %FIELDS = ( + longest => LONGEST, + total => TOTAL, + count => COUNT, + shortest => SHORTEST, + key1 => PATH+0, + key2 => PATH+1, + key3 => PATH+2, + ); + sub sort { + my $self = shift; + my $nodes = $self->{_nodes}; + my %opt = @_; + + croak("Missing required field option.") unless $opt{field}; + + my $index = $FIELDS{$opt{field}}; + + croak("Unrecognized sort field '$opt{field}'.") + unless defined $index; + + # sort over index + if ($opt{reverse}) { + @$nodes = sort { + $a->[$index] <=> $b->[$index] + } @$nodes; + } else { + @$nodes = sort { + $b->[$index] <=> $a->[$index] + } @$nodes; + } + + # remember how we're sorted + $self->{_sort} = $opt{field}; + + return $self; + } +} + + +=head2 $count = $prof->exclude(key2 => "disconnect") + +=head2 $count = $prof->exclude(key2 => "disconnect", case_sensitive => 1) + +=head2 $count = $prof->exclude(key1 => qr/^SELECT/i) + +Removes records from the data set that match the given string or +regular expression. This method modifies the data in a permanent +fashion - use clone() first to maintain the original data after +exclude(). Returns the number of nodes left in the profile data set. + +=cut + +sub exclude { + my $self = shift; + my $nodes = $self->{_nodes}; + my %opt = @_; + + # find key index number + my ($index, $val); + foreach (keys %opt) { + if (/^key(\d+)$/) { + $index = PATH + $1 - 1; + $val = $opt{$_}; + last; + } + } + croak("Missing required keyN option.") unless $index; + + if (UNIVERSAL::isa($val,"Regexp")) { + # regex match + @$nodes = grep { + $#$_ < $index or $_->[$index] !~ /$val/ + } @$nodes; + } else { + if ($opt{case_sensitive}) { + @$nodes = grep { + $#$_ < $index or $_->[$index] ne $val; + } @$nodes; + } else { + $val = lc $val; + @$nodes = grep { + $#$_ < $index or lc($_->[$index]) ne $val; + } @$nodes; + } + } + + return scalar @$nodes; +} + + +=head2 $count = $prof->match(key2 => "disconnect") + +=head2 $count = $prof->match(key2 => "disconnect", case_sensitive => 1) + +=head2 $count = $prof->match(key1 => qr/^SELECT/i) + +Removes records from the data set that do not match the given string +or regular expression. This method modifies the data in a permanent +fashion - use clone() first to maintain the original data after +match(). Returns the number of nodes left in the profile data set. + +=cut + +sub match { + my $self = shift; + my $nodes = $self->{_nodes}; + my %opt = @_; + + # find key index number + my ($index, $val); + foreach (keys %opt) { + if (/^key(\d+)$/) { + $index = PATH + $1 - 1; + $val = $opt{$_}; + last; + } + } + croak("Missing required keyN option.") unless $index; + + if (UNIVERSAL::isa($val,"Regexp")) { + # regex match + @$nodes = grep { + $#$_ >= $index and $_->[$index] =~ /$val/ + } @$nodes; + } else { + if ($opt{case_sensitive}) { + @$nodes = grep { + $#$_ >= $index and $_->[$index] eq $val; + } @$nodes; + } else { + $val = lc $val; + @$nodes = grep { + $#$_ >= $index and lc($_->[$index]) eq $val; + } @$nodes; + } + } + + return scalar @$nodes; +} + + +=head2 $Data = $prof->Data() + +Returns the same Data hash structure as seen in DBI::Profile. This +structure is not sorted. The nodes() structure probably makes more +sense for most analysis. + +=cut + +sub Data { + my $self = shift; + my (%Data, @data, $ptr); + + foreach my $node (@{$self->{_nodes}}) { + # traverse to key location + $ptr = \%Data; + foreach my $key (@{$node}[PATH .. $#$node - 1]) { + $ptr->{$key} = {} unless exists $ptr->{$key}; + $ptr = $ptr->{$key}; + } + + # slice out node data + $ptr->{$node->[-1]} = [ @{$node}[0 .. 6] ]; + } + + return \%Data; +} + + +=head2 $text = $prof->format($nodes->[0]) + +Formats a single node into a human-readable block of text. + +=cut + +sub format { + my ($self, $node) = @_; + my $format; + + # setup keys + my $keys = ""; + for (my $i = PATH; $i <= $#$node; $i++) { + my $key = $node->[$i]; + + # remove leading and trailing space + $key =~ s/^\s+//; + $key =~ s/\s+$//; + + # if key has newlines or is long take special precautions + if (length($key) > 72 or $key =~ /\n/) { + $keys .= " Key " . ($i - PATH + 1) . " :\n\n$key\n\n"; + } else { + $keys .= " Key " . ($i - PATH + 1) . " : $key\n"; + } + } + + # nodes with multiple runs get the long entry format, nodes with + # just one run get a single count. + if ($node->[COUNT] > 1) { + $format = <<END; + Count : %d + Total Time : %3.6f seconds + Longest Time : %3.6f seconds + Shortest Time : %3.6f seconds + Average Time : %3.6f seconds +END + return sprintf($format, @{$node}[COUNT,TOTAL,LONGEST,SHORTEST], + $node->[TOTAL] / $node->[COUNT]) . $keys; + } else { + $format = <<END; + Count : %d + Time : %3.6f seconds +END + + return sprintf($format, @{$node}[COUNT,TOTAL]) . $keys; + + } +} + + +=head2 $text = $prof->report(number => 10) + +Produces a report with the given number of items. + +=cut + +sub report { + my $self = shift; + my $nodes = $self->{_nodes}; + my %opt = @_; + + croak("Missing required number option") unless exists $opt{number}; + + $opt{number} = @$nodes if @$nodes < $opt{number}; + + my $report = $self->_report_header($opt{number}); + for (0 .. $opt{number} - 1) { + $report .= sprintf("#" x 5 . "[ %d ]". "#" x 59 . "\n", + $_ + 1); + $report .= $self->format($nodes->[$_]); + $report .= "\n"; + } + return $report; +} + +# format the header for report() +sub _report_header { + my ($self, $number) = @_; + my $nodes = $self->{_nodes}; + my $node_count = @$nodes; + + # find total runtime and method count + my ($time, $count) = (0,0); + foreach my $node (@$nodes) { + $time += $node->[TOTAL]; + $count += $node->[COUNT]; + } + + my $header = <<END; + +DBI Profile Data ($self->{_profiler}) + +END + + # output header fields + while (my ($key, $value) = each %{$self->{_header}}) { + $header .= sprintf(" %-13s : %s\n", $key, $value); + } + + # output summary data fields + $header .= sprintf(<<END, $node_count, $number, $self->{_sort}, $count, $time); + Total Records : %d (showing %d, sorted by %s) + Total Count : %d + Total Runtime : %3.6f seconds + +END + + return $header; +} + + +1; + +__END__ + +=head1 AUTHOR + +Sam Tregar <sam@tregar.com> + +=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. + +=cut diff --git a/lib/DBI/ProfileDumper.pm b/lib/DBI/ProfileDumper.pm new file mode 100644 index 0000000..89bb884 --- /dev/null +++ b/lib/DBI/ProfileDumper.pm @@ -0,0 +1,351 @@ +package DBI::ProfileDumper; +use strict; + +=head1 NAME + +DBI::ProfileDumper - profile DBI usage and output data to a file + +=head1 SYNOPSIS + +To profile an existing program using DBI::ProfileDumper, set the +DBI_PROFILE environment variable and run your program as usual. For +example, using bash: + + DBI_PROFILE=2/DBI::ProfileDumper program.pl + +Then analyze the generated file (F<dbi.prof>) with L<dbiprof|dbiprof>: + + dbiprof + +You can also activate DBI::ProfileDumper from within your code: + + use DBI; + + # profile with default path (2) and output file (dbi.prof) + $dbh->{Profile} = "!Statement/DBI::ProfileDumper"; + + # same thing, spelled out + $dbh->{Profile} = "!Statement/DBI::ProfileDumper/File:dbi.prof"; + + # another way to say it + use DBI::ProfileDumper; + $dbh->{Profile} = DBI::ProfileDumper->new( + Path => [ '!Statement' ], + File => 'dbi.prof' ); + + # using a custom path + $dbh->{Profile} = DBI::ProfileDumper->new( + Path => [ "foo", "bar" ], + File => 'dbi.prof', + ); + + +=head1 DESCRIPTION + +DBI::ProfileDumper is a subclass of L<DBI::Profile|DBI::Profile> which +dumps profile data to disk instead of printing a summary to your +screen. You can then use L<dbiprof|dbiprof> to analyze the data in +a number of interesting ways, or you can roll your own analysis using +L<DBI::ProfileData|DBI::ProfileData>. + +B<NOTE:> For Apache/mod_perl applications, use +L<DBI::ProfileDumper::Apache|DBI::ProfileDumper::Apache>. + +=head1 USAGE + +One way to use this module is just to enable it in your C<$dbh>: + + $dbh->{Profile} = "1/DBI::ProfileDumper"; + +This will write out profile data by statement into a file called +F<dbi.prof>. If you want to modify either of these properties, you +can construct the DBI::ProfileDumper object yourself: + + use DBI::ProfileDumper; + $dbh->{Profile} = DBI::ProfileDumper->new( + Path => [ '!Statement' ], + File => 'dbi.prof' + ); + +The C<Path> option takes the same values as in +L<DBI::Profile>. The C<File> option gives the name of the +file where results will be collected. If it already exists it will be +overwritten. + +You can also activate this module by setting the DBI_PROFILE +environment variable: + + $ENV{DBI_PROFILE} = "!Statement/DBI::ProfileDumper"; + +This will cause all DBI handles to share the same profiling object. + +=head1 METHODS + +The following methods are available to be called using the profile +object. You can get access to the profile object from the Profile key +in any DBI handle: + + my $profile = $dbh->{Profile}; + +=head2 flush_to_disk + + $profile->flush_to_disk() + +Flushes all collected profile data to disk and empties the Data hash. Returns +the filename writen to. If no profile data has been collected then the file is +not written and flush_to_disk() returns undef. + +The file is locked while it's being written. A process 'consuming' the files +while they're being written to, should rename the file first, then lock it, +then read it, then close and delete it. The C<DeleteFiles> option to +L<DBI::ProfileData> does the right thing. + +This method may be called multiple times during a program run. + +=head2 empty + + $profile->empty() + +Clears the Data hash without writing to disk. + +=head2 filename + + $filename = $profile->filename(); + +Get or set the filename. + +The filename can be specified as a CODE reference, in which case the referenced +code should return the filename to be used. The code will be called with the +profile object as its first argument. + +=head1 DATA FORMAT + +The data format written by DBI::ProfileDumper starts with a header +containing the version number of the module used to generate it. Then +a block of variable declarations describes the profile. After two +newlines, the profile data forms the body of the file. For example: + + DBI::ProfileDumper 2.003762 + Path = [ '!Statement', '!MethodName' ] + Program = t/42profile_data.t + + + 1 SELECT name FROM users WHERE id = ? + + 2 prepare + = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576 + + 2 execute + 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576 + + 2 fetchrow_hashref + = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576 + + 1 UPDATE users SET name = ? WHERE id = ? + + 2 prepare + = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576 + + 2 execute + = 1 0.0312958955764771 0.000490069389343262 0.000176072120666504 0.00140702724456787 1023115819.83019 1023115819.86576 + +The lines beginning with C<+> signs signify keys. The number after +the C<+> sign shows the nesting level of the key. Lines beginning +with C<=> are the actual profile data, in the same order as +in DBI::Profile. + +Note that the same path may be present multiple times in the data file +since C<format()> may be called more than once. When read by +DBI::ProfileData the data points will be merged to produce a single +data set for each distinct path. + +The key strings are transformed in three ways. First, all backslashes +are doubled. Then all newlines and carriage-returns are transformed +into C<\n> and C<\r> respectively. Finally, any NULL bytes (C<\0>) +are entirely removed. When DBI::ProfileData reads the file the first +two transformations will be reversed, but NULL bytes will not be +restored. + +=head1 AUTHOR + +Sam Tregar <sam@tregar.com> + +=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. + +=cut + +# inherit from DBI::Profile +use DBI::Profile; + +our @ISA = ("DBI::Profile"); + +our $VERSION = sprintf("2.%06d", q$Revision: 15324 $ =~ /(\d+)/o); + +use Carp qw(croak); +use Fcntl qw(:flock); +use Symbol; + +my $HAS_FLOCK = (defined $ENV{DBI_PROFILE_FLOCK}) + ? $ENV{DBI_PROFILE_FLOCK} + : do { local $@; eval { flock STDOUT, 0; 1 } }; + +my $program_header; + + +# validate params and setup default +sub new { + my $pkg = shift; + my $self = $pkg->SUPER::new( + LockFile => $HAS_FLOCK, + @_, + ); + + # provide a default filename + $self->filename("dbi.prof") unless $self->filename; + + DBI->trace_msg("$self: @{[ %$self ]}\n",0) + if $self->{Trace} && $self->{Trace} >= 2; + + return $self; +} + + +# get/set filename to use +sub filename { + my $self = shift; + $self->{File} = shift if @_; + my $filename = $self->{File}; + $filename = $filename->($self) if ref($filename) eq 'CODE'; + return $filename; +} + + +# flush available data to disk +sub flush_to_disk { + my $self = shift; + my $class = ref $self; + my $filename = $self->filename; + my $data = $self->{Data}; + + if (1) { # make an option + if (not $data or ref $data eq 'HASH' && !%$data) { + DBI->trace_msg("flush_to_disk skipped for empty profile\n",0) if $self->{Trace}; + return undef; + } + } + + my $fh = gensym; + if (($self->{_wrote_header}||'') eq $filename) { + # append more data to the file + # XXX assumes that Path hasn't changed + open($fh, ">>", $filename) + or croak("Unable to open '$filename' for $class output: $!"); + } else { + # create new file (or overwrite existing) + if (-f $filename) { + my $bak = $filename.'.prev'; + unlink($bak); + rename($filename, $bak) + or warn "Error renaming $filename to $bak: $!\n"; + } + open($fh, ">", $filename) + or croak("Unable to open '$filename' for $class output: $!"); + } + # lock the file (before checking size and writing the header) + flock($fh, LOCK_EX) if $self->{LockFile}; + # write header if file is empty - typically because we just opened it + # in '>' mode, or perhaps we used '>>' but the file had been truncated externally. + if (-s $fh == 0) { + DBI->trace_msg("flush_to_disk wrote header to $filename\n",0) if $self->{Trace}; + $self->write_header($fh); + $self->{_wrote_header} = $filename; + } + + my $lines = $self->write_data($fh, $self->{Data}, 1); + DBI->trace_msg("flush_to_disk wrote $lines lines to $filename\n",0) if $self->{Trace}; + + close($fh) # unlocks the file + or croak("Error closing '$filename': $!"); + + $self->empty(); + + + return $filename; +} + + +# write header to a filehandle +sub write_header { + my ($self, $fh) = @_; + + # isolate us against globals which effect print + local($\, $,); + + # $self->VERSION can return undef during global destruction + my $version = $self->VERSION || $VERSION; + + # module name and version number + print $fh ref($self)." $version\n"; + + # print out Path (may contain CODE refs etc) + my @path_words = map { escape_key($_) } @{ $self->{Path} || [] }; + print $fh "Path = [ ", join(', ', @path_words), " ]\n"; + + # print out $0 and @ARGV + if (!$program_header) { + # XXX should really quote as well as escape + $program_header = "Program = " + . join(" ", map { escape_key($_) } $0, @ARGV) + . "\n"; + } + print $fh $program_header; + + # all done + print $fh "\n"; +} + + +# write data in the proscribed format +sub write_data { + my ($self, $fh, $data, $level) = @_; + + # XXX it's valid for $data to be an ARRAY ref, i.e., Path is empty. + # produce an empty profile for invalid $data + return 0 unless $data and UNIVERSAL::isa($data,'HASH'); + + # isolate us against globals which affect print + local ($\, $,); + + my $lines = 0; + while (my ($key, $value) = each(%$data)) { + # output a key + print $fh "+ $level ". escape_key($key). "\n"; + if (UNIVERSAL::isa($value,'ARRAY')) { + # output a data set for a leaf node + print $fh "= ".join(' ', @$value)."\n"; + $lines += 1; + } else { + # recurse through keys - this could be rewritten to use a + # stack for some small performance gain + $lines += $self->write_data($fh, $value, $level + 1); + } + } + return $lines; +} + + +# escape a key for output +sub escape_key { + my $key = shift; + $key =~ s!\\!\\\\!g; + $key =~ s!\n!\\n!g; + $key =~ s!\r!\\r!g; + $key =~ s!\0!!g; + return $key; +} + + +# flush data to disk when profile object goes out of scope +sub on_destroy { + shift->flush_to_disk(); +} + +1; diff --git a/lib/DBI/ProfileDumper/Apache.pm b/lib/DBI/ProfileDumper/Apache.pm new file mode 100644 index 0000000..1f58926 --- /dev/null +++ b/lib/DBI/ProfileDumper/Apache.pm @@ -0,0 +1,219 @@ +package DBI::ProfileDumper::Apache; + +use strict; + +=head1 NAME + +DBI::ProfileDumper::Apache - capture DBI profiling data from Apache/mod_perl + +=head1 SYNOPSIS + +Add this line to your F<httpd.conf>: + + PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache + +(If you're using mod_perl2, see L</When using mod_perl2> for some additional notes.) + +Then restart your server. Access the code you wish to test using a +web browser, then shutdown your server. This will create a set of +F<dbi.prof.*> files in your Apache log directory. + +Get a profiling report with L<dbiprof|dbiprof>: + + dbiprof /path/to/your/apache/logs/dbi.prof.* + +When you're ready to perform another profiling run, delete the old files and start again. + +=head1 DESCRIPTION + +This module interfaces DBI::ProfileDumper to Apache/mod_perl. Using +this module you can collect profiling data from mod_perl applications. +It works by creating a DBI::ProfileDumper data file for each Apache +process. These files are created in your Apache log directory. You +can then use the dbiprof utility to analyze the profile files. + +=head1 USAGE + +=head2 LOADING THE MODULE + +The easiest way to use this module is just to set the DBI_PROFILE +environment variable in your F<httpd.conf>: + + PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache + +The DBI will look after loading and using the module when the first DBI handle +is created. + +It's also possible to use this module by setting the Profile attribute +of any DBI handle: + + $dbh->{Profile} = "2/DBI::ProfileDumper::Apache"; + +See L<DBI::ProfileDumper> for more possibilities, and L<DBI::Profile> for full +details of the DBI's profiling mechanism. + +=head2 WRITING PROFILE DATA + +The profile data files will be written to your Apache log directory by default. + +The user that the httpd processes run as will need write access to the +directory. So, for example, if you're running the child httpds as user 'nobody' +and using chronolog to write to the logs directory, then you'll need to change +the default. + +You can change the destination directory either by specifying a C<Dir> value +when creating the profile (like C<File> in the L<DBI::ProfileDumper> docs), +or you can use the C<DBI_PROFILE_APACHE_LOG_DIR> env var to change that. For example: + + PerlSetEnv DBI_PROFILE_APACHE_LOG_DIR /server_root/logs + +=head3 When using mod_perl2 + +Under mod_perl2 you'll need to either set the C<DBI_PROFILE_APACHE_LOG_DIR> env var, +or enable the mod_perl2 C<GlobalRequest> option, like this: + + PerlOptions +GlobalRequest + +to the global config section you're about test with DBI::ProfileDumper::Apache. +If you don't do one of those then you'll see messages in your error_log similar to: + + DBI::ProfileDumper::Apache on_destroy failed: Global $r object is not available. Set: + PerlOptions +GlobalRequest in httpd.conf at ..../DBI/ProfileDumper/Apache.pm line 144 + +=head3 Naming the files + +The default file name is inherited from L<DBI::ProfileDumper> via the +filename() method, but DBI::ProfileDumper::Apache appends the parent pid and +the current pid, separated by dots, to that name. + +=head3 Silencing the log + +By default a message is written to STDERR (i.e., the apache error_log file) +when flush_to_disk() is called (either explicitly, or implicitly via DESTROY). + +That's usually very useful. If you don't want the log message you can silence +it by setting the C<Quiet> attribute true. + + PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache/Quiet:1 + + $dbh->{Profile} = "!Statement/DBI::ProfileDumper/Quiet:1"; + + $dbh->{Profile} = DBI::ProfileDumper->new( + Path => [ '!Statement' ] + Quiet => 1 + ); + + +=head2 GATHERING PROFILE DATA + +Once you have the module loaded, use your application as you normally +would. Stop the webserver when your tests are complete. Profile data +files will be produced when Apache exits and you'll see something like +this in your error_log: + + DBI::ProfileDumper::Apache writing to /usr/local/apache/logs/dbi.prof.2604.2619 + +Now you can use dbiprof to examine the data: + + dbiprof /usr/local/apache/logs/dbi.prof.2604.* + +By passing dbiprof a list of all generated files, dbiprof will +automatically merge them into one result set. You can also pass +dbiprof sorting and querying options, see L<dbiprof> for details. + +=head2 CLEANING UP + +Once you've made some code changes, you're ready to start again. +First, delete the old profile data files: + + rm /usr/local/apache/logs/dbi.prof.* + +Then restart your server and get back to work. + +=head1 OTHER ISSUES + +=head2 Memory usage + +DBI::Profile can use a lot of memory for very active applications because it +collects profiling data in memory for each distinct query run. +Calling C<flush_to_disk()> will write the current data to disk and free the +memory it's using. For example: + + $dbh->{Profile}->flush_to_disk() if $dbh->{Profile}; + +or, rather than flush every time, you could flush less often: + + $dbh->{Profile}->flush_to_disk() + if $dbh->{Profile} and ++$i % 100; + +=head1 AUTHOR + +Sam Tregar <sam@tregar.com> + +=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. + +=cut + +our $VERSION = sprintf("2.%06d", q$Revision: 14120 $ =~ /(\d+)/o); + +our @ISA = qw(DBI::ProfileDumper); + +use DBI::ProfileDumper; +use File::Spec; + +my $initial_pid = $$; + +use constant MP2 => ($ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0; + +my $server_root_dir; + +if (MP2) { + require Apache2::ServerUtil; + $server_root_dir = Apache2::ServerUtil::server_root(); +} +else { + require Apache; + $server_root_dir = eval { Apache->server_root_relative('') } || "/tmp"; +} + + +sub _dirname { + my $self = shift; + return $self->{Dir} ||= $ENV{DBI_PROFILE_APACHE_LOG_DIR} + || File::Spec->catdir($server_root_dir, "logs"); +} + + +sub filename { + my $self = shift; + my $filename = $self->SUPER::filename(@_); + return $filename if not $filename; # not set yet + + # to be able to identify groups of profile files from the same set of + # apache processes, we include the parent pid in the file name + # as well as the pid. + my $group_pid = ($$ eq $initial_pid) ? $$ : getppid(); + $filename .= ".$group_pid.$$"; + + return $filename if File::Spec->file_name_is_absolute($filename); + return File::Spec->catfile($self->_dirname, $filename); +} + + +sub flush_to_disk { + my $self = shift; + + my $filename = $self->SUPER::flush_to_disk(@_); + + print STDERR ref($self)." pid$$ written to $filename\n" + if $filename && not $self->{Quiet}; + + return $filename; +} + +1; diff --git a/lib/DBI/ProfileSubs.pm b/lib/DBI/ProfileSubs.pm new file mode 100644 index 0000000..02ca64d --- /dev/null +++ b/lib/DBI/ProfileSubs.pm @@ -0,0 +1,50 @@ +package DBI::ProfileSubs; + +our $VERSION = sprintf("0.%06d", q$Revision: 9395 $ =~ /(\d+)/o); + +=head1 NAME + +DBI::ProfileSubs - Subroutines for dynamic profile Path + +=head1 SYNOPSIS + + DBI_PROFILE='&norm_std_n3' prog.pl + +This is new and still experimental. + +=head1 TO DO + +Define come kind of naming convention for the subs. + +=cut + +use strict; +use warnings; + + +# would be good to refactor these regex into separate subs and find some +# way to compose them in various combinations into multiple subs. +# Perhaps via AUTOLOAD where \&auto_X_Y_Z creates a sub that does X, Y, and Z. +# The final subs always need to be very fast. +# + +sub norm_std_n3 { + # my ($h, $method_name) = @_; + local $_ = $_; + + s/\b\d+\b/<N>/g; # 42 -> <N> + s/\b0x[0-9A-Fa-f]+\b/<N>/g; # 0xFE -> <N> + + s/'.*?'/'<S>'/g; # single quoted strings (doesn't handle escapes) + s/".*?"/"<S>"/g; # double quoted strings (doesn't handle escapes) + + # convert names like log20001231 into log<N> + s/([a-z_]+)(\d{3,})\b/${1}<N>/ig; + + # abbreviate massive "in (...)" statements and similar + s!((\s*<[NS]>\s*,\s*){100,})!sprintf("$2,<repeated %d times>",length($1)/2)!eg; + + return $_; +} + +1; diff --git a/lib/DBI/ProxyServer.pm b/lib/DBI/ProxyServer.pm new file mode 100644 index 0000000..89e2de6 --- /dev/null +++ b/lib/DBI/ProxyServer.pm @@ -0,0 +1,890 @@ +# $Header: /home/timbo/dbi/lib/DBI/RCS/ProxyServer.pm,v 11.9 2003/05/14 11:08:17 timbo Exp $ +# -*- perl -*- +# +# DBI::ProxyServer - a proxy server for DBI drivers +# +# Copyright (c) 1997 Jochen Wiedmann +# +# The DBD::Proxy 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. +# +# +# Author: Jochen Wiedmann +# Am Eisteich 9 +# 72555 Metzingen +# Germany +# +# Email: joe@ispsoft.de +# Phone: +49 7123 14881 +# +# +############################################################################## + + +require 5.004; +use strict; + +use RPC::PlServer 0.2001; +require DBI; +require Config; + + +package DBI::ProxyServer; + + + +############################################################################ +# +# Constants +# +############################################################################ + +use vars qw($VERSION @ISA); + +$VERSION = "0.3005"; +@ISA = qw(RPC::PlServer DBI); + + +# Most of the options below are set to default values, we note them here +# just for the sake of documentation. +my %DEFAULT_SERVER_OPTIONS; +{ + my $o = \%DEFAULT_SERVER_OPTIONS; + $o->{'chroot'} = undef, # To be used in the initfile, + # after loading the required + # DBI drivers. + $o->{'clients'} = + [ { 'mask' => '.*', + 'accept' => 1, + 'cipher' => undef + } + ]; + $o->{'configfile'} = '/etc/dbiproxy.conf' if -f '/etc/dbiproxy.conf'; + $o->{'debug'} = 0; + $o->{'facility'} = 'daemon'; + $o->{'group'} = undef; + $o->{'localaddr'} = undef; # Bind to any local IP number + $o->{'localport'} = undef; # Must set port number on the + # command line. + $o->{'logfile'} = undef; # Use syslog or EventLog. + + # XXX don't restrict methods that can be called (trust users once connected) + $o->{'XXX_methods'} = { + 'DBI::ProxyServer' => { + 'Version' => 1, + 'NewHandle' => 1, + 'CallMethod' => 1, + 'DestroyHandle' => 1 + }, + 'DBI::ProxyServer::db' => { + 'prepare' => 1, + 'commit' => 1, + 'rollback' => 1, + 'STORE' => 1, + 'FETCH' => 1, + 'func' => 1, + 'quote' => 1, + 'type_info_all' => 1, + 'table_info' => 1, + 'disconnect' => 1, + }, + 'DBI::ProxyServer::st' => { + 'execute' => 1, + 'STORE' => 1, + 'FETCH' => 1, + 'func' => 1, + 'fetch' => 1, + 'finish' => 1 + } + }; + if ($Config::Config{'usethreads'} eq 'define') { + $o->{'mode'} = 'threads'; + } elsif ($Config::Config{'d_fork'} eq 'define') { + $o->{'mode'} = 'fork'; + } else { + $o->{'mode'} = 'single'; + } + # No pidfile by default, configuration must provide one if needed + $o->{'pidfile'} = 'none'; + $o->{'user'} = undef; +}; + + +############################################################################ +# +# Name: Version +# +# Purpose: Return version string +# +# Inputs: $class - This class +# +# Result: Version string; suitable for printing by "--version" +# +############################################################################ + +sub Version { + my $version = $DBI::ProxyServer::VERSION; + "DBI::ProxyServer $version, Copyright (C) 1998, Jochen Wiedmann"; +} + + +############################################################################ +# +# Name: AcceptApplication +# +# Purpose: Verify DBI DSN +# +# Inputs: $self - This instance +# $dsn - DBI dsn +# +# Returns: TRUE for a valid DSN, FALSE otherwise +# +############################################################################ + +sub AcceptApplication { + my $self = shift; my $dsn = shift; + $dsn =~ /^dbi:\w+:/i; +} + + +############################################################################ +# +# Name: AcceptVersion +# +# Purpose: Verify requested DBI version +# +# Inputs: $self - Instance +# $version - DBI version being requested +# +# Returns: TRUE for ok, FALSE otherwise +# +############################################################################ + +sub AcceptVersion { + my $self = shift; my $version = shift; + require DBI; + DBI::ProxyServer->init_rootclass(); + $DBI::VERSION >= $version; +} + + +############################################################################ +# +# Name: AcceptUser +# +# Purpose: Verify user and password by connecting to the client and +# creating a database connection +# +# Inputs: $self - Instance +# $user - User name +# $password - Password +# +############################################################################ + +sub AcceptUser { + my $self = shift; my $user = shift; my $password = shift; + return 0 if (!$self->SUPER::AcceptUser($user, $password)); + my $dsn = $self->{'application'}; + $self->Debug("Connecting to $dsn as $user"); + local $ENV{DBI_AUTOPROXY} = ''; # :-) + $self->{'dbh'} = eval { + DBI::ProxyServer->connect($dsn, $user, $password, + { 'PrintError' => 0, + 'Warn' => 0, + 'RaiseError' => 1, + 'HandleError' => sub { + my $err = $_[1]->err; + my $state = $_[1]->state || ''; + $_[0] .= " [err=$err,state=$state]"; + return 0; + } }) + }; + if ($@) { + $self->Error("Error while connecting to $dsn as $user: $@"); + return 0; + } + [1, $self->StoreHandle($self->{'dbh'}) ]; +} + + +sub CallMethod { + my $server = shift; + my $dbh = $server->{'dbh'}; + # We could store the private_server attribute permanently in + # $dbh. However, we'd have a reference loop in that case and + # I would be concerned about garbage collection. :-( + $dbh->{'private_server'} = $server; + $server->Debug("CallMethod: => " . do { local $^W; join(",", @_)}); + my @result = eval { $server->SUPER::CallMethod(@_) }; + my $msg = $@; + undef $dbh->{'private_server'}; + if ($msg) { + $server->Debug("CallMethod died with: $@"); + die $msg; + } else { + $server->Debug("CallMethod: <= " . do { local $^W; join(",", @result) }); + } + @result; +} + + +sub main { + my $server = DBI::ProxyServer->new(\%DEFAULT_SERVER_OPTIONS, \@_); + $server->Bind(); +} + + +############################################################################ +# +# The DBI part of the proxyserver is implemented as a DBI subclass. +# Thus we can reuse some of the DBI methods and overwrite only +# those that need additional handling. +# +############################################################################ + +package DBI::ProxyServer::dr; + +@DBI::ProxyServer::dr::ISA = qw(DBI::dr); + + +package DBI::ProxyServer::db; + +@DBI::ProxyServer::db::ISA = qw(DBI::db); + +sub prepare { + my($dbh, $statement, $attr, $params, $proto_ver) = @_; + my $server = $dbh->{'private_server'}; + if (my $client = $server->{'client'}) { + if ($client->{'sql'}) { + if ($statement =~ /^\s*(\S+)/) { + my $st = $1; + if (!($statement = $client->{'sql'}->{$st})) { + die "Unknown SQL query: $st"; + } + } else { + die "Cannot parse restricted SQL statement: $statement"; + } + } + } + my $sth = $dbh->SUPER::prepare($statement, $attr); + my $handle = $server->StoreHandle($sth); + + if ( $proto_ver and $proto_ver > 1 ) { + $sth->{private_proxyserver_described} = 0; + return $handle; + + } else { + # The difference between the usual prepare and ours is that we implement + # a combined prepare/execute. The DBD::Proxy driver doesn't call us for + # prepare. Only if an execute happens, then we are called with method + # "prepare". Further execute's are called as "execute". + my @result = $sth->execute($params); + my ($NAME, $TYPE); + my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS}; + if ($NUM_OF_FIELDS) { # is a SELECT + $NAME = $sth->{NAME}; + $TYPE = $sth->{TYPE}; + } + ($handle, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, + $NAME, $TYPE, @result); + } +} + +sub table_info { + my $dbh = shift; + my $sth = $dbh->SUPER::table_info(); + my $numFields = $sth->{'NUM_OF_FIELDS'}; + my $names = $sth->{'NAME'}; + my $types = $sth->{'TYPE'}; + + # We wouldn't need to send all the rows at this point, instead we could + # make use of $rsth->fetch() on the client as usual. + # The problem is that some drivers (namely DBD::ExampleP, DBD::mysql and + # DBD::mSQL) are returning foreign sth's here, thus an instance of + # DBI::st and not DBI::ProxyServer::st. We could fix this by permitting + # the client to execute method DBI::st, but I don't like this. + my @rows; + while (my ($row) = $sth->fetch()) { + last unless defined $row; + push(@rows, [@$row]); + } + ($numFields, $names, $types, @rows); +} + + +package DBI::ProxyServer::st; + +@DBI::ProxyServer::st::ISA = qw(DBI::st); + +sub execute { + my $sth = shift; my $params = shift; my $proto_ver = shift; + my @outParams; + if ($params) { + for (my $i = 0; $i < @$params;) { + my $param = $params->[$i++]; + if (!ref($param)) { + $sth->bind_param($i, $param); + } + else { + if (!ref(@$param[0])) {#It's not a reference + $sth->bind_param($i, @$param); + } + else { + $sth->bind_param_inout($i, @$param); + my $ref = shift @$param; + push(@outParams, $ref); + } + } + } + } + my $rows = $sth->SUPER::execute(); + if ( $proto_ver and $proto_ver > 1 and not $sth->{private_proxyserver_described} ) { + my ($NAME, $TYPE); + my $NUM_OF_FIELDS = $sth->{NUM_OF_FIELDS}; + if ($NUM_OF_FIELDS) { # is a SELECT + $NAME = $sth->{NAME}; + $TYPE = $sth->{TYPE}; + } + $sth->{private_proxyserver_described} = 1; + # First execution, we ship back description. + return ($rows, $NUM_OF_FIELDS, $sth->{'NUM_OF_PARAMS'}, $NAME, $TYPE, @outParams); + } + ($rows, @outParams); +} + +sub fetch { + my $sth = shift; my $numRows = shift || 1; + my($ref, @rows); + while ($numRows-- && ($ref = $sth->SUPER::fetch())) { + push(@rows, [@$ref]); + } + @rows; +} + + +1; + + +__END__ + +=head1 NAME + +DBI::ProxyServer - a server for the DBD::Proxy driver + +=head1 SYNOPSIS + + use DBI::ProxyServer; + DBI::ProxyServer::main(@ARGV); + +=head1 DESCRIPTION + +DBI::Proxy Server is a module for implementing a proxy for the DBI proxy +driver, DBD::Proxy. It allows access to databases over the network if the +DBMS does not offer networked operations. But the proxy server might be +useful for you, even if you have a DBMS with integrated network +functionality: It can be used as a DBI proxy in a firewalled environment. + +DBI::ProxyServer runs as a daemon on the machine with the DBMS or on the +firewall. The client connects to the agent using the DBI driver DBD::Proxy, +thus in the exactly same way than using DBD::mysql, DBD::mSQL or any other +DBI driver. + +The agent is implemented as a RPC::PlServer application. Thus you have +access to all the possibilities of this module, in particular encryption +and a similar configuration file. DBI::ProxyServer adds the possibility of +query restrictions: You can define a set of queries that a client may +execute and restrict access to those. (Requires a DBI driver that supports +parameter binding.) See L</CONFIGURATION FILE>. + +The provided driver script, L<dbiproxy>, may either be used as it is or +used as the basis for a local version modified to meet your needs. + +=head1 OPTIONS + +When calling the DBI::ProxyServer::main() function, you supply an +array of options. These options are parsed by the Getopt::Long module. +The ProxyServer inherits all of RPC::PlServer's and hence Net::Daemon's +options and option handling, in particular the ability to read +options from either the command line or a config file. See +L<RPC::PlServer>. See L<Net::Daemon>. Available options include + +=over 4 + +=item I<chroot> (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 I<clients> + +An array ref with a list of clients. Clients are hash refs, the attributes +I<accept> (0 for denying access and 1 for permitting) and I<mask>, a Perl +regular expression for the clients IP number or its host name. + +=item I<configfile> (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 L<"CONFIGURATION FILE"> section +below for details on the config file. + +=item I<debug> (B<--debug>) + +Turn debugging mode on. Mainly this asserts that logging messages of +level "debug" are created. + +=item I<facility> (B<--facility=mode>) + +(UNIX only) Facility to use for L<Sys::Syslog>. The default is +B<daemon>. + +=item I<group> (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 I<localaddr> (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 I<localport> (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 I<logfile> (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<Net::Daemon::Log> for details. + +=item I<mode> (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 I<pidfile> (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 I<user> (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 I<version> (B<--version>) + +Suppresses startup of the server; instead the version string will +be printed and the program exits immediately. + +=back + +=head1 SHUTDOWN + +DBI::ProxyServer is built on L<RPC::PlServer> which is, in turn, built on L<Net::Daemon>. + +You should refer to L<Net::Daemon> for how to shutdown the server, except that +you can't because it's not currently documented there (as of v0.43). +The bottom-line is that it seems that there's no support for graceful shutdown. + +=head1 CONFIGURATION FILE + +The configuration file is just that of I<RPC::PlServer> or I<Net::Daemon> +with some additional attributes in the client list. + +The config file is a Perl script. At the top of the file you may include +arbitrary Perl source, for example load drivers at the start (useful +to enhance performance), prepare a chroot environment and so on. + +The important thing is that you finally return a hash ref of option +name/value pairs. The possible options are listed above. + +All possibilities of Net::Daemon and RPC::PlServer apply, in particular + +=over 4 + +=item Host and/or User dependent access control + +=item Host and/or User dependent encryption + +=item Changing UID and/or GID after binding to the port + +=item Running in a chroot() environment + +=back + +Additionally the server offers you query restrictions. Suggest the +following client list: + + 'clients' => [ + { 'mask' => '^admin\.company\.com$', + 'accept' => 1, + 'users' => [ 'root', 'wwwrun' ], + }, + { + 'mask' => '^admin\.company\.com$', + 'accept' => 1, + 'users' => [ 'root', 'wwwrun' ], + 'sql' => { + 'select' => 'SELECT * FROM foo', + 'insert' => 'INSERT INTO foo VALUES (?, ?, ?)' + } + } + +then only the users root and wwwrun may connect from admin.company.com, +executing arbitrary queries, but only wwwrun may connect from other +hosts and is restricted to + + $sth->prepare("select"); + +or + + $sth->prepare("insert"); + +which in fact are "SELECT * FROM foo" or "INSERT INTO foo VALUES (?, ?, ?)". + + +=head1 Proxyserver Configuration file (bigger example) + +This section tells you how to restrict a DBI-Proxy: Not every user from +every workstation shall be able to execute every query. + +There is a perl program "dbiproxy" which runs on a machine which is able +to connect to all the databases we wish to reach. All Perl-DBD-drivers must +be installed on this machine. You can also reach databases for which drivers +are not available on the machine where you run the program querying the +database, e.g. ask MS-Access-database from Linux. + +Create a configuration file "proxy_oracle.cfg" at the dbproxy-server: + + { + # This shall run in a shell or a DOS-window + # facility => 'daemon', + pidfile => 'your_dbiproxy.pid', + logfile => 1, + debug => 0, + mode => 'single', + localport => '12400', + + # Access control, the first match in this list wins! + # So the order is important + clients => [ + # hint to organize: + # the most specialized rules for single machines/users are 1st + # then the denying rules + # the the rules about whole networks + + # rule: internal_webserver + # desc: to get statistical information + { + # this IP-address only is meant + mask => '^10\.95\.81\.243$', + # accept (not defer) connections like this + accept => 1, + # only users from this list + # are allowed to log on + users => [ 'informationdesk' ], + # only this statistical query is allowed + # to get results for a web-query + sql => { + alive => 'select count(*) from dual', + statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?', + } + }, + + # rule: internal_bad_guy_1 + { + mask => '^10\.95\.81\.1$', + accept => 0, + }, + + # rule: employee_workplace + # desc: get detailled information + { + # any IP-address is meant here + mask => '^10\.95\.81\.(\d+)$', + # accept (not defer) connections like this + accept => 1, + # only users from this list + # are allowed to log on + users => [ 'informationdesk', 'lippmann' ], + # all these queries are allowed: + sql => { + search_city => 'select ort_nr, plz, ort from e01admin.e01e200 where plz like ?', + search_area => 'select gebiettyp, geb_bezei from e01admin.e01e203 where geb_bezei like ? or geb_bezei like ?', + } + }, + + # rule: internal_bad_guy_2 + # This does NOT work, because rule "employee_workplace" hits + # with its ip-address-mask of the whole network + { + # don't accept connection from this ip-address + mask => '^10\.95\.81\.5$', + accept => 0, + } + ] + } + +Start the proxyserver like this: + + rem well-set Oracle_home needed for Oracle + set ORACLE_HOME=d:\oracle\ora81 + dbiproxy --configfile proxy_oracle.cfg + + +=head2 Testing the connection from a remote machine + +Call a program "dbish" from your commandline. I take the machine from rule "internal_webserver" + + dbish "dbi:Proxy:hostname=oracle.zdf;port=12400;dsn=dbi:Oracle:e01" informationdesk xxx + +There will be a shell-prompt: + + informationdesk@dbi...> alive + + Current statement buffer (enter '/'...): + alive + + informationdesk@dbi...> / + COUNT(*) + '1' + [1 rows of 1 fields returned] + + +=head2 Testing the connection with a perl-script + +Create a perl-script like this: + + # file: oratest.pl + # call me like this: perl oratest.pl user password + + use strict; + use DBI; + + my $user = shift || die "Usage: $0 user password"; + my $pass = shift || die "Usage: $0 user password"; + my $config = { + dsn_at_proxy => "dbi:Oracle:e01", + proxy => "hostname=oechsle.zdf;port=12400", + }; + my $dsn = sprintf "dbi:Proxy:%s;dsn=%s", + $config->{proxy}, + $config->{dsn_at_proxy}; + + my $dbh = DBI->connect( $dsn, $user, $pass ) + || die "connect did not work: $DBI::errstr"; + + my $sql = "search_city"; + printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; + my $cur = $dbh->prepare($sql); + $cur->bind_param(1,'905%'); + &show_result ($cur); + + my $sql = "search_area"; + printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; + my $cur = $dbh->prepare($sql); + $cur->bind_param(1,'Pfarr%'); + $cur->bind_param(2,'Bronnamberg%'); + &show_result ($cur); + + my $sql = "statistic_area"; + printf "%s\n%s\n%s\n", "="x40, $sql, "="x40; + my $cur = $dbh->prepare($sql); + $cur->bind_param(1,'Pfarr%'); + &show_result ($cur); + + $dbh->disconnect; + exit; + + + sub show_result { + my $cur = shift; + unless ($cur->execute()) { + print "Could not execute\n"; + return; + } + + my $rownum = 0; + while (my @row = $cur->fetchrow_array()) { + printf "Row is: %s\n", join(", ",@row); + if ($rownum++ > 5) { + print "... and so on\n"; + last; + } + } + $cur->finish; + } + +The result + + C:\>perl oratest.pl informationdesk xxx + ======================================== + search_city + ======================================== + Row is: 3322, 9050, Chemnitz + Row is: 3678, 9051, Chemnitz + Row is: 10447, 9051, Chemnitz + Row is: 12128, 9051, Chemnitz + Row is: 10954, 90513, Zirndorf + Row is: 5808, 90513, Zirndorf + Row is: 5715, 90513, Zirndorf + ... and so on + ======================================== + search_area + ======================================== + Row is: 101, Bronnamberg + Row is: 400, Pfarramt Zirndorf + Row is: 400, Pfarramt Rosstal + Row is: 400, Pfarramt Oberasbach + Row is: 401, Pfarramt Zirndorf + Row is: 401, Pfarramt Rosstal + ======================================== + statistic_area + ======================================== + DBD::Proxy::st execute failed: Server returned error: Failed to execute method CallMethod: Unknown SQL query: statistic_area at E:/Perl/site/lib/DBI/ProxyServer.pm line 258. + Could not execute + + +=head2 How the configuration works + +The most important section to control access to your dbi-proxy is "client=>" +in the file "proxy_oracle.cfg": + +Controlling which person at which machine is allowed to access + +=over 4 + +=item * "mask" is a perl regular expression against the plain ip-address of the machine which wishes to connect _or_ the reverse-lookup from a nameserver. + +=item * "accept" tells the dbiproxy-server wether ip-adresse like in "mask" are allowed to connect or not (0/1) + +=item * "users" is a reference to a list of usernames which must be matched, this is NOT a regular expression. + +=back + +Controlling which SQL-statements are allowed + +You can put every SQL-statement you like in simply ommiting "sql => ...", but the more important thing is to restrict the connection so that only allowed queries are possible. + +If you include an sql-section in your config-file like this: + + sql => { + alive => 'select count(*) from dual', + statistic_area => 'select count(*) from e01admin.e01e203 where geb_bezei like ?', + } + +The user is allowed to put two queries against the dbi-proxy. The queries are _not_ "select count(*)...", the queries are "alive" and "statistic_area"! These keywords are replaced by the real query. So you can run a query for "alive": + + my $sql = "alive"; + my $cur = $dbh->prepare($sql); + ... + +The flexibility is that you can put parameters in the where-part of the query so the query are not static. Simply replace a value in the where-part of the query through a question mark and bind it as a parameter to the query. + + my $sql = "statistic_area"; + my $cur = $dbh->prepare($sql); + $cur->bind_param(1,'905%'); + # A second parameter would be called like this: + # $cur->bind_param(2,'98%'); + +The result is this query: + + select count(*) from e01admin.e01e203 + where geb_bezei like '905%' + +Don't try to put parameters into the sql-query like this: + + # Does not work like you think. + # Only the first word of the query is parsed, + # so it's changed to "statistic_area", the rest is omitted. + # You _have_ to work with $cur->bind_param. + my $sql = "statistic_area 905%"; + my $cur = $dbh->prepare($sql); + ... + + +=head2 Problems + +=over 4 + +=item * I don't know how to restrict users to special databases. + +=item * I don't know how to pass query-parameters via dbish + +=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<dbiproxy>, L<DBD::Proxy>, L<DBI>, L<RPC::PlServer>, +L<RPC::PlClient>, L<Net::Daemon>, L<Net::Daemon::Log>, +L<Sys::Syslog>, L<Win32::EventLog>, L<syslog> diff --git a/lib/DBI/PurePerl.pm b/lib/DBI/PurePerl.pm new file mode 100644 index 0000000..593379d --- /dev/null +++ b/lib/DBI/PurePerl.pm @@ -0,0 +1,1259 @@ +######################################################################## +package # hide from PAUSE + DBI; +# vim: ts=8:sw=4 +######################################################################## +# +# Copyright (c) 2002,2003 Tim Bunce Ireland. +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. +# +######################################################################## +# +# Please send patches and bug reports to +# +# Jeff Zucker <jeff@vpservices.com> with cc to <dbi-dev@perl.org> +# +######################################################################## + +use strict; +use Carp; +require Symbol; + +require utf8; +*utf8::is_utf8 = sub { # hack for perl 5.6 + require bytes; + return unless defined $_[0]; + return !(length($_[0]) == bytes::length($_[0])) +} unless defined &utf8::is_utf8; + +$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; +$DBI::PurePerl::VERSION = sprintf("2.%06d", q$Revision: 14285 $ =~ /(\d+)/o); + +$DBI::neat_maxlen ||= 400; + +$DBI::tfh = Symbol::gensym(); +open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; +select( (select($DBI::tfh), $| = 1)[0] ); # autoflush + +# 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 = [] ); + 1; +}; + +%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); + +use constant SQL_ALL_TYPES => 0; +use constant SQL_ARRAY => 50; +use constant SQL_ARRAY_LOCATOR => 51; +use constant SQL_BIGINT => (-5); +use constant SQL_BINARY => (-2); +use constant SQL_BIT => (-7); +use constant SQL_BLOB => 30; +use constant SQL_BLOB_LOCATOR => 31; +use constant SQL_BOOLEAN => 16; +use constant SQL_CHAR => 1; +use constant SQL_CLOB => 40; +use constant SQL_CLOB_LOCATOR => 41; +use constant SQL_DATE => 9; +use constant SQL_DATETIME => 9; +use constant SQL_DECIMAL => 3; +use constant SQL_DOUBLE => 8; +use constant SQL_FLOAT => 6; +use constant SQL_GUID => (-11); +use constant SQL_INTEGER => 4; +use constant SQL_INTERVAL => 10; +use constant SQL_INTERVAL_DAY => 103; +use constant SQL_INTERVAL_DAY_TO_HOUR => 108; +use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; +use constant SQL_INTERVAL_DAY_TO_SECOND => 110; +use constant SQL_INTERVAL_HOUR => 104; +use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; +use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; +use constant SQL_INTERVAL_MINUTE => 105; +use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; +use constant SQL_INTERVAL_MONTH => 102; +use constant SQL_INTERVAL_SECOND => 106; +use constant SQL_INTERVAL_YEAR => 101; +use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; +use constant SQL_LONGVARBINARY => (-4); +use constant SQL_LONGVARCHAR => (-1); +use constant SQL_MULTISET => 55; +use constant SQL_MULTISET_LOCATOR => 56; +use constant SQL_NUMERIC => 2; +use constant SQL_REAL => 7; +use constant SQL_REF => 20; +use constant SQL_ROW => 19; +use constant SQL_SMALLINT => 5; +use constant SQL_TIME => 10; +use constant SQL_TIMESTAMP => 11; +use constant SQL_TINYINT => (-6); +use constant SQL_TYPE_DATE => 91; +use constant SQL_TYPE_TIME => 92; +use constant SQL_TYPE_TIMESTAMP => 93; +use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; +use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; +use constant SQL_UDT => 17; +use constant SQL_UDT_LOCATOR => 18; +use constant SQL_UNKNOWN_TYPE => 0; +use constant SQL_VARBINARY => (-3); +use constant SQL_VARCHAR => 12; +use constant SQL_WCHAR => (-8); +use constant SQL_WLONGVARCHAR => (-10); +use constant SQL_WVARCHAR => (-9); + +# for Cursor types +use constant SQL_CURSOR_FORWARD_ONLY => 0; +use constant SQL_CURSOR_KEYSET_DRIVEN => 1; +use constant SQL_CURSOR_DYNAMIC => 2; +use constant SQL_CURSOR_STATIC => 3; +use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; + +use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ +use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ +use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ +use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ +use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ +use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ +use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ +use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ +use constant IMA_STUB => 0x0100; #/* donothing eg $dbh->connected */ +use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ +use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ +use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ +use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ +use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ +use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ +use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ +use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ + +use constant DBIstcf_STRICT => 0x0001; +use constant DBIstcf_DISCARD_STRING => 0x0002; + +my %is_flag_attribute = map {$_ =>1 } qw( + Active + AutoCommit + ChopBlanks + CompatMode + Executed + Taint + TaintIn + TaintOut + InactiveDestroy + AutoInactiveDestroy + LongTruncOk + MultiThread + PrintError + PrintWarn + RaiseError + ShowErrorStatement + Warn +); +my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( + ActiveKids + Attribution + BegunWork + CachedKids + Callbacks + ChildHandles + CursorName + Database + DebugDispatch + Driver + Err + Errstr + ErrCount + FetchHashKeyName + HandleError + HandleSetErr + ImplementorClass + Kids + LongReadLen + NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash + NULLABLE + NUM_OF_FIELDS + NUM_OF_PARAMS + Name + PRECISION + ParamValues + Profile + Provider + ReadOnly + RootClass + RowCacheSize + RowsInCache + SCALE + State + Statement + TYPE + Type + TraceLevel + Username + Version +)); + +sub valid_attribute { + my $attr = shift; + return 1 if $is_valid_attribute{$attr}; + return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter + return 0 +} + +my $initial_setup; +sub initial_setup { + $initial_setup = 1; + print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" + if $DBI::dbi_debug & 0xF; + untie $DBI::err; + untie $DBI::errstr; + untie $DBI::state; + untie $DBI::rows; + #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +} + +sub _install_method { + my ( $caller, $method, $from, $param_hash ) = @_; + initial_setup() unless $initial_setup; + + my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; + my $bitmask = $param_hash->{'O'} || 0; + my @pre_call_frag; + + return if $method_name eq 'can'; + + push @pre_call_frag, q{ + # ignore DESTROY for outer handle (DESTROY for inner likely to follow soon) + return if $h_inner; + # handle AutoInactiveDestroy and InactiveDestroy + $h->{InactiveDestroy} = 1 + if $h->{AutoInactiveDestroy} and $$ != $h->{dbi_pp_pid}; + $h->{Active} = 0 + if $h->{InactiveDestroy}; + # copy err/errstr/state up to driver so $DBI::err etc still work + if ($h->{err} and my $drh = $h->{Driver}) { + $drh->{$_} = $h->{$_} for ('err','errstr','state'); + } + } if $method_name eq 'DESTROY'; + + push @pre_call_frag, q{ + return $h->{$_[0]} if exists $h->{$_[0]}; + } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? + + push @pre_call_frag, "return;" + if IMA_STUB & $bitmask; + + push @pre_call_frag, q{ + $method_name = pop @_; + } if IMA_FUNC_REDIRECT & $bitmask; + + push @pre_call_frag, q{ + my $parent_dbh = $h->{Database}; + } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; + + push @pre_call_frag, q{ + warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems + $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; + } if IMA_COPY_UP_STMT & $bitmask; + + push @pre_call_frag, q{ + $h->{Executed} = 1; + $parent_dbh->{Executed} = 1 if $parent_dbh; + } if IMA_EXECUTE & $bitmask; + + push @pre_call_frag, q{ + %{ $h->{CachedKids} } = () if $h->{CachedKids}; + } if IMA_CLEAR_CACHED_KIDS & $bitmask; + + if (IMA_KEEP_ERR & $bitmask) { + push @pre_call_frag, q{ + my $keep_error = 1; + }; + } + else { + my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) + ? q{= $h->{dbi_pp_parent}->{dbi_pp_call_depth} } + : ""; + push @pre_call_frag, qq{ + my \$keep_error $ke_init; + }; + my $keep_error_code = q{ + #warn "$method_name cleared err"; + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + }; + $keep_error_code = q{ + printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". + $h->{err}, $h->{err} + if defined $h->{err} && $DBI::dbi_debug & 0xF; + }. $keep_error_code + if exists $ENV{DBI_TRACE}; + push @pre_call_frag, ($ke_init) + ? qq{ unless (\$keep_error) { $keep_error_code }} + : $keep_error_code + unless $method_name eq 'set_err'; + } + + push @pre_call_frag, q{ + my $ErrCount = $h->{ErrCount}; + }; + + push @pre_call_frag, q{ + if (($DBI::dbi_debug & 0xF) >= 2) { + local $^W; + my $args = join " ", map { DBI::neat($_) } ($h, @_); + printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; + } + } if exists $ENV{DBI_TRACE}; # note use of 'exists' + + push @pre_call_frag, q{ + $h->{'dbi_pp_last_method'} = $method_name; + } unless exists $DBI::last_method_except{$method_name}; + + # --- post method call code fragments --- + my @post_call_frag; + + push @post_call_frag, q{ + if (my $trace_level = ($DBI::dbi_debug & 0xF)) { + if ($h->{err}) { + printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; + } + my $ret = join " ", map { DBI::neat($_) } @ret; + my $msg = " < $method_name= $ret"; + $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; + print $DBI::tfh $msg; + } + } if exists $ENV{DBI_TRACE}; # note use of exists + + push @post_call_frag, q{ + $h->{Executed} = 0; + if ($h->{BegunWork}) { + $h->{BegunWork} = 0; + $h->{AutoCommit} = 1; + } + } if IMA_END_WORK & $bitmask; + + push @post_call_frag, q{ + if ( ref $ret[0] and + UNIVERSAL::isa($ret[0], 'DBI::_::common') and + defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) + ) { + # copy up info/warn to drh so PrintWarn on connect is triggered + $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) + } + } if IMA_IS_FACTORY & $bitmask; + + push @post_call_frag, q{ + $keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount; + + $DBI::err = $h->{err}; + $DBI::errstr = $h->{errstr}; + $DBI::state = $h->{state}; + + if ( !$keep_error + && defined(my $err = $h->{err}) + && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) + ) { + + my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)}; + my $msg; + + if ($err && ($pe || $re || $he) # error + or (!$err && length($err) && $pw) # warning + ) { + my $last = ($DBI::last_method_except{$method_name}) + ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; + my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; + my $msg = sprintf "%s %s %s: %s", $imp, $last, + ($err eq "0") ? "warning" : "failed", $errstr; + + if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { + $msg .= ' [for Statement "' . $Statement; + if (my $ParamValues = $h->FETCH('ParamValues')) { + $msg .= '" with ParamValues: '; + $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); + $msg .= "]"; + } + else { + $msg .= '"]'; + } + } + if ($err eq "0") { # is 'warning' (not info) + carp $msg if $pw; + } + else { + my $do_croak = 1; + if (my $subsub = $h->{'HandleError'}) { + $do_croak = 0 if &$subsub($msg,$h,$ret[0]); + } + if ($do_croak) { + printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" + if ($DBI::dbi_debug & 0xF) >= 4; + carp $msg if $pe; + die $msg if $h->{RaiseError}; + } + } + } + } + }; + + + my $method_code = q[ + sub { + my $h = shift; + my $h_inner = tied(%$h); + $h = $h_inner if $h_inner; + + my $imp; + if ($method_name eq 'DESTROY') { + # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" + # implying that tied() above lied to us, so we need to use eval + local $@; # protect $@ + $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction + } + else { + $imp = $h->{"ImplementorClass"} or do { + warn "Can't call $method_name method on handle $h after take_imp_data()\n" + if not exists $h->{Active}; + return; # or, more likely, global destruction + }; + } + + ] . join("\n", '', @pre_call_frag, '') . q[ + + my $call_depth = $h->{'dbi_pp_call_depth'} + 1; + local ($h->{'dbi_pp_call_depth'}) = $call_depth; + + my @ret; + my $sub = $imp->can($method_name); + if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { + push @_, $method_name; + } + if ($sub) { + (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); + } + else { + # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc + # which would then let Multiplex pass PurePerl tests, but some + # hook into install_method may be better. + croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" + if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; + } + + ] . join("\n", '', @post_call_frag, '') . q[ + + return (wantarray) ? @ret : $ret[0]; + } + ]; + no strict qw(refs); + my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; + warn "$@\n$method_code\n" if $@; + die "$@\n$method_code\n" if $@; + *$method = $code_ref; + if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool + my $l=0; # show line-numbered code for method + warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); + } +} + + +sub _new_handle { + my ($class, $parent, $attr, $imp_data, $imp_class) = @_; + + DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") + if $DBI::dbi_debug >= 3; + + $attr->{ImplementorClass} = $imp_class + or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); + + # This is how we create a DBI style Object: + # %outer gets tied to %$attr (which becomes the 'inner' handle) + my (%outer, $i, $h); + $i = tie %outer, $class, $attr; # ref to inner hash (for driver) + $h = bless \%outer, $class; # ref to outer hash (for application) + # The above tie and bless may migrate down into _setup_handle()... + # Now add magic so DBI method dispatch works + DBI::_setup_handle($h, $imp_class, $parent, $imp_data); + return $h unless wantarray; + return ($h, $i); +} + +sub _setup_handle { + my($h, $imp_class, $parent, $imp_data) = @_; + my $h_inner = tied(%$h) || $h; + if (($DBI::dbi_debug & 0xF) >= 4) { + local $^W; + print $DBI::tfh " _setup_handle(@_)\n"; + } + $h_inner->{"imp_data"} = $imp_data; + $h_inner->{"ImplementorClass"} = $imp_class; + $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained + if ($parent) { + foreach (qw( + RaiseError PrintError PrintWarn HandleError HandleSetErr + Warn LongTruncOk ChopBlanks AutoCommit ReadOnly + ShowErrorStatement FetchHashKeyName LongReadLen CompatMode + )) { + $h_inner->{$_} = $parent->{$_} + if exists $parent->{$_} && !exists $h_inner->{$_}; + } + if (ref($parent) =~ /::db$/) { + $h_inner->{Database} = $parent; + $parent->{Statement} = $h_inner->{Statement}; + $h_inner->{NUM_OF_PARAMS} = 0; + } + elsif (ref($parent) =~ /::dr$/){ + $h_inner->{Driver} = $parent; + } + $h_inner->{dbi_pp_parent} = $parent; + + # add to the parent's ChildHandles + if ($HAS_WEAKEN) { + my $handles = $parent->{ChildHandles} ||= []; + push @$handles, $h; + Scalar::Util::weaken($handles->[-1]); + # purge destroyed handles occasionally + if (@$handles % 120 == 0) { + @$handles = grep { defined } @$handles; + Scalar::Util::weaken($_) for @$handles; # re-weaken after grep + } + } + } + else { # setting up a driver handle + $h_inner->{Warn} = 1; + $h_inner->{PrintWarn} = $^W; + $h_inner->{AutoCommit} = 1; + $h_inner->{TraceLevel} = 0; + $h_inner->{CompatMode} = (1==0); + $h_inner->{FetchHashKeyName} ||= 'NAME'; + $h_inner->{LongReadLen} ||= 80; + $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; + $h_inner->{Type} ||= 'dr'; + } + $h_inner->{"dbi_pp_call_depth"} = 0; + $h_inner->{"dbi_pp_pid"} = $$; + $h_inner->{ErrCount} = 0; + $h_inner->{Active} = 1; +} + +sub constant { + warn "constant(@_) called unexpectedly"; return undef; +} + +sub trace { + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + _set_trace_file($file) if $level; + if (defined $level) { + $DBI::dbi_debug = $level; + print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " + . "dispatch trace level set to $DBI::dbi_debug\n" + if $DBI::dbi_debug & 0xF; + } + _set_trace_file($file) if !$level; + return $old_level; +} + +sub _set_trace_file { + my ($file) = @_; + # + # DAA add support for filehandle inputs + # + # DAA required to avoid closing a prior fh trace() + $DBI::tfh = undef unless $DBI::tfh_needs_close; + + if (ref $file eq 'GLOB') { + $DBI::tfh = $file; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + if ($file && ref \$file eq 'GLOB') { + $DBI::tfh = *{$file}{IO}; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + $DBI::tfh_needs_close = 1; + if (!$file || $file eq 'STDERR') { + open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; + } + elsif ($file eq 'STDOUT') { + open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; + } + else { + open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; + } + select((select($DBI::tfh), $| = 1)[0]); + return 1; +} +sub _get_imp_data { shift->{"imp_data"}; } +sub _svdump { } +sub dump_handle { + my ($h,$msg,$level) = @_; + $msg||="dump_handle $h"; + print $DBI::tfh "$msg:\n"; + for my $attrib (sort keys %$h) { + print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; + } +} + +sub _handles { + my $h = shift; + my $h_inner = tied %$h; + if ($h_inner) { # this is okay + return $h unless wantarray; + return ($h, $h_inner); + } + # XXX this isn't okay... we have an inner handle but + # currently have no way to get at its outer handle, + # so we just warn and return the inner one for both... + Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); + return $h unless wantarray; + return ($h,$h); +} + +sub hash { + my ($key, $type) = @_; + my ($hash); + if (!$type) { + $hash = 0; + # XXX The C version uses the "char" type, which could be either + # signed or unsigned. I use signed because so do the two + # compilers on my system. + for my $char (unpack ("c*", $key)) { + $hash = $hash * 33 + $char; + } + $hash &= 0x7FFFFFFF; # limit to 31 bits + $hash |= 0x40000000; # set bit 31 + return -$hash; # return negative int + } + elsif ($type == 1) { # Fowler/Noll/Vo hash + # see http://www.isthe.com/chongo/tech/comp/fnv/ + require Math::BigInt; # feel free to reimplement w/o BigInt! + (my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01" + if ($version >= 1.56) { + $hash = Math::BigInt->new(0x811c9dc5); + for my $uchar (unpack ("C*", $key)) { + # multiply by the 32 bit FNV magic prime mod 2^64 + $hash = ($hash * 0x01000193) & 0xffffffff; + # xor the bottom with the current octet + $hash ^= $uchar; + } + # cast to int + return unpack "i", pack "i", $hash; + } + croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)"); + } + else { + croak("bad hash type $type"); + } +} + +sub looks_like_number { + my @new = (); + for my $thing(@_) { + if (!defined $thing or $thing eq '') { + push @new, undef; + } + else { + push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; + } + } + return (@_ >1) ? @new : $new[0]; +} + +sub neat { + my $v = shift; + return "undef" unless defined $v; + my $quote = q{"}; + if (not utf8::is_utf8($v)) { + return $v if (($v & ~ $v) eq "0"); # is SvNIOK + $quote = q{'}; + } + my $maxlen = shift || $DBI::neat_maxlen; + if ($maxlen && $maxlen < length($v) + 2) { + $v = substr($v,0,$maxlen-5); + $v .= '...'; + } + $v =~ s/[^[:print:]]/./g; + return "$quote$v$quote"; +} + +sub sql_type_cast { + my (undef, $sql_type, $flags) = @_; + + return -1 unless defined $_[0]; + + my $cast_ok = 1; + + my $evalret = eval { + use warnings FATAL => qw(numeric); + if ($sql_type == SQL_INTEGER) { + my $dummy = $_[0] + 0; + return 1; + } + elsif ($sql_type == SQL_DOUBLE) { + my $dummy = $_[0] + 0.0; + return 1; + } + elsif ($sql_type == SQL_NUMERIC) { + my $dummy = $_[0] + 0.0; + return 1; + } + else { + return -2; + } + } or $^W && warn $@; # XXX warnings::warnif("numeric", $@) ? + + return $evalret if defined($evalret) && ($evalret == -2); + $cast_ok = 0 unless $evalret; + + # DBIstcf_DISCARD_STRING not supported for PurePerl currently + + return 2 if $cast_ok; + return 0 if $flags & DBIstcf_STRICT; + return 1; +} + +sub dbi_time { + return time(); +} + +sub DBI::st::TIEHASH { bless $_[1] => $_[0] }; + +sub _concat_hash_sorted { + my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; + # $num_sort: 0=lexical, 1=numeric, undef=try to guess + + return undef unless defined $hash_ref; + die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; + my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); + my $string = ''; + for my $key (@$keys) { + $string .= $pair_separator if length $string > 0; + my $value = $hash_ref->{$key}; + if ($use_neat) { + $value = DBI::neat($value, 0); + } + else { + $value = (defined $value) ? "'$value'" : 'undef'; + } + $string .= $key . $kv_separator . $value; + } + return $string; +} + +sub _get_sorted_hash_keys { + my ($hash_ref, $num_sort) = @_; + if (not defined $num_sort) { + my $sort_guess = 1; + $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess + for keys %$hash_ref; + $num_sort = $sort_guess; + } + + my @keys = keys %$hash_ref; + no warnings 'numeric'; + my @sorted = ($num_sort) + ? sort { $a <=> $b or $a cmp $b } @keys + : sort @keys; + return \@sorted; +} + + + +package + DBI::var; + +sub FETCH { + my($key)=shift; + return $DBI::err if $$key eq '*err'; + return $DBI::errstr if $$key eq '&errstr'; + Carp::confess("FETCH $key not supported when using DBI::PurePerl"); +} + +package + DBD::_::common; + +sub swap_inner_handle { + my ($h1, $h2) = @_; + # can't make this work till we can get the outer handle from the inner one + # probably via a WeakRef + return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl"); +} + +sub trace { # XXX should set per-handle level, not global + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + DBI::_set_trace_file($file) if defined $file; + if (defined $level) { + $DBI::dbi_debug = $level; + if ($DBI::dbi_debug) { + printf $DBI::tfh + " %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n", + $h, $DBI::dbi_debug; + print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n" + unless exists $ENV{DBI_TRACE}; + } + } + return $old_level; +} +*debug = \&trace; *debug = \&trace; # twice to avoid typo warning + +sub FETCH { + my($h,$key)= @_; + my $v = $h->{$key}; + #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n"); + return $v if defined $v; + if ($key =~ /^NAME_.c$/) { + my $cols = $h->FETCH('NAME'); + return undef unless $cols; + my @lcols = map { lc $_ } @$cols; + $h->{NAME_lc} = \@lcols; + my @ucols = map { uc $_ } @$cols; + $h->{NAME_uc} = \@ucols; + return $h->FETCH($key); + } + if ($key =~ /^NAME.*_hash$/) { + my $i=0; + for my $c(@{$h->FETCH('NAME')||[]}) { + $h->{'NAME_hash'}->{$c} = $i; + $h->{'NAME_lc_hash'}->{"\L$c"} = $i; + $h->{'NAME_uc_hash'}->{"\U$c"} = $i; + $i++; + } + return $h->{$key}; + } + if (!defined $v && !exists $h->{$key}) { + return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint'; + return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef + return $DBI::dbi_debug if $key eq 'TraceLevel'; + return [] if $key eq 'ChildHandles' && $HAS_WEAKEN; + if ($key eq 'Type') { + return "dr" if $h->isa('DBI::dr'); + return "db" if $h->isa('DBI::db'); + return "st" if $h->isa('DBI::st'); + Carp::carp( sprintf "Can't determine Type for %s",$h ); + } + if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) { + local $^W; # hide undef warnings + Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key ) + } + } + return $v; +} +sub STORE { + my ($h,$key,$value) = @_; + if ($key eq 'AutoCommit') { + Carp::croak("DBD driver has not implemented the AutoCommit attribute") + unless $value == -900 || $value == -901; + $value = ($value == -901); + } + elsif ($key =~ /^Taint/ ) { + Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key) + if $value; + } + elsif ($key eq 'TraceLevel') { + $h->trace($value); + return 1; + } + elsif ($key eq 'NUM_OF_FIELDS') { + $h->{$key} = $value; + if ($value) { + my $fbav = DBD::_::st::dbih_setup_fbav($h); + @$fbav = (undef) x $value if @$fbav != $value; + } + return 1; + } + elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) { + Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s", + $h,$key,$value); + } + $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value; + return 1; +} +sub err { return shift->{err} } +sub errstr { return shift->{errstr} } +sub state { return shift->{state} } +sub set_err { + my ($h, $errnum,$msg,$state, $method, $rv) = @_; + $h = tied(%$h) || $h; + + if (my $hss = $h->{HandleSetErr}) { + return if $hss->($h, $errnum, $msg, $state, $method); + } + + if (!defined $errnum) { + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + return; + } + + if ($h->{errstr}) { + $h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum + if $h->{err} && $errnum && $h->{err} ne $errnum; + $h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state + if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state; + $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg; + $DBI::errstr = $h->{errstr}; + } + else { + $h->{errstr} = $DBI::errstr = $msg; + } + + # assign if higher priority: err > "0" > "" > undef + my $err_changed; + if ($errnum # new error: so assign + or !defined $h->{err} # no existing warn/info: so assign + # new warn ("0" len 1) > info ("" len 0): so assign + or defined $errnum && length($errnum) > length($h->{err}) + ) { + $h->{err} = $DBI::err = $errnum; + ++$h->{ErrCount} if $errnum; + ++$err_changed; + } + + if ($err_changed) { + $state ||= "S1000" if $DBI::err; + $h->{state} = $DBI::state = ($state eq "00000") ? "" : $state + if $state; + } + + if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY) + $p->{err} = $DBI::err; + $p->{errstr} = $DBI::errstr; + $p->{state} = $DBI::state; + } + + $h->{'dbi_pp_last_method'} = $method; + return $rv; # usually undef +} +sub trace_msg { + my ($h, $msg, $minlevel)=@_; + $minlevel = 1 unless defined $minlevel; + return unless $minlevel <= ($DBI::dbi_debug & 0xF); + print $DBI::tfh $msg; + return 1; +} +sub private_data { + warn "private_data @_"; +} +sub take_imp_data { + my $dbh = shift; + # A reasonable default implementation based on the one in DBI.xs. + # Typically a pure-perl driver would have their own take_imp_data method + # that would delete all but the essential items in the hash before einding with: + # return $dbh->SUPER::take_imp_data(); + # Of course it's useless if the driver doesn't also implement support for + # the dbi_imp_data attribute to the connect() method. + require Storable; + croak("Can't take_imp_data from handle that's not Active") + unless $dbh->{Active}; + for my $sth (@{ $dbh->{ChildHandles} || [] }) { + next unless $sth; + $sth->finish if $sth->{Active}; + bless $sth, 'DBI::zombie'; + } + delete $dbh->{$_} for (keys %is_valid_attribute); + delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh; + # warn "@{[ %$dbh ]}"; + local $Storable::forgive_me = 1; # in case there are some CODE refs + my $imp_data = Storable::freeze($dbh); + # XXX um, should probably untie here - need to check dispatch behaviour + return $imp_data; +} +sub rows { + return -1; # always returns -1 here, see DBD::_::st::rows below +} +sub DESTROY { +} + +package + DBD::_::dr; + +sub dbixs_revision { + return 0; +} + +package + DBD::_::db; + +sub connected { +} + + +package + DBD::_::st; + +sub fetchrow_arrayref { + my $h = shift; + # if we're here then driver hasn't implemented fetch/fetchrow_arrayref + # so we assume they've implemented fetchrow_array and call that instead + my @row = $h->fetchrow_array or return; + return $h->_set_fbav(\@row); +} +# twice to avoid typo warning +*fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref; + +sub fetchrow_array { + my $h = shift; + # if we're here then driver hasn't implemented fetchrow_array + # so we assume they've implemented fetch/fetchrow_arrayref + my $row = $h->fetch or return; + return @$row; +} +*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array; + +sub fetchrow_hashref { + my $h = shift; + my $row = $h->fetch or return; + my $FetchCase = shift; + my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME'; + my $FetchHashKeys = $h->FETCH($FetchHashKeyName); + my %rowhash; + @rowhash{ @$FetchHashKeys } = @$row; + return \%rowhash; +} +sub dbih_setup_fbav { + my $h = shift; + return $h->{'_fbav'} || do { + $DBI::rows = $h->{'_rows'} = 0; + my $fields = $h->{'NUM_OF_FIELDS'} + or DBI::croak("NUM_OF_FIELDS not set"); + my @row = (undef) x $fields; + \@row; + }; +} +sub _get_fbav { + my $h = shift; + my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h); + $DBI::rows = ++$h->{'_rows'}; + return $av; +} +sub _set_fbav { + my $h = shift; + my $fbav = $h->{'_fbav'}; + if ($fbav) { + $DBI::rows = ++$h->{'_rows'}; + } + else { + $fbav = $h->_get_fbav; + } + my $row = shift; + if (my $bc = $h->{'_bound_cols'}) { + for my $i (0..@$row-1) { + my $bound = $bc->[$i]; + $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i]; + } + } + else { + @$fbav = @$row; + } + return $fbav; +} +sub bind_col { + my ($h, $col, $value_ref,$from_bind_columns) = @_; + my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() + my $num_of_fields = @$fbav; + DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") + if $col < 1 or $col > $num_of_fields; + return 1 if not defined $value_ref; # ie caller is just trying to set TYPE + DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar") + unless ref $value_ref eq 'SCALAR'; + $h->{'_bound_cols'}->[$col-1] = $value_ref; + return 1; +} +sub finish { + my $h = shift; + $h->{'_fbav'} = undef; + $h->{'Active'} = 0; + return 1; +} +sub rows { + my $h = shift; + my $rows = $h->{'_rows'}; + return -1 unless defined $rows; + return $rows; +} + +1; +__END__ + +=pod + +=head1 NAME + +DBI::PurePerl -- a DBI emulation using pure perl (no C/XS compilation required) + +=head1 SYNOPSIS + + BEGIN { $ENV{DBI_PUREPERL} = 2 } + use DBI; + +=head1 DESCRIPTION + +This is a pure perl emulation of the DBI internals. In almost all +cases you will be better off using standard DBI since the portions +of the standard version written in C make it *much* faster. + +However, if you are in a situation where it isn't possible to install +a compiled version of standard DBI, and you're using pure-perl DBD +drivers, then this module allows you to use most common features +of DBI without needing any changes in your scripts. + +=head1 EXPERIMENTAL STATUS + +DBI::PurePerl is new so please treat it as experimental pending +more extensive testing. So far it has passed all tests with DBD::CSV, +DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP. Please send +bug reports to Jeff Zucker at <jeff@vpservices.com> with a cc to +<dbi-dev@perl.org>. + +=head1 USAGE + +The usage is the same as for standard DBI with the exception +that you need to set the environment variable DBI_PUREPERL if +you want to use the PurePerl version. + + DBI_PUREPERL == 0 (the default) Always use compiled DBI, die + if it isn't properly compiled & installed + + DBI_PUREPERL == 1 Use compiled DBI if it is properly compiled + & installed, otherwise use PurePerl + + DBI_PUREPERL == 2 Always use PurePerl + +You may set the enviornment variable in your shell (e.g. with +set or setenv or export, etc) or else set it in your script like +this: + + BEGIN { $ENV{DBI_PUREPERL}=2 } + +before you C<use DBI;>. + +=head1 INSTALLATION + +In most situations simply install DBI (see the DBI pod for details). + +In the situation in which you can not install DBI itself, you +may manually copy DBI.pm and PurePerl.pm into the appropriate +directories. + +For example: + + cp DBI.pm /usr/jdoe/mylibs/. + cp PurePerl.pm /usr/jdoe/mylibs/DBI/. + +Then add this to the top of scripts: + + BEGIN { + $ENV{DBI_PUREPERL} = 1; # or =2 + unshift @INC, '/usr/jdoe/mylibs'; + } + +(Or should we perhaps patch Makefile.PL so that if DBI_PUREPERL +is set to 2 prior to make, the normal compile process is skipped +and the files are installed automatically?) + +=head1 DIFFERENCES BETWEEN DBI AND DBI::PurePerl + +=head2 Attributes + +Boolean attributes still return boolean values but the actual values +used may be different, i.e., 0 or undef instead of an empty string. + +Some handle attributes are either not supported or have very limited +functionality: + + ActiveKids + InactiveDestroy + AutoInactiveDestroy + Kids + Taint + TaintIn + TaintOut + +(and probably others) + +=head2 Tracing + +Trace functionality is more limited and the code to handle tracing is +only embedded into DBI:PurePerl if the DBI_TRACE environment variable +is defined. To enable total tracing you can set the DBI_TRACE +environment variable as usual. But to enable individual handle +tracing using the trace() method you also need to set the DBI_TRACE +environment variable, but set it to 0. + +=head2 Parameter Usage Checking + +The DBI does some basic parameter count checking on method calls. +DBI::PurePerl doesn't. + +=head2 Speed + +DBI::PurePerl is slower. Although, with some drivers in some +contexts this may not be very significant for you. + +By way of example... the test.pl script in the DBI source +distribution has a simple benchmark that just does: + + my $null_dbh = DBI->connect('dbi:NullP:','',''); + my $i = 10_000; + $null_dbh->prepare('') while $i--; + +In other words just prepares a statement, creating and destroying +a statement handle, over and over again. Using the real DBI this +runs at ~4550 handles per second whereas DBI::PurePerl manages +~2800 per second on the same machine (not too bad really). + +=head2 May not fully support hash() + +If you want to use type 1 hash, i.e., C<hash($string,1)> with +DBI::PurePerl, you'll need version 1.56 or higher of Math::BigInt +(available on CPAN). + +=head2 Doesn't support preparse() + +The DBI->preparse() method isn't supported in DBI::PurePerl. + +=head2 Doesn't support DBD::Proxy + +There's a subtle problem somewhere I've not been able to identify. +DBI::ProxyServer seem to work fine with DBI::PurePerl but DBD::Proxy +does not work 100% (which is sad because that would be far more useful :) +Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem +that remains will affect you're usage. + +=head2 Others + + can() - doesn't have any special behaviour + +Please let us know if you find any other differences between DBI +and DBI::PurePerl. + +=head1 AUTHORS + +Tim Bunce and Jeff Zucker. + +Tim provided the direction and basis for the code. The original +idea for the module and most of the brute force porting from C to +Perl was by Jeff. Tim then reworked some core parts to boost the +performance and accuracy of the emulation. Thanks also to Randal +Schwartz and John Tobey for patches. + +=head1 COPYRIGHT + +Copyright (c) 2002 Tim Bunce Ireland. + +See COPYRIGHT section in DBI.pm for usage and distribution rights. + +=cut diff --git a/lib/DBI/SQL/Nano.pm b/lib/DBI/SQL/Nano.pm new file mode 100644 index 0000000..dc0711f --- /dev/null +++ b/lib/DBI/SQL/Nano.pm @@ -0,0 +1,1010 @@ +####################################################################### +# +# DBI::SQL::Nano - a very tiny SQL engine +# +# Copyright (c) 2010 by Jens Rehsack < rehsack AT cpan.org > +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# +# 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. +# +# See the pod at the bottom of this file for help information +# +####################################################################### + +####################### +package DBI::SQL::Nano; +####################### +use strict; +use warnings; +use vars qw( $VERSION $versions ); + +use Carp qw(croak); + +require DBI; # for looks_like_number() + +BEGIN +{ + $VERSION = sprintf( "1.%06d", q$Revision: 14600 $ =~ /(\d+)/o ); + + $versions->{nano_version} = $VERSION; + if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.28' } ) + { + @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_); + @DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_); + } + else + { + @DBI::SQL::Nano::Statement::ISA = qw( SQL::Statement ); + @DBI::SQL::Nano::Table::ISA = qw( SQL::Eval::Table); + $versions->{statement_version} = $SQL::Statement::VERSION; + } +} + +################################### +package DBI::SQL::Nano::Statement_; +################################### + +use Carp qw(croak); +use Errno; + +if ( eval { require Clone; } ) +{ + Clone->import("clone"); +} +else +{ + require Storable; # in CORE since 5.7.3 + *clone = \&Storable::dclone; +} + +sub new +{ + my ( $class, $sql ) = @_; + my $self = {}; + bless $self, $class; + return $self->prepare($sql); +} + +##################################################################### +# PREPARE +##################################################################### +sub prepare +{ + my ( $self, $sql ) = @_; + $sql =~ s/\s+$//; + for ($sql) + { + /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is + && do + { + $self->{command} = 'CREATE'; + $self->{table_name} = $1; + $self->{column_names} = parse_coldef_list($2) if $2; + $self->{column_names} or croak "Can't find columns"; + }; + /^\s*DROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.*?)\s*$/is + && do + { + $self->{command} = 'DROP'; + $self->{table_name} = $2; + $self->{ignore_missing_table} = 1 if $1; + }; + /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is + && do + { + $self->{command} = 'SELECT'; + $self->{column_names} = parse_comma_list($1) if $1; + $self->{column_names} or croak "Can't find columns"; + $self->{table_name} = $2; + if ( my $clauses = $4 ) + { + if ( $clauses =~ /^(.*)\s+ORDER\s+BY\s+(.*)$/is ) + { + $clauses = $1; + $self->{order_clause} = $self->parse_order_clause($2); + } + $self->{where_clause} = $self->parse_where_clause($clauses) if ($clauses); + } + }; + /^\s*INSERT\s+(?:INTO\s+)?(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is + && do + { + $self->{command} = 'INSERT'; + $self->{table_name} = $1; + $self->{column_names} = parse_comma_list($2) if $2; + $self->{values} = $self->parse_values_list($4) if $4; + $self->{values} or croak "Can't parse values"; + }; + /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is + && do + { + $self->{command} = 'DELETE'; + $self->{table_name} = $1; + $self->{where_clause} = $self->parse_where_clause($3) if $3; + }; + /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is + && do + { + $self->{command} = 'UPDATE'; + $self->{table_name} = $1; + $self->parse_set_clause($2) if $2; + $self->{where_clause} = $self->parse_where_clause($3) if $3; + }; + } + croak "Couldn't parse" unless ( $self->{command} and $self->{table_name} ); + return $self; +} + +sub parse_order_clause +{ + my ( $self, $str ) = @_; + my @clause = split /\s+/, $str; + return { $clause[0] => 'ASC' } if ( @clause == 1 ); + croak "Bad ORDER BY clause '$str'" if ( @clause > 2 ); + $clause[1] ||= ''; + return { $clause[0] => uc $clause[1] } + if $clause[1] =~ /^ASC$/i + or $clause[1] =~ /^DESC$/i; + croak "Bad ORDER BY clause '$clause[1]'"; +} + +sub parse_coldef_list +{ # check column definitions + my @col_defs; + for ( split ',', shift ) + { + my $col = clean_parse_str($_); + if ( $col =~ /^(\S+?)\s+.+/ ) + { # doesn't check what it is + $col = $1; # just checks if it exists + } + else + { + croak "No column definition for '$_'"; + } + push @col_defs, $col; + } + return \@col_defs; +} + +sub parse_comma_list +{ + [ map { clean_parse_str($_) } split( ',', shift ) ]; +} +sub clean_parse_str { local $_ = shift; s/\(//; s/\)//; s/^\s+//; s/\s+$//; $_; } + +sub parse_values_list +{ + my ( $self, $str ) = @_; + [ map { $self->parse_value( clean_parse_str($_) ) } split( ',', $str ) ]; +} + +sub parse_set_clause +{ + my $self = shift; + my @cols = split /,/, shift; + my $set_clause; + for my $col (@cols) + { + my ( $col_name, $value ) = $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s; + push @{ $self->{column_names} }, $col_name; + push @{ $self->{values} }, $self->parse_value($value); + } + croak "Can't parse set clause" unless ( $self->{column_names} and $self->{values} ); +} + +sub parse_value +{ + my ( $self, $str ) = @_; + return unless ( defined $str ); + $str =~ s/\s+$//; + $str =~ s/^\s+//; + if ( $str =~ /^\?$/ ) + { + push @{ $self->{params} }, '?'; + return { + value => '?', + type => 'placeholder' + }; + } + return { + value => undef, + type => 'NULL' + } if ( $str =~ /^NULL$/i ); + return { + value => $1, + type => 'string' + } if ( $str =~ /^'(.+)'$/s ); + return { + value => $str, + type => 'number' + } if ( DBI::looks_like_number($str) ); + return { + value => $str, + type => 'column' + }; +} + +sub parse_where_clause +{ + my ( $self, $str ) = @_; + $str =~ s/\s+$//; + if ( $str =~ /^\s*WHERE\s+(.*)/i ) + { + $str = $1; + } + else + { + croak "Couldn't find WHERE clause in '$str'"; + } + my ($neg) = $str =~ s/^\s*(NOT)\s+//is; + my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS'; + my ( $val1, $op, $val2 ) = $str =~ /^(.+?)\s*($opexp)\s*(.+)\s*$/iso; + croak "Couldn't parse WHERE expression '$str'" unless ( defined $val1 and defined $op and defined $val2 ); + return { + arg1 => $self->parse_value($val1), + arg2 => $self->parse_value($val2), + op => $op, + neg => $neg, + }; +} + +##################################################################### +# EXECUTE +##################################################################### +sub execute +{ + my ( $self, $data, $params ) = @_; + my $num_placeholders = $self->params; + my $num_params = scalar @$params || 0; + croak "Number of params '$num_params' does not match number of placeholders '$num_placeholders'" + unless ( $num_placeholders == $num_params ); + if ( scalar @$params ) + { + for my $i ( 0 .. $#{ $self->{values} } ) + { + if ( $self->{values}->[$i]->{type} eq 'placeholder' ) + { + $self->{values}->[$i]->{value} = shift @$params; + } + } + if ( $self->{where_clause} ) + { + if ( $self->{where_clause}->{arg1}->{type} eq 'placeholder' ) + { + $self->{where_clause}->{arg1}->{value} = shift @$params; + } + if ( $self->{where_clause}->{arg2}->{type} eq 'placeholder' ) + { + $self->{where_clause}->{arg2}->{value} = shift @$params; + } + } + } + my $command = $self->{command}; + ( $self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'}, $self->{'data'}, ) = $self->$command( $data, $params ); + $self->{NAME} ||= $self->{column_names}; + return $self->{'NUM_OF_ROWS'} || '0E0'; +} + +my $enoentstr = "Cannot open .*\(" . Errno::ENOENT . "\)"; +my $enoentrx = qr/$enoentstr/; + +sub DROP ($$$) +{ + my ( $self, $data, $params ) = @_; + + my $table; + my @err; + eval { + local $SIG{__WARN__} = sub { push @err, @_ }; + ($table) = $self->open_tables( $data, 0, 1 ); + }; + if ( $self->{ignore_missing_table} and ( $@ or @err ) and grep { $_ =~ $enoentrx } ( @err, $@ ) ) + { + $@ = ''; + return ( -1, 0 ); + } + + croak( $@ || $err[0] ) if ( $@ || @err ); + return ( -1, 0 ) unless $table; + + $table->drop($data); + ( -1, 0 ); +} + +sub CREATE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 1, 1 ); + $table->push_names( $data, $self->{column_names} ); + ( 0, 0 ); +} + +sub INSERT ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + $table->seek( $data, 0, 2 ) unless ( $table->can('insert_one_row') ); + my ($array) = []; + my ( $val, $col, $i ); + $self->{column_names} = $table->col_names() unless ( $self->{column_names} ); + my $cNum = scalar( @{ $self->{column_names} } ) if ( $self->{column_names} ); + my $param_num = 0; + + if ($cNum) + { + for ( $i = 0; $i < $cNum; $i++ ) + { + $col = $self->{column_names}->[$i]; + $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i); + } + } + else + { + croak "Bad col names in INSERT"; + } + + $table->can('insert_new_row') ? $table->insert_new_row( $data, $array ) : $table->push_row( $data, $array ); + + return ( 1, 0 ); +} + +sub DELETE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + my ($affected) = 0; + my ( @rows, $array ); + my $can_dor = $table->can('delete_one_row'); + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + ++$affected; + if ( $self->{fetched_from_key} ) + { + $array = $self->{fetched_value}; + $table->delete_one_row( $data, $array ); + return ( $affected, 0 ); + } + push( @rows, $array ) if ($can_dor); + } + else + { + push( @rows, $array ) unless ($can_dor); + } + } + if ($can_dor) + { + foreach $array (@rows) + { + $table->delete_one_row( $data, $array ); + } + } + else + { + $table->seek( $data, 0, 0 ); + foreach $array (@rows) + { + $table->push_row( $data, $array ); + } + $table->truncate($data); + } + return ( $affected, 0 ); +} + +sub _anycmp($$;$) +{ + my ( $a, $b, $case_fold ) = @_; + + if ( !defined($a) || !defined($b) ) + { + return defined($a) - defined($b); + } + elsif ( DBI::looks_like_number($a) && DBI::looks_like_number($b) ) + { + return $a <=> $b; + } + else + { + return $case_fold ? lc($a) cmp lc($b) || $a cmp $b : $a cmp $b; + } +} + +sub SELECT ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 0 ); + $self->verify_columns($table); + my $tname = $self->{table_name}; + my ($affected) = 0; + my ( @rows, %cols, $array, $val, $col, $i ); + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + $array = $self->{fetched_value} if ( $self->{fetched_from_key} ); + unless ( keys %cols ) + { + my $col_nums = $self->column_nums($table); + %cols = reverse %{$col_nums}; + } + + my $rowhash; + for ( sort keys %cols ) + { + $rowhash->{ $cols{$_} } = $array->[$_]; + } + my @newarray; + for ( $i = 0; $i < @{ $self->{column_names} }; $i++ ) + { + $col = $self->{column_names}->[$i]; + push @newarray, $rowhash->{$col}; + } + push( @rows, \@newarray ); + return ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows ) + if ( $self->{fetched_from_key} ); + } + } + if ( $self->{order_clause} ) + { + my ( $sort_col, $desc ) = each %{ $self->{order_clause} }; + my @sortCols = ( $self->column_nums( $table, $sort_col, 1 ) ); + $sortCols[1] = uc $desc eq 'DESC' ? 1 : 0; + + @rows = sort { + my ( $result, $colNum, $desc ); + my $i = 0; + do + { + $colNum = $sortCols[ $i++ ]; + $desc = $sortCols[ $i++ ]; + $result = _anycmp( $a->[$colNum], $b->[$colNum] ); + $result = -$result if ($desc); + } while ( !$result && $i < @sortCols ); + $result; + } @rows; + } + ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows ); +} + +sub UPDATE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + return undef unless $table; + my $affected = 0; + my $can_usr = $table->can('update_specific_row'); + my $can_uor = $table->can('update_one_row'); + my $can_rwu = $can_usr || $can_uor; + my ( @rows, $array, $f_array, $val, $col, $i ); + + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + $array = $self->{fetched_value} if ( $self->{fetched_from_key} and $can_rwu ); + my $orig_ary = clone($array) if ($can_usr); + for ( $i = 0; $i < @{ $self->{column_names} }; $i++ ) + { + $col = $self->{column_names}->[$i]; + $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i); + } + $affected++; + if ( $self->{fetched_value} ) + { + if ($can_usr) + { + $table->update_specific_row( $data, $array, $orig_ary ); + } + elsif ($can_uor) + { + $table->update_one_row( $data, $array ); + } + return ( $affected, 0 ); + } + push( @rows, $can_usr ? [ $array, $orig_ary ] : $array ); + } + else + { + push( @rows, $array ) unless ($can_rwu); + } + } + if ($can_rwu) + { + foreach my $array (@rows) + { + if ($can_usr) + { + $table->update_specific_row( $data, @$array ); + } + elsif ($can_uor) + { + $table->update_one_row( $data, $array ); + } + } + } + else + { + $table->seek( $data, 0, 0 ); + foreach my $array (@rows) + { + $table->push_row( $data, $array ); + } + $table->truncate($data); + } + + return ( $affected, 0 ); +} + +sub verify_columns +{ + my ( $self, $table ) = @_; + my @cols = @{ $self->{column_names} }; + if ( $self->{where_clause} ) + { + if ( my $col = $self->{where_clause}->{arg1} ) + { + push @cols, $col->{value} if $col->{type} eq 'column'; + } + if ( my $col = $self->{where_clause}->{arg2} ) + { + push @cols, $col->{value} if $col->{type} eq 'column'; + } + } + for (@cols) + { + $self->column_nums( $table, $_ ); + } +} + +sub column_nums +{ + my ( $self, $table, $stmt_col_name, $find_in_stmt ) = @_; + my %dbd_nums = %{ $table->col_nums() }; + my @dbd_cols = @{ $table->col_names() }; + my %stmt_nums; + if ( $stmt_col_name and !$find_in_stmt ) + { + while ( my ( $k, $v ) = each %dbd_nums ) + { + return $v if uc $k eq uc $stmt_col_name; + } + croak "No such column '$stmt_col_name'"; + } + if ( $stmt_col_name and $find_in_stmt ) + { + for my $i ( 0 .. @{ $self->{column_names} } ) + { + return $i if uc $stmt_col_name eq uc $self->{column_names}->[$i]; + } + croak "No such column '$stmt_col_name'"; + } + for my $i ( 0 .. $#dbd_cols ) + { + for my $stmt_col ( @{ $self->{column_names} } ) + { + $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col; + } + } + return \%stmt_nums; +} + +sub eval_where +{ + my ( $self, $table, $rowary ) = @_; + my $where = $self->{"where_clause"} || return 1; + my $col_nums = $table->col_nums(); + my %cols = reverse %{$col_nums}; + my $rowhash; + for ( sort keys %cols ) + { + $rowhash->{ uc $cols{$_} } = $rowary->[$_]; + } + return $self->process_predicate( $where, $table, $rowhash ); +} + +sub process_predicate +{ + my ( $self, $pred, $table, $rowhash ) = @_; + my $val1 = $pred->{arg1}; + if ( $val1->{type} eq 'column' ) + { + $val1 = $rowhash->{ uc $val1->{value} }; + } + else + { + $val1 = $val1->{value}; + } + my $val2 = $pred->{arg2}; + if ( $val2->{type} eq 'column' ) + { + $val2 = $rowhash->{ uc $val2->{value} }; + } + else + { + $val2 = $val2->{value}; + } + my $op = $pred->{op}; + my $neg = $pred->{neg}; + if ( $op eq '=' and !$neg and $table->can('fetch_one_row') ) + { + my $key_col = $table->fetch_one_row( 1, 1 ); + if ( $pred->{arg1}->{value} =~ /^$key_col$/i ) + { + $self->{fetched_from_key} = 1; + $self->{fetched_value} = $table->fetch_one_row( 0, $pred->{arg2}->{value} ); + return 1; + } + } + my $match = $self->is_matched( $val1, $op, $val2 ) || 0; + if ($neg) { $match = $match ? 0 : 1; } + return $match; +} + +sub is_matched +{ + my ( $self, $val1, $op, $val2 ) = @_; + if ( $op eq 'IS' ) + { + return 1 if ( !defined $val1 or $val1 eq '' ); + return 0; + } + $val1 = '' unless ( defined $val1 ); + $val2 = '' unless ( defined $val2 ); + if ( $op =~ /LIKE|CLIKE/i ) + { + $val2 = quotemeta($val2); + $val2 =~ s/\\%/.*/g; + $val2 =~ s/_/./g; + } + if ( $op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; } + if ( $op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; } + if ( DBI::looks_like_number($val1) && DBI::looks_like_number($val2) ) + { + if ( $op eq '<' ) { return $val1 < $val2; } + if ( $op eq '>' ) { return $val1 > $val2; } + if ( $op eq '=' ) { return $val1 == $val2; } + if ( $op eq '<>' ) { return $val1 != $val2; } + if ( $op eq '<=' ) { return $val1 <= $val2; } + if ( $op eq '>=' ) { return $val1 >= $val2; } + } + else + { + if ( $op eq '<' ) { return $val1 lt $val2; } + if ( $op eq '>' ) { return $val1 gt $val2; } + if ( $op eq '=' ) { return $val1 eq $val2; } + if ( $op eq '<>' ) { return $val1 ne $val2; } + if ( $op eq '<=' ) { return $val1 ge $val2; } + if ( $op eq '>=' ) { return $val1 le $val2; } + } +} + +sub params +{ + my ( $self, $val_num ) = @_; + if ( !$self->{"params"} ) { return 0; } + if ( defined $val_num ) + { + return $self->{"params"}->[$val_num]; + } + if (wantarray) + { + return @{ $self->{"params"} }; + } + else + { + return scalar @{ $self->{"params"} }; + } + +} + +sub open_tables +{ + my ( $self, $data, $createMode, $lockMode ) = @_; + my $table_name = $self->{table_name}; + my $table; + eval { $table = $self->open_table( $data, $table_name, $createMode, $lockMode ) }; + if ($@) + { + chomp $@; + croak $@; + } + croak "Couldn't open table '$table_name'" unless $table; + if ( !$self->{column_names} or $self->{column_names}->[0] eq '*' ) + { + $self->{column_names} = $table->col_names(); + } + return $table; +} + +sub row_values +{ + my ( $self, $val_num ) = @_; + if ( !$self->{"values"} ) { return 0; } + if ( defined $val_num ) + { + return $self->{"values"}->[$val_num]->{value}; + } + if (wantarray) + { + return map { $_->{"value"} } @{ $self->{"values"} }; + } + else + { + return scalar @{ $self->{"values"} }; + } +} + +sub column_names +{ + my ($self) = @_; + my @col_names; + if ( $self->{column_names} and $self->{column_names}->[0] ne '*' ) + { + @col_names = @{ $self->{column_names} }; + } + return @col_names; +} + +############################### +package DBI::SQL::Nano::Table_; +############################### + +use Carp qw(croak); + +sub new ($$) +{ + my ( $proto, $attr ) = @_; + my ($self) = {%$attr}; + + defined( $self->{col_names} ) and "ARRAY" eq ref( $self->{col_names} ) + or croak("attribute 'col_names' must be defined as an array"); + exists( $self->{col_nums} ) or $self->{col_nums} = _map_colnums( $self->{col_names} ); + defined( $self->{col_nums} ) and "HASH" eq ref( $self->{col_nums} ) + or croak("attribute 'col_nums' must be defined as a hash"); + + bless( $self, ( ref($proto) || $proto ) ); + return $self; +} + +sub _map_colnums +{ + my $col_names = $_[0]; + my %col_nums; + for my $i ( 0 .. $#$col_names ) + { + next unless $col_names->[$i]; + $col_nums{ $col_names->[$i] } = $i; + } + return \%col_nums; +} + +sub row() { return $_[0]->{row}; } +sub column($) { return $_[0]->{row}->[ $_[0]->column_num( $_[1] ) ]; } +sub column_num($) { $_[0]->{col_nums}->{ $_[1] }; } +sub col_nums() { $_[0]->{col_nums} } +sub col_names() { $_[0]->{col_names}; } + +sub drop ($$) { croak "Abstract method " . ref( $_[0] ) . "::drop called" } +sub fetch_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::fetch_row called" } +sub push_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_row called" } +sub push_names ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_names called" } +sub truncate ($$) { croak "Abstract method " . ref( $_[0] ) . "::truncate called" } +sub seek ($$$$) { croak "Abstract method " . ref( $_[0] ) . "::seek called" } + +1; +__END__ + +=pod + +=head1 NAME + +DBI::SQL::Nano - a very tiny SQL engine + +=head1 SYNOPSIS + + BEGIN { $ENV{DBI_SQL_NANO}=1 } # forces use of Nano rather than SQL::Statement + use DBI::SQL::Nano; + use Data::Dumper; + my $stmt = DBI::SQL::Nano::Statement->new( + "SELECT bar,baz FROM foo WHERE qux = 1" + ) or die "Couldn't parse"; + print Dumper $stmt; + +=head1 DESCRIPTION + +C<< DBI::SQL::Nano >> is meant as a I<very> minimal SQL engine for use in +situations where SQL::Statement is not available. In most situations you are +better off installing L<SQL::Statement> although DBI::SQL::Nano may be faster +for some B<very> simple tasks. + +DBI::SQL::Nano, like SQL::Statement is primarily intended to provide a SQL +engine for use with some pure perl DBDs including L<DBD::DBM>, L<DBD::CSV>, +L<DBD::AnyData>, and L<DBD::Excel>. It is not of much use in and of itself. +You can dump out the structure of a parsed SQL statement, but that is about +it. + +=head1 USAGE + +=head2 Setting the DBI_SQL_NANO flag + +By default, when a C<< DBD >> uses C<< DBI::SQL::Nano >>, the module will +look to see if C<< SQL::Statement >> is installed. If it is, SQL::Statement +objects are used. If SQL::Statement is not available, DBI::SQL::Nano +objects are used. + +In some cases, you may wish to use DBI::SQL::Nano objects even if +SQL::Statement is available. To force usage of DBI::SQL::Nano objects +regardless of the availability of SQL::Statement, set the environment +variable DBI_SQL_NANO to 1. + +You can set the environment variable in your shell prior to running your +script (with SET or EXPORT or whatever), or else you can set it in your +script by putting this at the top of the script: + + BEGIN { $ENV{DBI_SQL_NANO} = 1 } + +=head2 Supported SQL syntax + + Here's a pseudo-BNF. Square brackets [] indicate optional items; + Angle brackets <> indicate items defined elsewhere in the BNF. + + statement ::= + DROP TABLE [IF EXISTS] <table_name> + | CREATE TABLE <table_name> <col_def_list> + | INSERT INTO <table_name> [<insert_col_list>] VALUES <val_list> + | DELETE FROM <table_name> [<where_clause>] + | UPDATE <table_name> SET <set_clause> <where_clause> + | SELECT <select_col_list> FROM <table_name> [<where_clause>] + [<order_clause>] + + the optional IF EXISTS clause ::= + * similar to MySQL - prevents errors when trying to drop + a table that doesn't exist + + identifiers ::= + * table and column names should be valid SQL identifiers + * especially avoid using spaces and commas in identifiers + * note: there is no error checking for invalid names, some + will be accepted, others will cause parse failures + + table_name ::= + * only one table (no multiple table operations) + * see identifier for valid table names + + col_def_list ::= + * a parens delimited, comma-separated list of column names + * see identifier for valid column names + * column types and column constraints may be included but are ignored + e.g. these are all the same: + (id,phrase) + (id INT, phrase VARCHAR(40)) + (id INT PRIMARY KEY, phrase VARCHAR(40) NOT NULL) + * you are *strongly* advised to put in column types even though + they are ignored ... it increases portability + + insert_col_list ::= + * a parens delimited, comma-separated list of column names + * as in standard SQL, this is optional + + select_col_list ::= + * a comma-separated list of column names + * or an asterisk denoting all columns + + val_list ::= + * a parens delimited, comma-separated list of values which can be: + * placeholders (an unquoted question mark) + * numbers (unquoted numbers) + * column names (unquoted strings) + * nulls (unquoted word NULL) + * strings (delimited with single quote marks); + * note: leading and trailing percent mark (%) and underscore (_) + can be used as wildcards in quoted strings for use with + the LIKE and CLIKE operators + * note: escaped single quotation marks within strings are not + supported, neither are embedded commas, use placeholders instead + + set_clause ::= + * a comma-separated list of column = value pairs + * see val_list for acceptable value formats + + where_clause ::= + * a single "column/value <op> column/value" predicate, optionally + preceded by "NOT" + * note: multiple predicates combined with ORs or ANDs are not supported + * see val_list for acceptable value formats + * op may be one of: + < > >= <= = <> LIKE CLIKE IS + * CLIKE is a case insensitive LIKE + + order_clause ::= column_name [ASC|DESC] + * a single column optional ORDER BY clause is supported + * as in standard SQL, if neither ASC (ascending) nor + DESC (descending) is specified, ASC becomes the default + +=head1 TABLES + +DBI::SQL::Nano::Statement operates on exactly one table. This table will be +opened by inherit from DBI::SQL::Nano::Statement and implements the +C<< open_table >> method. + + sub open_table ($$$$$) + { + ... + return Your::Table->new( \%attributes ); + } + +DBI::SQL::Nano::Statement_ expects a rudimentary interface is implemented by +the table object, as well as SQL::Statement expects. + + package Your::Table; + + use vars qw(@ISA); + @ISA = qw(DBI::SQL::Nano::Table); + + sub drop ($$) { ... } + sub fetch_row ($$$) { ... } + sub push_row ($$$) { ... } + sub push_names ($$$) { ... } + sub truncate ($$) { ... } + sub seek ($$$$) { ... } + +The base class interfaces are provided by DBI::SQL::Nano::Table_ in case of +relying on DBI::SQL::Nano or SQL::Eval::Table (see L<SQL::Eval> for details) +otherwise. + +=head1 BUGS AND LIMITATIONS + +There are no known bugs in DBI::SQL::Nano::Statement. If you find a one +and want to report, please see L<DBI> for how to report bugs. + +DBI::SQL::Nano::Statement is designed to provide a minimal subset for +executing SQL statements. + +The most important limitation might be the restriction on one table per +statement. This implies, that no JOINs are supported and there cannot be +any foreign key relation between tables. + +The where clause evaluation of DBI::SQL::Nano::Statement is very slow +(SQL::Statement uses a precompiled evaluation). + +INSERT can handle only one row per statement. To insert multiple rows, +use placeholders as explained in DBI. + +The DBI::SQL::Nano parser is very limited and does not support any +additional syntax such as brackets, comments, functions, aggregations +etc. + +In contrast to SQL::Statement, temporary tables are not supported. + +=head1 ACKNOWLEDGEMENTS + +Tim Bunce provided the original idea for this module, helped me out of the +tangled trap of namespaces, and provided help and advice all along the way. +Although I wrote it from the ground up, it is based on Jochen Wiedmann's +original design of SQL::Statement, so much of the credit for the API goes +to him. + +=head1 AUTHOR AND COPYRIGHT + +This module is originally written by Jeff Zucker < jzucker AT cpan.org > + +This module is currently maintained by Jens Rehsack < jrehsack AT cpan.org > + +Copyright (C) 2010 by Jens Rehsack, all rights reserved. +Copyright (C) 2004 by Jeff Zucker, 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. + +=cut + diff --git a/lib/DBI/Util/CacheMemory.pm b/lib/DBI/Util/CacheMemory.pm new file mode 100644 index 0000000..f111432 --- /dev/null +++ b/lib/DBI/Util/CacheMemory.pm @@ -0,0 +1,117 @@ +package DBI::Util::CacheMemory; + +# $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z timbo $ +# +# Copyright (c) 2007, 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. + +use strict; +use warnings; + +=head1 NAME + +DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory + +=head1 DESCRIPTION + +Like Cache::Memory (part of the Cache distribution) but doesn't support any fancy features. + +This module aims to be a very fast compatible strict sub-set for simple cases, +such as basic client-side caching for DBD::Gofer. + +Like Cache::Memory, and other caches in the Cache and Cache::Cache +distributions, the data will remain in the cache until cleared, it expires, +or the process dies. The cache object simply going out of scope will I<not> +destroy the data. + +=head1 METHODS WITH CHANGES + +=head2 new + +All options except C<namespace> are ignored. + +=head2 set + +Doesn't support expiry. + +=head2 purge + +Same as clear() - deletes everything in the namespace. + +=head1 METHODS WITHOUT CHANGES + +=over + +=item clear + +=item count + +=item exists + +=item remove + +=back + +=head1 UNSUPPORTED METHODS + +If it's not listed above, it's not supported. + +=cut + +our $VERSION = sprintf("0.%06d", q$Revision: 10314 $ =~ /(\d+)/o); + +my %cache; + +sub new { + my ($class, %options ) = @_; + my $namespace = $options{namespace} ||= 'Default'; + #$options{_cache} = \%cache; # can be handy for debugging/dumping + my $self = bless \%options => $class; + $cache{ $namespace } ||= {}; # init - ensure it exists + return $self; +} + +sub set { + my ($self, $key, $value) = @_; + $cache{ $self->{namespace} }->{$key} = $value; +} + +sub get { + my ($self, $key) = @_; + return $cache{ $self->{namespace} }->{$key}; +} + +sub exists { + my ($self, $key) = @_; + return exists $cache{ $self->{namespace} }->{$key}; +} + +sub remove { + my ($self, $key) = @_; + return delete $cache{ $self->{namespace} }->{$key}; +} + +sub purge { + return shift->clear; +} + +sub clear { + $cache{ shift->{namespace} } = {}; +} + +sub count { + return scalar keys %{ $cache{ shift->{namespace} } }; +} + +sub size { + my $c = $cache{ shift->{namespace} }; + my $size = 0; + while ( my ($k,$v) = each %$c ) { + $size += length($k) + length($v); + } + return $size; +} + +1; diff --git a/lib/DBI/Util/_accessor.pm b/lib/DBI/Util/_accessor.pm new file mode 100644 index 0000000..7836ebe --- /dev/null +++ b/lib/DBI/Util/_accessor.pm @@ -0,0 +1,65 @@ +package DBI::Util::_accessor; +use strict; +use Carp; +our $VERSION = sprintf("0.%06d", q$Revision: 9478 $ =~ /(\d+)/); + +# inspired by Class::Accessor::Fast + +sub new { + my($proto, $fields) = @_; + my($class) = ref $proto || $proto; + $fields ||= {}; + + my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields; + carp "$class doesn't have accessors for fields: @dubious" if @dubious; + + # make a (shallow) copy of $fields. + bless {%$fields}, $class; +} + +sub mk_accessors { + my($self, @fields) = @_; + $self->mk_accessors_using('make_accessor', @fields); +} + +sub mk_accessors_using { + my($self, $maker, @fields) = @_; + my $class = ref $self || $self; + + # So we don't have to do lots of lookups inside the loop. + $maker = $self->can($maker) unless ref $maker; + + no strict 'refs'; + foreach my $field (@fields) { + my $accessor = $self->$maker($field); + *{$class."\:\:$field"} = $accessor + unless defined &{$class."\:\:$field"}; + } + #my $hash_ref = \%{$class."\:\:_accessors_hash}; + #$hash_ref->{$_}++ for @fields; + # XXX also copy down _accessors_hash of base class(es) + # so one in this class is complete + return; +} + +sub make_accessor { + my($class, $field) = @_; + return sub { + my $self = shift; + return $self->{$field} unless @_; + croak "Too many arguments to $field" if @_ > 1; + return $self->{$field} = shift; + }; +} + +sub make_accessor_autoviv_hashref { + my($class, $field) = @_; + return sub { + my $self = shift; + return $self->{$field} ||= {} unless @_; + croak "Too many arguments to $field" if @_ > 1; + return $self->{$field} = shift; + }; +} + +1; diff --git a/lib/DBI/W32ODBC.pm b/lib/DBI/W32ODBC.pm new file mode 100644 index 0000000..ac2aea1 --- /dev/null +++ b/lib/DBI/W32ODBC.pm @@ -0,0 +1,181 @@ +package + DBI; # hide this non-DBI package from simple indexers + +# $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z timbo $ +# +# Copyright (c) 1997,1999 Tim Bunce +# With many thanks to Patrick Hollins for polishing. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +=head1 NAME + +DBI::W32ODBC - An experimental DBI emulation layer for Win32::ODBC + +=head1 SYNOPSIS + + use DBI::W32ODBC; + + # apart from the line above everything is just the same as with + # the real DBI when using a basic driver with few features. + +=head1 DESCRIPTION + +This is an experimental pure perl DBI emulation layer for Win32::ODBC + +If you can improve this code I'd be interested in hearing about it. If +you are having trouble using it please respect the fact that it's very +experimental. Ideally fix it yourself and send me the details. + +=head2 Some Things Not Yet Implemented + + Most attributes including PrintError & RaiseError. + type_info and table_info + +Volunteers welcome! + +=cut + +${'DBI::VERSION'} # hide version from PAUSE indexer + = "0.01"; + +my $Revision = sprintf("12.%06d", q$Revision: 8696 $ =~ /(\d+)/o); + + +sub DBI::W32ODBC::import { } # must trick here since we're called DBI/W32ODBC.pm + + +use Carp; + +use Win32::ODBC; + +@ISA = qw(Win32::ODBC); + +use strict; + +$DBI::dbi_debug = $ENV{PERL_DBI_DEBUG} || 0; +carp "Loaded (W32ODBC) DBI.pm ${'DBI::VERSION'} (debug $DBI::dbi_debug)" + if $DBI::dbi_debug; + + + +sub connect { + my ($class, $dbname, $dbuser, $dbpasswd, $module, $attr) = @_; + $dbname .= ";UID=$dbuser" if $dbuser; + $dbname .= ";PWD=$dbpasswd" if $dbpasswd; + my $h = new Win32::ODBC $dbname; + warn "Error connecting to $dbname: ".Win32::ODBC::Error()."\n" unless $h; + bless $h, $class if $h; # rebless into our class + $h; +} + + +sub quote { + my ($h, $string) = @_; + return "NULL" if !defined $string; + $string =~ s/'/''/g; # standard + # This hack seems to be required for Access but probably breaks for + # other databases when using \r and \n. It would be better if we could + # use ODBC options to detect that we're actually using Access. + $string =~ s/\r/' & chr\$(13) & '/g; + $string =~ s/\n/' & chr\$(10) & '/g; + "'$string'"; +} + +sub do { + my($h, $statement, $attribs, @params) = @_; + Carp::carp "\$h->do() attribs unused" if $attribs; + my $new_h = $h->prepare($statement) or return undef; ## + pop @{ $h->{'___sths'} }; ## certian death assured + $new_h->execute(@params) or return undef; ## + my $rows = $new_h->rows; ## + $new_h->finish; ## bang bang + ($rows == 0) ? "0E0" : $rows; +} + +# --- + +sub prepare { + my ($h, $sql) = @_; + ## opens a new connection with every prepare to allow + ## multiple, concurrent queries + my $new_h = new Win32::ODBC $h->{DSN}; ## + return undef if not $new_h; ## bail if no connection + bless $new_h; ## shouldn't be sub-classed... + $new_h->{'__prepare'} = $sql; ## + $new_h->{NAME} = []; ## + $new_h->{NUM_OF_FIELDS} = -1; ## + push @{ $h->{'___sths'} } ,$new_h; ## save sth in parent for mass destruction + return $new_h; ## +} + +sub execute { + my ($h) = @_; + my $rc = $h->Sql($h->{'__prepare'}); + return undef if $rc; + my @fields = $h->FieldNames; + $h->{NAME} = \@fields; + $h->{NUM_OF_FIELDS} = scalar @fields; + $h; # return dbh as pseudo sth +} + + +sub fetchrow_hashref { ## provide DBI compatibility + my $h = shift; + my $NAME = shift || "NAME"; + my $row = $h->fetchrow_arrayref or return undef; + my %hash; + @hash{ @{ $h->{$NAME} } } = @$row; + return \%hash; +} + +sub fetchrow { + my $h = shift; + return unless $h->FetchRow(); + my $fields_r = $h->{NAME}; + return $h->Data(@$fields_r); +} +sub fetch { + my @row = shift->fetchrow; + return undef unless @row; + return \@row; +} +*fetchrow_arrayref = \&fetch; ## provide DBI compatibility +*fetchrow_array = \&fetchrow; ## provide DBI compatibility + +sub rows { + shift->RowCount; +} + +sub finish { + shift->Close; ## uncommented this line +} + +# --- + +sub commit { + shift->Transact(ODBC::SQL_COMMIT); +} +sub rollback { + shift->Transact(ODBC::SQL_ROLLBACK); +} + +sub disconnect { + my ($h) = shift; ## this will kill all the statement handles + foreach (@{$h->{'___sths'}}) { ## created for a specific connection + $_->Close if $_->{DSN}; ## + } ## + $h->Close; ## +} + +sub err { + (shift->Error)[0]; +} +sub errstr { + scalar( shift->Error ); +} + +# --- + +1; diff --git a/lib/Win32/DBIODBC.pm b/lib/Win32/DBIODBC.pm new file mode 100644 index 0000000..a93f69b --- /dev/null +++ b/lib/Win32/DBIODBC.pm @@ -0,0 +1,248 @@ +package # hide this package from CPAN indexer + Win32::ODBC; + +#use strict; + +use DBI; + +# once we've been loaded we don't want perl to load the real Win32::ODBC +$INC{'Win32/ODBC.pm'} = $INC{'Win32/DBIODBC.pm'} || 1; + +#my $db = new Win32::ODBC("DSN=$self->{'DSN'};UID=$self->{'UID'};PWD=$self->{'PWD'};"); + +#EMU --- my $db = new Win32::ODBC("DSN=$DSN;UID=$login;PWD=$password;"); +sub new +{ + shift; + my $connect_line= shift; + +# [R] self-hack to allow empty UID and PWD + my $temp_connect_line; + $connect_line=~/DSN=\w+/; + $temp_connect_line="$&;"; + if ($connect_line=~/UID=\w?/) + {$temp_connect_line.="$&;";} + else {$temp_connect_line.="UID=;";}; + if ($connect_line=~/PWD=\w?/) + {$temp_connect_line.="$&;";} + else {$temp_connect_line.="PWD=;";}; + $connect_line=$temp_connect_line; +# -[R]- + + my $self= {}; + + + $_=$connect_line; + /^(DSN=)(.*)(;UID=)(.*)(;PWD=)(.*)(;)$/; + + #---- DBI CONNECTION VARIABLES + + $self->{ODBC_DSN}=$2; + $self->{ODBC_UID}=$4; + $self->{ODBC_PWD}=$6; + + + #---- DBI CONNECTION VARIABLES + $self->{DBI_DBNAME}=$self->{ODBC_DSN}; + $self->{DBI_USER}=$self->{ODBC_UID}; + $self->{DBI_PASSWORD}=$self->{ODBC_PWD}; + $self->{DBI_DBD}='ODBC'; + + #---- DBI CONNECTION + $self->{'DBI_DBH'}=DBI->connect($self->{'DBI_DBNAME'}, + $self->{'DBI_USER'},$self->{'DBI_PASSWORD'},$self->{'DBI_DBD'}); + + warn "Error($DBI::err) : $DBI::errstr\n" if ! $self->{'DBI_DBH'}; + + + #---- RETURN + + bless $self; +} + + +#EMU --- $db->Sql('SELECT * FROM DUAL'); +sub Sql +{ + my $self= shift; + my $SQL_statment=shift; + + # print " SQL : $SQL_statment \n"; + + $self->{'DBI_SQL_STATMENT'}=$SQL_statment; + + my $dbh=$self->{'DBI_DBH'}; + + # print " DBH : $dbh \n"; + + my $sth=$dbh->prepare("$SQL_statment"); + + # print " STH : $sth \n"; + + $self->{'DBI_STH'}=$sth; + + if ($sth) + { + $sth->execute(); + } + + #--- GET ERROR MESSAGES + $self->{DBI_ERR}=$DBI::err; + $self->{DBI_ERRSTR}=$DBI::errstr; + + if ($sth) + { + #--- GET COLUMNS NAMES + $self->{'DBI_NAME'} = $sth->{NAME}; + } + +# [R] provide compatibility with Win32::ODBC's way of identifying erraneous SQL statements + return ($self->{'DBI_ERR'})?1:undef; +# -[R]- +} + + +#EMU --- $db->FetchRow()) +sub FetchRow +{ + my $self= shift; + + my $sth=$self->{'DBI_STH'}; + if ($sth) + { + my @row=$sth->fetchrow_array; + $self->{'DBI_ROW'}=\@row; + + if (scalar(@row)>0) + { + #-- the row of result is not nul + #-- return somthing nothing will be return else + return 1; + } + } + return undef; +} + +# [R] provide compatibility with Win32::ODBC's Data() method. +sub Data +{ + my $self=shift; + my @array=@{$self->{'DBI_ROW'}}; + foreach my $element (@array) + { + # remove padding of spaces by DBI + $element=~s/(\s*$)//; + }; + return (wantarray())?@array:join('', @array); +}; +# -[R]- + +#EMU --- %record = $db->DataHash; +sub DataHash +{ + my $self= shift; + + my $p_name=$self->{'DBI_NAME'}; + my $p_row=$self->{'DBI_ROW'}; + + my @name=@$p_name; + my @row=@$p_row; + + my %DataHash; +#print @name; print "\n"; print @row; +# [R] new code that seems to work consistent with Win32::ODBC + while (@name) + { + my $name=shift(@name); + my $value=shift(@row); + + # remove padding of spaces by DBI + $name=~s/(\s*$)//; + $value=~s/(\s*$)//; + + $DataHash{$name}=$value; + }; +# -[R]- + +# [R] old code that didn't appear to work +# foreach my $name (@name) +# { +# $name=~s/(^\s*)|(\s*$)//; +# my @arr=@$name; +# foreach (@arr) +# { +# print "lot $name name col $_ or ROW= 0 $row[0] 1 $row[1] 2 $row[2] \n "; +# $DataHash{$name}=shift(@row); +# } +# } +# -[R]- + + #--- Return Hash + return %DataHash; +} + + +#EMU --- $db->Error() +sub Error +{ + my $self= shift; + + if ($self->{'DBI_ERR'} ne '') + { + #--- Return error message + $self->{'DBI_ERRSTR'}; + } + + #-- else good no error message + +} + +# [R] provide compatibility with Win32::ODBC's Close() method. +sub Close +{ + my $self=shift; + + my $dbh=$self->{'DBI_DBH'}; + $dbh->disconnect; +} +# -[R]- + +1; + +__END__ + +# [R] to -[R]- indicate sections edited by me, Roy Lee + +=head1 NAME + +Win32::DBIODBC - Win32::ODBC emulation layer for the DBI + +=head1 SYNOPSIS + + use Win32::DBIODBC; # instead of use Win32::ODBC + +=head1 DESCRIPTION + +This is a I<very> basic I<very> alpha quality Win32::ODBC emulation +for the DBI. To use it just replace + + use Win32::ODBC; + +in your scripts with + + use Win32::DBIODBC; + +or, while experimenting, you can pre-load this module without changing your +scripts by doing + + perl -MWin32::DBIODBC your_script_name + +=head1 TO DO + +Error handling is virtually non-existent. + +=head1 AUTHOR + +Tom Horen <tho@melexis.com> + +=cut diff --git a/t/01basics.t b/t/01basics.t new file mode 100755 index 0000000..2c11f3c --- /dev/null +++ b/t/01basics.t @@ -0,0 +1,336 @@ +#!perl -w + +use strict; + +use Test::More tests => 130; +use File::Spec; + +$|=1; + +## ---------------------------------------------------------------------------- +## 01basic.t - test of some basic DBI functions +## ---------------------------------------------------------------------------- +# Mostly this script takes care of testing the items exported by the 3 +# tags below (in this order): +# - :sql_types +# - :squl_cursor_types +# - :util +# It also then handles some other class methods and functions of DBI, such +# as the following: +# - $DBI::dbi_debug & its relation to DBI->trace +# - DBI->internal +# and then tests on that return value: +# - $i->debug +# - $i->{DebugDispatch} +# - $i->{Warn} +# - $i->{Attribution} +# - $i->{Version} +# - $i->{private_test1} +# - $i->{cachedKids} +# - $i->{Kids} +# - $i->{ActiveKids} +# - $i->{Active} +# - and finally that it will not autovivify +# - DBI->available_drivers +# - DBI->installed_versions (only for developers) +## ---------------------------------------------------------------------------- + +## load DBI and export some symbols +BEGIN { + use_ok('DBI', qw( + :sql_types + :sql_cursor_types + :utils + )); +} + +## ---------------------------------------------------------------------------- +## testing the :sql_types exports + +cmp_ok(SQL_GUID , '==', -11, '... testing sql_type'); +cmp_ok(SQL_WLONGVARCHAR , '==', -10, '... testing sql_type'); +cmp_ok(SQL_WVARCHAR , '==', -9, '... testing sql_type'); +cmp_ok(SQL_WCHAR , '==', -8, '... testing sql_type'); +cmp_ok(SQL_BIT , '==', -7, '... testing sql_type'); +cmp_ok(SQL_TINYINT , '==', -6, '... testing sql_type'); +cmp_ok(SQL_BIGINT , '==', -5, '... testing sql_type'); +cmp_ok(SQL_LONGVARBINARY , '==', -4, '... testing sql_type'); +cmp_ok(SQL_VARBINARY , '==', -3, '... testing sql_type'); +cmp_ok(SQL_BINARY , '==', -2, '... testing sql_type'); +cmp_ok(SQL_LONGVARCHAR , '==', -1, '... testing sql_type'); +cmp_ok(SQL_UNKNOWN_TYPE , '==', 0, '... testing sql_type'); +cmp_ok(SQL_ALL_TYPES , '==', 0, '... testing sql_type'); +cmp_ok(SQL_CHAR , '==', 1, '... testing sql_type'); +cmp_ok(SQL_NUMERIC , '==', 2, '... testing sql_type'); +cmp_ok(SQL_DECIMAL , '==', 3, '... testing sql_type'); +cmp_ok(SQL_INTEGER , '==', 4, '... testing sql_type'); +cmp_ok(SQL_SMALLINT , '==', 5, '... testing sql_type'); +cmp_ok(SQL_FLOAT , '==', 6, '... testing sql_type'); +cmp_ok(SQL_REAL , '==', 7, '... testing sql_type'); +cmp_ok(SQL_DOUBLE , '==', 8, '... testing sql_type'); +cmp_ok(SQL_DATETIME , '==', 9, '... testing sql_type'); +cmp_ok(SQL_DATE , '==', 9, '... testing sql_type'); +cmp_ok(SQL_INTERVAL , '==', 10, '... testing sql_type'); +cmp_ok(SQL_TIME , '==', 10, '... testing sql_type'); +cmp_ok(SQL_TIMESTAMP , '==', 11, '... testing sql_type'); +cmp_ok(SQL_VARCHAR , '==', 12, '... testing sql_type'); +cmp_ok(SQL_BOOLEAN , '==', 16, '... testing sql_type'); +cmp_ok(SQL_UDT , '==', 17, '... testing sql_type'); +cmp_ok(SQL_UDT_LOCATOR , '==', 18, '... testing sql_type'); +cmp_ok(SQL_ROW , '==', 19, '... testing sql_type'); +cmp_ok(SQL_REF , '==', 20, '... testing sql_type'); +cmp_ok(SQL_BLOB , '==', 30, '... testing sql_type'); +cmp_ok(SQL_BLOB_LOCATOR , '==', 31, '... testing sql_type'); +cmp_ok(SQL_CLOB , '==', 40, '... testing sql_type'); +cmp_ok(SQL_CLOB_LOCATOR , '==', 41, '... testing sql_type'); +cmp_ok(SQL_ARRAY , '==', 50, '... testing sql_type'); +cmp_ok(SQL_ARRAY_LOCATOR , '==', 51, '... testing sql_type'); +cmp_ok(SQL_MULTISET , '==', 55, '... testing sql_type'); +cmp_ok(SQL_MULTISET_LOCATOR , '==', 56, '... testing sql_type'); +cmp_ok(SQL_TYPE_DATE , '==', 91, '... testing sql_type'); +cmp_ok(SQL_TYPE_TIME , '==', 92, '... testing sql_type'); +cmp_ok(SQL_TYPE_TIMESTAMP , '==', 93, '... testing sql_type'); +cmp_ok(SQL_TYPE_TIME_WITH_TIMEZONE , '==', 94, '... testing sql_type'); +cmp_ok(SQL_TYPE_TIMESTAMP_WITH_TIMEZONE , '==', 95, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_YEAR , '==', 101, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_MONTH , '==', 102, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_DAY , '==', 103, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_HOUR , '==', 104, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_MINUTE , '==', 105, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_SECOND , '==', 106, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_YEAR_TO_MONTH , '==', 107, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_DAY_TO_HOUR , '==', 108, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_DAY_TO_MINUTE , '==', 109, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_DAY_TO_SECOND , '==', 110, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_HOUR_TO_MINUTE , '==', 111, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_HOUR_TO_SECOND , '==', 112, '... testing sql_type'); +cmp_ok(SQL_INTERVAL_MINUTE_TO_SECOND , '==', 113, '... testing sql_type'); + +## ---------------------------------------------------------------------------- +## testing the :sql_cursor_types exports + +cmp_ok(SQL_CURSOR_FORWARD_ONLY, '==', 0, '... testing sql_cursor_types'); +cmp_ok(SQL_CURSOR_KEYSET_DRIVEN, '==', 1, '... testing sql_cursor_types'); +cmp_ok(SQL_CURSOR_DYNAMIC, '==', 2, '... testing sql_cursor_types'); +cmp_ok(SQL_CURSOR_STATIC, '==', 3, '... testing sql_cursor_types'); +cmp_ok(SQL_CURSOR_TYPE_DEFAULT, '==', 0, '... testing sql_cursor_types'); + +## ---------------------------------------------------------------------------- +## test the :util exports + +## testing looks_like_number + +my @is_num = looks_like_number(undef, "", "foo", 1, ".", 2, "2"); + +ok(!defined $is_num[0], '... looks_like_number : undef -> undef'); +ok(!defined $is_num[1], '... looks_like_number : "" -> undef (eg "don\'t know")'); +ok( defined $is_num[2], '... looks_like_number : "foo" -> defined false'); +ok( !$is_num[2], '... looks_like_number : "foo" -> defined false'); +ok( $is_num[3], '... looks_like_number : 1 -> true'); +ok( !$is_num[4], '... looks_like_number : "." -> false'); +ok( $is_num[5], '... looks_like_number : 1 -> true'); +ok( $is_num[6], '... looks_like_number : 1 -> true'); + +## testing neat + +cmp_ok($DBI::neat_maxlen, '==', 1000, "... $DBI::neat_maxlen initial state is 400"); + +is(neat(1 + 1), "2", '... neat : 1 + 1 -> "2"'); +is(neat("2"), "'2'", '... neat : 2 -> "\'2\'"'); +is(neat(undef), "undef", '... neat : undef -> "undef"'); + +## testing neat_list + +is(neat_list([ 1 + 1, "2", undef, "foobarbaz"], 8, "|"), "2|'2'|undef|'foo...'", '... test array argument w/seperator and maxlen'); +is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out seperator or maxlen'); + + +## ---------------------------------------------------------------------------- +## testing DBI functions + +## test DBI->internal + +my $switch = DBI->internal; + +isa_ok($switch, 'DBI::dr'); + +## checking attributes of $switch + +# NOTE: +# check too see if this covers all the attributes or not + +# TO DO: +# these three can be improved +$switch->debug(0); +pass('... test debug'); +$switch->{DebugDispatch} = 0; # handled by Switch +pass('... test DebugDispatch'); +$switch->{Warn} = 1; # handled by DBI core +pass('... test Warn'); + +like($switch->{'Attribution'}, qr/DBI.*? by Tim Bunce/, '... this should say Tim Bunce'); + +# is this being presumptious? +is($switch->{'Version'}, $DBI::VERSION, '... the version should match DBI version'); + +cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and return 1'); +cmp_ok($switch->{private_test1}, '==', 1, '... this should equal 1'); + +is($switch->{CachedKids}, undef, '... CachedKids should be undef initially'); +my $cache = {}; +$switch->{CachedKids} = $cache; +is($switch->{CachedKids}, $cache, '... CachedKids should be our ref'); + +cmp_ok($switch->{Kids}, '==', 0, '... this should be zero'); +cmp_ok($switch->{ActiveKids}, '==', 0, '... this should be zero'); + +ok($switch->{Active}, '... Active flag is true'); + +# test attribute warnings +{ + my $warn = ""; + local $SIG{__WARN__} = sub { $warn .= "@_" }; + $switch->{FooBarUnknown} = 1; + like($warn, qr/Can't set.*FooBarUnknown/, '... we should get a warning here'); + + $warn = ""; + $_ = $switch->{BarFooUnknown}; + like($warn, qr/Can't get.*BarFooUnknown/, '... we should get a warning here'); + + $warn = ""; + my $dummy = $switch->{$_} for qw(private_foo dbd_foo dbi_foo); # special cases + cmp_ok($warn, 'eq', "", '... we should get no warnings here'); +} + +# is this here for a reason? Are we testing anything? + +$switch->trace_msg("Test \$h->trace_msg text.\n", 1); +DBI->trace_msg("Test DBI->trace_msg text.\n", 1); + +## testing DBI->available_drivers + +my @drivers = DBI->available_drivers(); +cmp_ok(scalar(@drivers), '>', 0, '... we at least have one driver installed'); + +# NOTE: +# we lowercase the interpolated @drivers array +# so that our reg-exp will match on VMS & Win32 + +like(lc("@drivers"), qr/examplep/, '... we should at least have ExampleP installed'); + +# call available_drivers in scalar context + +my $num_drivers = DBI->available_drivers; +cmp_ok($num_drivers, '>', 0, '... we should at least have one driver'); + +## testing DBI::hash + +cmp_ok(DBI::hash("foo1" ), '==', -1077531989, '... should be -1077531989'); +cmp_ok(DBI::hash("foo1",0), '==', -1077531989, '... should be -1077531989'); +cmp_ok(DBI::hash("foo2",0), '==', -1077531990, '... should be -1077531990'); +SKIP: { + skip("Math::BigInt < 1.56",2) + if $DBI::PurePerl && !eval { require Math::BigInt; require_version Math::BigInt 1.56 }; + skip("Math::BigInt $Math::BigInt::VERSION broken",2) + if $DBI::PurePerl && $Math::BigInt::VERSION =~ /^1\.8[45]/; + my $bigint_vers = $Math::BigInt::VERSION || ""; + if (!$DBI::PurePerl) { + cmp_ok(DBI::hash("foo1",1), '==', -1263462440); + cmp_ok(DBI::hash("foo2",1), '==', -1263462437); + } + else { + # for PurePerl we use Math::BigInt but that's often caused test failures that + # aren't DBI's fault. So we just warn (via a skip) if it's not working right. + skip("Seems like your Math::BigInt $Math::BigInt::VERSION has a bug",2) + unless (DBI::hash("foo1X",1) == -1263462440) && (DBI::hash("foo2",1) == -1263462437); + ok(1, "Math::BigInt $Math::BigInt::VERSION worked okay"); + ok(1); + } +} + +is(data_string_desc(""), "UTF8 off, ASCII, 0 characters 0 bytes"); +is(data_string_desc(42), "UTF8 off, ASCII, 2 characters 2 bytes"); +is(data_string_desc("foo"), "UTF8 off, ASCII, 3 characters 3 bytes"); +is(data_string_desc(undef), "UTF8 off, undef"); +is(data_string_desc("bar\x{263a}"), "UTF8 on, non-ASCII, 4 characters 6 bytes"); +is(data_string_desc("\xEA"), "UTF8 off, non-ASCII, 1 characters 1 bytes"); + +is(data_string_diff( "", ""), ""); +is(data_string_diff( "",undef), "String b is undef, string a has 0 characters"); +is(data_string_diff(undef,undef), ""); +is(data_string_diff("aaa","aaa"), ""); + +is(data_string_diff("aaa","aba"), "Strings differ at index 1: a[1]=a, b[1]=b"); +is(data_string_diff("aba","aaa"), "Strings differ at index 1: a[1]=b, b[1]=a"); +is(data_string_diff("aa" ,"aaa"), "String a truncated after 2 characters"); +is(data_string_diff("aaa","aa" ), "String b truncated after 2 characters"); + +is(data_diff( "", ""), ""); +is(data_diff(undef,undef), ""); +is(data_diff("aaa","aaa"), ""); + +is(data_diff( "",undef), + join "","a: UTF8 off, ASCII, 0 characters 0 bytes\n", + "b: UTF8 off, undef\n", + "String b is undef, string a has 0 characters\n"); +is(data_diff("aaa","aba"), + join "","a: UTF8 off, ASCII, 3 characters 3 bytes\n", + "b: UTF8 off, ASCII, 3 characters 3 bytes\n", + "Strings differ at index 1: a[1]=a, b[1]=b\n"); +is(data_diff(pack("C",0xEA), pack("U",0xEA)), + join "", "a: UTF8 off, non-ASCII, 1 characters 1 bytes\n", + "b: UTF8 on, non-ASCII, 1 characters 2 bytes\n", + "Strings contain the same sequence of characters\n"); +is(data_diff(pack("C",0xEA), pack("U",0xEA), 1), ""); # no logical difference + + +## ---------------------------------------------------------------------------- +# restrict this test to just developers + +SKIP: { + skip 'developer tests', 4 unless -d ".svn" || -d ".git"; + + if ($^O eq "MSWin32" && eval { require Win32API::File }) { + Win32API::File::SetErrorMode(Win32API::File::SEM_FAILCRITICALERRORS()); + } + + print "Test DBI->installed_versions (for @drivers)\n"; + print "(If one of those drivers, or the configuration for it, is bad\n"; + print "then these tests can kill or freeze the process here. That's not the DBI's fault.)\n"; + $SIG{ALRM} = sub { + die "Test aborted because a driver (one of: @drivers) hung while loading" + ." (almost certainly NOT a DBI problem)"; + }; + alarm(20); + + ## ---------------------------------------------------------------------------- + ## test installed_versions + + # scalar context + my $installed_versions = DBI->installed_versions; + + is(ref($installed_versions), 'HASH', '... we got a hash of installed versions'); + cmp_ok(scalar(keys(%{$installed_versions})), '>=', 1, '... make sure we have at least one'); + + # list context + my @installed_drivers = DBI->installed_versions; + + cmp_ok(scalar(@installed_drivers), '>=', 1, '... make sure we got at least one'); + like("@installed_drivers", qr/Sponge/, '... make sure at least one of them is DBD::Sponge'); +} + +## testing dbi_debug + +cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug's initial state is 0"); + +SKIP: { + my $null = File::Spec->devnull(); + skip "cannot find : $null", 2 unless ($^O eq "MSWin32" || -e $null); + + DBI->trace(15,$null); + cmp_ok($DBI::dbi_debug, '==', 15, "... DBI::dbi_debug is 15"); + DBI->trace(0, undef); + cmp_ok($DBI::dbi_debug, '==', 0, "... DBI::dbi_debug is 0"); +} + +1; diff --git a/t/02dbidrv.t b/t/02dbidrv.t new file mode 100755 index 0000000..7a80ffe --- /dev/null +++ b/t/02dbidrv.t @@ -0,0 +1,254 @@ +#!perl -w +# vim:sw=4:ts=8:et +$|=1; + +use strict; + +use Test::More tests => 53; + +## ---------------------------------------------------------------------------- +## 02dbidrv.t - ... +## ---------------------------------------------------------------------------- +# This test creates a Test Driver (DBD::Test) and then exercises it. +# NOTE: +# There are a number of tests as well that are embedded within the actual +# driver code as well +## ---------------------------------------------------------------------------- + +## load DBI + +BEGIN { + use_ok('DBI'); +} + +## ---------------------------------------------------------------------------- +## create a Test Driver (DBD::Test) + +## main Test Driver Package +{ + package DBD::Test; + + use strict; + use warnings; + + my $drh = undef; + + sub driver { + return $drh if $drh; + + Test::More::pass('... DBD::Test->driver called to getnew Driver handle'); + + my($class, $attr) = @_; + $class = "${class}::dr"; + ($drh) = DBI::_new_drh($class, { + Name => 'Test', + Version => '$Revision: 11.11 $', + }, + 77 # 'implementors data' + ); + + Test::More::ok($drh, "... new Driver handle ($drh) created successfully"); + Test::More::isa_ok($drh, 'DBI::dr'); + + return $drh; + } +} + +## Test Driver +{ + package DBD::Test::dr; + + use strict; + use warnings; + + $DBD::Test::dr::imp_data_size = 0; + + Test::More::cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo'); + + sub DESTROY { undef } + + sub data_sources { + my ($h) = @_; + + Test::More::ok($h, '... Driver object passed to data_sources'); + Test::More::isa_ok($h, 'DBI::dr'); + Test::More::ok(!tied $h, '... Driver object is not tied'); + + return ("dbi:Test:foo", "dbi:Test:bar"); + } +} + +## Test db package +{ + package DBD::Test::db; + + use strict; + + $DBD::Test::db::imp_data_size = 0; + + Test::More::cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo'); + + sub do { + my $h = shift; + + Test::More::ok($h, '... Database object passed to do'); + Test::More::isa_ok($h, 'DBI::db'); + Test::More::ok(!tied $h, '... Database object is not tied'); + + my $drh_i = $h->{Driver}; + + Test::More::ok($drh_i, '... got Driver object from Database object with Driver attribute'); + Test::More::isa_ok($drh_i, "DBI::dr"); + Test::More::ok(!tied %{$drh_i}, '... Driver object is not tied'); + + my $drh_o = $h->FETCH('Driver'); + + Test::More::ok($drh_o, '... got Driver object from Database object by FETCH-ing Driver attribute'); + Test::More::isa_ok($drh_o, "DBI::dr"); + SKIP: { + Test::More::skip "running DBI::PurePerl", 1 if $DBI::PurePerl; + Test::More::ok(tied %{$drh_o}, '... Driver object is not tied'); + } + + # return this to make our test pass + return 1; + } + + sub data_sources { + my ($dbh, $attr) = @_; + my @ds = $dbh->SUPER::data_sources($attr); + + Test::More::is_deeply(( + \@ds, + [ 'dbi:Test:foo', 'dbi:Test:bar' ] + ), + '... checking fetched datasources from Driver' + ); + + push @ds, "dbi:Test:baz"; + return @ds; + } + + sub disconnect { + shift->STORE(Active => 0); + } +} + +## ---------------------------------------------------------------------------- +## test the Driver (DBD::Test) + +$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver() + +# Note that install_driver should *not* normally be called directly. +# This test does so only because it's a test of install_driver! + +my $drh = DBI->install_driver('Test'); + +ok($drh, '... got a Test Driver object back from DBI->install_driver'); +isa_ok($drh, 'DBI::dr'); + +cmp_ok(DBI::_get_imp_data($drh), '==', 77, '... checking the DBI::_get_imp_data function'); + +my @ds1 = DBI->data_sources("Test"); +is_deeply(( + [ @ds1 ], + [ 'dbi:Test:foo', 'dbi:Test:bar' ] + ), '... got correct datasources from DBI->data_sources("Test")' +); + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids'); +} + +# create scope to test $dbh DESTROY behaviour +do { + + my $dbh = $drh->connect; + + ok($dbh, '... got a database handle from calling $drh->connect'); + isa_ok($dbh, 'DBI::db'); + + SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 1, '... this Driver does not yet have any Kids'); + } + + my @ds2 = $dbh->data_sources(); + is_deeply(( + [ @ds2 ], + [ 'dbi:Test:foo', 'dbi:Test:bar', 'dbi:Test:baz' ] + ), '... got correct datasources from $dbh->data_sources()' + ); + + ok($dbh->do('dummy'), '... this will trigger more driver internal tests above in DBD::Test::db'); + + $dbh->disconnect; + + $drh->set_err("41", "foo 41 drh"); + cmp_ok($drh->err, '==', 41, '... checking Driver handle err set with set_err method'); + $dbh->set_err("42", "foo 42 dbh"); + cmp_ok($dbh->err, '==', 42, '... checking Database handle err set with set_err method'); + cmp_ok($drh->err, '==', 41, '... checking Database handle err set with Driver handle set_err method'); + +}; + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids') + or $drh->dump_handle("bad Kids",3); +} + +# copied up to drh from dbh when dbh was DESTROYd +cmp_ok($drh->err, '==', 42, '... $dbh->DESTROY should set $drh->err to 42'); + +$drh->set_err("99", "foo"); +cmp_ok($DBI::err, '==', 99, '... checking $DBI::err set with Driver handle set_err method'); +is($DBI::errstr, "foo 42 dbh [err was 42 now 99]\nfoo", '... checking $DBI::errstr'); + +$drh->default_user("",""); # just to reset err etc +$drh->set_err(1, "errmsg", "00000"); +is($DBI::state, "", '... checking $DBI::state'); + +$drh->set_err(1, "test error 1"); +is($DBI::state, 'S1000', '... checking $DBI::state'); + +$drh->set_err(2, "test error 2", "IM999"); +is($DBI::state, 'IM999', '... checking $DBI::state'); + +SKIP: { + skip "using DBI::PurePerl", 1 if $DBI::PurePerl; + eval { + $DBI::rows = 1 + }; + like($@, qr/Can't modify/, '... trying to assign to $DBI::rows should throw an excpetion'); #' +} + +is($drh->{FetchHashKeyName}, 'NAME', '... FetchHashKeyName is NAME'); +$drh->{FetchHashKeyName} = 'NAME_lc'; +is($drh->{FetchHashKeyName}, 'NAME_lc', '... FetchHashKeyName is now changed to NAME_lc'); + +ok(!$drh->disconnect_all, '... calling $drh->disconnect_all (not implemented but will fail silently)'); + +ok defined $drh->dbixs_revision, 'has dbixs_revision'; +ok($drh->dbixs_revision =~ m/^\d+$/, 'has integer dbixs_revision'); + +SKIP: { + skip "using DBI::PurePerl", 5 if $DBI::PurePerl; + my $can = $drh->can('FETCH'); + + ok($can, '... $drh can FETCH'); + is(ref($can), "CODE", '... and it returned a proper CODE ref'); + + my $name = $can->($drh, "Name"); + + ok($name, '... used FETCH returned from can to fetch the Name attribute'); + is($name, "Test", '... the Name attribute is equal to Test'); + + ok(!$drh->can('disconnect_all'), '... '); +} + +1; diff --git a/t/03handle.t b/t/03handle.t new file mode 100644 index 0000000..7440ad0 --- /dev/null +++ b/t/03handle.t @@ -0,0 +1,410 @@ +#!perl -w +$|=1; + +use strict; + +use Test::More tests => 137; + +## ---------------------------------------------------------------------------- +## 03handle.t - tests handles +## ---------------------------------------------------------------------------- +# This set of tests exercises the different handles; Driver, Database and +# Statement in various ways, in particular in their interactions with one +# another +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok( 'DBI' ); +} + +# installed drivers should start empty +my %drivers = DBI->installed_drivers(); +is(scalar keys %drivers, 0); + +## ---------------------------------------------------------------------------- +# get the Driver handle + +my $driver = "ExampleP"; + +my $drh = DBI->install_driver($driver); +isa_ok( $drh, 'DBI::dr' ); + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids'); +} + +# now the driver should be registered +%drivers = DBI->installed_drivers(); +is(scalar keys %drivers, 1); +ok(exists $drivers{ExampleP}); +ok($drivers{ExampleP}->isa('DBI::dr')); + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; + +## ---------------------------------------------------------------------------- +# do database handle tests inside do BLOCK to capture scope + +do { + my $dbh = DBI->connect("dbi:$driver:", '', ''); + isa_ok($dbh, 'DBI::db'); + + my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer + + SKIP: { + skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid'); + cmp_ok($drh->{ActiveKids}, '==', 1, '... our Driver has one ActiveKid'); + } + + my $sql = "select name from ?"; + + my $sth1 = $dbh->prepare_cached($sql); + isa_ok($sth1, 'DBI::st'); + ok($sth1->execute("."), '... execute ran successfully'); + + my $ck = $dbh->{CachedKids}; + is(ref($ck), "HASH", '... we got the CachedKids hash'); + + cmp_ok(scalar(keys(%{$ck})), '==', 1, '... there is one CachedKid'); + ok(eq_set( + [ values %{$ck} ], + [ $sth1 ] + ), + '... our statment handle should be in the CachedKids'); + + ok($sth1->{Active}, '... our first statment is Active'); + + { + my $warn = 0; # use this to check that we are warned + local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/i }; + + my $sth2 = $dbh->prepare_cached($sql); + isa_ok($sth2, 'DBI::st'); + + is($sth1, $sth2, '... prepare_cached returned the same statement handle'); + cmp_ok($warn,'==', 1, '... we got warned about our first statement handle being still active'); + + ok(!$sth1->{Active}, '... our first statment is no longer Active since we re-prepared it'); + + my $sth3 = $dbh->prepare_cached($sql, { foo => 1 }); + isa_ok($sth3, 'DBI::st'); + + isnt($sth1, $sth3, '... prepare_cached returned a different statement handle now'); + cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); + ok(eq_set( + [ values %{$ck} ], + [ $sth1, $sth3 ] + ), + '... both statment handles should be in the CachedKids'); + + ok($sth1->execute("."), '... executing first statement handle again'); + ok($sth1->{Active}, '... first statement handle is now active again'); + + my $sth4 = $dbh->prepare_cached($sql, undef, 3); + isa_ok($sth4, 'DBI::st'); + + isnt($sth1, $sth4, '... our fourth statement handle is not the same as our first'); + ok($sth1->{Active}, '... first statement handle is still active'); + + cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); + ok(eq_set( + [ values %{$ck} ], + [ $sth2, $sth4 ] + ), + '... second and fourth statment handles should be in the CachedKids'); + + $sth1->finish; + ok(!$sth1->{Active}, '... first statement handle is no longer active'); + + ok($sth4->execute("."), '... fourth statement handle executed properly'); + ok($sth4->{Active}, '... fourth statement handle is Active'); + + my $sth5 = $dbh->prepare_cached($sql, undef, 1); + isa_ok($sth5, 'DBI::st'); + + cmp_ok($warn, '==', 1, '... we still only got one warning'); + + is($sth4, $sth5, '... fourth statement handle and fifth one match'); + ok(!$sth4->{Active}, '... fourth statement handle is not Active'); + ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be its the same as fifth)'); + + cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids'); + ok(eq_set( + [ values %{$ck} ], + [ $sth2, $sth5 ] + ), + '... second and fourth/fifth statment handles should be in the CachedKids'); + } + + SKIP: { + skip "swap_inner_handle() not supported under DBI::PurePerl", 23 if $DBI::PurePerl; + + my $sth6 = $dbh->prepare($sql); + $sth6->execute("."); + my $sth1_driver_name = $sth1->{Database}{Driver}{Name}; + + ok( $sth6->{Active}, '... sixth statement handle is active'); + ok(!$sth1->{Active}, '... first statement handle is not active'); + + ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); + ok(!$sth6->{Active}, '... sixth statement handle is now not active'); + ok( $sth1->{Active}, '... first statement handle is now active again'); + + ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); + ok( $sth6->{Active}, '... sixth statement handle is active'); + ok(!$sth1->{Active}, '... first statement handle is not active'); + + ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); + ok(!$sth6->{Active}, '... sixth statement handle is now not active'); + ok( $sth1->{Active}, '... first statement handle is now active again'); + + $sth1->{PrintError} = 0; + ok(!$sth1->swap_inner_handle($dbh), '... can not swap a sth with a dbh'); + cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle between sth and dbh"); + + ok($sth1->swap_inner_handle($sth6), '... first statement handle becomes the sixth'); + ok( $sth6->{Active}, '... sixth statement handle is active'); + ok(!$sth1->{Active}, '... first statement handle is not active'); + + $sth6->finish; + + ok(my $dbh_nullp = DBI->connect("dbi:NullP:", undef, undef, { go_bypass => 1 })); + ok(my $sth7 = $dbh_nullp->prepare("")); + + $sth1->{PrintError} = 0; + ok(!$sth1->swap_inner_handle($sth7), "... can't swap_inner_handle with handle from different parent"); + cmp_ok( $sth1->errstr, 'eq', "Can't swap_inner_handle with handle from different parent"); + + cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', $sth1_driver_name ); + ok( $sth1->swap_inner_handle($sth7,1), "... can swap to different parent if forced"); + cmp_ok( $sth1->{Database}{Driver}{Name}, 'eq', "NullP" ); + + $dbh_nullp->disconnect; + } + + ok( $dbh->ping, 'ping should be true before disconnect'); + $dbh->disconnect; + $dbh->{PrintError} = 0; # silence 'not connected' warning + ok( !$dbh->ping, 'ping should be false after disconnect'); + + SKIP: { + skip "Kids and ActiveKids attributes not supported under DBI::PurePerl", 2 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 1, '... our Driver has one Kid after disconnect'); + cmp_ok($drh->{ActiveKids}, '==', 0, '... our Driver has no ActiveKids after disconnect'); + } + +}; + +if ($using_dbd_gofer) { + $drh->{CachedKids} = {}; +} + +# make sure our driver has no more kids after this test +# NOTE: +# this also assures us that the next test has an empty slate as well +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, "... our $drh->{Name} driver should have 0 Kids after dbh was destoryed"); +} + +## ---------------------------------------------------------------------------- +# handle reference leak tests + +# NOTE: +# this test checks for reference leaks by testing the Kids attribute +# which is not supported by DBI::PurePerl, so we just do not run this +# for DBI::PurePerl all together. Even though some of the tests would +# pass, it does not make sense becuase in the end, what is actually +# being tested for will give a false positive + +sub work { + my (%args) = @_; + my $dbh = DBI->connect("dbi:$driver:", '', ''); + isa_ok( $dbh, 'DBI::db' ); + + cmp_ok($drh->{Kids}, '==', 1, '... the Driver should have 1 Kid(s) now'); + + if ( $args{Driver} ) { + isa_ok( $dbh->{Driver}, 'DBI::dr' ); + } else { + pass( "not testing Driver here" ); + } + + my $sth = $dbh->prepare_cached("select name from ?"); + isa_ok( $sth, 'DBI::st' ); + + if ( $args{Database} ) { + isa_ok( $sth->{Database}, 'DBI::db' ); + } else { + pass( "not testing Database here" ); + } + + $dbh->disconnect; + # both handles should be freed here +} + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 25 if $DBI::PurePerl; + skip "drh Kids not testable under DBD::Gofer", 25 if $using_dbd_gofer; + + foreach my $args ( + {}, + { Driver => 1 }, + { Database => 1 }, + { Driver => 1, Database => 1 }, + ) { + work( %{$args} ); + cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids'); + } + + # make sure we have no kids when we end this + cmp_ok($drh->{Kids}, '==', 0, '... the Driver should have no Kids at the end of this test'); +} + +## ---------------------------------------------------------------------------- +# handle take_imp_data test + +SKIP: { + skip "take_imp_data test not supported under DBD::Gofer", 19 if $using_dbd_gofer; + + my $dbh = DBI->connect("dbi:$driver:", '', ''); + isa_ok($dbh, "DBI::db"); + my $drh = $dbh->{Driver}; # (re)get drh here so tests can work using_dbd_gofer + + cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here') + unless $DBI::PurePerl && pass(); + + $dbh->prepare("select name from ?"); # destroyed at once + my $sth2 = $dbh->prepare("select name from ?"); # inactive + my $sth3 = $dbh->prepare("select name from ?"); # active: + $sth3->execute("."); + is $sth3->{Active}, 1; + is $dbh->{ActiveKids}, 1 + unless $DBI::PurePerl && pass(); + + my $ChildHandles = $dbh->{ChildHandles}; + + skip "take_imp_data test needs weakrefs", 15 if not $ChildHandles; + + ok $ChildHandles, 'we need weakrefs for take_imp_data to work safely with child handles'; + is @$ChildHandles, 3, 'should have 3 entries (implementation detail)'; + is grep({ defined } @$ChildHandles), 2, 'should have 2 defined handles'; + + my $imp_data = $dbh->take_imp_data; + ok($imp_data, '... we got some imp_data to test'); + # generally length($imp_data) = 112 for 32bit, 116 for 64 bit + # (as of DBI 1.37) but it can differ on some platforms + # depending on structure packing by the compiler + # so we just test that it's something reasonable: + cmp_ok(length($imp_data), '>=', 80, '... test that our imp_data is greater than or equal to 80, this is reasonable'); + + cmp_ok($drh->{Kids}, '==', 0, '... our Driver should have 0 Kid(s) after calling take_imp_data'); + + is ref $sth3, 'DBI::zombie', 'sth should be reblessed'; + eval { $sth3->finish }; + like $@, qr/Can't locate object method/; + + { + my @warn; + local $SIG{__WARN__} = sub { push @warn, $_[0] if $_[0] =~ /after take_imp_data/; print "warn: @_\n"; }; + + my $drh = $dbh->{Driver}; + ok(!defined $drh, '... our Driver should be undefined'); + + my $trace_level = $dbh->{TraceLevel}; + ok(!defined $trace_level, '... our TraceLevel should be undefined'); + + ok(!defined $dbh->disconnect, '... disconnect should return undef'); + + ok(!defined $dbh->quote(42), '... quote should return undefined'); + + cmp_ok(scalar @warn, '==', 4, '... we should have gotten 4 warnings'); + } + + my $dbh2 = DBI->connect("dbi:$driver:", '', '', { dbi_imp_data => $imp_data }); + isa_ok($dbh2, "DBI::db"); + # need a way to test dbi_imp_data has been used + + cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) again') + unless $DBI::PurePerl && pass(); + +} + +# we need this SKIP block on its own since we are testing the +# destruction of objects within the scope of the above SKIP +# block +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... our Driver has no Kids after this test'); +} + +## ---------------------------------------------------------------------------- +# NullP statement handle attributes without execute + +my $driver2 = "NullP"; + +my $drh2 = DBI->install_driver($driver); +isa_ok( $drh2, 'DBI::dr' ); + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids before this test'); +} + +do { + my $dbh = DBI->connect("dbi:$driver2:", '', ''); + isa_ok($dbh, "DBI::db"); + + my $sth = $dbh->prepare("foo bar"); + isa_ok($sth, "DBI::st"); + + cmp_ok($sth->{NUM_OF_PARAMS}, '==', 0, '... NUM_OF_PARAMS is 0'); + is($sth->{NUM_OF_FIELDS}, undef, '... NUM_OF_FIELDS should be undef'); + is($sth->{Statement}, "foo bar", '... Statement is "foo bar"'); + + ok(!defined $sth->{NAME}, '... NAME is undefined'); + ok(!defined $sth->{TYPE}, '... TYPE is undefined'); + ok(!defined $sth->{SCALE}, '... SCALE is undefined'); + ok(!defined $sth->{PRECISION}, '... PRECISION is undefined'); + ok(!defined $sth->{NULLABLE}, '... NULLABLE is undefined'); + ok(!defined $sth->{RowsInCache}, '... RowsInCache is undefined'); + ok(!defined $sth->{ParamValues}, '... ParamValues is undefined'); + # derived NAME attributes + ok(!defined $sth->{NAME_uc}, '... NAME_uc is undefined'); + ok(!defined $sth->{NAME_lc}, '... NAME_lc is undefined'); + ok(!defined $sth->{NAME_hash}, '... NAME_hash is undefined'); + ok(!defined $sth->{NAME_uc_hash}, '... NAME_uc_hash is undefined'); + ok(!defined $sth->{NAME_lc_hash}, '... NAME_lc_hash is undefined'); + + my $dbh_ref = ref($dbh); + my $sth_ref = ref($sth); + + ok($dbh_ref->can("prepare"), '... $dbh can call "prepare"'); + ok(!$dbh_ref->can("nonesuch"), '... $dbh cannot call "nonesuch"'); + ok($sth_ref->can("execute"), '... $sth can call "execute"'); + + # what is this test for?? + + # I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't: + # Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot to load "DBI::db"?) + eval { ref($dbh)->nonesuch; }; + + $dbh->disconnect; +}; + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh2->{Kids}, '==', 0, '... our Driver (2) has no Kids after this test'); +} + +## ---------------------------------------------------------------------------- + +1; diff --git a/t/04mods.t b/t/04mods.t new file mode 100644 index 0000000..97638d0 --- /dev/null +++ b/t/04mods.t @@ -0,0 +1,59 @@ +#!perl -w +$|=1; + +use strict; + +use Test::More tests => 12; + +## ---------------------------------------------------------------------------- +## 04mods.t - ... +## ---------------------------------------------------------------------------- +# Note: +# the modules tested here are all marked as new and not guaranteed, so this if +# they change, these will fail. +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok( 'DBI' ); + + # load these first, since the other two load them + # and we want to catch the error first + use_ok( 'DBI::Const::GetInfo::ANSI' ); + use_ok( 'DBI::Const::GetInfo::ODBC' ); + + use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) ); + use_ok( 'DBI::Const::GetInfoReturn', qw(%GetInfoReturnTypes %GetInfoReturnValues) ); +} + +## test GetInfoType + +cmp_ok(scalar(keys(%GetInfoType)), '>', 1, '... we have at least one key in the GetInfoType hash'); + +is_deeply( + \%GetInfoType, + { %DBI::Const::GetInfo::ANSI::InfoTypes, %DBI::Const::GetInfo::ODBC::InfoTypes }, + '... the GetInfoType hash is constructed from the ANSI and ODBC hashes' + ); + +## test GetInfoReturnTypes + +cmp_ok(scalar(keys(%GetInfoReturnTypes)), '>', 1, '... we have at least one key in the GetInfoReturnType hash'); + +is_deeply( + \%GetInfoReturnTypes, + { %DBI::Const::GetInfo::ANSI::ReturnTypes, %DBI::Const::GetInfo::ODBC::ReturnTypes }, + '... the GetInfoReturnType hash is constructed from the ANSI and ODBC hashes' + ); + +## test GetInfoReturnValues + +cmp_ok(scalar(keys(%GetInfoReturnValues)), '>', 1, '... we have at least one key in the GetInfoReturnValues hash'); + +# ... testing GetInfoReturnValues any further would be difficult + +## test the two methods found in DBI::Const::GetInfoReturn + +can_ok('DBI::Const::GetInfoReturn', 'Format'); +can_ok('DBI::Const::GetInfoReturn', 'Explain'); + +1; diff --git a/t/05concathash.t b/t/05concathash.t new file mode 100644 index 0000000..554fc34 --- /dev/null +++ b/t/05concathash.t @@ -0,0 +1,190 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl CatHash.t' + +######################### + +# change 'tests => 1' to 'tests => last_test_to_print'; + +use strict; +use Benchmark qw(:all); +use Scalar::Util qw(looks_like_number); +no warnings 'uninitialized'; + +use Test::More tests => 41; + +BEGIN { use_ok('DBI') }; + +# null and undefs -- segfaults?; +is (DBI::_concat_hash_sorted(undef, "=", ":", 0, undef), undef); +is (DBI::_concat_hash_sorted({ }, "=", ":", 0, undef), ""); +eval { DBI::_concat_hash_sorted([], "=", ":", 0, undef) }; +like ($@ || "", qr/is not a hash reference/); +is (DBI::_concat_hash_sorted({ }, undef, ":", 0, undef), ""); +is (DBI::_concat_hash_sorted({ }, "=", undef, 0, undef), ""); +is (DBI::_concat_hash_sorted({ }, "=", ":", undef, undef),""); + +# simple cases +is (DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=", ", ", undef, undef), "1='a', 2='b'"); +# nul byte in key sep and pair sep +# (nul byte in hash not supported) +is DBI::_concat_hash_sorted({ 1=>"a", 2=>"b" }, "=\000=", ":\000:", undef, undef), + "1=\000='a':\000:2=\000='b'", 'should work with nul bytes in kv_sep and pair_sep'; +is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 1, undef), + "1='a.a':2='b'", 'should work with nul bytes in hash value (neat)'; +is DBI::_concat_hash_sorted({ 1=>"a\000a", 2=>"b" }, "=", ":", 0, undef), + "1='a\000a':2='b'", 'should work with nul bytes in hash value (not neat)'; + +# Simple stress tests +# limit stress when performing automated testing +# eg http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4374116.html +my $stress = $ENV{AUTOMATED_TESTING} ? 1_000 : 10_000; +ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "="x$stress, ":", 1, undef)); +ok(DBI::_concat_hash_sorted({bob=>'two', fred=>'one' }, "=", ":"x$stress, 1, undef)); +ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "="x$stress, ":", 1, undef)); +ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..1000)}, "=", ":"x$stress, 1, undef), 'test'); +ok(DBI::_concat_hash_sorted({map {$_=>undef} (1..100)}, "="x$stress, ":"x$stress, 1, undef), 'test'); + +my $simple_hash = { + bob=>"there", + jack=>12, + fred=>"there", + norman=>"there", + # sam =>undef +}; + +my $simple_numeric = { + 1=>"there", + 2=>"there", + 16 => 'yo', + 07 => "buddy", + 49 => undef, +}; + +my $simple_mixed = { + bob=>"there", + jack=>12, + fred=>"there", + sam =>undef, + 1=>"there", + 32=>"there", + 16 => 'yo', + 07 => "buddy", + 49 => undef, +}; + +my $simple_float = { + 1.12 =>"there", + 3.1415926 =>"there", + 32=>"there", + 1.6 => 'yo', + 0.78 => "buddy", + 49 => undef, +}; + +#eval { +# DBI::_concat_hash_sorted($simple_hash, "=",,":",1,12); +#}; +ok(1," Unknown sort order"); +#like ($@, qr/Unknown sort order/, "Unknown sort order"); + + + +## Loopify and Add Neat + + +my %neats = ( + "Neat"=>0, + "Not Neat"=> 1 +); +my %sort_types = ( + guess=>undef, + numeric => 1, + lexical=> 0 +); +my %hashes = ( + Numeric=>$simple_numeric, + "Simple Hash" => $simple_hash, + "Mixed Hash" => $simple_mixed, + "Float Hash" => $simple_float +); + +for my $sort_type (keys %sort_types){ + for my $neat (keys %neats) { + for my $hash (keys %hashes) { + test_concat_hash($hash, $neat, $sort_type); + } + } +} + +sub test_concat_hash { + my ($hash, $neat, $sort_type) = @_; + my @args = ($hashes{$hash}, "=", ":",$neats{$neat}, $sort_types{$sort_type}); + is ( + DBI::_concat_hash_sorted(@args), + _concat_hash_sorted(@args), + "$hash - $neat $sort_type" + ); +} + +if (0) { + eval { + cmpthese(200_000, { + Perl => sub {_concat_hash_sorted($simple_hash, "=", ":",0,undef); }, + C=> sub {DBI::_concat_hash_sorted($simple_hash, "=", ":",0,1);} + }); + + print "\n"; + cmpthese(200_000, { + NotNeat => sub {DBI::_concat_hash_sorted( + $simple_hash, "=", ":",1,undef); + }, + Neat => sub {DBI::_concat_hash_sorted( + $simple_hash, "=", ":",0,undef); + } + }); + }; +} +#CatHash::_concat_hash_values({ }, ":-",,"::",1,1); + + +sub _concat_hash_sorted { + my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; + # $num_sort: 0=lexical, 1=numeric, undef=try to guess + + return undef unless defined $hash_ref; + die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; + my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); + my $string = ''; + for my $key (@$keys) { + $string .= $pair_separator if length $string > 0; + my $value = $hash_ref->{$key}; + if ($use_neat) { + $value = DBI::neat($value, 0); + } + else { + $value = (defined $value) ? "'$value'" : 'undef'; + } + $string .= $key . $kv_separator . $value; + } + return $string; +} + +sub _get_sorted_hash_keys { + my ($hash_ref, $sort_type) = @_; + if (not defined $sort_type) { + my $sort_guess = 1; + $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess + for keys %$hash_ref; + $sort_type = $sort_guess; + } + + my @keys = keys %$hash_ref; + no warnings 'numeric'; + my @sorted = ($sort_type) + ? sort { $a <=> $b or $a cmp $b } @keys + : sort @keys; + #warn "$sort_type = @sorted\n"; + return \@sorted; +} + +1; diff --git a/t/06attrs.t b/t/06attrs.t new file mode 100644 index 0000000..89ba7c1 --- /dev/null +++ b/t/06attrs.t @@ -0,0 +1,311 @@ +#!perl -w + +use strict; + +use Test::More tests => 148; + +## ---------------------------------------------------------------------------- +## 06attrs.t - ... +## ---------------------------------------------------------------------------- +# This test checks the parameters and the values associated with them for +# the three different handles (Driver, Database, Statement) +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok( 'DBI' ) +} + +$|=1; + +my $using_autoproxy = ($ENV{DBI_AUTOPROXY}); +my $dsn = 'dbi:ExampleP:dummy'; + +# Connect to the example driver. +my $dbh = DBI->connect($dsn, '', '', { + PrintError => 0, RaiseError => 1, +}); + +isa_ok( $dbh, 'DBI::db' ); + +# Clean up when we're done. +END { $dbh->disconnect if $dbh }; + +## ---------------------------------------------------------------------------- +# Check the database handle attributes. + +# bit flag attr +ok( $dbh->{Warn}, '... checking Warn attribute for dbh'); +ok( $dbh->{Active}, '... checking Active attribute for dbh'); +ok( $dbh->{AutoCommit}, '... checking AutoCommit attribute for dbh'); +ok(!$dbh->{CompatMode}, '... checking CompatMode attribute for dbh'); +ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestory attribute for dbh'); +ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for dbh'); +ok(!$dbh->{PrintError}, '... checking PrintError attribute for dbh'); +ok( $dbh->{PrintWarn}, '... checking PrintWarn attribute for dbh'); # true because of perl -w above +ok( $dbh->{RaiseError}, '... checking RaiseError attribute for dbh'); +ok(!$dbh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for dbh'); +ok(!$dbh->{ChopBlanks}, '... checking ChopBlanks attribute for dbh'); +ok(!$dbh->{LongTruncOk}, '... checking LongTrunkOk attribute for dbh'); +ok(!$dbh->{TaintIn}, '... checking TaintIn attribute for dbh'); +ok(!$dbh->{TaintOut}, '... checking TaintOut attribute for dbh'); +ok(!$dbh->{Taint}, '... checking Taint attribute for dbh'); +ok(!$dbh->{Executed}, '... checking Executed attribute for dbh'); + +# other attr +cmp_ok($dbh->{ErrCount}, '==', 0, '... checking ErrCount attribute for dbh'); + +SKIP: { + skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl; + + cmp_ok($dbh->{Kids}, '==', 0, '... checking Kids attribute for dbh');; + cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for dbh');; +} + +is($dbh->{CachedKids}, undef, '... checking CachedKids attribute for dbh'); +ok(!defined $dbh->{HandleError}, '... checking HandleError attribute for dbh'); +ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh'); +ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh'); +ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for dbh'); +ok(!defined $dbh->{ReadOnly}, '... checking ReadOnly attribute for dbh'); + +is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for dbh'); +is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh') # fails for Multiplex + unless $using_autoproxy && ok(1); + +cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for dbh'); +cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for dbh'); + +is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCount)) ], + [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many'; + +is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value'; + +# Raise an error. +eval { + $dbh->do('select foo from foo') +}; +like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching exception'); + +ok(defined $dbh->err, '... $dbh->err is undefined'); +like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking $dbh->errstr'); + +is($dbh->state, 'S1000', '... checking $dbh->state'); + +ok($dbh->{Executed}, '... checking Executed attribute for dbh'); # even though it failed +$dbh->{Executed} = 0; # reset(able) +cmp_ok($dbh->{Executed}, '==', 0, '... checking Executed attribute for dbh (after reset)'); + +cmp_ok($dbh->{ErrCount}, '==', 1, '... checking ErrCount attribute for dbh (after error was generated)'); + +## ---------------------------------------------------------------------------- +# Test the driver handle attributes. + +my $drh = $dbh->{Driver}; +isa_ok( $drh, 'DBI::dr' ); + +ok($dbh->err, '... checking $dbh->err'); + +cmp_ok($drh->{ErrCount}, '==', 0, '... checking ErrCount attribute for drh'); + +ok( $drh->{Warn}, '... checking Warn attribute for drh'); +ok( $drh->{Active}, '... checking Active attribute for drh'); +ok( $drh->{AutoCommit}, '... checking AutoCommit attribute for drh'); +ok(!$drh->{CompatMode}, '... checking CompatMode attribute for drh'); +ok(!$drh->{InactiveDestroy}, '... checking InactiveDestory attribute for drh'); +ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for drh'); +ok(!$drh->{PrintError}, '... checking PrintError attribute for drh'); +ok( $drh->{PrintWarn}, '... checking PrintWarn attribute for drh'); # true because of perl -w above +ok(!$drh->{RaiseError}, '... checking RaiseError attribute for drh'); +ok(!$drh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for drh'); +ok(!$drh->{ChopBlanks}, '... checking ChopBlanks attribute for drh'); +ok(!$drh->{LongTruncOk}, '... checking LongTrunkOk attribute for drh'); +ok(!$drh->{TaintIn}, '... checking TaintIn attribute for drh'); +ok(!$drh->{TaintOut}, '... checking TaintOut attribute for drh'); +ok(!$drh->{Taint}, '... checking Taint attribute for drh'); + +SKIP: { + skip "Executed attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + ok($drh->{Executed}, '... checking Executed attribute for drh') # due to the do() above +} + +SKIP: { + skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if ($DBI::PurePerl or $dbh->{mx_handle_list}); + cmp_ok($drh->{Kids}, '==', 1, '... checking Kids attribute for drh'); + cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for drh'); +} + +is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh'); +ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh'); +ok(!defined $drh->{Profile}, '... checking Profile attribute for drh'); +ok(!defined $drh->{ReadOnly}, '... checking ReadOnly attribute for drh'); + +cmp_ok($drh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for drh'); +cmp_ok($drh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for drh'); + +is($drh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for drh'); +is($drh->{Name}, 'ExampleP', '... checking Name attribute for drh') + unless $using_autoproxy && ok(1); + +## ---------------------------------------------------------------------------- +# Test the statement handle attributes. + +# Create a statement handle. +my $sth = $dbh->prepare("select ctime, name from ?"); +isa_ok($sth, "DBI::st"); + +ok(!$sth->{Executed}, '... checking Executed attribute for sth'); +ok(!$dbh->{Executed}, '... checking Executed attribute for dbh'); +cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth'); + +# Trigger an exception. +eval { + $sth->execute("foo") +}; +# we don't check actual opendir error msg because of locale differences +like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '... checking exception'); + +# Test all of the statement handle attributes. +like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr'); +is($sth->state, 'S1000', '... checking $sth->state'); +ok($sth->{Executed}, '... checking Executed attribute for sth'); # even though it failed +ok($dbh->{Executed}, '... checking Exceuted attribute for dbh'); # due to $sth->prepare, even though it failed + +cmp_ok($sth->{ErrCount}, '==', 1, '... checking ErrCount attribute for sth'); +eval { + $sth->{ErrCount} = 42 +}; +like($@, qr/STORE failed:/, '... checking exception'); + +cmp_ok($sth->{ErrCount}, '==', 42 , '... checking ErrCount attribute for sth (after assignment)'); + +$sth->{ErrCount} = 0; +cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after reset)'); + +# booleans +ok( $sth->{Warn}, '... checking Warn attribute for sth'); +ok(!$sth->{Active}, '... checking Active attribute for sth'); +ok(!$sth->{CompatMode}, '... checking CompatMode attribute for sth'); +ok(!$sth->{InactiveDestroy}, '... checking InactiveDestroy attribute for sth'); +ok(!$sth->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for sth'); +ok(!$sth->{PrintError}, '... checking PrintError attribute for sth'); +ok( $sth->{PrintWarn}, '... checking PrintWarn attribute for sth'); +ok( $sth->{RaiseError}, '... checking RaiseError attribute for sth'); +ok(!$sth->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for sth'); +ok(!$sth->{ChopBlanks}, '... checking ChopBlanks attribute for sth'); +ok(!$sth->{LongTruncOk}, '... checking LongTrunkOk attribute for sth'); +ok(!$sth->{TaintIn}, '... checking TaintIn attribute for sth'); +ok(!$sth->{TaintOut}, '... checking TaintOut attribute for sth'); +ok(!$sth->{Taint}, '... checking Taint attribute for sth'); + +# common attr +SKIP: { + skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl; + cmp_ok($sth->{Kids}, '==', 0, '... checking Kids attribute for sth'); + cmp_ok($sth->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for sth'); +} + +ok(!defined $sth->{CachedKids}, '... checking CachedKids attribute for sth'); +ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth'); +ok(!defined $sth->{Profile}, '... checking Profile attribute for sth'); +ok(!defined $sth->{ReadOnly}, '... checking ReadOnly attribute for sth'); + +cmp_ok($sth->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for sth'); +cmp_ok($sth->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for sth'); + +is($sth->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for sth'); + +# sth specific attr +ok(!defined $sth->{CursorName}, '... checking CursorName attribute for sth'); + +cmp_ok($sth->{NUM_OF_FIELDS}, '==', 2, '... checking NUM_OF_FIELDS attribute for sth'); +cmp_ok($sth->{NUM_OF_PARAMS}, '==', 1, '... checking NUM_OF_PARAMS attribute for sth'); + +my $name = $sth->{NAME}; +is(ref($name), 'ARRAY', '... checking type of NAME attribute for sth'); +cmp_ok(scalar(@{$name}), '==', 2, '... checking number of elements returned'); +is_deeply($name, ['ctime', 'name' ], '... checking values returned'); + +my $name_lc = $sth->{NAME_lc}; +is(ref($name_lc), 'ARRAY', '... checking type of NAME_lc attribute for sth'); +cmp_ok(scalar(@{$name_lc}), '==', 2, '... checking number of elements returned'); +is_deeply($name_lc, ['ctime', 'name' ], '... checking values returned'); + +my $name_uc = $sth->{NAME_uc}; +is(ref($name_uc), 'ARRAY', '... checking type of NAME_uc attribute for sth'); +cmp_ok(scalar(@{$name_uc}), '==', 2, '... checking number of elements returned'); +is_deeply($name_uc, ['CTIME', 'NAME' ], '... checking values returned'); + +my $nhash = $sth->{NAME_hash}; +is(ref($nhash), 'HASH', '... checking type of NAME_hash attribute for sth'); +cmp_ok(scalar(keys(%{$nhash})), '==', 2, '... checking number of keys returned'); +cmp_ok($nhash->{ctime}, '==', 0, '... checking values returned'); +cmp_ok($nhash->{name}, '==', 1, '... checking values returned'); + +my $nhash_lc = $sth->{NAME_lc_hash}; +is(ref($nhash_lc), 'HASH', '... checking type of NAME_lc_hash attribute for sth'); +cmp_ok(scalar(keys(%{$nhash_lc})), '==', 2, '... checking number of keys returned'); +cmp_ok($nhash_lc->{ctime}, '==', 0, '... checking values returned'); +cmp_ok($nhash_lc->{name}, '==', 1, '... checking values returned'); + +my $nhash_uc = $sth->{NAME_uc_hash}; +is(ref($nhash_uc), 'HASH', '... checking type of NAME_uc_hash attribute for sth'); +cmp_ok(scalar(keys(%{$nhash_uc})), '==', 2, '... checking number of keys returned'); +cmp_ok($nhash_uc->{CTIME}, '==', 0, '... checking values returned'); +cmp_ok($nhash_uc->{NAME}, '==', 1, '... checking values returned'); + +my $type = $sth->{TYPE}; +is(ref($type), 'ARRAY', '... checking type of TYPE attribute for sth'); +cmp_ok(scalar(@{$type}), '==', 2, '... checking number of elements returned'); +is_deeply($type, [ 4, 12 ], '... checking values returned'); + +my $null = $sth->{NULLABLE}; +is(ref($null), 'ARRAY', '... checking type of NULLABLE attribute for sth'); +cmp_ok(scalar(@{$null}), '==', 2, '... checking number of elements returned'); +is_deeply($null, [ 0, 0 ], '... checking values returned'); + +# Should these work? They don't. +my $prec = $sth->{PRECISION}; +is(ref($prec), 'ARRAY', '... checking type of PRECISION attribute for sth'); +cmp_ok(scalar(@{$prec}), '==', 2, '... checking number of elements returned'); +is_deeply($prec, [ 10, 1024 ], '... checking values returned'); + +my $scale = $sth->{SCALE}; +is(ref($scale), 'ARRAY', '... checking type of SCALE attribute for sth'); +cmp_ok(scalar(@{$scale}), '==', 2, '... checking number of elements returned'); +is_deeply($scale, [ 0, 0 ], '... checking values returned'); + +my $params = $sth->{ParamValues}; +is(ref($params), 'HASH', '... checking type of ParamValues attribute for sth'); +is($params->{1}, 'foo', '... checking values returned'); + +is($sth->{Statement}, "select ctime, name from ?", '... checking Statement attribute for sth'); +ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute for sth'); + +is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth attribute value'; + +# $h->{TraceLevel} tests are in t/09trace.t + +note "Checking inheritance\n"; + +SKIP: { + skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if $ENV{DBI_AUTOPROXY}; + +sub check_inherited { + my ($drh, $attr, $value, $skip_sth) = @_; + local $drh->{$attr} = $value; + local $drh->{PrintError} = 1; + my $dbh = $drh->connect("dummy"); + is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from drh"; + unless ($skip_sth) { + my $sth = $dbh->prepare("select name from ."); + is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited from dbh"; + } +} + +check_inherited($drh, "ReadOnly", 1, 0); + +} + +1; +# end diff --git a/t/07kids.t b/t/07kids.t new file mode 100644 index 0000000..8364ad2 --- /dev/null +++ b/t/07kids.t @@ -0,0 +1,102 @@ +#!perl -w +$|=1; + +use strict; + +use Test::More; + +use DBI 1.50; # also tests Exporter::require_version + +BEGIN { + plan skip_all => '$h->{Kids} attribute not supported for DBI::PurePerl' + if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning + plan tests => 20; +} + +## ---------------------------------------------------------------------------- +## 07kids.t +## ---------------------------------------------------------------------------- +# This test check the Kids and the ActiveKids attributes and how they act +# in various situations. +# +# Check the database handle's kids: +# - upon creation of handle +# - upon creation of statement handle +# - after execute of statement handle +# - after finish of statement handle +# - after destruction of statement handle +# Check the driver handle's kids: +# - after creation of database handle +# - after disconnection of database handle +# - after destruction of database handle +## ---------------------------------------------------------------------------- + + +# Connect to the example driver and create a database handle +my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '', + { + PrintError => 1, + RaiseError => 0 + }); + +# check our database handle to make sure its good +isa_ok($dbh, 'DBI::db'); + +# check that it has no Kids or ActiveKids yet +cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) at start'); +cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) at start'); + +# create a scope for our $sth to live and die in +do { + + # create a statement handle + my $sth = $dbh->prepare('select uid from ./'); + + # verify that it is a correct statement handle + isa_ok($sth, "DBI::st"); + + # check our Kids and ActiveKids after prepare + cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $dbh->prepare'); + cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $dbh->prepare'); + + $sth->execute(); + + # check our Kids and ActiveKids after execute + cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->execute'); + cmp_ok($dbh->{ActiveKids}, '==', 1, '... database handle has 1 ActiveKid(s) after $sth->execute'); + + $sth->finish(); + + # check our Kids and Activekids after finish + cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after $sth->finish'); + cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth->finish'); + +}; + +# now check it after the statement handle has been destroyed +cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) after $sth is destroyed'); +cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after $sth is destroyed'); + +# get the database handles driver Driver +my $drh = $dbh->{Driver}; + +# check that is it a correct driver handle +isa_ok($drh, "DBI::dr"); + +# check the driver's Kids and ActiveKids +cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s)'); +cmp_ok( $drh->{ActiveKids}, '==', 1, '... driver handle has 1 ActiveKid(s)'); + +$dbh->disconnect; + +# check the driver's Kids and ActiveKids after $dbh->disconnect +cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s) after $dbh->disconnect'); +cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after $dbh->disconnect'); + +undef $dbh; +ok(!defined($dbh), '... lets be sure that $dbh is not undefined'); + +# check the driver's Kids and ActiveKids after undef $dbh +cmp_ok( $drh->{Kids}, '==', 0, '... driver handle has 0 Kid(s) after undef $dbh'); +cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after undef $dbh'); + diff --git a/t/08keeperr.t b/t/08keeperr.t new file mode 100644 index 0000000..617a81d --- /dev/null +++ b/t/08keeperr.t @@ -0,0 +1,291 @@ +#!perl -w + +use strict; + +use Test::More tests => 79; + +## ---------------------------------------------------------------------------- +## 08keeperr.t +## ---------------------------------------------------------------------------- +# +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok('DBI'); +} + +$|=1; +$^W=1; + +## ---------------------------------------------------------------------------- +# subclass DBI + +# DBI subclass +package My::DBI; +use base 'DBI'; + +# Database handle subclass +package My::DBI::db; +use base 'DBI::db'; + +# Statement handle subclass +package My::DBI::st; +use base 'DBI::st'; + +sub execute { + my $sth = shift; + # we localize an attribute here to check that the correpoding STORE + # at scope exit doesn't clear any recorded error + local $sth->{Warn} = 0; + my $rv = $sth->SUPER::execute(@_); + return $rv; +} + + +## ---------------------------------------------------------------------------- +# subclass the subclass of DBI + +package Test; + +use strict; +use base 'My::DBI'; + +use DBI; + +my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 1 }); + +sub test_select { + my $dbh = shift; + eval { $dbh->selectrow_arrayref('select * from foo') }; + $dbh->disconnect; + return $@; +} + +my $err1 = test_select( My::DBI->connect(@con_info) ); +Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error'); + +my $err2 = test_select( DBI->connect(@con_info) ); +Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error'); + +package main; + +# test ping does not destroy the errstr +sub ping_keeps_err { + my $dbh = DBI->connect('DBI:ExampleP:', undef, undef, { PrintError => 0 }); + + $dbh->set_err(42, "ERROR 42"); + is $dbh->err, 42; + is $dbh->errstr, "ERROR 42"; + ok $dbh->ping, "ping returns true"; + is $dbh->err, 42, "err unchanged after ping"; + is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; + + $dbh->disconnect; + + $dbh->set_err(42, "ERROR 42"); + is $dbh->err, 42, "err unchanged after ping"; + is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; + ok !$dbh->ping, "ping returns false"; + # it's reasonable for ping() to set err/errstr if it fails + # so here we just test that there is an error + ok $dbh->err, "err true after failed ping"; + ok $dbh->errstr, "errstr true after failed ping"; +} + +## ---------------------------------------------------------------------------- +print "Test HandleSetErr\n"; + +my $dbh = DBI->connect(@con_info); +isa_ok($dbh, "DBI::db"); + +$dbh->{RaiseError} = 1; +$dbh->{PrintError} = 1; +$dbh->{PrintWarn} = 1; + +# warning handler +my %warn = ( failed => 0, warning => 0 ); +my @handlewarn = (0,0,0); +$SIG{__WARN__} = sub { + my $msg = shift; + if ($msg =~ /^DBD::\w+::\S+\s+(\S+)\s+(\w+)/) { + ++$warn{$2}; + $msg =~ s/\n/\\n/g; + print "warn: '$msg'\n"; + return; + } + warn $msg; +}; + +# HandleSetErr handler +$dbh->{HandleSetErr} = sub { + my ($h, $err, $errstr, $state) = @_; + return 0 + unless defined $err; + ++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls + return 1 + if $state && $state eq "return"; # for tests + ($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123") + if $state && $state eq "override"; # for tests + return 0 + if $err; # be transparent for errors + local $^W; + print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n"; + return 0; +}; + +# start our tests + +ok(!defined $DBI::err, '... $DBI::err is not defined'); + +# ---- + +$dbh->set_err("", "(got info)"); + +ok(defined $DBI::err, '... $DBI::err is defined'); # true +is($DBI::err, "", '... $DBI::err is an empty string'); +is($DBI::errstr, "(got info)", '... $DBI::errstr is as we expected'); +is($dbh->errstr, "(got info)", '... $dbh->errstr matches $DBI::errstr'); +cmp_ok($warn{failed}, '==', 0, '... $warn{failed} is 0'); +cmp_ok($warn{warning}, '==', 0, '... $warn{warning} is 0'); +is_deeply(\@handlewarn, [ 1, 0, 0 ], '... the @handlewarn array is (1, 0, 0)'); + +# ---- + +$dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn + +ok(defined $DBI::err, '... $DBI::err is defined'); +is($DBI::err, "0", '... $DBI::err is "0"'); +is($DBI::errstr, "(got info)\n(got warn)", + '... $DBI::errstr is as we expected'); +is($dbh->errstr, "(got info)\n(got warn)", + '... $dbh->errstr matches $DBI::errstr'); +is($DBI::state, "AA001", '... $DBI::state is AA001'); +cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1'); +is_deeply(\@handlewarn, [ 1, 1, 0 ], '... the @handlewarn array is (1, 1, 0)'); + + +# ---- + +$dbh->set_err("", "(got more info)"); # triggers PrintWarn + +ok(defined $DBI::err, '... $DBI::err is defined'); +is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's still a warn +is($dbh->err, "0", '... $dbh->err is "0"'); +is($DBI::state, "AA001", '... $DBI::state is AA001'); +is($DBI::errstr, "(got info)\n(got warn)\n(got more info)", + '... $DBI::errstr is as we expected'); +is($dbh->errstr, "(got info)\n(got warn)\n(got more info)", + '... $dbh->errstr matches $DBI::errstr'); +cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); +is_deeply(\@handlewarn, [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)'); + + +# ---- + +$dbh->{RaiseError} = 0; +$dbh->{PrintError} = 1; + +# ---- + +$dbh->set_err("42", "(got error)", "AA002"); + +ok(defined $DBI::err, '... $DBI::err is defined'); +cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); +cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); +is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)", + '... $dbh->errstr is as we expected'); +is($DBI::state, "AA002", '... $DBI::state is AA002'); +is_deeply(\@handlewarn, [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)'); + +# ---- + +$dbh->set_err("", "(got info)"); + +ok(defined $DBI::err, '... $DBI::err is defined'); +cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); +cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); +is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)", + '... $dbh->errstr is as we expected'); +is_deeply(\@handlewarn, [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)'); + +# ---- + +$dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err + +ok(defined $DBI::err, '... $DBI::err is defined'); +cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42'); +cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); +is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn)", + '... $dbh->errstr is as we expected'); +is_deeply(\@handlewarn, [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)'); + +# ---- + +$dbh->set_err("4200", "(got new error)", "AA003"); + +ok(defined $DBI::err, '... $DBI::err is defined'); +cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200'); +cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2'); +is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now AA003]\n(got new error)", + '... $dbh->errstr is as we expected'); +is_deeply(\@handlewarn, [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)'); + +# ---- + +$dbh->set_err(undef, "foo", "bar"); # clear error + +ok(!defined $dbh->errstr, '... $dbh->errstr is defined'); +ok(!defined $dbh->err, '... $dbh->err is defined'); +is($dbh->state, "", '... $dbh->state is an empty string'); + +# ---- + +%warn = ( failed => 0, warning => 0 ); +@handlewarn = (0,0,0); + +# ---- + +my @ret; +@ret = $dbh->set_err(1, "foo"); # PrintError + +cmp_ok(scalar(@ret), '==', 1, '... only returned one value'); +ok(!defined $ret[0], '... the first value is undefined'); +ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); # PrintError +ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); # PrintError +ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); # PrintError +is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn", + '... $dbh->errstr is as we expected'); +is($warn{failed}, 4, '... $warn{failed} is 4'); +is_deeply(\@handlewarn, [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)'); + +# ---- + +$dbh->set_err(undef, undef, undef); # clear error + +@ret = $dbh->set_err(1, "foo", "AA123", "method"); +cmp_ok(scalar @ret, '==', 1, '... only returned one value'); +ok(!defined $ret[0], '... the first value is undefined'); + +@ret = $dbh->set_err(1, "foo", "AA123", "method", "42"); +cmp_ok(scalar @ret, '==', 1, '... only returned one value'); +is($ret[0], "42", '... the first value is "42"'); + +@ret = $dbh->set_err(1, "foo", "return"); +cmp_ok(scalar @ret, '==', 0, '... returned no values'); + +# ---- + +$dbh->set_err(undef, undef, undef); # clear error + +@ret = $dbh->set_err("", "info", "override"); +cmp_ok(scalar @ret, '==', 1, '... only returned one value'); +ok(!defined $ret[0], '... the first value is undefined'); +cmp_ok($dbh->err, '==', 99, '... $dbh->err is 99'); +is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected'); +is($dbh->state, "OV123", '... $dbh->state is as we expected'); +$dbh->disconnect; + +ping_keeps_err(); + +1; +# end diff --git a/t/09trace.t b/t/09trace.t new file mode 100644 index 0000000..021bc5c --- /dev/null +++ b/t/09trace.t @@ -0,0 +1,137 @@ +#!perl -w +# vim:sw=4:ts=8 + +use strict; + +use Test::More tests => 99; + +## ---------------------------------------------------------------------------- +## 09trace.t +## ---------------------------------------------------------------------------- +# +## ---------------------------------------------------------------------------- + +BEGIN { + $ENV{DBI_TRACE} = 0; # for PurePerl - ensure DBI_TRACE is in the env + use_ok( 'DBI' ); +} + +$|=1; + + +my $trace_file = "dbitrace$$.log"; + +1 while unlink $trace_file; +warn "Can't unlink existing $trace_file: $!" if -e $trace_file; + +my $orig_trace_level = DBI->trace; +DBI->trace(3, $trace_file); # enable trace before first driver load + +my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef); +die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh; + +isa_ok($dbh, 'DBI::db'); + +$dbh->dump_handle("dump_handle test, write to log file", 2); + +DBI->trace(0, undef); # turn off and restore to STDERR + +SKIP: { + skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i); + ok( -s $trace_file, "trace file size = " . -s $trace_file); +} + +DBI->trace($orig_trace_level); # no way to restore previous outfile XXX + + +# Clean up when we're done. +END { $dbh->disconnect if $dbh; + 1 while unlink $trace_file; }; + +## ---------------------------------------------------------------------------- +# Check the database handle attributes. + +cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute'); + +1 while unlink $trace_file; + +$dbh->trace(0, $trace_file); +ok( -f $trace_file, '... trace file successfully created'); + +my @names = qw( + SQL + CON + ENC + DBD + TXN + foo bar baz boo bop +); +my %flag; +my $all_flags = 0; + +foreach my $name (@names) { + print "parse_trace_flag $name\n"; + ok( my $flag1 = $dbh->parse_trace_flag($name) ); + ok( my $flag2 = $dbh->parse_trace_flags($name) ); + is( $flag1, $flag2 ); + + $dbh->{TraceLevel} = $flag1; + is( $dbh->{TraceLevel}, $flag1 ); + + $dbh->{TraceLevel} = 0; + is( $dbh->{TraceLevel}, 0 ); + + $dbh->trace($flag1); + is $dbh->trace, $flag1; + is $dbh->{TraceLevel}, $flag1; + + $dbh->{TraceLevel} = $name; # set by name + $dbh->{TraceLevel} = undef; # check no change on undef + is( $dbh->{TraceLevel}, $flag1 ); + + $flag{$name} = $flag1; + $all_flags |= $flag1 + if defined $flag1; # reduce noise if there's a bug +} + +print "parse_trace_flag @names\n"; +ok(eq_set([ keys %flag ], [ @names ]), '...'); +$dbh->{TraceLevel} = 0; +$dbh->{TraceLevel} = join "|", @names; +is($dbh->{TraceLevel}, $all_flags, '...'); + +{ + print "inherit\n"; + my $sth = $dbh->prepare("select ctime, name from foo"); + isa_ok( $sth, 'DBI::st' ); + is( $sth->{TraceLevel}, $all_flags ); +} + +$dbh->{TraceLevel} = 0; +ok !$dbh->{TraceLevel}; +$dbh->{TraceLevel} = 'ALL'; +ok $dbh->{TraceLevel}; + +{ + print "test unknown parse_trace_flag\n"; + my $warn = 0; + local $SIG{__WARN__} = sub { + if ($_[0] =~ /unknown/i) { ++$warn; print "caught warn: ",@_ }else{ warn @_ } + }; + is $dbh->parse_trace_flag("nonesuch"), undef; + is $warn, 0; + is $dbh->parse_trace_flags("nonesuch"), 0; + is $warn, 1; + is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL"); + is $warn, 2; +} + +$dbh->dump_handle("dump_handle test, write to log file", 2); + +$dbh->trace(0); +ok !$dbh->{TraceLevel}; +$dbh->trace(undef, "STDERR"); # close $trace_file +ok( -s $trace_file ); + +1; +# end diff --git a/t/10examp.t b/t/10examp.t new file mode 100644 index 0000000..b7f063a --- /dev/null +++ b/t/10examp.t @@ -0,0 +1,579 @@ +#!perl -w + +use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB +use DBI qw(:sql_types); +use Config; +use Cwd; +use strict; +use Data::Dumper; + +$^W = 1; +$| = 1; + +require File::Basename; +require File::Spec; +require VMS::Filespec if $^O eq 'VMS'; + +use Test::More tests => 229; + +do { + # provide some protection against growth in size of '.' during the test + # which was probable cause of this failure + # http://www.nntp.perl.org/group/perl.cpan.testers/2009/09/msg5297317.html + my $tmpfile = "deleteme_$$"; + open my $fh, ">$tmpfile"; + close $fh; + unlink $tmpfile; +}; + +# "globals" +my ($r, $dbh); + +ok !eval { + $dbh = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1, AutoCommit => 1 }); +}, 'connect should fail'; +like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an exception here'); +ok(!$dbh, '... $dbh2 should not be defined'); + +$dbh = DBI->connect('dbi:ExampleP:', '', ''); + +sub check_connect_cached { + # connect_cached + # ------------------------------------------ + # This test checks that connect_cached works + # and how it then relates to the CachedKids + # attribute for the driver. + + ok my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); + + ok my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); + + is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so they are the same'); + + ok my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo => 1 }); + + isnt($dbh_cached_3, $dbh_cached_2, '... this handle was created with different parameters, so it is not the same'); + + # check that cached_connect applies attributes to handles returned from the cache + # (The specific case of Executed is relevant to DBD::Gofer retry-on-error logic) + ok $dbh_cached_1->do("select * from ."); # set Executed flag + ok $dbh_cached_1->{Executed}, 'Executed should be true'; + ok my $dbh_cached_4 = DBI->connect_cached('dbi:ExampleP:', '', '', { TraceLevel=>0, Executed => 0 }); + is $dbh_cached_4, $dbh_cached_1, 'should return same handle'; + ok !$dbh_cached_4->{Executed}, 'Executed should be false because reset by connect attributes'; + + my $drh = $dbh->{Driver}; + isa_ok($drh, "DBI::dr"); + + my @cached_kids = values %{$drh->{CachedKids}}; + ok(eq_set(\@cached_kids, [ $dbh_cached_1, $dbh_cached_3 ]), '... these are our cached kids'); + + $drh->{CachedKids} = {}; + cmp_ok(scalar(keys %{$drh->{CachedKids}}), '==', 0, '... we have emptied out cache'); +} + +check_connect_cached(); + +$dbh->{AutoCommit} = 1; +$dbh->{PrintError} = 0; + +ok($dbh->{AutoCommit} == 1); +cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0'); + +is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME'); + +# test access to driver-private attributes +like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the example driver_path'); + +print "others\n"; +eval { $dbh->commit('dummy') }; +ok($@ =~ m/DBI commit: invalid number of arguments:/, $@) + unless $DBI::PurePerl && ok(1); + +ok($dbh->ping, "ping should return true"); + +# --- errors +my $cursor_e = $dbh->prepare("select unknown_field_name from ?"); +is($cursor_e, undef, "prepare should fail"); +ok($dbh->err, "sth->err should be true"); +ok($DBI::err, "DBI::err should be true"); +cmp_ok($DBI::err, 'eq', $dbh->err , "\$DBI::err should match \$dbh->err"); +like($DBI::errstr, qr/Unknown field names: unknown_field_name/, "\$DBI::errstr should contain error string"); +cmp_ok($DBI::errstr, 'eq', $dbh->errstr, "\$DBI::errstr should match \$dbh->errstr"); + +# --- func +ok($dbh->errstr eq $dbh->func('errstr')); + +my $std_sql = "select mode,size,name from ?"; +my $csr_a = $dbh->prepare($std_sql); +ok(ref $csr_a); +ok($csr_a->{NUM_OF_FIELDS} == 3); + +SKIP: { + skip "inner/outer handles not fully supported for DBI::PurePerl", 3 if $DBI::PurePerl; + ok(tied %{ $csr_a->{Database} }); # ie is 'outer' handle + ok($csr_a->{Database} eq $dbh, "$csr_a->{Database} ne $dbh") + unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex tests + ok(tied %{ $csr_a->{Database}->{Driver} }); # ie is 'outer' handle +} + +my $driver_name = $csr_a->{Database}->{Driver}->{Name}; +ok($driver_name eq 'ExampleP') + unless $ENV{DBI_AUTOPROXY} && ok(1); + +# --- FetchHashKeyName +$dbh->{FetchHashKeyName} = 'NAME_uc'; +my $csr_b = $dbh->prepare($std_sql); +$csr_b->execute('.'); +ok(ref $csr_b); + +ok($csr_a != $csr_b); + +ok("@{$csr_b->{NAME_lc}}" eq "mode size name"); # before NAME +ok("@{$csr_b->{NAME_uc}}" eq "MODE SIZE NAME"); +ok("@{$csr_b->{NAME}}" eq "mode size name"); +ok("@{$csr_b->{ $csr_b->{FetchHashKeyName} }}" eq "MODE SIZE NAME"); + +ok("@{[sort keys %{$csr_b->{NAME_lc_hash}}]}" eq "mode name size"); +ok("@{[sort values %{$csr_b->{NAME_lc_hash}}]}" eq "0 1 2"); +ok("@{[sort keys %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE"); +ok("@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2"); + +do "t/lib.pl"; + +# get a dir always readable on all platforms +#my $dir = getcwd() || cwd(); +#$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; +# untaint $dir +#$dir =~ m/(.*)/; $dir = $1 || die; +my $dir = test_dir (); + +# --- + +my($col0, $col1, $col2, $col3, $rows); +my(@row_a, @row_b); + +ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) ); +ok($csr_a->execute( $dir ), $DBI::errstr); + +@row_a = $csr_a->fetchrow_array; +ok(@row_a); + +# check bind_columns +is($row_a[0], $col0); +is($row_a[1], $col1); +is($row_a[2], $col2); + +ok( ! $csr_a->bind_columns(undef, \($col0, $col1)) ); +like $csr_a->errstr, '/bind_columns called with 2 values but 3 are needed/', 'errstr should contain error message'; +ok( ! $csr_a->bind_columns(undef, \($col0, $col1, $col2, $col3)) ); +like $csr_a->errstr, '/bind_columns called with 4 values but 3 are needed/', 'errstr should contain error message'; + +ok( $csr_a->bind_col(2, undef, { foo => 42 }) ); +ok ! eval { $csr_a->bind_col(0, undef) }; +like $@, '/bind_col: column 0 is not a valid column \(1..3\)/', 'errstr should contain error message'; +ok ! eval { $csr_a->bind_col(4, undef) }; +like $@, '/bind_col: column 4 is not a valid column \(1..3\)/', 'errstr should contain error message'; + +ok($csr_b->bind_param(1, $dir)); +ok($csr_b->execute()); +@row_b = @{ $csr_b->fetchrow_arrayref }; +ok(@row_b); + +ok("@row_a" eq "@row_b"); +@row_b = $csr_b->fetchrow_array; +ok("@row_a" ne "@row_b"); + +ok($csr_a->finish); +ok($csr_b->finish); + +$csr_a = undef; # force destruction of this cursor now +ok(1); + +print "fetchrow_hashref('NAME_uc')\n"; +ok($csr_b->execute()); +my $row_b = $csr_b->fetchrow_hashref('NAME_uc'); +ok($row_b); +ok($row_b->{MODE} == $row_a[0]); +ok($row_b->{SIZE} == $row_a[1]); +ok($row_b->{NAME} eq $row_a[2]); + +print "fetchrow_hashref('ParamValues')\n"; +ok($csr_b->execute()); +ok(!defined eval { $csr_b->fetchrow_hashref('ParamValues') } ); # PurePerl croaks + +print "FetchHashKeyName\n"; +ok($csr_b->execute()); +$row_b = $csr_b->fetchrow_hashref(); +ok($row_b); +ok(keys(%$row_b) == 3); +ok($row_b->{MODE} == $row_a[0]); +ok($row_b->{SIZE} == $row_a[1]); +ok($row_b->{NAME} eq $row_a[2]); + +print "fetchall_arrayref\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref; +ok($r); +ok(@$r); +ok($r->[0]->[0] == $row_a[0]); +ok($r->[0]->[1] == $row_a[1]); +ok($r->[0]->[2] eq $row_a[2]); + +print "fetchall_arrayref array slice\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref([2,1]); +ok($r && @$r); +ok($r->[0]->[1] == $row_a[1]); +ok($r->[0]->[0] eq $row_a[2]); + +print "fetchall_arrayref hash slice\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref({ SizE=>1, nAMe=>1}); +ok($r && @$r); +ok($r->[0]->{SizE} == $row_a[1]); +ok($r->[0]->{nAMe} eq $row_a[2]); + +ok ! $csr_b->fetchall_arrayref({ NoneSuch=>1 }); +like $DBI::errstr, qr/Invalid column name/; + +print "fetchall_arrayref renaming hash slice\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref(\{ 1 => "Koko", 2 => "Nimi"}); +ok($r && @$r); +ok($r->[0]->{Koko} == $row_a[1]); +ok($r->[0]->{Nimi} eq $row_a[2]); + +ok ! eval { $csr_b->fetchall_arrayref(\{ 9999 => "Koko" }) }; +like $@, qr/\Qis not a valid column/; + +print "fetchall_arrayref empty renaming hash slice\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref(\{}); +ok($r && @$r); +ok(keys %{$r->[0]} == 0); + +ok($csr_b->execute()); +ok(!$csr_b->fetchall_arrayref(\[])); +like $DBI::errstr, qr/\Qfetchall_arrayref(REF) invalid/; + +print "fetchall_arrayref hash\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref({}); +ok($r); +ok(keys %{$r->[0]} == 3); +ok("@{$r->[0]}{qw(MODE SIZE NAME)}" eq "@row_a", "'@{$r->[0]}{qw(MODE SIZE NAME)}' ne '@row_a'"); + +print "rows()\n"; # assumes previous fetch fetched all rows +$rows = $csr_b->rows; +ok($rows > 0, "row count $rows"); +ok($rows == @$r, "$rows vs ".@$r); +ok($rows == $DBI::rows, "$rows vs $DBI::rows"); + +print "fetchall_arrayref array slice and max rows\n"; +ok($csr_b->execute()); +$r = $csr_b->fetchall_arrayref([0], 1); +ok($r); +is_deeply($r, [[$row_a[0]]]); + +$r = $csr_b->fetchall_arrayref([], 1); +is @$r, 1, 'should fetch one row'; + +$r = $csr_b->fetchall_arrayref([], 99999); +ok @$r, 'should fetch all the remaining rows'; + +$r = $csr_b->fetchall_arrayref([], 99999); +is $r, undef, 'should return undef as there are no more rows'; + +# --- + +print "selectrow_array\n"; +@row_b = $dbh->selectrow_array($std_sql, undef, $dir); +ok(@row_b == 3); +ok("@row_b" eq "@row_a"); + +print "selectrow_hashref\n"; +$r = $dbh->selectrow_hashref($std_sql, undef, $dir); +ok(keys %$r == 3); +ok($r->{MODE} eq $row_a[0]); +ok($r->{SIZE} eq $row_a[1]); +ok($r->{NAME} eq $row_a[2]); + +print "selectall_arrayref\n"; +$r = $dbh->selectall_arrayref($std_sql, undef, $dir); +ok($r); +ok(@{$r->[0]} == 3); +ok("@{$r->[0]}" eq "@row_a"); +ok(@$r == $rows); + +print "selectall_arrayref Slice array slice\n"; +$r = $dbh->selectall_arrayref($std_sql, { Slice => [ 2, 0 ] }, $dir); +ok($r); +ok(@{$r->[0]} == 2); +ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"}); +ok(@$r == $rows); + +print "selectall_arrayref Columns array slice\n"; +$r = $dbh->selectall_arrayref($std_sql, { Columns => [ 3, 1 ] }, $dir); +ok($r); +ok(@{$r->[0]} == 2); +ok("@{$r->[0]}" eq "$row_a[2] $row_a[0]", qq{"@{$r->[0]}" eq "$row_a[2] $row_a[0]"}); +ok(@$r == $rows); + +print "selectall_arrayref hash slice\n"; +$r = $dbh->selectall_arrayref($std_sql, { Columns => { MoDe=>1, NamE=>1 } }, $dir); +ok($r); +ok(keys %{$r->[0]} == 2); +ok(exists $r->[0]{MoDe}); +ok(exists $r->[0]{NamE}); +ok($r->[0]{MoDe} eq $row_a[0]); +ok($r->[0]{NamE} eq $row_a[2]); +ok(@$r == $rows); + +print "selectall_hashref\n"; +$r = $dbh->selectall_hashref($std_sql, 'NAME', undef, $dir); +ok($r, "selectall_hashref result"); +is(ref $r, 'HASH', "selectall_hashref HASH: ".ref $r); +is(scalar keys %$r, $rows); +is($r->{ $row_a[2] }{SIZE}, $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]}); + +print "selectall_hashref by column number\n"; +$r = $dbh->selectall_hashref($std_sql, 3, undef, $dir); +ok($r); +ok($r->{ $row_a[2] }{SIZE} eq $row_a[1], qq{$r->{ $row_a[2] }{SIZE} eq $row_a[1]}); + +print "selectcol_arrayref\n"; +$r = $dbh->selectcol_arrayref($std_sql, undef, $dir); +ok($r); +ok(@$r == $rows); +ok($r->[0] eq $row_b[0]); + +print "selectcol_arrayref column slice\n"; +$r = $dbh->selectcol_arrayref($std_sql, { Columns => [3,2] }, $dir); +ok($r); +# warn Dumper([\@row_b, $r]); +ok(@$r == $rows * 2); +ok($r->[0] eq $row_b[2]); +ok($r->[1] eq $row_b[1]); + +# --- + +print "others...\n"; +my $csr_c; +$csr_c = $dbh->prepare("select unknown_field_name1 from ?"); +ok(!defined $csr_c); +ok($DBI::errstr =~ m/Unknown field names: unknown_field_name1/); + +print "RaiseError & PrintError & ShowErrorStatement\n"; +$dbh->{RaiseError} = 1; +ok($dbh->{RaiseError}); +$dbh->{ShowErrorStatement} = 1; +ok($dbh->{ShowErrorStatement}); + +my $error_sql = "select unknown_field_name2 from ?"; + +ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); +#print "$@\n"; +like $@, qr/\Q$error_sql/; # ShowErrorStatement +like $@, qr/Unknown field names: unknown_field_name2/; + +# check attributes are inherited +my $se_sth1 = $dbh->prepare("select mode from ?"); +ok($se_sth1->{RaiseError}); +ok($se_sth1->{ShowErrorStatement}); + +# check ShowErrorStatement ParamValues are included and sorted +$se_sth1->bind_param($_, "val$_") for (1..11); +ok( !eval { $se_sth1->execute } ); +like $@, qr/\[for Statement "select mode from \?" with ParamValues: 1='val1', 2='val2', 3='val3', 4='val4', 5='val5', 6='val6', 7='val7', 8='val8', 9='val9', 10='val10', 11='val11'\]/; + +# this test relies on the fact that ShowErrorStatement is set above +TODO: { + local $TODO = "rt66127 not fixed yet"; + eval { + local $se_sth1->{PrintError} = 0; + $se_sth1->execute(1,2); + }; + unlike($@, qr/ParamValues:/, 'error string does not contain ParamValues'); + is($se_sth1->{ParamValues}, undef, 'ParamValues is empty') + or diag(Dumper($se_sth1->{ParamValues})); +}; +# check that $dbh->{Statement} tracks last _executed_ sth +$se_sth1 = $dbh->prepare("select mode from ?"); +ok($se_sth1->{Statement} eq "select mode from ?"); +ok($dbh->{Statement} eq "select mode from ?") or print "got: $dbh->{Statement}\n"; +my $se_sth2 = $dbh->prepare("select name from ?"); +ok($se_sth2->{Statement} eq "select name from ?"); +ok($dbh->{Statement} eq "select name from ?"); +$se_sth1->execute('.'); +ok($dbh->{Statement} eq "select mode from ?"); + +# show error param values +ok(! eval { $se_sth1->execute('first','second') }); # too many params +ok($@ =~ /\b1='first'/, $@); +ok($@ =~ /\b2='second'/, $@); + +$se_sth1->finish; +$se_sth2->finish; + +$dbh->{RaiseError} = 0; +ok(!$dbh->{RaiseError}); +$dbh->{ShowErrorStatement} = 0; +ok(!$dbh->{ShowErrorStatement}); + +{ + my @warn; + local($SIG{__WARN__}) = sub { push @warn, @_ }; + $dbh->{PrintError} = 1; + ok($dbh->{PrintError}); + ok(! $dbh->selectall_arrayref("select unknown_field_name3 from ?")); + ok("@warn" =~ m/Unknown field names: unknown_field_name3/); + $dbh->{PrintError} = 0; + ok(!$dbh->{PrintError}); +} + + +print "HandleError\n"; +my $HandleErrorReturn; +my $HandleError = sub { + my $msg = sprintf "HandleError: %s [h=%s, rv=%s, #=%d]", + $_[0],$_[1],(defined($_[2])?$_[2]:'undef'),scalar(@_); + die $msg if $HandleErrorReturn < 0; + print "$msg\n"; + $_[2] = 42 if $HandleErrorReturn == 2; + return $HandleErrorReturn; +}; + +$dbh->{HandleError} = $HandleError; +ok($dbh->{HandleError}); +ok($dbh->{HandleError} == $HandleError); + +$dbh->{RaiseError} = 1; +$dbh->{PrintError} = 0; +$error_sql = "select unknown_field_name2 from ?"; + +print "HandleError -> die\n"; +$HandleErrorReturn = -1; +ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); +ok($@ =~ m/^HandleError:/, $@); + +print "HandleError -> 0 -> RaiseError\n"; +$HandleErrorReturn = 0; +ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; }); +ok($@ =~ m/^DBD::(ExampleP|Multiplex|Gofer)::db prepare failed:/, $@); + +print "HandleError -> 1 -> return (original)undef\n"; +$HandleErrorReturn = 1; +$r = eval { $csr_c = $dbh->prepare($error_sql); }; +ok(!$@, $@); +ok(!defined($r), $r); + +print "HandleError -> 2 -> return (modified)42\n"; +$HandleErrorReturn = 2; +$r = eval { $csr_c = $dbh->prepare($error_sql); }; +ok(!$@, $@); +ok($r==42) unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex + +$dbh->{HandleError} = undef; +ok(!$dbh->{HandleError}); + +{ + # dump_results; + my $sth = $dbh->prepare($std_sql); + + isa_ok($sth, "DBI::st"); + + if (length(File::Spec->updir)) { + ok($sth->execute(File::Spec->updir)); + } else { + ok($sth->execute('../')); + } + + my $dump_file = 'dumpcsr.tst'; + SKIP: { + skip "# dump_results test skipped: unable to open $dump_file: $!\n", 4 + unless open(DUMP_RESULTS, ">$dump_file"); + ok($sth->dump_results("10", "\n", ",\t", \*DUMP_RESULTS)); + close(DUMP_RESULTS) or warn "close $dump_file: $!"; + ok(-s $dump_file > 0); + is( unlink( $dump_file ), 1, "Remove $dump_file" ); + ok( !-e $dump_file, "Actually gone" ); + } + +} + +note "table_info\n"; +# First generate a list of all subdirectories +$dir = File::Basename::dirname( $INC{"DBI.pm"} ); +my $dh; +ok(opendir($dh, $dir)); +my(%dirs, %unexpected, %missing); +while (defined(my $file = readdir($dh))) { + $dirs{$file} = 1 if -d File::Spec->catdir($dir,$file); +} +note( "Local $dir subdirs: @{[ keys %dirs ]}" ); +closedir($dh); +my $sth = $dbh->table_info($dir, undef, "%", "TABLE"); +ok($sth); +%unexpected = %dirs; +%missing = (); +while (my $ref = $sth->fetchrow_hashref()) { + if (exists($unexpected{$ref->{'TABLE_NAME'}})) { + delete $unexpected{$ref->{'TABLE_NAME'}}; + } else { + $missing{$ref->{'TABLE_NAME'}} = 1; + } +} +ok(keys %unexpected == 0) + or diag "Unexpected directories: ", join(",", keys %unexpected), "\n"; +ok(keys %missing == 0) + or diag "Missing directories: ", join(",", keys %missing), "\n"; + +note "tables\n"; +my @tables_expected = ( + q{"schema"."table"}, + q{"sch-ema"."table"}, + q{"schema"."ta-ble"}, + q{"sch ema"."table"}, + q{"schema"."ta ble"}, +); +my @tables = $dbh->tables(undef, undef, "%", "VIEW"); +ok(@tables == @tables_expected, "Table count mismatch".@tables_expected." vs ".@tables); +ok($tables[$_] eq $tables_expected[$_], "$tables[$_] ne $tables_expected[$_]") + foreach (0..$#tables_expected); + +for (my $i = 0; $i < 300; $i += 100) { + note "Testing the fake directories ($i).\n"; + ok($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i")); + ok($csr_a->execute(), $DBI::errstr); + my $ary = $csr_a->fetchall_arrayref; + ok(@$ary == $i, @$ary." rows instead of $i"); + if ($i) { + my @n1 = map { $_->[0] } @$ary; + my @n2 = reverse map { "file$_" } 1..$i; + ok("@n1" eq "@n2", "'@n1' ne '@n2'"); + } + else { + ok(1); + } +} + + +SKIP: { + skip "test not tested with Multiplex", 1 + if $dbh->{mx_handle_list}; + note "Testing \$dbh->func().\n"; + my %tables; + %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables(); + my @func_tables = $dbh->func('lib', 'examplep_tables'); + foreach my $t (@func_tables) { + defined(delete $tables{$t}) or print "Unexpected table: $t\n"; + } + is(keys(%tables), 0); +} + +$dbh->disconnect; +ok(!$dbh->{Active}); +ok(!$dbh->ping, "ping should return false after disconnect"); + +1; diff --git a/t/11fetch.t b/t/11fetch.t new file mode 100644 index 0000000..5f2fedc --- /dev/null +++ b/t/11fetch.t @@ -0,0 +1,124 @@ +#!perl -w +# vim:ts=8:sw=4 +$|=1; + +use strict; + +use Test::More; +use DBI; +use Storable qw(dclone); +use Data::Dumper; + +$Data::Dumper::Indent = 1; +$Data::Dumper::Sortkeys = 1; +$Data::Dumper::Quotekeys = 0; + +plan tests => 24; + +my $dbh = DBI->connect("dbi:Sponge:foo","","", { + PrintError => 0, + RaiseError => 1, +}); + +my $source_rows = [ # data for DBD::Sponge to return via fetch + [ 41, "AAA", 9 ], + [ 41, "BBB", 9 ], + [ 42, "BBB", undef ], + [ 43, "ccc", 7 ], + [ 44, "DDD", 6 ], +]; + +sub go { + my $source = shift || $source_rows; + my $sth = $dbh->prepare("foo", { + rows => dclone($source), + NAME => [ qw(C1 C2 C3) ], + }); + ok($sth->execute(), $DBI::errstr); + return $sth; +} + +my($sth, $col0, $col1, $col2, $rows); + +# --- fetchrow_arrayref +# --- fetchrow_array +# etc etc + +# --- fetchall_hashref +my @fetchall_hashref_results = ( # single keys + C1 => { + 41 => { C1 => 41, C2 => 'BBB', C3 => 9 }, + 42 => { C1 => 42, C2 => 'BBB', C3 => undef }, + 43 => { C1 => 43, C2 => 'ccc', C3 => 7 }, + 44 => { C1 => 44, C2 => 'DDD', C3 => 6 } + }, + C2 => { + AAA => { C1 => 41, C2 => 'AAA', C3 => 9 }, + BBB => { C1 => 42, C2 => 'BBB', C3 => undef }, + DDD => { C1 => 44, C2 => 'DDD', C3 => 6 }, + ccc => { C1 => 43, C2 => 'ccc', C3 => 7 } + }, + [ 'C2' ] => { # single key within arrayref + AAA => { C1 => 41, C2 => 'AAA', C3 => 9 }, + BBB => { C1 => 42, C2 => 'BBB', C3 => undef }, + DDD => { C1 => 44, C2 => 'DDD', C3 => 6 }, + ccc => { C1 => 43, C2 => 'ccc', C3 => 7 } + }, +); +push @fetchall_hashref_results, ( # multiple keys + [ 'C1', 'C2' ] => { + '41' => { + AAA => { C1 => '41', C2 => 'AAA', C3 => 9 }, + BBB => { C1 => '41', C2 => 'BBB', C3 => 9 } + }, + '42' => { + BBB => { C1 => '42', C2 => 'BBB', C3 => undef } + }, + '43' => { + ccc => { C1 => '43', C2 => 'ccc', C3 => 7 } + }, + '44' => { + DDD => { C1 => '44', C2 => 'DDD', C3 => 6 } + } + }, +); + +my %dump; + +while (my $keyfield = shift @fetchall_hashref_results) { + my $expected = shift @fetchall_hashref_results; + my $k = (ref $keyfield) ? "[@$keyfield]" : $keyfield; + print "# fetchall_hashref($k)\n"; + ok($sth = go()); + my $result = $sth->fetchall_hashref($keyfield); + ok($result); + is_deeply($result, $expected); + # $dump{$k} = dclone $result; # just for adding tests +} + +warn Dumper \%dump if %dump; + +# test assignment to NUM_OF_FIELDS automatically alters the row buffer +$sth = go(); +my $row = $sth->fetchrow_arrayref; +is scalar @$row, 3; +is $sth->{NUM_OF_FIELDS}, 3; +is scalar @{ $sth->_get_fbav }, 3; +$sth->{NUM_OF_FIELDS} = 4; +is $sth->{NUM_OF_FIELDS}, 4; +is scalar @{ $sth->_get_fbav }, 4; +$sth->{NUM_OF_FIELDS} = 2; +is $sth->{NUM_OF_FIELDS}, 2; +is scalar @{ $sth->_get_fbav }, 2; + +$sth->finish; + + +if (0) { + my @perf = map { [ int($_/100), $_, $_ ] } 0..10000; + require Benchmark; + Benchmark::timethis(10, sub { go(\@perf)->fetchall_hashref([ 'C1','C2','C3' ]) }); +} + + +1; # end diff --git a/t/12quote.t b/t/12quote.t new file mode 100644 index 0000000..c7dc948 --- /dev/null +++ b/t/12quote.t @@ -0,0 +1,48 @@ +#!perl -w + +use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB +use strict; + +use Test::More tests => 10; + +use DBI qw(:sql_types); +use Config; +use Cwd; + +$^W = 1; +$| = 1; + +my $dbh = DBI->connect('dbi:ExampleP:', '', ''); + +sub check_quote { + # checking quote + is($dbh->quote("quote's"), "'quote''s'", '... quoting strings with embedded single quotes'); + is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as SQL_VARCHAR'); + is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as SQL_INTEGER'); + is($dbh->quote(undef), "NULL", '... quoting undef as NULL'); +} + +check_quote(); + +sub check_quote_identifier { + + is($dbh->quote_identifier('foo'), '"foo"', '... properly quotes foo as "foo"'); + is($dbh->quote_identifier('f"o'), '"f""o"', '... properly quotes f"o as "f""o"'); + is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '... properly quotes foo, bar as "foo"."bar"'); + is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '... properly quotes undef, undef, bar as "bar"'); + + is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '... properly quotes foo, undef, bar as "foo"."bar"'); + + SKIP: { + skip "Can't test alternate quote_identifier logic with DBI_AUTOPROXY", 1 + if $ENV{DBI_AUTOPROXY}; + my $qi = $dbh->{dbi_quote_identifier_cache} || die "test out of date with dbi internals?"; + $qi->[1] = '@'; # SQL_CATALOG_NAME_SEPARATOR + $qi->[2] = 2; # SQL_CATALOG_LOCATION + is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now quotes it as "bar"@"foo" after flushing cache'); + } +} + +check_quote_identifier(); + +1; diff --git a/t/13taint.t b/t/13taint.t new file mode 100644 index 0000000..4fd1076 --- /dev/null +++ b/t/13taint.t @@ -0,0 +1,133 @@ +#!perl -wT + +use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB +use DBI qw(:sql_types); +use Config; +use Cwd; +use strict; + + +$^W = 1; +$| = 1; + +require VMS::Filespec if $^O eq 'VMS'; + +use Test::More; + +# Check Taint attribute works. This requires this test to be run +# manually with the -T flag: "perl -T -Mblib t/examp.t" +sub is_tainted { + my $foo; + return ! eval { ($foo=join('',@_)), kill 0; 1; }; +} +sub mk_tainted { + my $string = shift; + return substr($string.$^X, 0, length($string)); +} + +plan skip_all => "Taint attributes not supported with DBI::PurePerl" if $DBI::PurePerl; +plan skip_all => "Taint attribute tests require taint mode (perl -T)" unless is_tainted($^X); +plan skip_all => "Taint attribute tests not functional with DBI_AUTOPROXY" if $ENV{DBI_AUTOPROXY}; + +plan tests => 36; + +# get a dir always readable on all platforms +my $dir = getcwd() || cwd(); +$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; +$dir =~ m/(.*)/; $dir = $1 || die; # untaint $dir + +my ($r, $dbh); + +$dbh = DBI->connect('dbi:ExampleP:', '', '', { PrintError=>0, RaiseError=>1, Taint => 1 }); + +my $std_sql = "select mode,size,name from ?"; +my $csr_a = $dbh->prepare($std_sql); +ok(ref $csr_a); + +ok($dbh->{'Taint'}); +ok($dbh->{'TaintIn'} == 1); +ok($dbh->{'TaintOut'} == 1); + +$dbh->{'TaintOut'} = 0; +ok($dbh->{'Taint'} == 0); +ok($dbh->{'TaintIn'} == 1); +ok($dbh->{'TaintOut'} == 0); + +$dbh->{'Taint'} = 0; +ok($dbh->{'Taint'} == 0); +ok($dbh->{'TaintIn'} == 0); +ok($dbh->{'TaintOut'} == 0); + +$dbh->{'TaintIn'} = 1; +ok($dbh->{'Taint'} == 0); +ok($dbh->{'TaintIn'} == 1); +ok($dbh->{'TaintOut'} == 0); + +$dbh->{'TaintOut'} = 1; +ok($dbh->{'Taint'} == 1); +ok($dbh->{'TaintIn'} == 1); +ok($dbh->{'TaintOut'} == 1); + +$dbh->{'Taint'} = 0; +my $st; +eval { $st = $dbh->prepare($std_sql); }; +ok(ref $st); + +ok($st->{'Taint'} == 0); + +ok($st->execute( $dir ), 'should execute ok'); + +my @row = $st->fetchrow_array; +ok(@row); + +ok(!is_tainted($row[0])); +ok(!is_tainted($row[1])); +ok(!is_tainted($row[2])); + +print "TaintIn\n"; +$st->{'TaintIn'} = 1; + +@row = $st->fetchrow_array; +ok(@row); + +ok(!is_tainted($row[0])); +ok(!is_tainted($row[1])); +ok(!is_tainted($row[2])); + +print "TaintOut\n"; +$st->{'TaintOut'} = 1; + +@row = $st->fetchrow_array; +ok(@row); + +ok(is_tainted($row[0])); +ok(is_tainted($row[1])); +ok(is_tainted($row[2])); + +$st->finish; + +my $tainted_sql = mk_tainted($std_sql); +my $tainted_dot = mk_tainted('.'); + +$dbh->{'Taint'} = $csr_a->{'Taint'} = 1; +eval { $dbh->prepare($tainted_sql); 1; }; +ok($@ =~ /Insecure dependency/, $@); +eval { $csr_a->execute($tainted_dot); 1; }; +ok($@ =~ /Insecure dependency/, $@); +undef $@; + +$dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0; + +eval { $dbh->prepare($tainted_sql); 1; }; +ok(!$@, $@); +eval { $csr_a->execute($tainted_dot); 1; }; +ok(!$@, $@); + +$csr_a->{Taint} = 0; +ok($csr_a->{Taint} == 0); + +$csr_a->finish; + +$dbh->disconnect; + +1; diff --git a/t/14utf8.t b/t/14utf8.t new file mode 100644 index 0000000..c141e38 --- /dev/null +++ b/t/14utf8.t @@ -0,0 +1,76 @@ +#!perl -w +# vim:ts=8:sw=4 +$|=1; + +use Test::More; +use DBI; + +plan skip_all => "Requires perl 5.8" + unless $] >= 5.008; + +eval { + require Storable; + import Storable qw(dclone); + require Encode; + import Encode qw(_utf8_on _utf8_off is_utf8); +}; + +plan skip_all => "Unable to load required module ($@)" + unless defined &_utf8_on; + +plan tests => 16; + +$dbh = DBI->connect("dbi:Sponge:foo","","", { + PrintError => 0, + RaiseError => 1, +}); + +my $source_rows = [ # data for DBD::Sponge to return via fetch + [ 41, "AAA", 9 ], + [ 42, "BB", undef ], + [ 43, undef, 7 ], + [ 44, "DDD", 6 ], +]; + +my($sth, $col0, $col1, $col2, $rows); + +# set utf8 on one of the columns so we can check it carries through into the +# keys of fetchrow_hashref +my @col_names = qw(Col1 Col2 Col3); +_utf8_on($col_names[1]); +ok is_utf8($col_names[1]); +ok !is_utf8($col_names[0]); + +$sth = $dbh->prepare("foo", { + rows => dclone($source_rows), + NAME => \@col_names, +}); + +ok($sth->bind_columns(\($col0, $col1, $col2)) ); +ok($sth->execute(), $DBI::errstr); + +ok $sth->fetch; +cmp_ok $col1, 'eq', "AAA"; +ok !is_utf8($col1); + +# force utf8 flag on +_utf8_on($col1); +ok is_utf8($col1); + +ok $sth->fetch; +cmp_ok $col1, 'eq', "BB"; +# XXX sadly this test doesn't detect the problem when using DBD::Sponge +# because DBD::Sponge uses $sth->_set_fbav (correctly) and that uses +# sv_setsv which doesn't have the utf8 persistence that sv_setpv does. +ok !is_utf8($col1); # utf8 flag should have been reset + +ok $sth->fetch; +ok !defined $col1; # null +ok !is_utf8($col1); # utf8 flag should have been reset + +ok my $hash = $sth->fetchrow_hashref; +ok 1 == grep { is_utf8($_) } keys %$hash; + +$sth->finish; + +# end diff --git a/t/15array.t b/t/15array.t new file mode 100644 index 0000000..2b91001 --- /dev/null +++ b/t/15array.t @@ -0,0 +1,254 @@ +#!perl -w +$|=1; + +use strict; + +use Test::More tests => 55; + +## ---------------------------------------------------------------------------- +## 15array.t +## ---------------------------------------------------------------------------- +# +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok('DBI'); +} + +# create a database handle +my $dbh = DBI->connect("dbi:Sponge:dummy", '', '', { + RaiseError => 1, + ShowErrorStatement => 1, + AutoCommit => 1 +}); + +# check that our db handle is good +isa_ok($dbh, "DBI::db"); + +my $rv; +my $rows = []; +my $tuple_status = []; +my $dumped; + +my $sth = $dbh->prepare("insert", { + rows => $rows, # where to 'insert' (push) the rows + NUM_OF_PARAMS => 4, + execute_hook => sub { # DBD::Sponge hook to make certain data trigger an error for that row + local $^W; + return $_[0]->set_err(1,"errmsg") if grep { $_ and $_ eq "B" } @_; + return 1; + } + }); + +isa_ok($sth, "DBI::st"); + +cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); + +# ----------------------------------------------- + +ok(! eval { + local $sth->{PrintError} = 0; + $sth->execute_array( + { + ArrayTupleStatus => $tuple_status + }, + [ 1, 2, 3 ], # array of integers + 42, # scalar 42 treated as array of 42's + undef, # scalar undef treated as array of undef's + [ qw(A B C) ], # array of strings + ) }, + '... execute_array should return false' +); +ok $@, 'execute_array failure with RaiseError should have died'; +like $sth->errstr, '/executing 3 generated 1 errors/'; + +cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); + +ok(eq_array( + $rows, + [ [1, 42, undef, 'A'], [3, 42, undef, 'C'] ] + ), + '... our rows are as expected'); + +ok(eq_array( + $tuple_status, + [1, [1, 'errmsg', 'S1000'], 1] + ), + '... our tuple_status is as expected'); + +# ----------------------------------------------- +# --- change one param and re-execute + +@$rows = (); +ok( $sth->bind_param_array(4, [ qw(a b c) ]), '... bind_param_array should return true'); +ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }), '... execute_array should return true'); + +cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); + +ok(eq_array( + $rows, + [ [1, 42, undef, 'a'], [2, 42, undef, 'b'], [3, 42, undef, 'c'] ] + ), + '... our rows are as expected'); + +ok(eq_array( + $tuple_status, + [1, 1, 1] + ), + '... our tuple_status is as expected'); + +# ----------------------------------------------- +# --- call execute_array in array context to get executed AND affected +@$rows = (); +my ($executed, $affected) = $sth->execute_array({ ArrayTupleStatus => $tuple_status }); +ok($executed, '... execute_array should return true'); +cmp_ok($executed, '==', 3, '... we should have executed 3 rows'); +cmp_ok($affected, '==', 3, '... we should have affected 3 rows'); + +# ----------------------------------------------- +# --- with no values for bind params, should execute zero times + +@$rows = (); +$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [], [], [], []); +ok($rv, '... execute_array should return true'); +ok(!($rv+0), '... execute_array should return 0 (but true)'); + +cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status'); + +# ----------------------------------------------- +# --- with only scalar values for bind params, should execute just once + +@$rows = (); +$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, 6, 7, 8); +cmp_ok($rv, '==', 1, '... execute_array should return 1'); + +cmp_ok(scalar @{$rows}, '==', 1, '... we should have 1 rows'); +ok(eq_array( $rows, [ [5,6,7,8] ]), '... our rows are as expected'); +cmp_ok(scalar @{$tuple_status}, '==', 1,'... we should have 1 tuple_status'); +ok(eq_array( $tuple_status, [1]), '... our tuple_status is as expected'); + +# ----------------------------------------------- +# --- with mix of scalar values and arrays only arrays control tuples + +@$rows = (); +$rv = $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 5, [], 7, 8); +cmp_ok($rv, '==', 0, '... execute_array should return 0'); + +cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status'); + +# ----------------------------------------------- +# --- catch 'undefined value' bug with zero bind values + +@$rows = (); +my $sth_other = $dbh->prepare("insert", { + rows => $rows, # where to 'insert' (push) the rows + NUM_OF_PARAMS => 1, +}); + +isa_ok($sth_other, "DBI::st"); + +$rv = $sth_other->execute_array( {}, [] ); +ok($rv, '... execute_array should return true'); +ok(!($rv+0), '... execute_array should return 0 (but true)'); +# no ArrayTupleStatus + +cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows'); + +# ----------------------------------------------- +# --- ArrayTupleFetch code-ref tests --- + +my $index = 0; + +my $fetchrow = sub { # generate 5 rows of two integer values + return if $index >= 2; + $index +=1; + # There doesn't seem any reliable way to force $index to be + # treated as a string (and so dumped as such). We just have to + # make the test case allow either 1 or '1'. + return [ $index, 'a','b','c' ]; +}; + +@$rows = (); +ok( $sth->execute_array({ + ArrayTupleFetch => $fetchrow, + ArrayTupleStatus => $tuple_status + }), '... execute_array should return true'); + +cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 2, '... we should have 2 tuple_status'); + +ok(eq_array( + $rows, + [ [1, 'a', 'b', 'c'], [2, 'a', 'b', 'c'] ] + ), + '... rows should match' +); + +ok(eq_array( + $tuple_status, + [1, 1] + ), + '... tuple_status should match' +); + +# ----------------------------------------------- +# --- ArrayTupleFetch sth tests --- + +my $fetch_sth = $dbh->prepare("foo", { + rows => [ map { [ $_,'x','y','z' ] } 7..9 ], + NUM_OF_FIELDS => 4 + }); + +isa_ok($fetch_sth, "DBI::st"); + +$fetch_sth->execute(); + +@$rows = (); + +ok( $sth->execute_array({ + ArrayTupleFetch => $fetch_sth, + ArrayTupleStatus => $tuple_status, + }), '... execute_array should return true'); + +cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows'); +cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status'); + +ok(eq_array( + $rows, + [ [7, 'x', 'y', 'z'], [8, 'x', 'y', 'z'], [9, 'x', 'y', 'z'] ] + ), + '... rows should match' +); + +ok(eq_array( + $tuple_status, + [1, 1, 1] + ), + '... tuple status should match' +); + +# ----------------------------------------------- +# --- error detection tests --- + +$sth->{RaiseError} = 0; +$sth->{PrintError} = 0; + +ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]), '... execute_array should return undef'); +is($sth->errstr, '2 bind values supplied but 4 expected', '... errstr is as expected'); + +ok(!defined $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), '... execute_array should return undef'); +is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref', '... errstr is as expected'); + +ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4), '... execute_array should return undef'); +is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a HASH', '... errstr is as expected'); + +ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array should return undef'); +is( $sth->errstr, "Can't use named placeholder ':foo' for non-driver supported bind_param_array", '... errstr is as expected'); + +$dbh->disconnect; + +1; diff --git a/t/16destroy.t b/t/16destroy.t new file mode 100644 index 0000000..a2945c4 --- /dev/null +++ b/t/16destroy.t @@ -0,0 +1,147 @@ +#!perl -w + +use strict; + +use Test::More tests => 20; + +BEGIN{ use_ok( 'DBI' ) } + +my $expect_active; + +## main Test Driver Package +{ + package DBD::Test; + + use strict; + use warnings; + + my $drh = undef; + + sub driver { + return $drh if $drh; + my ($class, $attr) = @_; + $class = "${class}::dr"; + ($drh) = DBI::_new_drh($class, { + Name => 'Test', + Version => '1.0', + }, 77 ); + return $drh; + } + + sub CLONE { undef $drh } +} + +## Test Driver +{ + package DBD::Test::dr; + + use warnings; + use Test::More; + + sub connect { # normally overridden, but a handy default + my($drh, $dbname, $user, $auth, $attrs)= @_; + my ($outer, $dbh) = DBI::_new_dbh($drh); + $dbh->STORE(Active => 1); + $dbh->STORE(AutoCommit => 1); + $dbh->STORE( $_ => $attrs->{$_}) for keys %$attrs; + return $outer; + } + + $DBD::Test::dr::imp_data_size = 0; + cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo'); +} + +## Test db package +{ + package DBD::Test::db; + + use strict; + use warnings; + use Test::More; + + $DBD::Test::db::imp_data_size = 0; + cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo'); + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; + return $dbh->SUPER::STORE($attrib, $value); + } + + sub DESTROY { + if ($expect_active < 0) { # inside child + my $self = shift; + exit $self->FETCH('Active') || 0 unless $^O eq 'MSWin32'; + + # On Win32, the forked child is actually a thread. So don't exit, + # and report failure directly. + fail 'Child should be inactive on DESTROY' if $self->FETCH('Active'); + } else { + return $expect_active + ? ok( shift->FETCH('Active'), 'Should be active in DESTROY') + : ok( !shift->FETCH('Active'), 'Should not be active in DESTROY'); + } + } +} + +my $dsn = 'dbi:ExampleP:dummy'; + +$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver() +ok my $drh = DBI->install_driver('Test'), 'Install test driver'; + +NOSETTING: { + # Try defaults. + ok my $dbh = $drh->connect, 'Connect to test driver'; + ok $dbh->{Active}, 'Should start active'; + $expect_active = 1; +} + +IAD: { + # Try InactiveDestroy. + ok my $dbh = $drh->connect($dsn, '', '', { InactiveDestroy => 1 }), + 'Create with ActiveDestroy'; + ok $dbh->{InactiveDestroy}, 'InactiveDestroy should be set'; + ok $dbh->{Active}, 'Should start active'; + $expect_active = 0; +} + +AIAD: { + # Try AutoInactiveDestroy. + ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }), + 'Create with AutoInactiveDestroy'; + ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set'; + ok $dbh->{Active}, 'Should start active'; + $expect_active = 1; +} + +FORK: { + # Try AutoInactiveDestroy and fork. + ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }), + 'Create with AutoInactiveDestroy again'; + ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set'; + ok $dbh->{Active}, 'Should start active'; + + my $pid = eval { fork() }; + if (not defined $pid) { + chomp $@; + my $msg = "AutoInactiveDestroy destroy test skipped"; + diag "$msg because $@\n"; + pass $msg; # in lieu of the child status test + } + elsif ($pid) { + # parent. + $expect_active = 1; + wait; + ok $? == 0, 'Child should be inactive on DESTROY'; + } else { + # child. + $expect_active = -1; + } +} diff --git a/t/19fhtrace.t b/t/19fhtrace.t new file mode 100644 index 0000000..d310db4 --- /dev/null +++ b/t/19fhtrace.t @@ -0,0 +1,306 @@ +#!perl -w +# vim:sw=4:ts=8 + +use strict; + +use Test::More tests => 27; + +## ---------------------------------------------------------------------------- +## 09trace.t +## ---------------------------------------------------------------------------- +# +## ---------------------------------------------------------------------------- + +BEGIN { + use_ok( 'DBI' ); +} + +$|=1; + +our $fancylogfn = "fancylog$$.log"; +our $trace_file = "dbitrace$$.log"; + +# Clean up when we're done. +END { 1 while unlink $fancylogfn; + 1 while unlink $trace_file; }; + +package PerlIO::via::TraceDBI; + +our $logline; + +sub OPEN { + return 1; +} + +sub PUSHED +{ + my ($class,$mode,$fh) = @_; + # When writing we buffer the data + my $buf = ''; + return bless \$buf,$class; +} + +sub FILL +{ + my ($obj,$fh) = @_; + return $logline; +} + +sub READLINE +{ + my ($obj,$fh) = @_; + return $logline; +} + +sub WRITE +{ + my ($obj,$buf,$fh) = @_; +# print "\n*** WRITING $buf\n"; + $logline = $buf; + return length($buf); +} + +sub FLUSH +{ + my ($obj,$fh) = @_; + return 0; +} + +sub CLOSE { +# print "\n*** CLOSING!!!\n"; + $logline = "**** CERRADO! ***"; + return -1; +} + +1; + +package PerlIO::via::MyFancyLogLayer; + +sub OPEN { + my ($obj, $path, $mode, $fh) = @_; + $$obj = $path; + return 1; +} + +sub PUSHED +{ + my ($class,$mode,$fh) = @_; + # When writing we buffer the data + my $logger; + return bless \$logger,$class; +} + +sub WRITE +{ + my ($obj,$buf,$fh) = @_; + $$obj->log($buf); + return length($buf); +} + +sub FLUSH +{ + my ($obj,$fh) = @_; + return 0; +} + +sub CLOSE { + my $self = shift; + $$self->close(); + return 0; +} + +1; + +package MyFancyLogger; + +use Symbol qw(gensym); + +sub new +{ + my $self = {}; + my $fh = gensym(); + open $fh, '>', $fancylogfn; + $self->{_fh} = $fh; + $self->{_buf} = ''; + return bless $self, shift; +} + +sub log +{ + my $self = shift; + my $fh = $self->{_fh}; + $self->{_buf} .= shift; + 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; + +package main; + +## ---------------------------------------------------------------------------- +# Connect to the example driver. + +my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '', + { PrintError => 0, + RaiseError => 1, + PrintWarn => 1, + }); +isa_ok( $dbh, 'DBI::db' ); + +# Clean up when we're done. +END { $dbh->disconnect if $dbh }; + +## ---------------------------------------------------------------------------- +# Check the database handle attributes. + +cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute'); + +1 while unlink $trace_file; + +my $tracefd; +## ---------------------------------------------------------------------------- +# First use regular filehandle +open $tracefd, '>>', $trace_file; + +my $oldfd = select($tracefd); +$| = 1; +select $oldfd; + +ok(-f $trace_file, '... regular fh: trace file successfully created'); + +$dbh->trace(2, $tracefd); +ok( 1, '... regular fh: filehandle successfully set'); + +# +# read current size of file +# +my $filesz = (stat $tracefd)[7]; +$dbh->trace_msg("First logline\n", 1); +# +# read new file size and verify its different +# +my $newfsz = (stat $tracefd)[7]; +SKIP: { + skip 'on VMS autoflush using select does not work', 1 if $^O eq 'VMS'; + ok(($filesz != $newfsz), '... regular fh: trace_msg'); +} + +$dbh->trace(undef, "STDOUT"); # close $trace_file +ok(-f $trace_file, '... regular fh: file successfully changed'); + +$filesz = (stat $tracefd)[7]; +$dbh->trace_msg("Next logline\n"); +# +# read new file size and verify its same +# +$newfsz = (stat $tracefd)[7]; +ok(($filesz == $newfsz), '... regular fh: trace_msg after changing trace output'); + +#1 while unlink $trace_file; + +$dbh->trace(0); # disable trace + +{ # Open trace to glob. started failing in perl-5.10 + my $tf = "foo.log"; + 1 while unlink $tf; + 1 while unlink "*main::FOO"; + 1 while unlink "*main::STDERR"; + is (-f $tf, undef, "Tracefile removed"); + ok (open (FOO, ">", $tf), "Tracefile FOO opened"); + ok (-f $tf, "Tracefile created"); + DBI->trace (1, *FOO); + is (-f "*main::FOO", undef, "Regression test"); + DBI->trace_msg ("foo\n", 1); + DBI->trace (0, *STDERR); + close FOO; + open my $fh, "<", $tf; + is ((<$fh>)[-1], "foo\n", "Traced message"); + close $fh; + is (-f "*main::STDERR", undef, "Regression test"); + 1 while unlink $tf; + } + +SKIP: { + eval { require 5.008; }; + skip "Layered I/O not available in Perl $^V", 13 + if $@; +## ---------------------------------------------------------------------------- +# Then use layered filehandle +# +open TRACEFD, '+>:via(TraceDBI)', 'layeredtrace.out'; +print TRACEFD "*** Test our layer\n"; +my $result = <TRACEFD>; +is $result, "*** Test our layer\n", "... layered fh: file is layered: $result\n"; + +$dbh->trace(1, \*TRACEFD); +ok( 1, '... layered fh: filehandle successfully set'); + +$dbh->trace_msg("Layered logline\n", 1); + +$result = <TRACEFD>; +is $result, "Layered logline\n", "... layered fh: trace_msg: $result\n"; + +$dbh->trace(1, "STDOUT"); # close $trace_file +$result = <TRACEFD>; +is $result, "Layered logline\n", "... layered fh: close doesn't close: $result\n"; + +$dbh->trace_msg("Next logline\n", 1); +$result = <TRACEFD>; +is $result, "Layered logline\n", "... layered fh: trace_msg after change trace output: $result\n"; + +## ---------------------------------------------------------------------------- +# Then use scalar filehandle +# +my $tracestr; +open TRACEFD, '+>:scalar', \$tracestr; +print TRACEFD "*** Test our layer\n"; +ok 1, "... scalar trace: file is layered: $tracestr\n"; + +$dbh->trace(1, \*TRACEFD); +ok 1, '... scalar trace: filehandle successfully set'; + +$dbh->trace_msg("Layered logline\n", 1); +ok 1, "... scalar trace: $tracestr\n"; + +$dbh->trace(1, "STDOUT"); # close $trace_file +ok 1, "... scalar trace: close doesn't close: $tracestr\n"; + +$dbh->trace_msg("Next logline\n", 1); +ok 1, "... scalar trace: after change trace output: $tracestr\n"; + +## ---------------------------------------------------------------------------- +# Then use fancy logger +# +open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new(); + +$dbh->trace('SQL', $fh); + +$dbh->trace_msg("Layered logline\n", 1); +ok 1, "... logger: trace_msg\n"; + +$dbh->trace(1, "STDOUT"); # close $trace_file +ok 1, "... logger: close doesn't close\n"; + +$dbh->trace_msg("Next logline\n", 1); +ok 1, "... logger: trace_msg after change trace output\n"; + +close $fh; + +} + +1; + +# end diff --git a/t/20meta.t b/t/20meta.t new file mode 100644 index 0000000..a8d609e --- /dev/null +++ b/t/20meta.t @@ -0,0 +1,32 @@ +#!perl -w + +use strict; +use Test::More tests => 8; + +$|=1; +$^W=1; + +BEGIN { use_ok( 'DBI', ':sql_types' ) } +BEGIN { use_ok( 'DBI::DBD::Metadata' ) } # just to check for syntax errors etc + +my $dbh = DBI->connect("dbi:ExampleP:.","","", { FetchHashKeyName => 'NAME_lc' }) + or die "Unable to connect to ExampleP driver: $DBI::errstr"; + +isa_ok($dbh, 'DBI::db'); +#$dbh->trace(3); + +#use Data::Dumper; +#print Dumper($dbh->type_info_all); +#print Dumper($dbh->type_info); +#print Dumper($dbh->type_info(DBI::SQL_INTEGER)); + +my @ti = $dbh->type_info; +ok(@ti>0); + +is($dbh->type_info(SQL_INTEGER)->{DATA_TYPE}, SQL_INTEGER); +is($dbh->type_info(SQL_INTEGER)->{TYPE_NAME}, 'INTEGER'); + +is($dbh->type_info(SQL_VARCHAR)->{DATA_TYPE}, SQL_VARCHAR); +is($dbh->type_info(SQL_VARCHAR)->{TYPE_NAME}, 'VARCHAR'); + +1; diff --git a/t/30subclass.t b/t/30subclass.t new file mode 100644 index 0000000..3217a9e --- /dev/null +++ b/t/30subclass.t @@ -0,0 +1,182 @@ +#!perl -w + +use strict; + +$|=1; +$^W=1; + +my $calls = 0; +my %my_methods; + + +# ================================================= +# Example code for sub classing the DBI. +# +# Note that the extra ::db and ::st classes must be set up +# as sub classes of the corresponding DBI classes. +# +# This whole mechanism is new and experimental - it may change! + +package MyDBI; +@MyDBI::ISA = qw(DBI); + +# the MyDBI::dr::connect method is NOT called! +# you can either override MyDBI::connect() +# or use MyDBI::db::connected() + +package MyDBI::db; +@MyDBI::db::ISA = qw(DBI::db); + +sub prepare { + my($dbh, @args) = @_; + ++$my_methods{prepare}; + ++$calls; + my $sth = $dbh->SUPER::prepare(@args); + return $sth; +} + + +package MyDBI::st; +@MyDBI::st::ISA = qw(DBI::st); + +sub fetch { + my($sth, @args) = @_; + ++$my_methods{fetch}; + ++$calls; + # this is just to trigger (re)STORE on exit to test that the STORE + # doesn't clear any erro condition + local $sth->{Taint} = 0; + my $row = $sth->SUPER::fetch(@args); + if ($row) { + # modify fetched data as an example + $row->[1] = lc($row->[1]); + + # also demonstrate calling set_err() + return $sth->set_err(1,"Don't be so negative",undef,"fetch") + if $row->[0] < 0; + # ... and providing alternate results + # (although typically would trap and hide and error from SUPER::fetch) + return $sth->set_err(2,"Don't exagerate",undef, undef, [ 42,"zz",0 ]) + if $row->[0] > 42; + } + return $row; +} + + +# ================================================= +package main; + +use Test::More tests => 43; + +BEGIN { + use_ok( 'DBI' ); +} + +my $tmp; + +#DBI->trace(2); +my $dbh = MyDBI->connect("dbi:Sponge:foo","","", { + PrintError => 0, + RaiseError => 1, + CompatMode => 1, # just for clone test +}); +isa_ok($dbh, 'MyDBI::db'); +is($dbh->{CompatMode}, 1); +undef $dbh; + +$dbh = DBI->connect("dbi:Sponge:foo","","", { + PrintError => 0, + RaiseError => 1, + RootClass => "MyDBI", + CompatMode => 1, # just for clone test + dbi_foo => 1, # just to help debugging clone etc +}); +isa_ok( $dbh, 'MyDBI::db'); +is($dbh->{CompatMode}, 1); + +#$dbh->trace(5); +my $sth = $dbh->prepare("foo", + # data for DBD::Sponge to return via fetch + { rows => [ + [ 40, "AAA", 9 ], + [ 41, "BB", 8 ], + [ -1, "C", 7 ], + [ 49, "DD", 6 ] + ], + } +); + +is($calls, 1); +isa_ok($sth, 'MyDBI::st'); + +my $row = $sth->fetch; +is($calls, 2); +is($row->[1], "aaa"); + +$row = $sth->fetch; +is($calls, 3); +is($row->[1], "bb"); + +is($DBI::err, undef); +$row = eval { $sth->fetch }; +my $eval_err = $@; +is(!defined $row, 1); +is(substr($eval_err,0,50), "DBD::Sponge::st fetch failed: Don't be so negative"); + +#$sth->trace(5); +#$sth->{PrintError} = 1; +$sth->{RaiseError} = 0; +$row = eval { $sth->fetch }; +isa_ok($row, 'ARRAY'); +is($row->[0], 42); +is($DBI::err, 2); +like($DBI::errstr, qr/Don't exagerate/); +is($@ =~ /Don't be so negative/, $@); + + +my $dbh2 = $dbh->clone; +isa_ok( $dbh2, 'MyDBI::db', "Clone A" ); +is($dbh2 != $dbh, 1); +is($dbh2->{CompatMode}, 1); + +my $dbh3 = $dbh->clone({}); +isa_ok( $dbh3, 'MyDBI::db', 'Clone B' ); +is($dbh3 != $dbh, 1); +is($dbh3 != $dbh2, 1); +isa_ok( $dbh3, 'MyDBI::db'); +is($dbh3->{CompatMode}, 1); + +my $dbh2c = $dbh2->clone; +isa_ok( $dbh2c, 'MyDBI::db', "Clone of clone A" ); +is($dbh2c != $dbh2, 1); +is($dbh2c->{CompatMode}, 1); + +my $dbh3c = $dbh3->clone({ CompatMode => 0 }); +isa_ok( $dbh3c, 'MyDBI::db', 'Clone of clone B' ); +is((grep { $dbh3c == $_ } $dbh, $dbh2, $dbh3), 0); +isa_ok( $dbh3c, 'MyDBI::db'); +ok(!$dbh3c->{CompatMode}); + +$tmp = $dbh->sponge_test_installed_method('foo','bar'); +isa_ok( $tmp, "ARRAY", "installed method" ); +is_deeply( $tmp, [qw( foo bar )] ); +$tmp = eval { $dbh->sponge_test_installed_method() }; +is(!$tmp, 1); +is($dbh->err, 42); +is($dbh->errstr, "not enough parameters"); + + +$dbh = eval { DBI->connect("dbi:Sponge:foo","","", { + RootClass => 'nonesuch1', PrintError => 0, RaiseError => 0, }); +}; +ok( !defined($dbh), "Failed connect #1" ); +is(substr($@,0,25), "Can't locate nonesuch1.pm"); + +$dbh = eval { nonesuch2->connect("dbi:Sponge:foo","","", { + PrintError => 0, RaiseError => 0, }); +}; +ok( !defined($dbh), "Failed connect #2" ); +is(substr($@,0,36), q{Can't locate object method "connect"}); + +print "@{[ %my_methods ]}\n"; +1; diff --git a/t/31methcache.t b/t/31methcache.t new file mode 100644 index 0000000..2ffd0a5 --- /dev/null +++ b/t/31methcache.t @@ -0,0 +1,153 @@ +#!perl -w +# +# check that the inner-method lookup cache works +# (or rather, check that it doesn't cache things when it shouldn't) + +BEGIN { eval "use threads;" } # Must be first +my $use_threads_err = $@; +use Config qw(%Config); +# With this test code and threads, 5.8.1 has issues with freeing freed +# scalars, while 5.8.9 doesn't; I don't know about in-between - DAPM +my $has_threads = $Config{useithreads}; +die $use_threads_err if $has_threads && $use_threads_err; + + +use strict; + +$|=1; +$^W=1; + + + +use Test::More tests => 49; + +BEGIN { + use_ok( 'DBI' ); +} + +sub new_handle { + my $dbh = DBI->connect("dbi:Sponge:foo","","", { + PrintError => 0, + RaiseError => 1, + }); + + my $sth = $dbh->prepare("foo", + # data for DBD::Sponge to return via fetch + { rows => + [ + [ "row0" ], + [ "row1" ], + [ "row2" ], + [ "row3" ], + [ "row4" ], + [ "row5" ], + [ "row6" ], + ], + } + ); + + return ($dbh, $sth); +} + + +sub Foo::local1 { [ "local1" ] }; +sub Foo::local2 { [ "local2" ] }; + + +my $fetch_hook; +{ + package Bar; + @Bar::ISA = qw(DBD::_::st); + sub fetch { &$fetch_hook }; +} + +sub run_tests { + my ($desc, $dbh, $sth) = @_; + my $row = $sth->fetch; + is($row->[0], "row0", "$desc row0"); + + { + # replace CV slot + no warnings 'redefine'; + local *DBD::Sponge::st::fetch = sub { [ "local0" ] }; + $row = $sth->fetch; + is($row->[0], "local0", "$desc local0"); + } + $row = $sth->fetch; + is($row->[0], "row1", "$desc row1"); + + { + # replace GP + local *DBD::Sponge::st::fetch = *Foo::local1; + $row = $sth->fetch; + is($row->[0], "local1", "$desc local1"); + } + $row = $sth->fetch; + is($row->[0], "row2", "$desc row2"); + + { + # replace GV + local $DBD::Sponge::st::{fetch} = *Foo::local2; + $row = $sth->fetch; + is($row->[0], "local2", "$desc local2"); + } + $row = $sth->fetch; + is($row->[0], "row3", "$desc row3"); + + { + # @ISA = NoSuchPackage + local $DBD::Sponge::st::{fetch}; + local @DBD::Sponge::st::ISA = qw(NoSuchPackage); + eval { local $SIG{__WARN__} = sub {}; $row = $sth->fetch }; + like($@, qr/Can't locate DBI object method/, "$desc locate DBI object"); + } + $row = $sth->fetch; + is($row->[0], "row4", "$desc row4"); + + { + # @ISA = Bar + $fetch_hook = \&DBD::Sponge::st::fetch; + local $DBD::Sponge::st::{fetch}; + local @DBD::Sponge::st::ISA = qw(Bar); + $row = $sth->fetch; + is($row->[0], "row5", "$desc row5"); + $fetch_hook = sub { [ "local3" ] }; + $row = $sth->fetch; + is($row->[0], "local3", "$desc local3"); + } + $row = $sth->fetch; + is($row->[0], "row6", "$desc row6"); +} + +run_tests("plain", new_handle()); + + +SKIP: { + skip "no threads / perl < 5.8.9", 12 unless $has_threads; + # only enable this when handles are allowed to be shared across threads + #{ + # my @h = new_handle(); + # threads->new(sub { run_tests("threads", @h) })->join; + #} + threads->new(sub { run_tests("threads-h", new_handle()) })->join; +}; + +# using weaken attaches magic to the CV; see whether this interferes +# with the cache magic + +use Scalar::Util qw(weaken); +my $fetch_ref = \&DBI::st::fetch; +weaken $fetch_ref; +run_tests("magic", new_handle()); + +SKIP: { + skip "no threads / perl < 5.8.9", 12 unless $has_threads; + # only enable this when handles are allowed to be shared across threads + #{ + # my @h = new_handle(); + # threads->new(sub { run_tests("threads", @h) })->join; + #} + threads->new(sub { run_tests("magic threads-h", new_handle()) })->join; +}; + +1; diff --git a/t/35thrclone.t b/t/35thrclone.t new file mode 100644 index 0000000..b2678e9 --- /dev/null +++ b/t/35thrclone.t @@ -0,0 +1,81 @@ +#!perl -w +$|=1; + +# --- Test DBI support for threads created after the DBI was loaded + +BEGIN { eval "use threads;" } # Must be first +my $use_threads_err = $@; + +use strict; +use Config qw(%Config); +use Test::More; + +BEGIN { + if (!$Config{useithreads} || $] < 5.008001) { + plan skip_all => "this $^O perl $] not supported for DBI iThreads"; + } + die $use_threads_err if $use_threads_err; # need threads +} + +my $threads = 4; +plan tests => 4 + 4 * $threads; + +{ + package threads_sub; + use base qw(threads); +} + +use_ok('DBI'); + +$DBI::PurePerl = $DBI::PurePerl; # just to silence used only once warning +$DBI::neat_maxlen = 12345; +cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was successful'); + +my @connect_args = ("dbi:ExampleP:", '', ''); + +my $dbh_parent = DBI->connect_cached(@connect_args); +isa_ok( $dbh_parent, 'DBI::db' ); + +# this our function for the threads to run + +sub testing { + cmp_ok($DBI::neat_maxlen, '==', 12345, '... DBI::neat_maxlen still holding its value'); + + my $dbh = DBI->connect_cached(@connect_args); + isa_ok( $dbh, 'DBI::db' ); + isnt($dbh, $dbh_parent, '... new $dbh is not the same instance as $dbh_parent'); + + SKIP: { + # skip seems broken with threads (5.8.3) + # skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($dbh->{Driver}->{Kids}, '==', 1, '... the Driver has one Kid') + unless $DBI::PurePerl && ok(1); + } + + # RT #77137: a thread created from a thread was crashing the + # interpreter + + threads->new(sub {})->join(); +} + +# load up the threads + +my @thr; +push @thr, threads_sub->create( \&testing ) + or die "thread->create failed ($!)" + foreach (1..$threads); + +# join all the threads + +foreach my $thread (@thr) { + $thread->join; + + # provide a little insurance against thread scheduling issues (hopefully) + # http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4369660.html + eval { select undef, undef, undef, 0.2 }; +} + +pass('... all tests have passed'); + +1; diff --git a/t/40profile.t b/t/40profile.t new file mode 100644 index 0000000..5cb0023 --- /dev/null +++ b/t/40profile.t @@ -0,0 +1,485 @@ +#!perl -w +$|=1; + +# +# test script for DBI::Profile +# + +use strict; + +use Config; +use DBI::Profile; +use DBI qw(dbi_time); +use Data::Dumper; +use File::Spec; +use Storable qw(dclone); + +use Test::More; + +BEGIN { + plan skip_all => "profiling not supported for DBI::PurePerl" + if $DBI::PurePerl; + + # tie methods (STORE/FETCH etc) get called different number of times + plan skip_all => "test results assume perl >= 5.8.2" + if $] <= 5.008001; + + # clock instability on xen systems is a reasonably common cause of failure + # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html + # so we'll skip automated testing on those systems + plan skip_all => "skipping profile tests on xen (due to clock instability)" + if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 + and $ENV{AUTOMATED_TESTING}; + + plan tests => 60; +} + +$Data::Dumper::Indent = 1; +$Data::Dumper::Terse = 1; + +# log file to store profile results +my $LOG_FILE = "profile$$.log"; +my $orig_dbi_debug = $DBI::dbi_debug; +DBI->trace($DBI::dbi_debug, $LOG_FILE); +END { + return if $orig_dbi_debug; + 1 while unlink $LOG_FILE; +} + + +print "Test enabling the profile\n"; + +# make sure profiling starts disabled +my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +ok($dbh, 'connect'); +ok(!$dbh->{Profile} && !$ENV{DBI_PROFILE}, 'Profile and DBI_PROFILE not set'); + + +# can turn it on after the fact using a path number +$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +$dbh->{Profile} = "4"; +is_deeply sanitize_tree($dbh->{Profile}), bless { + 'Path' => [ '!MethodName' ], +} => 'DBI::Profile'; + +# using a package name +$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +$dbh->{Profile} = "/DBI::Profile"; +is_deeply sanitize_tree($dbh->{Profile}), bless { + 'Path' => [ ], +} => 'DBI::Profile'; + +# using a combined path and name +$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +$dbh->{Profile} = "20/DBI::Profile"; +is_deeply sanitize_tree($dbh->{Profile}), bless { + 'Path' => [ '!MethodName', '!Caller2' ], +} => 'DBI::Profile'; + +my $t_file = __FILE__; +$dbh->do("set foo=1"); my $line = __LINE__; +my $expected_caller = "40profile.t line $line"; +$expected_caller .= " via ${1}40profile.t line 4" + if $0 =~ /(zv\w+_)/; +print Dumper($dbh->{Profile}); +is_deeply sanitize_tree($dbh->{Profile}), bless { + 'Path' => [ '!MethodName', '!Caller2' ], + 'Data' => { 'do' => { + $expected_caller => [ 1, 0, 0, 0, 0, 0, 0 ] + } } +} => 'DBI::Profile' + or warn Dumper $dbh->{Profile}; + + +# can turn it on at connect +$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>6 }); +is_deeply $dbh->{Profile}{Path}, [ '!Statement', '!MethodName' ]; +cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 1, 'on at connect, 1 key'); +cmp_ok(keys %{ $dbh->{Profile}{Data}{""} }, '>=', 1, 'on at connect, 1 key'); # at least STORE +ok(ref $dbh->{Profile}{Data}{""}{STORE}, 'STORE is ref'); + +print "dbi_profile\n"; +# Try to avoid rounding problem on double precision systems +# $got->[5] = '1150962858.01596498' +# $expected->[5] = '1150962858.015965' +# by treating as a string (because is_deeply stringifies) +my $t1 = DBI::dbi_time() . ""; +my $dummy_statement = "Hi mom"; +my $dummy_methname = "my_method_name"; +my $leaf = dbi_profile($dbh, $dummy_statement, $dummy_methname, $t1, $t1 + 1); +print Dumper($dbh->{Profile}); +cmp_ok(keys %{ $dbh->{Profile}{Data} }, '==', 2, 'avoid rounding, 1 key'); +cmp_ok(keys %{ $dbh->{Profile}{Data}{$dummy_statement} }, '==', 1, + 'avoid rounding, 1 dummy statement'); +is(ref($dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}), 'ARRAY', + 'dummy method name is array'); + +ok $leaf, "should return ref to leaf node"; +is ref $leaf, 'ARRAY', "should return ref to leaf node"; + +my $mine = $dbh->{Profile}{Data}{$dummy_statement}{$dummy_methname}; + +is $leaf, $mine, "should return ref to correct leaf node"; + +print "@$mine\n"; +is_deeply $mine, [ 1, 1, 1, 1, 1, $t1, $t1 ]; + +my $t2 = DBI::dbi_time() . ""; +dbi_profile($dbh, $dummy_statement, $dummy_methname, $t2, $t2 + 2); +print "@$mine\n"; +is_deeply $mine, [ 2, 3, 1, 1, 2, $t1, $t2 ]; + + +print "Test collected profile data\n"; + +$dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1, Profile=>2 }); +# do a (hopefully) measurable amount of work +my $sql = "select mode,size,name from ?"; +my $sth = $dbh->prepare($sql); +for my $loop (1..50) { # enough work for low-res timers or v.fast cpus + $sth->execute("."); + while ( my $hash = $sth->fetchrow_hashref ) {} +} +$dbh->do("set foo=1"); + +print Dumper($dbh->{Profile}); + +# check that the proper key was set in Data +my $data = $dbh->{Profile}{Data}{$sql}; +ok($data, 'profile data'); +is(ref $data, 'ARRAY', 'ARRAY ref'); +ok(@$data == 7, '7 elements'); +ok((grep { defined($_) } @$data) == 7, 'all 7 defined'); +ok((grep { DBI::looks_like_number($_) } @$data) == 7, 'all 7 numeric'); +my ($count, $total, $first, $shortest, $longest, $time1, $time2) = @$data; +ok($count > 3, 'count is 3'); +ok($total > $first, ' total > first'); +ok($total > $longest, 'total > longest') or + warn "total $total > longest $longest: failed\n"; +ok($longest > 0, 'longest > 0') or + warn "longest $longest > 0: failed\n"; # XXX theoretically not reliable +ok($longest > $shortest, 'longest > shortest'); +ok($time1 >= $^T, 'time1 later than start time'); +ok($time2 >= $^T, 'time2 later than start time'); +ok($time1 <= $time2, 'time1 <= time2'); +my $next = int(dbi_time()) + 1; +ok($next > $time1, 'next > time1') or + warn "next $next > first $time1: failed\n"; +ok($next > $time2, 'next > time2') or + warn "next $next > last $time2: failed\n"; +if ($shortest < 0) { + my $sys = "$Config{archname} $Config{osvers}"; # ie sparc-linux 2.4.20-2.3sparcsmp + warn <<EOT; +Time went backwards at some point during the test on this $sys system! +Perhaps you have time sync software (like NTP) that adjusted the clock +by more than $shortest seconds during the test. +Also some multiprocessor systems, and some virtualization systems can exhibit +this kind of clock behaviour. Please retry. +EOT + # don't treat small negative values as failure + $shortest = 0 if $shortest > -0.008; +} + + +my $tmp = sanitize_tree($dbh->{Profile}); +$tmp->{Data}{$sql}[0] = -1; # make test insensitive to local file count +is_deeply $tmp, (bless { + 'Path' => [ '!Statement' ], + 'Data' => { + '' => [ 6, 0, 0, 0, 0, 0, 0 ], + $sql => [ -1, 0, 0, 0, 0, 0, 0 ], + 'set foo=1' => [ 1, 0, 0, 0, 0, 0, 0 ], + } +} => 'DBI::Profile'), 'profile'; + +print "Test profile format\n"; +my $output = $dbh->{Profile}->format(); +print "Profile Output\n$output"; + +# check that output was produced in the expected format +ok(length $output, 'non zero length'); +ok($output =~ /^DBI::Profile:/, 'DBI::Profile'); +ok($output =~ /\((\d+) calls\)/, 'some calls'); +ok($1 >= $count, 'calls >= count'); + +# ----------------------------------------------------------------------------------- + +# try statement and method name and reference-to-scalar path +my $by_reference = 'foo'; +$dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', { + RaiseError => 1, + Profile => { Path => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ] } +}); +$sql = "select name from ."; +$sth = $dbh->prepare($sql); +$sth->execute(); +$sth->fetchrow_hashref; +$by_reference = 'bar'; +$sth->finish; +undef $sth; # DESTROY + +$tmp = sanitize_tree($dbh->{Profile}); +ok $tmp->{Data}{usrnam}{""}{foo}{STORE}, 'username stored'; +$tmp->{Data}{usrnam}{""}{foo} = {}; +# make test insentitive to number of local files +#warn Dumper($tmp); +is_deeply $tmp, bless { + 'Path' => [ '{Username}', '!Statement', \$by_reference, '!MethodName' ], + 'Data' => { + '' => { # because Profile was enabled by DBI just before Username was set + '' => { + 'foo' => { + 'STORE' => [ 3, 0, 0, 0, 0, 0, 0 ], + } + } + }, + 'usrnam' => { + '' => { + 'foo' => { }, + }, + 'select name from .' => { + 'foo' => { + 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ], + }, + 'bar' => { + 'DESTROY' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ], + }, + }, + }, + }, +} => 'DBI::Profile'; + +$tmp = [ $dbh->{Profile}->as_node_path_list() ]; +is @$tmp, 8, 'should have 8 nodes'; +sanitize_profile_data_nodes($_->[0]) for @$tmp; +#warn Dumper($dbh->{Profile}->{Data}); +is_deeply $tmp, [ + [ [ 3, 0, 0, 0, 0, 0, 0 ], '', '', 'foo', 'STORE' ], + [ [ 2, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'STORE' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', '', 'foo', 'connected' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'DESTROY' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'bar', 'finish' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'execute' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'fetchrow_hashref' ], + [ [ 1, 0, 0, 0, 0, 0, 0 ], 'usrnam', 'select name from .', 'foo', 'prepare' ] +]; + + +print "testing '!File', '!Caller' and their variants in Path\n"; + +$dbh->{Profile}->{Path} = [ '!File', '!File2', '!Caller', '!Caller2' ]; +$dbh->{Profile}->{Data} = undef; + +my $file = (File::Spec->splitpath(__FILE__))[2]; # '40profile.t' +my ($line1, $line2); +sub a_sub { + $sth = $dbh->prepare("select name from ."); $line2 = __LINE__; +} +a_sub(); $line1 = __LINE__; + +$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data}); +#warn Dumper($tmp); +is_deeply $tmp, { + "$file" => { + "$file via $file" => { + "$file line $line2" => { + "$file line $line2 via $file line $line1" => [ 1, 0, 0, 0, 0, 0, 0 ] + } + } + } +}; + + +print "testing '!Time' and variants in Path\n"; + +undef $sth; +my $factor = 1_000_000; +$dbh->{Profile}->{Path} = [ '!Time', "!Time~$factor", '!MethodName' ]; +$dbh->{Profile}->{Data} = undef; + +# give up a timeslice in the hope that the following few lines +# run in well under a second even of slow/overloaded systems +$t1 = int(dbi_time())+1; 1 while int(dbi_time()-0.01) < $t1; # spin till just after second starts +$t2 = int($t1/$factor)*$factor; + +$sth = $dbh->prepare("select name from ."); +$tmp = sanitize_profile_data_nodes($dbh->{Profile}{Data}); + +# if actual "!Time" recorded is 'close enough' then we'll pass +# the test - it's not worth failing just because a system is slow +$t1 = (keys %$tmp)[0] if (abs($t1 - (keys %$tmp)[0]) <= 5); + +is_deeply $tmp, { + $t1 => { $t2 => { prepare => [ 1, 0, 0, 0, 0, 0, 0 ] }} +}, "!Time and !Time~$factor should work" + or warn Dumper([$t1, $t2, $tmp]); + + +print "testing &norm_std_n3 in Path\n"; + +$dbh->{Profile} = '&norm_std_n3'; # assign as string to get magic +is_deeply $dbh->{Profile}{Path}, [ + \&DBI::ProfileSubs::norm_std_n3 +]; +$dbh->{Profile}->{Data} = undef; +$sql = qq{insert into foo20060726 (a,b) values (42,"foo")}; +dbi_profile( { foo => $dbh, bar => undef }, $sql, 'mymethod', 100000000, 100000002); +$tmp = $dbh->{Profile}{Data}; +#warn Dumper($tmp); +is_deeply $tmp, { + 'insert into foo<N> (a,b) values (<N>,"<S>")' => [ 1, '2', '2', '2', '2', '100000000', '100000000' ] +}, '&norm_std_n3 should normalize statement'; + + +# ----------------------------------------------------------------------------------- + +print "testing code ref in Path\n"; + +sub run_test1 { + my ($profile) = @_; + $dbh = DBI->connect("dbi:ExampleP:", 'usrnam', '', { + RaiseError => 1, + Profile => $profile, + }); + $sql = "select name from ."; + $sth = $dbh->prepare($sql); + $sth->execute(); + $sth->fetchrow_hashref; + $sth->finish; + undef $sth; # DESTROY + my $data = sanitize_profile_data_nodes($dbh->{Profile}{Data}, 1); + return ($data, $dbh) if wantarray; + return $data; +} + +$tmp = run_test1( { Path => [ 'foo', sub { 'bar' }, 'baz' ] }); +is_deeply $tmp, { 'foo' => { 'bar' => { 'baz' => [ 11, 0,0,0,0,0,0 ] } } }; + +$tmp = run_test1( { Path => [ 'foo', sub { 'ping','pong' } ] }); +is_deeply $tmp, { 'foo' => { 'ping' => { 'pong' => [ 11, 0,0,0,0,0,0 ] } } }; + +$tmp = run_test1( { Path => [ 'foo', sub { \undef } ] }); +is_deeply $tmp, { 'foo' => undef }, 'should be vetoed'; + +# check what code ref sees in $_ +$tmp = run_test1( { Path => [ sub { $_ } ] }); +is_deeply $tmp, { + '' => [ 6, 0, 0, 0, 0, 0, 0 ], + 'select name from .' => [ 5, 0, 0, 0, 0, 0, 0 ] +}, '$_ should contain statement'; + +# check what code ref sees in @_ +$tmp = run_test1( { Path => [ sub { my ($h,$method) = @_; return \undef if $method =~ /^[A-Z]+$/; return (ref $h, $method) } ] }); +is_deeply $tmp, { + 'DBI::db' => { + 'connected' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'prepare' => [ 1, 0, 0, 0, 0, 0, 0 ], + }, + 'DBI::st' => { + 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'execute' => [ 1, 0, 0, 0, 0, 0, 0 ], + 'finish' => [ 1, 0, 0, 0, 0, 0, 0 ], + }, +}, 'should have @_ as keys'; + +# check we can filter by method +$tmp = run_test1( { Path => [ sub { return \undef unless $_[1] =~ /^fetch/; return $_[1] } ] }); +#warn Dumper($tmp); +is_deeply $tmp, { + 'fetchrow_hashref' => [ 1, 0, 0, 0, 0, 0, 0 ], +}, 'should be able to filter by method'; + +DBI->trace(0, "STDOUT"); # close current log to flush it +ok(-s $LOG_FILE, 'output should go to log file'); + +# ----------------------------------------------------------------------------------- + +print "testing as_text\n"; + +# check %N$ indices +$dbh->{Profile}->{Data} = { P1 => { P2 => [ 100, 400, 42, 43, 44, 45, 46, 47 ] } }; +my $as_text = $dbh->{Profile}->as_text({ + path => [ 'top' ], + separator => ':', + format => '%1$s %2$d [ %10$d %11$d %12$d %13$d %14$d %15$d %16$d %17$d ]', +}); +is($as_text, "top:P1:P2 4 [ 100 400 42 43 44 45 46 47 ]", 'as_text'); + +# test sortsub +$dbh->{Profile}->{Data} = { + A => { Z => [ 101, 1, 2, 3, 4, 5, 6, 7 ] }, + B => { Y => [ 102, 1, 2, 3, 4, 5, 6, 7 ] }, +}; +$as_text = $dbh->{Profile}->as_text({ + separator => ':', + format => '%1$s %10$d ', + sortsub => sub { my $ary=shift; @$ary = sort { $a->[2] cmp $b->[2] } @$ary } +}); +is($as_text, "B:Y 102 A:Z 101 ", 'as_text sortsub'); + +# general test, including defaults +($tmp, $dbh) = run_test1( { Path => [ 'foo', '!MethodName', 'baz' ] }); +$as_text = $dbh->{Profile}->as_text(); +$as_text =~ s/\.00+/.0/g; +#warn "[$as_text]"; +is $as_text, q{foo > DESTROY > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > STORE > baz: 0.0s / 5 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > connected > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > execute > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > fetchrow_hashref > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > finish > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +foo > prepare > baz: 0.0s / 1 = 0.0s avg (first 0.0s, min 0.0s, max 0.0s) +}, 'as_text general'; + +# ----------------------------------------------------------------------------------- + +print "dbi_profile_merge_nodes\n"; +my $total_time = dbi_profile_merge_nodes( + my $totals=[], + [ 10, 0.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ], + [ 15, 0.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ], +); +$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues +is("@$totals", "25.00 0.93 0.11 0.01 0.23 1023110000.00 1023110010.00", + 'merged nodes'); +is($total_time, 0.93, 'merged time'); + +$total_time = dbi_profile_merge_nodes( + $totals=[], { + foo => [ 10, 1.51, 0.11, 0.01, 0.22, 1023110000, 1023110010 ], + bar => [ 17, 1.42, 0.12, 0.02, 0.23, 1023110005, 1023110009 ], + } +); +$_ = sprintf "%.2f", $_ for @$totals; # avoid precision issues +is("@$totals", "27.00 2.93 0.11 0.01 0.23 1023110000.00 1023110010.00", + 'merged time foo/bar'); +is($total_time, 2.93, 'merged nodes foo/bar time'); + +exit 0; + + +sub sanitize_tree { + my $data = shift; + my $skip_clone = shift; + return $data unless ref $data; + $data = dclone($data) unless $skip_clone; + sanitize_profile_data_nodes($data->{Data}) if $data->{Data}; + return $data; +} + +sub sanitize_profile_data_nodes { + my $node = shift; + if (ref $node eq 'HASH') { + sanitize_profile_data_nodes($_) for values %$node; + } + elsif (ref $node eq 'ARRAY') { + if (@$node == 7 and DBI::looks_like_number($node->[0])) { + # sanitize the profile data node to simplify tests + $_ = 0 for @{$node}[1..@$node-1]; # not 0 + } + } + return $node; +} diff --git a/t/41prof_dump.t b/t/41prof_dump.t new file mode 100644 index 0000000..c921893 --- /dev/null +++ b/t/41prof_dump.t @@ -0,0 +1,105 @@ +#!perl -wl +# Using -l to ensure ProfileDumper is isolated from changes to $/ and $\ and such + +$|=1; + +use strict; + +# +# test script for DBI::ProfileDumper +# + +use DBI; +use Config; +use Test::More; + +BEGIN { + plan skip_all => 'profiling not supported for DBI::PurePerl' + if $DBI::PurePerl; + + # clock instability on xen systems is a reasonably common cause of failure + # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html + # so we'll skip automated testing on those systems + plan skip_all => "skipping profile tests on xen (due to clock instability)" + if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 + and $ENV{AUTOMATED_TESTING}; + + plan tests => 15; +} + +BEGIN { + use_ok( 'DBI' ); + use_ok( 'DBI::ProfileDumper' ); +} + +my $prof_file = "dbi$$.prof"; +my $prof_backup = $prof_file . ".prev"; +END { 1 while unlink $prof_file; + 1 while unlink $prof_backup; } + +my $dbh = DBI->connect("dbi:ExampleP:", '', '', + { RaiseError=>1, Profile=>"2/DBI::ProfileDumper/File:$prof_file" }); +isa_ok( $dbh, 'DBI::db' ); +isa_ok( $dbh->{Profile}, "DBI::ProfileDumper" ); +isa_ok( $dbh->{Profile}{Data}, 'HASH' ); +isa_ok( $dbh->{Profile}{Path}, 'ARRAY' ); + +# do a little work +my $sql = "select mode,size,name from ?"; +my $sth = $dbh->prepare($sql); +isa_ok( $sth, 'DBI::st' ); +$sth->execute("."); + +# check that flush_to_disk doesn't change Path if Path is undef (it +# did before 1.49) +{ + local $dbh->{Profile}->{Path} = undef; + $sth->{Profile}->flush_to_disk(); + is($dbh->{Profile}->{Path}, undef); +} + +$sth->{Profile}->flush_to_disk(); +while ( my $hash = $sth->fetchrow_hashref ) {} + +# force output +undef $sth; +$dbh->disconnect; +undef $dbh; + +# wrote the profile to disk? +ok( -s $prof_file, 'Profile is on disk and nonzero size' ); + +# XXX We're breaking encapsulation here +open(PROF, $prof_file) or die $!; +my @prof = <PROF>; +close PROF; + +print @prof; + +# has a header? +like( $prof[0], '/^DBI::ProfileDumper\s+([\d.]+)/', 'Found a version number' ); + +# version matches VERSION? (DBI::ProfileDumper uses $self->VERSION so +# it's a stringified version object that looks like N.N.N) +$prof[0] =~ /^DBI::ProfileDumper\s+([\d.]+)/; +is( $1, DBI::ProfileDumper->VERSION, "Version numbers match in $prof[0]" ); + +like( $prof[1], qr{^Path\s+=\s+\[\s+\]}, 'Found the Path'); +ok( $prof[2] =~ m{^Program\s+=\s+(\S+)}, 'Found the Program'); + +# check that expected key is there +like(join('', @prof), qr/\+\s+1\s+\Q$sql\E/m); + +# unlink($prof_file); # now done by 'make clean' + +# should be able to load DBI::ProfileDumper::Apache outside apache +# this also naturally checks for syntax errors etc. +SKIP: { + skip "developer-only test", 1 + unless (-d ".svn" || -d ".git") && -f "MANIFEST.SKIP"; + skip "Apache module not installed", 1 + unless eval { require Apache }; + require_ok('DBI::ProfileDumper::Apache') +} + +1; diff --git a/t/42prof_data.t b/t/42prof_data.t new file mode 100644 index 0000000..f9ce4a3 --- /dev/null +++ b/t/42prof_data.t @@ -0,0 +1,150 @@ +#!perl -w +$|=1; + +use strict; + +use DBI; +use Config; +use Test::More; +use Data::Dumper; + +BEGIN { + plan skip_all => 'profiling not supported for DBI::PurePerl' + if $DBI::PurePerl; + + # clock instability on xen systems is a reasonably common cause of failure + # http://www.nntp.perl.org/group/perl.cpan.testers/2009/05/msg3828158.html + # so we'll skip automated testing on those systems + plan skip_all => "skipping profile tests on xen (due to clock instability)" + if $Config{osvers} =~ /xen/ # eg 2.6.18-4-xen-amd64 + and $ENV{AUTOMATED_TESTING}; + + plan tests => 31; +} + +BEGIN { + use_ok( 'DBI::ProfileDumper' ); + use_ok( 'DBI::ProfileData' ); +} + +my $sql = "select mode,size,name from ?"; + +my $prof_file = "dbi$$.prof"; +my $prof_backup = $prof_file . ".prev"; +END { 1 while unlink $prof_file; + 1 while unlink $prof_backup; } + +my $dbh = DBI->connect("dbi:ExampleP:", '', '', + { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); +isa_ok( $dbh, 'DBI::db', 'Created connection' ); + +# do a little work, but enough to ensure we don't get 0's on systems with low res timers +foreach (1..6) { + $dbh->do("set dummy=$_"); + my $sth = $dbh->prepare($sql); + for my $loop (1..50) { + $sth->execute("."); + $sth->fetchrow_hashref; + $sth->finish; + } + $sth->{Profile}->flush_to_disk(); +} +$dbh->disconnect; +undef $dbh; + + +# wrote the profile to disk? +ok(-s $prof_file, "Profile written to disk, non-zero size" ); + +# load up +my $prof = DBI::ProfileData->new( + File => $prof_file, + Filter => sub { + my ($path_ref, $data_ref) = @_; + $path_ref->[0] =~ s/set dummy=\d/set dummy=N/; + }, +); +isa_ok( $prof, 'DBI::ProfileData' ); +cmp_ok( $prof->count, '>=', 3, 'At least 3 profile data items' ); + +# try a few sorts +my $nodes = $prof->nodes; +$prof->sort(field => "longest"); +my $longest = $nodes->[0][4]; +ok($longest); +$prof->sort(field => "longest", reverse => 1); +cmp_ok( $nodes->[0][4], '<', $longest ); + +$prof->sort(field => "count"); +my $most = $nodes->[0]; +ok($most); +$prof->sort(field => "count", reverse => 1); +cmp_ok( $nodes->[0][0], '<', $most->[0] ); + +# remove the top count and make sure it's gone +my $clone = $prof->clone(); +isa_ok( $clone, 'DBI::ProfileData' ); +$clone->sort(field => "count"); +ok($clone->exclude(key1 => $most->[7])); + +# compare keys of the new first element and the old one to make sure +# exclude works +ok($clone->nodes()->[0][7] ne $most->[7] && + $clone->nodes()->[0][8] ne $most->[8]); + +# there can only be one +$clone = $prof->clone(); +isa_ok( $clone, 'DBI::ProfileData' ); +ok($clone->match(key1 => $clone->nodes->[0][7])); +ok($clone->match(key2 => $clone->nodes->[0][8])); +ok($clone->count == 1); + +# take a look through Data +my $Data = $prof->Data; +print "SQL: $_\n" for keys %$Data; +ok(exists($Data->{$sql}), "Data for '$sql' should exist") + or print Dumper($Data); +ok(exists($Data->{$sql}{execute}), "Data for '$sql'->{execute} should exist"); + +# did the Filter convert set dummy=1 (etc) into set dummy=N? +ok(exists($Data->{"set dummy=N"})); + +# test escaping of \n and \r in keys +$dbh = DBI->connect("dbi:ExampleP:", '', '', + { RaiseError=>1, Profile=>"6/DBI::ProfileDumper/File:$prof_file" }); +isa_ok( $dbh, 'DBI::db', 'Created connection' ); + +my $sql2 = 'select size from . where name = "LITERAL: \r\n"'; +my $sql3 = "select size from . where name = \"EXPANDED: \r\n\""; + +# do a little work +foreach (1,2,3) { + my $sth2 = $dbh->prepare($sql2); + isa_ok( $sth2, 'DBI::st' ); + $sth2->execute(); + $sth2->fetchrow_hashref; + $sth2->finish; + my $sth3 = $dbh->prepare($sql3); + isa_ok( $sth3, 'DBI::st' ); + $sth3->execute(); + $sth3->fetchrow_hashref; + $sth3->finish; +} +$dbh->disconnect; +undef $dbh; + +# load dbi.prof +$prof = DBI::ProfileData->new( File => $prof_file, DeleteFiles => 1 ); +isa_ok( $prof, 'DBI::ProfileData' ); + +ok(not(-e $prof_file), "file should be deleted when DeleteFiles set" ); + + +# make sure the keys didn't get garbled +$Data = $prof->Data; +ok(exists $Data->{$sql2}, "Data for '$sql2' should exist") + or print Dumper($Data); +ok(exists $Data->{$sql3}, "Data for '$sql3' should exist") + or print Dumper($Data); + +1; diff --git a/t/43prof_env.t b/t/43prof_env.t new file mode 100644 index 0000000..6726cf7 --- /dev/null +++ b/t/43prof_env.t @@ -0,0 +1,52 @@ +#!perl -w +$|=1; + +use strict; + +# +# test script for using DBI_PROFILE env var to enable DBI::Profile +# and testing non-ref assignments to $h->{Profile} +# + +BEGIN { $ENV{DBI_PROFILE} = 6 } # prior to use DBI + +use DBI; +use DBI::Profile; +use Config; +use Data::Dumper; + +BEGIN { + if ($DBI::PurePerl) { + print "1..0 # Skipped: profiling not supported for DBI::PurePerl\n"; + exit 0; + } +} + +use Test::More tests => 11; + +DBI->trace(0, "STDOUT"); + +my $dbh1 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +is(ref $dbh1->{Profile}, "DBI::Profile"); +is(ref $dbh1->{Profile}{Data}, 'HASH'); +is(ref $dbh1->{Profile}{Path}, 'ARRAY'); + +my $dbh2 = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); +is(ref $dbh2->{Profile}, "DBI::Profile"); +is(ref $dbh2->{Profile}{Data}, 'HASH'); +is(ref $dbh2->{Profile}{Path}, 'ARRAY'); + +is $dbh1->{Profile}, $dbh2->{Profile}, '$h->{Profile} should be shared'; + +$dbh1->do("set dummy=1"); +$dbh1->do("set dummy=2"); + +my $profile = $dbh1->{Profile}; + +my $p_data = $profile->{Data}; +is keys %$p_data, 3; # '', $sql1, $sql2 +ok $p_data->{''}; +ok $p_data->{"set dummy=1"}; +ok $p_data->{"set dummy=2"}; + +__END__ diff --git a/t/48dbi_dbd_sqlengine.t b/t/48dbi_dbd_sqlengine.t new file mode 100644 index 0000000..c916d51 --- /dev/null +++ b/t/48dbi_dbd_sqlengine.t @@ -0,0 +1,81 @@ +#!perl -w +$|=1; + +use strict; + +use Cwd; +use File::Path; +use File::Spec; +use Test::More; + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; + +my $tbl; +BEGIN { $tbl = "db_". $$ . "_" }; +#END { $tbl and unlink glob "${tbl}*" } + +use_ok ("DBI"); +use_ok ("DBI::DBD::SqlEngine"); +use_ok ("DBD::File"); + +my $sql_statement = DBI::DBD::SqlEngine::Statement->isa('SQL::Statement'); +my $dbh = DBI->connect( "DBI:File:", undef, undef, { PrintError => 0, RaiseError => 0, } ); # Can't use DBI::DBD::SqlEngine direct + +for my $sql ( split "\n", <<"" ) + CREATE TABLE foo (id INT, foo TEXT) + CREATE TABLE bar (id INT, baz TEXT) + INSERT INTO foo VALUES (1, "Hello world") + INSERT INTO bar VALUES (1, "Bugfixes welcome") + INSERT bar VALUES (2, "Bug reports, too") + SELECT foo FROM foo where ID=1 + UPDATE bar SET id=5 WHERE baz="Bugfixes welcome" + DELETE FROM foo + DELETE FROM bar WHERE baz="Bugfixes welcome" + +{ + my $sth; + $sql =~ s/^\s+//; + eval { $sth = $dbh->prepare( $sql ); }; + ok( $sth, "prepare '$sql'" ); +} + +for my $line ( split "\n", <<"" ) + Junk -- Junk + CREATE foo (id INT, foo TEXT) -- missing table + INSERT INTO bar (1, "Bugfixes welcome") -- missing "VALUES" + UPDATE bar id=5 WHERE baz="Bugfixes welcome" -- missing "SET" + DELETE * FROM foo -- waste between "DELETE" and "FROM" + +{ + my $sth; + $line =~ s/^\s+//; + my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ ); + eval { $sth = $dbh->prepare( $sql ); }; + ok( !$sth, "$test: prepare '$sql'" ); +} + +SKIP: { + # some SQL::Statement / SQL::Parser related tests + skip( "Not running with SQL::Statement", 3 ) unless ($sql_statement); + for my $line ( split "\n", <<"" ) + Junk -- Junk + CREATE TABLE bar (id INT, baz CHARACTER VARYING(255)) -- invalid column type + + { + my $sth; + $line =~ s/^\s+//; + my ($sql, $test) = ( $line =~ m/^([^-]+)\s+--\s+(.*)$/ ); + eval { $sth = $dbh->prepare( $sql ); }; + ok( !$sth, "$test: prepare '$sql'" ); + } + + my $dbh2 = DBI->connect( "DBI:File:", undef, undef, { sql_dialect => "ANSI" } ); + my $sth; + eval { $sth = $dbh2->prepare( "CREATE TABLE foo (id INTEGER PRIMARY KEY, phrase CHARACTER VARYING(40) UNIQUE)" ); }; + ok( $sth, "prepared statement using ANSI dialect" ); + skip( "Gofer proxy prevents fetching embedded SQL::Parser object", 1 ); + my $sql_parser = $dbh2->FETCH("sql_parser_object"); + cmp_ok( $sql_parser->dialect(), "eq", "ANSI", "SQL::Parser has 'ANSI' as dialect" ); +} + +done_testing (); diff --git a/t/49dbd_file.t b/t/49dbd_file.t new file mode 100644 index 0000000..0c64328 --- /dev/null +++ b/t/49dbd_file.t @@ -0,0 +1,174 @@ +#!perl -w +$|=1; + +use strict; + +use Cwd; +use File::Path; +use File::Spec; +use Test::More; + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; + +my $tbl; +BEGIN { $tbl = "db_". $$ . "_" }; +#END { $tbl and unlink glob "${tbl}*" } + +use_ok ("DBI"); +use_ok ("DBD::File"); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my $rowidx = 0; +my @rows = ( [ "Hello World" ], [ "Hello DBI Developers" ], ); + +my $dbh; + +# Check if we can connect at all +ok ($dbh = DBI->connect ("dbi:File:"), "Connect clean"); +is (ref $dbh, "DBI::db", "Can connect to DBD::File driver"); + +my $f_versions = $dbh->func ("f_versions"); +note $f_versions; +ok ($f_versions, "f_versions"); + +# Check if all the basic DBI attributes are accepted +ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { + RaiseError => 1, + PrintError => 1, + AutoCommit => 1, + ChopBlanks => 1, + ShowErrorStatement => 1, + FetchHashKeyName => "NAME_lc", + }), "Connect with DBI attributes"); + +# Check if all the f_ attributes are accepted, in two ways +ok ($dbh = DBI->connect ("dbi:File:f_ext=.txt;f_dir=.;f_encoding=cp1252;f_schema=test"), "Connect with driver attributes in DSN"); + +my $encoding = "iso-8859-1"; + +# now use dir to prove file existence +ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { + f_ext => ".txt", + f_dir => $dir, + f_schema => undef, + f_encoding => $encoding, + f_lock => 0, + + RaiseError => 0, + PrintError => 0, + }), "Connect with driver attributes in hash"); + +my $sth; +ok ($sth = $dbh->prepare ("select * from t_sbdgf_53442Gz"), "Prepare select from non-existing file"); + +{ my @msg; + eval { + local $SIG{__DIE__} = sub { push @msg, @_ }; + $sth->execute; + }; + like ("@msg", qr{Cannot open .*t_sbdgf_}, "Cannot open non-existing file"); + eval { + note $dbh->f_get_meta ("t_sbdgf_53442Gz", "f_fqfn"); + }; + } + +SKIP: { + my $fh; + my $tbl2 = $tbl . "2"; + + my $tbl2_file1 = File::Spec->catfile ($dir, "$tbl2.txt"); + open $fh, ">", $tbl2_file1 or skip; + print $fh "You cannot read this anyway ..."; + close $fh; + + my $tbl2_file2 = File::Spec->catfile ($dir, "$tbl2"); + open $fh, ">", $tbl2_file2 or skip; + print $fh "Neither that"; + close $fh; + + ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (first file)"); + ok (! -f $tbl2_file1, "$tbl2_file1 removed"); + ok ( -f $tbl2_file2, "$tbl2_file2 exists"); + ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (second file)"); + ok (! -f $tbl2_file2, "$tbl2_file2 removed"); + } + +my @tfhl; + +# Now test some basic SQL statements +my $tbl_file = File::Spec->catfile (Cwd::abs_path( $dir ), "$tbl.txt"); +ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or diag $dbh->errstr; +ok (-f $tbl_file, "Test table exists"); + +is ($dbh->f_get_meta ($tbl, "f_fqfn"), $tbl_file, "get single table meta data"); +is_deeply ($dbh->f_get_meta ([$tbl, "t_sbdgf_53442Gz"], [qw(f_dir f_ext)]), + { + $tbl => { + f_dir => $dir, + f_ext => ".txt", + }, + t_sbdgf_53442Gz => { + f_dir => $dir, + f_ext => ".txt", + }, + }, + "get multiple meta data"); + +# Expected: ("unix", "perlio", "encoding(iso-8859-1)") +# use Data::Peek; DDumper [ @tfh ]; +my @layer = grep { $_ eq "encoding($encoding)" } @tfhl; +is (scalar @layer, 1, "encoding shows in layer"); + +SKIP: { + $using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 4; + ok ($dbh->f_set_meta ($tbl, "f_dir", $dir), "set single meta datum"); + is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set single meta datum"); + ok ($dbh->f_set_meta ($tbl, { f_dir => $dir }), "set multiple meta data"); + is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set multiple meta attributes"); + } + +ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl"); +$rowidx = 0; +SKIP: { + $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; + ok ($sth->execute, "execute on $tbl"); + $dbh->errstr and diag; + } + +my $uctbl = uc($tbl); +ok ($sth = $dbh->prepare ("select * from $uctbl"), "Prepare select * from $uctbl"); +$rowidx = 0; +SKIP: { + $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; + ok ($sth->execute, "execute on $uctbl"); + $dbh->errstr and diag; + } + +ok ($dbh->do ("drop table $tbl"), "table drop"); +is (-s "$tbl.txt", undef, "Test table removed"); + +done_testing (); + +sub DBD::File::Table::fetch_row ($$) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + if ($rowidx >= scalar @rows) { + $self->{row} = undef; + } + else { + $self->{row} = $rows[$rowidx++]; + } + return $self->{row}; + } # fetch_row + +sub DBD::File::Table::push_names ($$$) +{ + my ($self, $data, $row_aryref) = @_; + my $meta = $self->{meta}; + @tfhl = PerlIO::get_layers ($meta->{fh}); + @{$meta->{col_names}} = @{$row_aryref}; + } # push_names diff --git a/t/50dbm_simple.t b/t/50dbm_simple.t new file mode 100755 index 0000000..e176161 --- /dev/null +++ b/t/50dbm_simple.t @@ -0,0 +1,264 @@ +#!perl -w +$|=1; + +use strict; +use warnings; + +require DBD::DBM; + +use File::Path; +use File::Spec; +use Test::More; +use Cwd; +use Config qw(%Config); +use Storable qw(dclone); + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; + +use DBI; +use vars qw( @mldbm_types @dbm_types ); + +BEGIN { + + # 0=SQL::Statement if avail, 1=DBI::SQL::Nano + # next line forces use of Nano rather than default behaviour + # $ENV{DBI_SQL_NANO}=1; + # This is done in zv*n*_50dbm_simple.t + + push @mldbm_types, ''; + if (eval { require 'MLDBM.pm'; }) { + push @mldbm_types, qw(Data::Dumper Storable); # both in CORE + push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' }; + push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; }; + push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; + } + + # Potential DBM modules in preference order (SDBM_File first) + # skip NDBM and ODBM as they don't support EXISTS + my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File); + my @use_dbms = @ARGV; + if( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) { + @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS}; + } + + if (lc "@use_dbms" eq "all") { + # test with as many of the major DBM types as are available + @dbm_types = grep { eval { local $^W; require "$_.pm" } } @dbms; + } + elsif (@use_dbms) { + @dbm_types = @use_dbms; + } + else { + # we only test SDBM_File by default to avoid tripping up + # on any broken DBM's that may be installed in odd places. + # It's only DBD::DBM we're trying to test here. + # (However, if SDBM_File is not available, then use another.) + for my $dbm (@dbms) { + if (eval { local $^W; require "$dbm.pm" }) { + @dbm_types = ($dbm); + last; + } + } + } + + if( eval { require List::MoreUtils; } ) + { + List::MoreUtils->import("part"); + } + else + { + # XXX from PP part of List::MoreUtils + eval <<'EOP'; +sub part(&@) { + my ($code, @list) = @_; + my @parts; + push @{ $parts[$code->($_)] }, $_ for @list; + return @parts; +} +EOP + } +} + +my $dbi_sql_nano = not DBD::DBM::Statement->isa('SQL::Statement'); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my %tests_statement_results = ( + 2 => [ + "DROP TABLE IF EXISTS fruit", -1, + "CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))", '0E0', + "INSERT INTO fruit VALUES (1,'oranges' )", 1, + "INSERT INTO fruit VALUES (2,'to_change' )", 1, + "INSERT INTO fruit VALUES (3, NULL )", 1, + "INSERT INTO fruit VALUES (4,'to delete' )", 1, + "INSERT INTO fruit VALUES (?,?); #5,via placeholders", 1, + "INSERT INTO fruit VALUES (6,'to delete' )", 1, + "INSERT INTO fruit VALUES (7,'to_delete' )", 1, + "DELETE FROM fruit WHERE dVal='to delete'", 2, + "UPDATE fruit SET dVal='apples' WHERE dKey=2", 1, + "DELETE FROM fruit WHERE dKey=7", 1, + "SELECT * FROM fruit ORDER BY dKey DESC", [ + [ 5, 'via placeholders' ], + [ 3, '' ], + [ 2, 'apples' ], + [ 1, 'oranges' ], + ], + "DELETE FROM fruit", 4, + $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM fruit", [ [ 0 ] ] ), + "DROP TABLE fruit", -1, + ], + 3 => [ + "DROP TABLE IF EXISTS multi_fruit", -1, + "CREATE TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT)", '0E0', + "INSERT INTO multi_fruit VALUES (1,'oranges' , 11 )", 1, + "INSERT INTO multi_fruit VALUES (2,'to_change', 0 )", 1, + "INSERT INTO multi_fruit VALUES (3, NULL , 13 )", 1, + "INSERT INTO multi_fruit VALUES (4,'to_delete', 14 )", 1, + "INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15", 1, + "INSERT INTO multi_fruit VALUES (6,'to_delete', 16 )", 1, + "INSERT INTO multi_fruit VALUES (7,'to delete', 17 )", 1, + "INSERT INTO multi_fruit VALUES (8,'to remove', 18 )", 1, + "UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2", 1, + "DELETE FROM multi_fruit WHERE dVal='to_delete'", 2, + "DELETE FROM multi_fruit WHERE qux=17", 1, + "DELETE FROM multi_fruit WHERE dKey=8", 1, + "SELECT * FROM multi_fruit ORDER BY dKey DESC", [ + [ 5, 'via placeholders', 15 ], + [ 3, undef, 13 ], + [ 2, 'apples', 12 ], + [ 1, 'oranges', 11 ], + ], + "DELETE FROM multi_fruit", 4, + $dbi_sql_nano ? () : ( "SELECT COUNT(*) FROM multi_fruit", [ [ 0 ] ] ), + "DROP TABLE multi_fruit", -1, + ], +); + +print "Using DBM modules: @dbm_types\n"; +print "Using MLDBM serializers: @mldbm_types\n" if @mldbm_types; + +my %test_statements; +my %expected_results; + +for my $columns ( 2 .. 3 ) +{ + my $i = 0; + my @tests = part { $i++ % 2 } @{ $tests_statement_results{$columns} }; + @{ $test_statements{$columns} } = @{$tests[0]}; + @{ $expected_results{$columns} } = @{$tests[1]}; +} + +unless (@dbm_types) { + plan skip_all => "No DBM modules available"; +} + +for my $mldbm ( @mldbm_types ) { + my $columns = ($mldbm) ? 3 : 2; + for my $dbm_type ( @dbm_types ) { + print "\n--- Using $dbm_type ($mldbm) ---\n"; + eval { do_test( $dbm_type, $mldbm, $columns) } + or warn $@; + } +} + +done_testing(); + +sub do_test { + my ($dtype, $mldbm, $columns) = @_; + + #diag ("Starting test: " . $starting_test_no); + + # The DBI can't test locking here, sadly, because of the risk it'll hang + # on systems with broken NFS locking daemons. + # (This test script doesn't test that locking actually works anyway.) + + # use f_lockfile in next release - use it here as test case only + my $dsn ="dbi:DBM(RaiseError=0,PrintError=1):dbm_type=$dtype;dbm_mldbm=$mldbm;dbm_lockfile=.lck"; + + if ($using_dbd_gofer) { + $dsn .= ";f_dir=$dir"; + } + + my $dbh = DBI->connect( $dsn ); + + my $dbm_versions; + if ($DBI::VERSION >= 1.37 # needed for install_method + && !$ENV{DBI_AUTOPROXY} # can't transparently proxy driver-private methods + ) { + $dbm_versions = $dbh->dbm_versions; + } + else { + $dbm_versions = $dbh->func('dbm_versions'); + } + note $dbm_versions; + ok($dbm_versions, 'dbm_versions'); + isa_ok($dbh, 'DBI::db'); + + # test if it correctly accepts valid $dbh attributes + SKIP: { + skip "Can't set attributes after connect using DBD::Gofer", 2 + if $using_dbd_gofer; + eval {$dbh->{f_dir}=$dir}; + ok(!$@); + eval {$dbh->{dbm_mldbm}=$mldbm}; + ok(!$@); + } + + # test if it correctly rejects invalid $dbh attributes + # + eval { + local $SIG{__WARN__} = sub { } if $using_dbd_gofer; + local $dbh->{RaiseError} = 1; + local $dbh->{PrintError} = 0; + $dbh->{dbm_bad_name}=1; + }; + ok($@); + + my @queries = @{$test_statements{$columns}}; + my @results = @{$expected_results{$columns}}; + + SKIP: + for my $idx ( 0 .. $#queries ) { + my $sql = $queries[$idx]; + $sql =~ s/\S*fruit/${dtype}_fruit/; # include dbm type in table name + $sql =~ s/;$//; + #diag($sql); + + # XXX FIX INSERT with NULL VALUE WHEN COLUMN NOT NULLABLE + $dtype eq 'BerkeleyDB' and !$mldbm and 0 == index($sql, 'INSERT') and $sql =~ s/NULL/''/; + + $sql =~ s/\s*;\s*(?:#(.*))//; + my $comment = $1; + + my $sth = $dbh->prepare($sql); + ok($sth, "prepare $sql") or diag($dbh->errstr || 'unknown error'); + + my @bind; + if($sth->{NUM_OF_PARAMS}) + { + @bind = split /,/, $comment; + } + # if execute errors we will handle it, not PrintError: + $sth->{PrintError} = 0; + my $n = $sth->execute(@bind); + ok($n, 'execute') or diag($sth->errstr || 'unknown error'); + next if (!defined($n)); + + is( $n, $results[$idx], $sql ) unless( 'ARRAY' eq ref $results[$idx] ); + TODO: { + local $TODO = "AUTOPROXY drivers might throw away sth->rows()" if($ENV{DBI_AUTOPROXY}); + is( $n, $sth->rows, '$sth->execute(' . $sql . ') == $sth->rows' ) if( $sql =~ m/^(?:UPDATE|DELETE)/ ); + } + next unless $sql =~ /SELECT/; + my $results=''; + my $allrows = $sth->fetchall_arrayref(); + my $expected_rows = $results[$idx]; + is( $sth->rows, scalar( @{$expected_rows} ), $sql ); + is_deeply( $allrows, $expected_rows, 'SELECT results' ); + } + $dbh->disconnect; + return 1; +} +1; diff --git a/t/51dbm_file.t b/t/51dbm_file.t new file mode 100644 index 0000000..4b97288 --- /dev/null +++ b/t/51dbm_file.t @@ -0,0 +1,130 @@ +#!perl -w +$| = 1; + +use strict; +use warnings; + +use File::Copy (); +use File::Path; +use File::Spec (); +use Test::More; + +my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; + +use DBI; + +do "t/lib.pl"; + +my $dir = test_dir(); + +my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { + f_dir => $dir, + sql_identifier_case => 1, # SQL_IC_UPPER + } +); + +ok( $dbh->do(q/drop table if exists FRED/), 'drop table' ); + +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; + +$dbh->do(q/create table fred (a integer, b integer)/); +ok( -f File::Spec->catfile( $dir, "FRED$dirfext" ), "FRED$dirfext exists" ); + +rmtree $dir; +mkpath $dir; + +if ($using_dbd_gofer) +{ + # can't modify attributes when connect through a Gofer instance + $dbh->disconnect(); + $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { + f_dir => $dir, + sql_identifier_case => 2, # SQL_IC_LOWER + } + ); +} +else +{ + $dbh->dbm_clear_meta('fred'); # otherwise the col_names are still known! + $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER +} + +$dbh->do(q/create table FRED (a integer, b integer)/); +ok( -f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext exists" ); + +my $tblfext; +unless( $using_dbd_gofer ) +{ + $tblfext = $dbh->{dbm_tables}->{fred}->{f_ext} || ''; + $tblfext =~ s{/r$}{}; + ok( -f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext exists" ); +} + +ok( $dbh->do(q/insert into fRED (a,b) values(1,2)/), 'insert into mixed case table' ); + +# but change fRED to FRED and it works. + +ok( $dbh->do(q/insert into FRED (a,b) values(2,1)/), 'insert into uppercase table' ); + +unless ($using_dbd_gofer) +{ + my $fn_tbl2 = $dbh->{dbm_tables}->{fred}->{f_fqfn}; + $fn_tbl2 =~ s/fred(\.[^.]*)?$/freddy$1/; + my @dbfiles = grep { -f $_ } ( + $dbh->{dbm_tables}->{fred}->{f_fqfn}, + $dbh->{dbm_tables}->{fred}->{f_fqln}, + $dbh->{dbm_tables}->{fred}->{f_fqbn} . ".dir" + ); + foreach my $fn (@dbfiles) + { + my $tgt_fn = $fn; + $tgt_fn =~ s/fred(\.[^.]*)?$/freddy$1/; + File::Copy::copy( $fn, $tgt_fn ); + } + $dbh->{dbm_tables}->{krueger}->{file} = $fn_tbl2; + + my $r = $dbh->selectall_arrayref(q/select * from Krueger/); + ok( @$r == 2, 'rows found via cloned mixed case table' ); + + ok( $dbh->do(q/drop table if exists KRUeGEr/), 'drop table' ); +} + +my $r = $dbh->selectall_arrayref(q/select * from Fred/); +ok( @$r == 2, 'rows found via mixed case table' ); + +SKIP: +{ + DBD::DBM::Statement->isa("SQL::Statement") or skip("quoted identifiers aren't supported by DBI::SQL::Nano",1); + my $abs_tbl = File::Spec->catfile( $dir, 'fred' ); + # work around SQL::Statement bug + DBD::DBM::Statement->isa("SQL::Statement") and SQL::Statement->VERSION() lt "1.32" and $abs_tbl =~ s|\\|/|g; + $r = $dbh->selectall_arrayref( sprintf( q|select * from "%s"|, $abs_tbl ) ); + ok( @$r == 2, 'rows found via select via fully qualified path' ); +} + +if( $using_dbd_gofer ) +{ + ok( $dbh->do(q/drop table if exists FRED/), 'drop table' ); + ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" ); +} +else +{ + my $tbl_info = { file => "fred$tblfext" }; + + ok( $dbh->disconnect(), "disconnect" ); + $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { + f_dir => $dir, + sql_identifier_case => 2, # SQL_IC_LOWER + dbm_tables => { fred => $tbl_info }, + } + ); + + $r = $dbh->selectall_arrayref(q/select * from Fred/); + ok( @$r == 2, 'rows found after reconnect using "dbm_tables"' ); + + ok( $dbh->do(q/drop table if exists FRED/), 'drop table' ); + ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" ); + ok( !-f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext removed" ); +} + +done_testing(); diff --git a/t/52dbm_complex.t b/t/52dbm_complex.t new file mode 100644 index 0000000..31dc6e3 --- /dev/null +++ b/t/52dbm_complex.t @@ -0,0 +1,359 @@ +#!perl -w +$| = 1; + +use strict; +use warnings; + +require DBD::DBM; + +use File::Path; +use File::Spec; +use Test::More; +use Cwd; +use Config qw(%Config); +use Storable qw(dclone); + +my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; + +use DBI; +use vars qw( @mldbm_types @dbm_types ); + +BEGIN +{ + + # 0=SQL::Statement if avail, 1=DBI::SQL::Nano + # next line forces use of Nano rather than default behaviour + # $ENV{DBI_SQL_NANO}=1; + # This is done in zv*n*_50dbm_simple.t + + if ( eval { require 'MLDBM.pm'; } ) + { + push @mldbm_types, qw(Data::Dumper Storable); # both in CORE + push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' }; + push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; }; + push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; + } + + # Potential DBM modules in preference order (SDBM_File first) + # skip NDBM and ODBM as they don't support EXISTS + my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File); + my @use_dbms = @ARGV; + if ( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} ) + { + @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS}; + } + + if ( lc "@use_dbms" eq "all" ) + { + # test with as many of the major DBM types as are available + @dbm_types = grep { + eval { local $^W; require "$_.pm" } + } @dbms; + } + elsif (@use_dbms) + { + @dbm_types = @use_dbms; + } + else + { + # we only test SDBM_File by default to avoid tripping up + # on any broken DBM's that may be installed in odd places. + # It's only DBD::DBM we're trying to test here. + # (However, if SDBM_File is not available, then use another.) + for my $dbm (@dbms) + { + if ( eval { local $^W; require "$dbm.pm" } ) + { + @dbm_types = ($dbm); + last; + } + } + } + + if ( eval { require List::MoreUtils; } ) + { + List::MoreUtils->import("part"); + } + else + { + # XXX from PP part of List::MoreUtils + eval <<'EOP'; +sub part(&@) { + my ($code, @list) = @_; + my @parts; + push @{ $parts[$code->($_)] }, $_ for @list; + return @parts; +} +EOP + } +} + +my $haveSS = DBD::DBM::Statement->isa('SQL::Statement'); + +plan skip_all => "DBI::SQL::Nano is being used" unless ( $haveSS ); +plan skip_all => "Not running with MLDBM" unless ( @mldbm_types ); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, } ); + +my $suffix; +my $tbl_meta; + +sub break_at_warn +{ + note "break here"; +} +$SIG{__WARN__} = \&break_at_warn; +$SIG{__DIE__} = \&break_at_warn; + +sub load_tables +{ + my ( $dbmtype, $dbmmldbm ) = @_; + my $last_suffix; + + if ($using_dbd_gofer) + { + $dbh->disconnect(); + $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => $dir, dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm } ); + } + else + { + $last_suffix = $suffix; + $dbh->{dbm_type} = $dbmtype; + $dbh->{dbm_mldbm} = $dbmmldbm; + } + + (my $serializer = $dbmmldbm ) =~ s/::/_/g; + $suffix = join( "_", $$, $dbmtype, $serializer ); + + if ($last_suffix) + { + for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s)) + { + my $readsql = sprintf "SELECT * FROM $table", $last_suffix; + my $impsql = sprintf "CREATE TABLE $table AS IMPORT (?)", $suffix; + my ($readsth); + ok( $readsth = $dbh->prepare($readsql), "prepare: $readsql" ); + ok( $readsth->execute(), "execute: $readsql" ); + ok( $dbh->do( $impsql, {}, $readsth ), $impsql ) or warn $dbh->errstr(); + } + } + else + { + for my $sql ( split( "\n", join( '', <<'EOD' ) ) ) +CREATE TABLE APPL_%s (id INT, applname CHAR, appluniq CHAR, version CHAR, appl_type CHAR) +CREATE TABLE PREC_%s (id INT, appl_id INT, node_id INT, precedence INT) +CREATE TABLE NODE_%s (id INT, nodename CHAR, os CHAR, version CHAR) +CREATE TABLE LANDSCAPE_%s (id INT, landscapename CHAR) +CREATE TABLE CONTACT_%s (id INT, surname CHAR, familyname CHAR, phone CHAR, userid CHAR, mailaddr CHAR) +CREATE TABLE NM_LANDSCAPE_%s (id INT, ls_id INT, obj_id INT, obj_type INT) +CREATE TABLE APPL_CONTACT_%s (id INT, contact_id INT, appl_id INT, contact_type CHAR) + +INSERT INTO APPL_%s VALUES ( 1, 'ZQF', 'ZFQLIN', '10.2.0.4', 'Oracle DB') +INSERT INTO APPL_%s VALUES ( 2, 'YRA', 'YRA-UX', '10.2.0.2', 'Oracle DB') +INSERT INTO APPL_%s VALUES ( 3, 'PRN1', 'PRN1-4.B2', '1.1.22', 'CUPS' ) +INSERT INTO APPL_%s VALUES ( 4, 'PRN2', 'PRN2-4.B2', '1.1.22', 'CUPS' ) +INSERT INTO APPL_%s VALUES ( 5, 'PRN1', 'PRN1-4.B1', '1.1.22', 'CUPS' ) +INSERT INTO APPL_%s VALUES ( 7, 'PRN2', 'PRN2-4.B1', '1.1.22', 'CUPS' ) +INSERT INTO APPL_%s VALUES ( 8, 'sql-stmt', 'SQL::Statement', '1.21', 'Project Web-Site') +INSERT INTO APPL_%s VALUES ( 9, 'cpan.org', 'http://www.cpan.org/', '1.0', 'Web-Site') +INSERT INTO APPL_%s VALUES (10, 'httpd', 'cpan-apache', '2.2.13', 'Web-Server') +INSERT INTO APPL_%s VALUES (11, 'cpan-mods', 'cpan-mods', '8.4.1', 'PostgreSQL DB') +INSERT INTO APPL_%s VALUES (12, 'cpan-authors', 'cpan-authors', '8.4.1', 'PostgreSQL DB') + +INSERT INTO NODE_%s VALUES ( 1, 'ernie', 'RHEL', '5.2') +INSERT INTO NODE_%s VALUES ( 2, 'bert', 'RHEL', '5.2') +INSERT INTO NODE_%s VALUES ( 3, 'statler', 'FreeBSD', '7.2') +INSERT INTO NODE_%s VALUES ( 4, 'waldorf', 'FreeBSD', '7.2') +INSERT INTO NODE_%s VALUES ( 5, 'piggy', 'NetBSD', '5.0.2') +INSERT INTO NODE_%s VALUES ( 6, 'kermit', 'NetBSD', '5.0.2') +INSERT INTO NODE_%s VALUES ( 7, 'samson', 'NetBSD', '5.0.2') +INSERT INTO NODE_%s VALUES ( 8, 'tiffy', 'NetBSD', '5.0.2') +INSERT INTO NODE_%s VALUES ( 9, 'rowlf', 'Debian Lenny', '5.0') +INSERT INTO NODE_%s VALUES (10, 'fozzy', 'Debian Lenny', '5.0') + +INSERT INTO PREC_%s VALUES ( 1, 1, 1, 1) +INSERT INTO PREC_%s VALUES ( 2, 1, 2, 2) +INSERT INTO PREC_%s VALUES ( 3, 2, 2, 1) +INSERT INTO PREC_%s VALUES ( 4, 2, 1, 2) +INSERT INTO PREC_%s VALUES ( 5, 3, 5, 1) +INSERT INTO PREC_%s VALUES ( 6, 3, 7, 2) +INSERT INTO PREC_%s VALUES ( 7, 4, 6, 1) +INSERT INTO PREC_%s VALUES ( 8, 4, 8, 2) +INSERT INTO PREC_%s VALUES ( 9, 5, 7, 1) +INSERT INTO PREC_%s VALUES (10, 5, 5, 2) +INSERT INTO PREC_%s VALUES (11, 6, 8, 1) +INSERT INTO PREC_%s VALUES (12, 7, 6, 2) +INSERT INTO PREC_%s VALUES (13, 10, 9, 1) +INSERT INTO PREC_%s VALUES (14, 10, 10, 1) +INSERT INTO PREC_%s VALUES (15, 8, 9, 1) +INSERT INTO PREC_%s VALUES (16, 8, 10, 1) +INSERT INTO PREC_%s VALUES (17, 9, 9, 1) +INSERT INTO PREC_%s VALUES (18, 9, 10, 1) +INSERT INTO PREC_%s VALUES (19, 11, 3, 1) +INSERT INTO PREC_%s VALUES (20, 11, 4, 2) +INSERT INTO PREC_%s VALUES (21, 12, 4, 1) +INSERT INTO PREC_%s VALUES (22, 12, 3, 2) + +INSERT INTO LANDSCAPE_%s VALUES (1, 'Logistic') +INSERT INTO LANDSCAPE_%s VALUES (2, 'Infrastructure') +INSERT INTO LANDSCAPE_%s VALUES (3, 'CPAN') + +INSERT INTO CONTACT_%s VALUES ( 1, 'Hans Peter', 'Mueller', '12345', 'HPMUE', 'hp-mueller@here.com') +INSERT INTO CONTACT_%s VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', 'k-inge@here.com') +INSERT INTO CONTACT_%s VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', 'lola.ngyuen@customer.com') +INSERT INTO CONTACT_%s VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', 'helge.brunft@external-dc.at') + +-- TYPE: 1: APPL 2: NODE 3: CONTACT +INSERT INTO NM_LANDSCAPE_%s VALUES ( 1, 1, 1, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 2, 1, 2, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 3, 3, 3, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 4, 3, 4, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 5, 2, 5, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 6, 2, 6, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 7, 2, 7, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 8, 2, 8, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES ( 9, 3, 9, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES (10, 3,10, 2) +INSERT INTO NM_LANDSCAPE_%s VALUES (11, 1, 1, 1) +INSERT INTO NM_LANDSCAPE_%s VALUES (12, 2, 2, 1) +INSERT INTO NM_LANDSCAPE_%s VALUES (13, 2, 2, 3) +INSERT INTO NM_LANDSCAPE_%s VALUES (14, 3, 1, 3) + +INSERT INTO APPL_CONTACT_%s VALUES (1, 3, 1, 'OWNER') +INSERT INTO APPL_CONTACT_%s VALUES (2, 3, 2, 'OWNER') +INSERT INTO APPL_CONTACT_%s VALUES (3, 4, 3, 'ADMIN') +INSERT INTO APPL_CONTACT_%s VALUES (4, 4, 4, 'ADMIN') +INSERT INTO APPL_CONTACT_%s VALUES (5, 4, 5, 'ADMIN') +INSERT INTO APPL_CONTACT_%s VALUES (6, 4, 6, 'ADMIN') +EOD + { + chomp $sql; + $sql =~ s/^\s+//; + $sql =~ s/--.*$//; + $sql =~ s/\s+$//; + next if ( '' eq $sql ); + $sql = sprintf $sql, $suffix; + ok( $dbh->do($sql), $sql ); + } + } + + for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s)) + { + my $tbl_name = lc sprintf($table, $suffix); + $tbl_meta->{$tbl_name} = { dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm }; + } + + unless ($using_dbd_gofer) + { + my $tbl_known_meta = $dbh->dbm_get_meta( "+", [ qw(dbm_type dbm_mldbm) ] ); + is_deeply( $tbl_known_meta, $tbl_meta, "Know meta" ); + } +} + +sub do_tests +{ + my ( $dbmtype, $serializer ) = @_; + + note "Running do_tests for $dbmtype + $serializer"; + + load_tables( $dbmtype, $serializer ); + + my %joins; + my $sql; + + $sql = join( " ", + q{SELECT applname, appluniq, version, nodename }, + sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s }, ($suffix) x 3 ), + sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), + sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ), + ); + + $joins{$sql} = [ + 'ZQF~ZFQLIN~10.2.0.4~ernie', 'ZQF~ZFQLIN~10.2.0.4~bert', + 'YRA~YRA-UX~10.2.0.2~bert', 'YRA~YRA-UX~10.2.0.2~ernie', + 'cpan-mods~cpan-mods~8.4.1~statler', 'cpan-mods~cpan-mods~8.4.1~waldorf', + 'cpan-authors~cpan-authors~8.4.1~waldorf', 'cpan-authors~cpan-authors~8.4.1~statler', + ]; + + $sql = join( " ", + q{SELECT applname, appluniq, version, landscapename, nodename}, + sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, LANDSCAPE_%s, NM_LANDSCAPE_%s}, ($suffix) x 5 ), + sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), + sprintf( q{PREC_%s.node_id=NODE_%s.id AND NM_LANDSCAPE_%s.obj_id=APPL_%s.id AND}, ($suffix) x 4 ), + sprintf( q{NM_LANDSCAPE_%s.obj_type=1 AND NM_LANDSCAPE_%s.ls_id=LANDSCAPE_%s.id}, ($suffix) x 3 ), + ); + $joins{$sql} = [ + 'ZQF~ZFQLIN~10.2.0.4~Logistic~ernie', 'ZQF~ZFQLIN~10.2.0.4~Logistic~bert', + 'YRA~YRA-UX~10.2.0.2~Infrastructure~bert', 'YRA~YRA-UX~10.2.0.2~Infrastructure~ernie', + ]; + $sql = join( " ", + q{SELECT applname, appluniq, version, surname, familyname, phone, nodename}, + sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ), + sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), + sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id AND}, ($suffix) x 4 ), + sprintf( q{APPL_CONTACT_%s.contact_id=CONTACT_%s.id AND PREC_%s.PRECEDENCE=1}, ($suffix) x 3 ), + ); + $joins{$sql} = [ + 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', + 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit', + 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson', + ]; + $sql = join( " ", + q{SELECT DISTINCT applname, appluniq, version, surname, familyname, phone, nodename}, + sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ), + sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), + sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id}, ($suffix) x 4 ), + sprintf( q{AND APPL_CONTACT_%s.contact_id=CONTACT_%s.id}, ($suffix) x 2 ), + ); + $joins{$sql} = [ + 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', + 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy', + 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson', + 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~samson', + 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit', + 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~tiffy', + ]; + $sql = join( " ", + q{SELECT CONCAT('[% NOW %]') AS "timestamp", applname, appluniq, version, nodename}, + sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s}, ($suffix) x 3 ), + sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ), + sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ), + ); + $joins{$sql} = [ + '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~ernie', + '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~bert', + '[% NOW %]~YRA~YRA-UX~10.2.0.2~bert', + '[% NOW %]~YRA~YRA-UX~10.2.0.2~ernie', + '[% NOW %]~cpan-mods~cpan-mods~8.4.1~statler', + '[% NOW %]~cpan-mods~cpan-mods~8.4.1~waldorf', + '[% NOW %]~cpan-authors~cpan-authors~8.4.1~waldorf', + '[% NOW %]~cpan-authors~cpan-authors~8.4.1~statler', + ]; + + while ( my ( $sql, $result ) = each(%joins) ) + { + my $sth = $dbh->prepare($sql); + eval { $sth->execute() }; + warn $@ if $@; + my @res; + while ( my $row = $sth->fetchrow_arrayref() ) + { + push( @res, join( '~', @{$row} ) ); + } + is( join( '^', sort @res ), join( '^', sort @{$result} ), $sql ); + } +} + +foreach my $dbmtype (@dbm_types) +{ + foreach my $serializer (@mldbm_types) + { + do_tests( $dbmtype, $serializer ); + } +} + +done_testing(); diff --git a/t/60preparse.t b/t/60preparse.t new file mode 100755 index 0000000..6432feb --- /dev/null +++ b/t/60preparse.t @@ -0,0 +1,148 @@ +#!perl -w + +use DBI qw(:preparse_flags); + +$|=1; + +use Test::More; + +BEGIN { + if ($DBI::PurePerl) { + plan skip_all => 'preparse not supported for DBI::PurePerl'; + } + else { + plan tests => 39; + } +} + +my $dbh = DBI->connect("dbi:ExampleP:", "", "", { + PrintError => 0, +}); +isa_ok( $dbh, 'DBI::db' ); + +sub pp { + my $dbh = shift; + my $rv = $dbh->preparse(@_); + return $rv; +} + +# --------------------------------------------------------------------- # +# DBIpp_cm_cs /* C style */ +# DBIpp_cm_hs /* # */ +# DBIpp_cm_dd /* -- */ +# DBIpp_cm_br /* {} */ +# DBIpp_cm_dw /* '-- ' dash dash whitespace */ +# DBIpp_cm_XX /* any of the above */ + +# DBIpp_ph_qm /* ? */ +# DBIpp_ph_cn /* :1 */ +# DBIpp_ph_cs /* :name */ +# DBIpp_ph_sp /* %s (as return only, not accept) */ +# DBIpp_ph_XX /* any of the above */ + +# DBIpp_st_qq /* '' char escape */ +# DBIpp_st_bs /* \ char escape */ +# DBIpp_st_XX /* any of the above */ + +# ===================================================================== # +# pp (h input return accept expected) # +# ===================================================================== # + +## Comments: + +is( pp($dbh, "a#b\nc", DBIpp_cm_cs, DBIpp_cm_hs), "a/*b*/\nc" ); +is( pp($dbh, "a#b\nc", DBIpp_cm_dw, DBIpp_cm_hs), "a-- b\nc" ); +is( pp($dbh, "a/*b*/c", DBIpp_cm_hs, DBIpp_cm_cs), "a#b\nc" ); +is( pp($dbh, "a{b}c", DBIpp_cm_cs, DBIpp_cm_br), "a/*b*/c" ); +is( pp($dbh, "a--b\nc", DBIpp_cm_br, DBIpp_cm_dd), "a{b}\nc" ); + +is( pp($dbh, "a-- b\n/*c*/d", DBIpp_cm_br, DBIpp_cm_cs|DBIpp_cm_dw), "a{ b}\n{c}d" ); +is( pp($dbh, "a/*b*/c#d\ne--f\nh-- i\nj{k}", 0, DBIpp_cm_XX), "a c\ne\nh\nj " ); + +## Placeholders: + +is( pp($dbh, "a = :1", DBIpp_ph_qm, DBIpp_ph_cn), "a = ?" ); +is( pp($dbh, "a = :1", DBIpp_ph_sp, DBIpp_ph_cn), "a = %s" ); +is( pp($dbh, "a = ?" , DBIpp_ph_cn, DBIpp_ph_qm), "a = :p1" ); +is( pp($dbh, "a = ?" , DBIpp_ph_sp, DBIpp_ph_qm), "a = %s" ); + +is( pp($dbh, "a = :name", DBIpp_ph_qm, DBIpp_ph_cs), "a = ?" ); +is( pp($dbh, "a = :name", DBIpp_ph_sp, DBIpp_ph_cs), "a = %s" ); + +is( pp($dbh, "a = ? b = ? c = ?", DBIpp_ph_cn, DBIpp_ph_XX), "a = :p1 b = :p2 c = :p3" ); + +## Placeholders inside comments (should be ignored where comments style is accepted): + +is( pp( $dbh, + "a = ? /*b = :1*/ c = ?", + DBIpp_cm_dw|DBIpp_ph_cn, + DBIpp_cm_cs|DBIpp_ph_qm), + "a = :p1 -- b = :1\n c = :p2" ); + +## Placeholders inside single and double quotes (should be ignored): + +is( pp( $dbh, + "a = ? 'b = :1' c = ?", + DBIpp_ph_cn, + DBIpp_ph_XX), + "a = :p1 'b = :1' c = :p2" ); + +is( pp( $dbh, + 'a = ? "b = :1" c = ?', + DBIpp_ph_cn, + DBIpp_ph_XX), + 'a = :p1 "b = :1" c = :p2' ); + +## Comments inside single and double quotes (should be ignored): + +is( pp( $dbh, + "a = ? '{b = :1}' c = ?", + DBIpp_cm_cs|DBIpp_ph_cn, + DBIpp_cm_XX|DBIpp_ph_qm), + "a = :p1 '{b = :1}' c = :p2" ); + +is( pp( $dbh, + 'a = ? "/*b = :1*/" c = ?', + DBIpp_cm_dw|DBIpp_ph_cn, + DBIpp_cm_XX|DBIpp_ph_qm), + 'a = :p1 "/*b = :1*/" c = :p2' ); + +## Single and double quoted strings starting inside comments (should be ignored): + +is( pp( $dbh, + 'a = ? /*"b = :1 */ c = ?', + DBIpp_cm_br|DBIpp_ph_cn, + DBIpp_cm_XX|DBIpp_ph_qm), + 'a = :p1 {"b = :1 } c = :p2' ); + +## Check error conditions are trapped: + +is( pp($dbh, "a = :value and b = :1", DBIpp_ph_qm, DBIpp_ph_cs|DBIpp_ph_cn), undef ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found mixed placeholder styles (:1 / :name)" ); + +is( pp($dbh, "a = :1 and b = :3", DBIpp_ph_qm, DBIpp_ph_cn), undef ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found placeholder :3 out of sequence, expected :2" ); + +is( pp($dbh, "foo ' comment", 0, 0), "foo ' comment" ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found unterminated single-quoted string" ); + +is( pp($dbh, 'foo " comment', 0, 0), 'foo " comment' ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found unterminated double-quoted string" ); + +is( pp($dbh, 'foo /* comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo /* comment' ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found unterminated bracketed C-style comment" ); + +is( pp($dbh, 'foo { comment', DBIpp_cm_XX, DBIpp_cm_XX), 'foo { comment' ); +ok( $DBI::err ); +is( $DBI::errstr, "preparse found unterminated bracketed {...} comment" ); + +# --------------------------------------------------------------------- # + +$dbh->disconnect; + +1; diff --git a/t/65transact.t b/t/65transact.t new file mode 100644 index 0000000..f3d672b --- /dev/null +++ b/t/65transact.t @@ -0,0 +1,35 @@ +#!perl -w +$|=1; + +use strict; + +use DBI; + +use Test::More; + +plan skip_all => 'Transactions not supported by DBD::Gofer' + if $ENV{DBI_AUTOPROXY} && $ENV{DBI_AUTOPROXY} =~ /^dbi:Gofer/i; + +plan tests => 10; + +my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef) + or die "Unable to connect to ExampleP driver: $DBI::errstr"; + +print "begin_work...\n"; +ok($dbh->{AutoCommit}); +ok(!$dbh->{BegunWork}); + +ok($dbh->begin_work); +ok(!$dbh->{AutoCommit}); +ok($dbh->{BegunWork}); + +$dbh->commit; +ok($dbh->{AutoCommit}); +ok(!$dbh->{BegunWork}); + +ok($dbh->begin_work({})); +$dbh->rollback; +ok($dbh->{AutoCommit}); +ok(!$dbh->{BegunWork}); + +1; diff --git a/t/70callbacks.t b/t/70callbacks.t new file mode 100644 index 0000000..4acb9c3 --- /dev/null +++ b/t/70callbacks.t @@ -0,0 +1,207 @@ +#!perl -w +# vim:ts=8:sw=4 + +use strict; + +use Test::More; +use DBI; + +BEGIN { + plan skip_all => '$h->{Callbacks} attribute not supported for DBI::PurePerl' + if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning + plan tests => 63; +} + +$| = 1; +my $dsn = "dbi:ExampleP:"; +my %called; + +ok my $dbh = DBI->connect($dsn, '', ''), "Create dbh"; + +is $dbh->{Callbacks}, undef, "Callbacks initially undef"; +ok $dbh->{Callbacks} = my $cb = { }; +is ref $dbh->{Callbacks}, 'HASH', "Callbacks can be set to a hash ref"; +is $dbh->{Callbacks}, $cb, "Callbacks set to same hash ref"; + +$dbh->{Callbacks} = undef; +is $dbh->{Callbacks}, undef, "Callbacks set to undef again"; + +ok $dbh->{Callbacks} = { + ping => sub { + is $_, 'ping', '$_ holds method name'; + is @_, 1, '@_ holds 1 values'; + is ref $_[0], 'DBI::db', 'first is $dbh'; + $called{$_}++; + return; + }, + quote_identifier => sub { + is @_, 4, '@_ holds 4 values'; + my $dbh = shift; + is ref $dbh, 'DBI::db', 'first is $dbh'; + is $_[0], 'foo'; + is $_[1], 'bar'; + is $_[2], undef; + $_[2] = { baz => 1 }; + $called{$_}++; + return (1,2,3); # return something - which is not allowed + }, + disconnect => sub { # test die from within a callback + die "You can't disconnect that easily!\n"; + }, + "*" => sub { + $called{$_}++; + return; + } +}; +is keys %{ $dbh->{Callbacks} }, 4; + +is ref $dbh->{Callbacks}->{ping}, 'CODE'; + +$_ = 42; +ok $dbh->ping; +is $called{ping}, 1; +is $_, 42, '$_ not altered by callback'; + +ok $dbh->ping; +is $called{ping}, 2; + +ok $dbh->type_info_all; +is $called{type_info_all}, 1, 'fallback callback'; + +my $attr; +eval { $dbh->quote_identifier('foo','bar', $attr) }; +is $called{quote_identifier}, 1; +ok $@, 'quote_identifier callback caused fatal error'; +is ref $attr, 'HASH', 'param modified by callback - not recommended!'; + +ok !eval { $dbh->disconnect }; +ok $@, "You can't disconnect that easily!\n"; + +$dbh->{Callbacks} = undef; +ok $dbh->ping; +is $called{ping}, 2; # no change + + +# --- test skipping dispatch and fallback callbacks + +$dbh->{Callbacks} = { + ping => sub { + undef $_; # tell dispatch to not call the method + return "42 bells"; + }, + data_sources => sub { + my ($h, $values_to_return) = @_; + undef $_; # tell dispatch to not call the method + my @ret = 11..10+($values_to_return||0); + return @ret; + }, + commit => sub { # test using set_err within a callback + my $h = shift; + undef $_; # tell dispatch to not call the method + return $h->set_err(42, "faked commit failure"); + }, +}; + +# these tests are slightly convoluted because messing with the stack is bad for +# your mental health +my $rv = $dbh->ping; +is $rv, "42 bells"; +my @rv = $dbh->ping; +is scalar @rv, 1, 'should return a single value in list context'; +is "@rv", "42 bells"; +# test returning lists with different number of args to test +# the stack handling in the dispatch code +is join(":", $dbh->data_sources()), ""; +is join(":", $dbh->data_sources(0)), ""; +is join(":", $dbh->data_sources(1)), "11"; +is join(":", $dbh->data_sources(2)), "11:12"; + +{ +local $dbh->{RaiseError} = 1; +local $dbh->{PrintError} = 0; +is eval { $dbh->commit }, undef, 'intercepted commit should return undef'; +like $@, '/DBD::\w+::db commit failed: faked commit failure/'; +is $DBI::err, 42; +is $DBI::errstr, "faked commit failure"; +} + +# --- test connect_cached.* + +=for comment XXX + +The big problem here is that conceptually the Callbacks attribute +is applied to the $dbh _during_ the $drh->connect() call, so you can't +set a callback on "connect" on the $dbh because connect isn't called +on the dbh, but on the $drh. + +So a "connect" callback would have to be defined on the $drh, but that's +cumbersome for the user and then it would apply to all future connects +using that driver. + +The best thing to do is probably to special-case "connect", "connect_cached" +and (the already special-case) "connect_cached.reused". + +=cut + +my @args = ( + $dsn, '', '', { + Callbacks => { + "connect_cached.new" => sub { $called{new}++; return; }, + "connect_cached.reused" => sub { $called{cached}++; return; }, + } + } +); + +%called = (); + +ok $dbh = DBI->connect(@args), "Create handle with callbacks"; +is keys %called, 0, 'no callback for plain connect'; + +ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; +is $called{new}, 1, "connect_cached.new called"; +is $called{cached}, undef, "connect_cached.reused not yet called"; + +ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; +is $called{cached}, 1, "connect_cached.reused called"; +is $called{new}, 1, "connect_cached.new not called again"; + + +# --- test ChildCallbacks. +%called = (); +$args[-1] = { + Callbacks => my $dbh_callbacks = { + ping => sub { $called{ping}++; return; }, + ChildCallbacks => my $sth_callbacks = { + execute => sub { $called{execute}++; return; }, + fetch => sub { $called{fetch}++; return; }, + } + } +}; + +ok $dbh = DBI->connect(@args), "Create handle with ChildCallbacks"; +ok $dbh->ping, 'Ping'; +is $called{ping}, 1, 'Ping callback should have been called'; +ok my $sth = $dbh->prepare('SELECT name from t'), 'Prepare a statement handle (child)'; +ok $sth->{Callbacks}, 'child should have Callbacks'; +is $sth->{Callbacks}, $sth_callbacks, "child Callbacks should be ChildCallbacks of parent" + or diag "(dbh Callbacks is $dbh_callbacks)"; +ok $sth->execute, 'Execute'; +is $called{execute}, 1, 'Execute callback should have been called'; +ok $sth->fetch, 'Fetch'; +is $called{fetch}, 1, 'Fetch callback should have been called'; + +__END__ + +A generic 'transparent' callback looks like this: +(this assumes only scalar context will be used) + + sub { + my $h = shift; + return if our $avoid_deep_recursion->{"$h $_"}++; + my $this = $h->$_(@_); + undef $_; # tell DBI not to call original method + return $this; # tell DBI to return this instead + }; + +XXX should add a test for this +XXX even better would be to run chunks of the test suite with that as a '*' callback. In theory everything should pass (except this test file, naturally).. diff --git a/t/72childhandles.t b/t/72childhandles.t new file mode 100644 index 0000000..48fbe37 --- /dev/null +++ b/t/72childhandles.t @@ -0,0 +1,149 @@ +#!perl -w +$|=1; + +use strict; + +# +# test script for the ChildHandles attribute +# + +use DBI; + +use Test::More; + +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 DBI.pm + 1; +}; +if (!$HAS_WEAKEN) { + chomp $@; + print "1..0 # Skipped: Scalar::Util::weaken not available ($@)\n"; + exit 0; +} + +plan tests => 16; + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i; + +my $drh; + +{ + # make 10 connections + my @dbh; + for (1 .. 10) { + my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); + push @dbh, $dbh; + } + + # get the driver handle + $drh = $dbh[0]->{Driver}; + ok $drh; + + # get the kids, should be the same list of connections + my $db_handles = $drh->{ChildHandles}; + is ref $db_handles, 'ARRAY'; + is scalar @$db_handles, scalar @dbh; + + # make sure all the handles are there + my $found = 0; + foreach my $h (@dbh) { + ++$found if grep { $h == $_ } @$db_handles; + } + is $found, scalar @dbh; +} + +# now all the out-of-scope DB handles should be gone +{ + my $handles = $drh->{ChildHandles}; + my @db_handles = grep { defined } @$handles; + is scalar @db_handles, 0, "All handles should be undef now"; +} + +my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 }); + +my $empty = $dbh->{ChildHandles}; +is_deeply $empty, [], "ChildHandles should be an array-ref if wekref is available"; + +# test child handles for statement handles +{ + my @sth; + my $sth_count = 20; + for (1 .. $sth_count) { + my $sth = $dbh->prepare('SELECT name FROM t'); + push @sth, $sth; + } + my $handles = $dbh->{ChildHandles}; + is scalar @$handles, scalar @sth; + + # test a recursive walk like the one in the docs + my @lines; + sub show_child_handles { + my ($h, $level) = @_; + $level ||= 0; + push(@lines, + sprintf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h); + show_child_handles($_, $level + 1) + for (grep { defined } @{$h->{ChildHandles}}); + } + my $drh = $dbh->{Driver}; + show_child_handles($drh, 0); + print @lines[0..4]; + + is scalar @lines, $sth_count + 2; + like $lines[0], qr/^drh/; + like $lines[1], qr/^dbh/; + like $lines[2], qr/^sth/; +} + +my $handles = $dbh->{ChildHandles}; +my @live = grep { defined $_ } @$handles; +is scalar @live, 0, "handles should be gone now"; + +# test visit_child_handles +{ + my $info; + my $visitor = sub { + my ($h, $info) = @_; + my $type = $h->{Type}; + ++$info->{ $type }{ ($type eq 'st') ? $h->{Statement} : $h->{Name} }; + return $info; + }; + DBI->visit_handles($visitor, $info = {}); + is_deeply $info, { + 'dr' => { + 'ExampleP' => 1, + ($using_dbd_gofer) ? (Gofer => 1) : () + }, + 'db' => { '' => 1 }, + }; + + my $sth1 = $dbh->prepare('SELECT name FROM t'); + my $sth2 = $dbh->prepare('SELECT name FROM t'); + DBI->visit_handles($visitor, $info = {}); + is_deeply $info, { + 'dr' => { + 'ExampleP' => 1, + ($using_dbd_gofer) ? (Gofer => 1) : () + }, + 'db' => { '' => 1 }, + 'st' => { 'SELECT name FROM t' => 2 } + }; + +} + +# test that the childhandle array does not grow uncontrollably +SKIP: { + skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer; + + for (1 .. 1000) { + my $sth = $dbh->prepare('SELECT name FROM t'); + } + my $handles = $dbh->{ChildHandles}; + cmp_ok scalar @$handles, '<', 1000; + my @live = grep { defined } @$handles; + is scalar @live, 0; +} + +1; diff --git a/t/80proxy.t b/t/80proxy.t new file mode 100644 index 0000000..ab529b6 --- /dev/null +++ b/t/80proxy.t @@ -0,0 +1,473 @@ +#!perl -w # -*- perl -*- +# vim:sw=4:ts=8 + +require 5.004; +use strict; + + +use DBI; +use Config; +require VMS::Filespec if $^O eq 'VMS'; +require Cwd; + +my $haveFileSpec = eval { require File::Spec }; +my $failed_tests = 0; + +$| = 1; +$^W = 1; + +# $\ = "\n"; # XXX Triggers bug, check this later (JW, 1998-12-28) + +# Can we load the modules? If not, exit the test immediately: +# Reason is most probable a missing prerequisite. +# +# Is syslog available (required for the server)? + +eval { + local $SIG{__WARN__} = sub { $@ = shift }; + require Storable; + require DBD::Proxy; + require DBI::ProxyServer; + require RPC::PlServer; + require Net::Daemon::Test; +}; +if ($@) { + if ($@ =~ /^Can't locate (\S+)/) { + print "1..0 # Skipped: modules required for proxy are probably not installed (e.g., $1)\n"; + exit 0; + } + die $@; +} + +if ($DBI::PurePerl) { + # XXX temporary I hope + print "1..0 # Skipped: DBD::Proxy currently has a problem under DBI::PurePerl\n"; + exit 0; +} + +{ + my $numTest = 0; + sub _old_Test($;$) { + my $result = shift; my $str = shift || ''; + printf("%sok %d%s\n", ($result ? "" : "not "), ++$numTest, $str); + $result; + } + sub Test ($;$) { + my($ok, $msg) = @_; + $msg = ($msg) ? " ($msg)" : ""; + my $line = (caller)[2]; + ++$numTest; + ($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n"; + warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok; + ++$failed_tests unless $ok; + return $ok; + } +} + + +# Create an empty config file to make sure that settings aren't +# overloaded by /etc/dbiproxy.conf +my $config_file = "dbiproxytst.conf"; +unlink $config_file; +(open(FILE, ">$config_file") and + (print FILE "{}\n") and + close(FILE)) + or die "Failed to create config file $config_file: $!"; + +my $debug = ($ENV{DBI_TRACE}||=0) ? 1 : 0; +my $dbitracelog = "dbiproxy.dbilog"; + +my ($handle, $port, @child_args); + +my $numTests = 136; + +if (@ARGV) { + $port = $ARGV[0]; +} +else { + + unlink $dbitracelog; + unlink "dbiproxy.log"; + unlink "dbiproxy.truss"; + + # Uncommentand adjust this to isolate pure-perl client from server settings: + # local $ENV{DBI_PUREPERL} = 0; + + # If desperate uncomment this and add '-d' after $^X below: + # local $ENV{PERLDB_OPTS} = "AutoTrace NonStop=1 LineInfo=dbiproxy.dbg"; + + # pass our @INC to children (e.g., so -Mblib passes through) + $ENV{PERL5LIB} = join($Config{path_sep}, @INC); + + # server DBI trace level always at least 1 + my $dbitracelevel = DBI->trace(0) || 1; + @child_args = ( + #'truss', '-o', 'dbiproxy.truss', + $^X, 'dbiproxy', '--test', # --test must be first command line arg + "--dbitrace=$dbitracelevel=$dbitracelog", # must be second arg + '--configfile', $config_file, + ($dbitracelevel >= 2 ? ('--debug') : ()), + '--mode=single', + '--logfile=STDERR', + '--timeout=90' + ); + warn " starting test dbiproxy process: @child_args\n" if DBI->trace(0); + ($handle, $port) = Net::Daemon::Test->Child($numTests, @child_args); +} + +my $dsn = "DBI:Proxy:hostname=127.0.0.1;port=$port;debug=$debug;dsn=DBI:ExampleP:"; + +print "Making a first connection and closing it immediately.\n"; +Test(eval { DBI->connect($dsn, '', '', { 'PrintError' => 1 }) }) + or print "Connect error: " . $DBI::errstr . "\n"; + +print "Making a second connection.\n"; +my $dbh; +Test($dbh = eval { DBI->connect($dsn, '', '', { 'PrintError' => 0 }) }) + or print "Connect error: " . $DBI::errstr . "\n"; + +print "example_driver_path=$dbh->{example_driver_path}\n"; +Test($dbh->{example_driver_path}); + +print "Setting AutoCommit\n"; +$@ = "old-error"; # should be preserved across DBI calls +Test($dbh->{AutoCommit} = 1); +Test($dbh->{AutoCommit}); +Test($@ eq "old-error", "\$@ now '$@'"); +#$dbh->trace(2); + +eval { + local $dbh->{ AutoCommit } = 1; # This breaks die! + die "BANG!!!\n"; +}; +Test($@ eq "BANG!!!\n", "\$@ value lost"); + + +print "begin_work...\n"; +Test($dbh->{AutoCommit}); +Test(!$dbh->{BegunWork}); + +Test($dbh->begin_work); +Test(!$dbh->{AutoCommit}); +Test($dbh->{BegunWork}); + +$dbh->commit; +Test(!$dbh->{BegunWork}); +Test($dbh->{AutoCommit}); + +Test($dbh->begin_work({})); +$dbh->rollback; +Test($dbh->{AutoCommit}); +Test(!$dbh->{BegunWork}); + + +print "Doing a ping.\n"; +$_ = $dbh->ping; +Test($_); +Test($_ eq '2'); # ping was DBD::ExampleP's ping + +print "Ensure CompatMode enabled.\n"; +Test($dbh->{CompatMode}); + +print "Trying local quote.\n"; +$dbh->{'proxy_quote'} = 'local'; +Test($dbh->quote("quote's") eq "'quote''s'"); +Test($dbh->quote(undef) eq "NULL"); + +print "Trying remote quote.\n"; +$dbh->{'proxy_quote'} = 'remote'; +Test($dbh->quote("quote's") eq "'quote''s'"); +Test($dbh->quote(undef) eq "NULL"); + +# XXX the $optional param is undocumented and may be removed soon +Test($dbh->quote_identifier('foo') eq '"foo"', $dbh->quote_identifier('foo')); +Test($dbh->quote_identifier('f"o') eq '"f""o"', $dbh->quote_identifier('f"o')); +Test($dbh->quote_identifier('foo','bar') eq '"foo"."bar"'); +Test($dbh->quote_identifier('foo',undef,'bar') eq '"foo"."bar"'); +Test($dbh->quote_identifier(undef,undef,'bar') eq '"bar"'); + +print "Trying commit with invalid number of parameters.\n"; +eval { $dbh->commit('dummy') }; +Test($@ =~ m/^DBI commit: invalid number of arguments:/) + unless $DBI::PurePerl && Test(1); + +print "Trying select with unknown field name.\n"; +my $cursor_e = $dbh->prepare("select unknown_field_name from ?"); +Test(defined $cursor_e); +Test(!$cursor_e->execute('a')); +Test($DBI::err); +Test($DBI::err == $dbh->err); +Test($DBI::errstr =~ m/unknown_field_name/, $DBI::errstr); + +Test($DBI::errstr eq $dbh->errstr); +Test($dbh->errstr eq $dbh->func('errstr')); + +my $dir = Cwd::cwd(); # a dir always readable on all platforms +$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS'; + +print "Trying a real select.\n"; +my $csr_a = $dbh->prepare("select mode,name from ?"); +Test(ref $csr_a); +Test($csr_a->execute($dir)) + or print "Execute failed: ", $csr_a->errstr(), "\n"; + +print "Repeating the select with second handle.\n"; +my $csr_b = $dbh->prepare("select mode,name from ?"); +Test(ref $csr_b); +Test($csr_b->execute($dir)); +Test($csr_a != $csr_b); +Test($csr_a->{NUM_OF_FIELDS} == 2); +if ($DBI::PurePerl) { + $csr_a->trace(2); + use Data::Dumper; + warn Dumper($csr_a->{Database}); +} +Test($csr_a->{Database}->{Driver}->{Name} eq 'Proxy', "Name=$csr_a->{Database}->{Driver}->{Name}"); +$csr_a->trace(0), die if $DBI::PurePerl; + +my($col0, $col1); +my(@row_a, @row_b); + +#$csr_a->trace(2); +print "Trying bind_columns.\n"; +Test($csr_a->bind_columns(undef, \($col0, $col1)) ); +Test($csr_a->execute($dir)); +@row_a = $csr_a->fetchrow_array; +Test(@row_a); +Test($row_a[0] eq $col0); +Test($row_a[1] eq $col1); + +print "Trying bind_param.\n"; +Test($csr_b->bind_param(1, $dir)); +Test($csr_b->execute()); +@row_b = @{ $csr_b->fetchrow_arrayref }; +Test(@row_b); + +Test("@row_a" eq "@row_b"); +@row_b = $csr_b->fetchrow_array; +Test("@row_a" ne "@row_b") + or printf("Expected something different from '%s', got '%s'\n", "@row_a", + "@row_b"); + +print "Trying fetchrow_hashref.\n"; +Test($csr_b->execute()); +my $row_b = $csr_b->fetchrow_hashref; +Test($row_b); +print "row_a: @{[ @row_a ]}\n"; +print "row_b: @{[ %$row_b ]}\n"; +Test($row_b->{mode} == $row_a[0]); +Test($row_b->{name} eq $row_a[1]); + +print "Trying fetchrow_hashref with FetchHashKeyName.\n"; +do { +#local $dbh->{TraceLevel} = 9; +local $dbh->{FetchHashKeyName} = 'NAME_uc'; +Test($dbh->{FetchHashKeyName} eq 'NAME_uc'); +my $csr_c = $dbh->prepare("select mode,name from ?"); +Test($csr_c->execute($dir), $DBI::errstr); +$row_b = $csr_c->fetchrow_hashref; +Test($row_b); +print "row_b: @{[ %$row_b ]}\n"; +Test($row_b->{MODE} eq $row_a[0]); +}; + +print "Trying finish.\n"; +Test($csr_a->finish); +#Test($csr_b->finish); +Test(1); + +print "Forcing destructor.\n"; +$csr_a = undef; # force destruction of this cursor now +Test(1); + +print "Trying fetchall_arrayref.\n"; +Test($csr_b->execute()); +my $r = $csr_b->fetchall_arrayref; +Test($r); +Test(@$r); +Test($r->[0]->[0] == $row_a[0]); +Test($r->[0]->[1] eq $row_a[1]); + +Test($csr_b->finish); + + +print "Retrying unknown field name.\n"; +my $csr_c; +$csr_c = $dbh->prepare("select unknown_field_name1 from ?"); +Test($csr_c); +Test(!$csr_c->execute($dir)); +Test($DBI::errstr =~ m/Unknown field names: unknown_field_name1/) + or printf("Wrong error string: %s", $DBI::errstr); + +print "Trying RaiseError.\n"; +$dbh->{RaiseError} = 1; +Test($dbh->{RaiseError}); +Test($csr_c = $dbh->prepare("select unknown_field_name2 from ?")); +Test(!eval { $csr_c->execute(); 1 }); +#print "$@\n"; +Test($@ =~ m/Unknown field names: unknown_field_name2/); +$dbh->{RaiseError} = 0; +Test(!$dbh->{RaiseError}); + +print "Trying warnings.\n"; +{ + my @warn; + local($SIG{__WARN__}) = sub { push @warn, @_ }; + $dbh->{PrintError} = 1; + Test($dbh->{PrintError}); + Test(($csr_c = $dbh->prepare("select unknown_field_name3 from ?"))); + Test(!$csr_c->execute()); + Test("@warn" =~ m/Unknown field names: unknown_field_name3/); + $dbh->{PrintError} = 0; + Test(!$dbh->{PrintError}); +} +$csr_c->finish(); + + +print "Trying type_info_all.\n"; +my $array = $dbh->type_info_all(); +Test($array and ref($array) eq 'ARRAY') + or printf("Expected ARRAY, got %s, error %s\n", DBI::neat($array), + $dbh->errstr()); +Test($array->[0] and ref($array->[0]) eq 'HASH'); +my $ok = 1; +for (my $i = 1; $i < @{$array}; $i++) { + print "$array->[$i]\n"; + $ok = 0 unless ($array->[$i] and ref($array->[$i]) eq 'ARRAY'); + print "$ok\n"; +} +Test($ok); + +# Test the table_info method +# First generate a list of all subdirectories +$dir = $haveFileSpec ? File::Spec->curdir() : "."; +Test(opendir(DIR, $dir)); +my(%dirs, %unexpected, %missing); +while (defined(my $file = readdir(DIR))) { + $dirs{$file} = 1 if -d $file; +} +closedir(DIR); +my $sth = $dbh->table_info(undef, undef, undef, undef); +Test($sth) or warn "table_info failed: ", $dbh->errstr(), "\n"; +%missing = %dirs; +%unexpected = (); +while (my $ref = $sth->fetchrow_hashref()) { + print "table_info: Found table $ref->{'TABLE_NAME'}\n"; + if (exists($missing{$ref->{'TABLE_NAME'}})) { + delete $missing{$ref->{'TABLE_NAME'}}; + } else { + $unexpected{$ref->{'TABLE_NAME'}} = 1; + } +} +Test(!$sth->errstr()) + or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; +Test(keys %unexpected == 0) + or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; +Test(keys %missing == 0) + or print "Missing directories: ", join(",", keys %missing), "\n"; + +# Test the tables method +%missing = %dirs; +%unexpected = (); +print "Expecting directories ", join(",", keys %dirs), "\n"; +foreach my $table ($dbh->tables()) { + print "tables: Found table $table\n"; + if (exists($missing{$table})) { + delete $missing{$table}; + } else { + $unexpected{$table} = 1; + } +} +Test(!$sth->errstr()) + or print "Fetching table_info rows failed: ", $sth->errstr(), "\n"; +Test(keys %unexpected == 0) + or print "Unexpected directories: ", join(",", keys %unexpected), "\n"; +Test(keys %missing == 0) + or print "Missing directories: ", join(",", keys %missing), "\n"; + + +# Test large recordsets +for (my $i = 0; $i <= 300; $i += 100) { + print "Testing the fake directories ($i).\n"; + Test($csr_a = $dbh->prepare("SELECT name, mode FROM long_list_$i")); + Test($csr_a->execute(), $DBI::errstr); + my $ary = $csr_a->fetchall_arrayref; + Test(!$DBI::errstr, $DBI::errstr); + Test(@$ary == $i, "expected $i got ".@$ary); + if ($i) { + my @n1 = map { $_->[0] } @$ary; + my @n2 = reverse map { "file$_" } 1..$i; + Test("@n1" eq "@n2"); + } + else { + Test(1); + } +} + + +# Test the RowCacheSize attribute +Test($csr_a = $dbh->prepare("SELECT * FROM ?")); +Test($dbh->{'RowCacheSize'} == 20); +Test($csr_a->{'RowCacheSize'} == 20); +Test($csr_a->execute('long_list_50')); +Test($csr_a->fetchrow_arrayref()); +Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 19); +Test($csr_a->finish()); + +Test($dbh->{'RowCacheSize'} = 30); +Test($dbh->{'RowCacheSize'} == 30); +Test($csr_a->{'RowCacheSize'} == 30); +Test($csr_a->execute('long_list_50')); +Test($csr_a->fetchrow_arrayref()); +Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 29) + or print("Expected 29 records in cache, got " . @{$csr_a->{'proxy_data'}} . + "\n"); +Test($csr_a->finish()); + + +Test($csr_a->{'RowCacheSize'} = 10); +Test($dbh->{'RowCacheSize'} == 30); +Test($csr_a->{'RowCacheSize'} == 10); +Test($csr_a->execute('long_list_50')); +Test($csr_a->fetchrow_arrayref()); +Test($csr_a->{'proxy_data'} and @{$csr_a->{'proxy_data'}} == 9) + or print("Expected 9 records in cache, got " . @{$csr_a->{'proxy_data'}} . + "\n"); +Test($csr_a->finish()); + +$dbh->disconnect; + +# Test $dbh->func() +# print "Testing \$dbh->func().\n"; +# my %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables(); +# $ok = 1; +# foreach my $t ($dbh->func('lib', 'examplep_tables')) { +# defined(delete $tables{$t}) or print "Unexpected table: $t\n"; +# } +# Test(%tables == 0); + +if ($failed_tests) { + warn "Proxy: @child_args\n"; + for my $class (qw(Net::Daemon RPC::PlServer Storable)) { + (my $pm = $class) =~ s/::/\//g; $pm .= ".pm"; + my $version = eval { $class->VERSION } || '?'; + warn sprintf "Using %-13s %-6s %s\n", $class, $version, $INC{$pm}; + } + warn join(", ", map { "$_=$ENV{$_}" } grep { /^LC_|LANG/ } keys %ENV)."\n"; + warn "More info can be found in $dbitracelog\n"; + #system("cat $dbitracelog"); +} + + +END { + local $?; + $handle->Terminate() if $handle; + undef $handle; + unlink $config_file if $config_file; + if (!$failed_tests) { + unlink 'dbiproxy.log'; + unlink $dbitracelog if $dbitracelog; + } +}; + +1; diff --git a/t/85gofer.t b/t/85gofer.t new file mode 100644 index 0000000..8208195 --- /dev/null +++ b/t/85gofer.t @@ -0,0 +1,264 @@ +#!perl -w # -*- perl -*- +# vim:sw=4:ts=8 +$|=1; + +use strict; +use warnings; + +use Cwd; +use Config; +use Data::Dumper; +use Test::More 0.84; +use Getopt::Long; + +use DBI qw(dbi_time); + +if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity + plan skip_all => "transport+policy tests skipped with non-gofer DBI_AUTOPROXY" + if $ap !~ /^dbi:Gofer/i; + plan skip_all => "transport+policy tests skipped with non-pedantic policy in DBI_AUTOPROXY" + if $ap !~ /policy=pedantic\b/i; +} + +do "t/lib.pl"; + +# 0=SQL::Statement if avail, 1=DBI::SQL::Nano +# next line forces use of Nano rather than default behaviour +# $ENV{DBI_SQL_NANO}=1; +# This is done in zvn_50dbm.t + +GetOptions( + 'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)), + 'dbm=s' => \my $opt_dbm, + 'v|verbose!' => \my $opt_verbose, + 't|transport=s' => \my $opt_transport, + 'p|policy=s' => \my $opt_policy, +) or exit 1; + + +# so users can try others from the command line +if (!$opt_dbm) { + # pick first available, starting with SDBM_File + for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) { + if (eval { local $^W; require "$_.pm" }) { + $opt_dbm = ($_); + last; + } + } + plan skip_all => 'No DBM modules available' if !$opt_dbm; +} + +my @remote_dsns = DBI->data_sources( "dbi:DBM:", { + dbm_type => $opt_dbm, + f_lockfile => 0, + f_dir => test_dir() } ); +my $remote_dsn = $remote_dsns[0]; +( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i; +# Long timeout for slow/overloaded systems (incl virtual machines with low priority) +my $timeout = 240; + +if ($ENV{DBI_AUTOPROXY}) { + # this means we have DBD::Gofer => DBD::Gofer => DBD::DBM! + # rather than disable it we let it run because we're twisted + # and because it helps find more bugs (though debugging can be painful) + warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n" + unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t +} + +# ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib +local $ENV{PERL5LIB} = join $Config{path_sep}, @INC; + +my %durations; +my $getcwd = getcwd(); +my $username = eval { getpwuid($>) } || ''; # fails on windows +my $can_ssh = ($username && $username eq 'timbo' && -d '.svn' + && system("sh -c 'echo > /dev/tcp/localhost/22' 2>/dev/null")==0 +); +my $perl = "$^X -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note two spaces) + +my %trials = ( + null => {}, + pipeone => { perl=>$perl, timeout=>$timeout }, + stream => { perl=>$perl, timeout=>$timeout }, + stream_ssh => ($can_ssh) + ? { perl=>$perl, timeout=>$timeout, url => "ssh:$username\@localhost" } + : undef, + #http => { url => "http://localhost:8001/gofer" }, +); + +# too dependant on local config to make a standard test +delete $trials{http} unless $username eq 'timbo' && -d '.svn'; + +my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials); +note("Transports: @transports"); +my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush); +note("Policies: @policies"); +note("Count: $opt_count"); + +for my $trial (@transports) { + (my $transport = $trial) =~ s/_.*//; + my $trans_attr = $trials{$trial} + or next; + + # XXX temporary restrictions, hopefully + if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) { + # stream needs Fcntl macro F_GETFL for non-blocking + # and pipe seems to hang on some windows systems + next if $transport eq 'stream' or $transport eq 'pipeone'; + } + + for my $policy_name (@policies) { + + eval { run_tests($transport, $trans_attr, $policy_name) }; + ($@) ? fail("$trial: $@") : pass(); + + } +} + +# to get baseline for comparisons if doing performance testing +run_tests('no', {}, 'pedantic') if $opt_count; + +while ( my ($activity, $stats_hash) = each %durations ) { + note(""); + $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+pedantic"}; + for my $perf_tag (reverse sort keys %$stats_hash) { + my $dur = $stats_hash->{$perf_tag} || 0.0000001; + note sprintf " %6s %-16s: %.6fsec (%5d/sec)", + $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur; + my $baseline_dur = $stats_hash->{'~baseline~'}; + note sprintf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000 + unless $perf_tag eq '~baseline~'; + note ""; + } +} + + +sub run_tests { + my ($transport, $trans_attr, $policy_name) = @_; + + my $policy = get_policy($policy_name); + my $skip_gofer_checks = ($transport eq 'no'); + + + my $test_run_tag = "Testing $transport transport with $policy_name policy"; + note "============="; + note "$test_run_tag"; + + my $driver_dsn = "transport=$transport;policy=$policy_name"; + $driver_dsn .= join ";", '', map { "$_=$trans_attr->{$_}" } keys %$trans_attr + if %$trans_attr; + + my $dsn = "dbi:Gofer:$driver_dsn;dsn=$remote_dsn"; + $dsn = $remote_dsn if $transport eq 'no'; + note " $dsn"; + + my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError => 0, ShowErrorStatement => 1 } ); + die "$test_run_tag aborted: $DBI::errstr\n" unless $dbh; # no point continuing + ok $dbh, sprintf "should connect to %s", $dsn; + + is $dbh->{Name}, ($policy->skip_connect_check) + ? $driver_dsn + : $remote_driver_dsn; + + END { unlink glob "fruit.???" } + ok $dbh->do("DROP TABLE IF EXISTS fruit"); + ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))"); + die "$test_run_tag aborted ($DBI::errstr)\n" if $DBI::err; + + my $sth = do { + local $dbh->{RaiseError} = 0; + $dbh->prepare("complete non-sql gibberish"); + }; + ($policy->skip_prepare_check) + ? isa_ok $sth, 'DBI::st' + : is $sth, undef, 'should detect prepare failure'; + + ok my $ins_sth = $dbh->prepare("INSERT INTO fruit VALUES (?,?)"); + ok $ins_sth->execute(1, 'oranges'); + ok $ins_sth->execute(2, 'oranges'); + + my $rowset; + ok $rowset = $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit ORDER BY dKey"); + is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]); + + ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'"); + ok $dbh->{go_response}->executed_flag_set, 'go_response executed flag should be true' + unless $skip_gofer_checks && pass(); + + ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit"); + ok $sth->execute; + ok $rowset = $sth->fetchall_hashref('dKey'); + is_deeply($rowset, { '1' => { dKey=>1, dVal=>'apples' }, 2 => { dKey=>2, dVal=>'apples' } }); + + if ($opt_count and $transport ne 'pipeone') { + note "performance check - $opt_count selects and inserts"; + my $start = dbi_time(); + $dbh->selectall_arrayref("SELECT dKey, dVal FROM fruit") + for (1000..1000+$opt_count); + $durations{select}{"$transport+$policy_name"} = dbi_time() - $start; + + # some rows in to get a (*very* rough) idea of overheads + $start = dbi_time(); + $ins_sth->execute($_, 'speed') + for (1000..1000+$opt_count); + $durations{insert}{"$transport+$policy_name"} = dbi_time() - $start; + } + + note "Testing go_request_count and caching of simple values"; + my $go_request_count = $dbh->{go_request_count}; + ok $go_request_count + unless $skip_gofer_checks && pass(); + + ok $dbh->do("DROP TABLE fruit"); + is ++$go_request_count, $dbh->{go_request_count} + unless $skip_gofer_checks && pass(); + + # tests go_request_count, caching, and skip_default_methods policy + my $use_remote = ($policy->skip_default_methods) ? 0 : 1; + note sprintf "use_remote=%s (policy=%s, transport=%s) %s", + $use_remote, $policy_name, $transport, $dbh->{dbi_default_methods}||''; + +SKIP: { + skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3 + if $ENV{DBI_AUTOPROXY} or $skip_gofer_checks; + $dbh->data_sources({ foo_bar => $go_request_count }); + is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; + $dbh->data_sources({ foo_bar => $go_request_count }); # should use cache + is $dbh->{go_request_count}, $go_request_count + 1*$use_remote; + @_=$dbh->data_sources({ foo_bar => $go_request_count }); # no cached yet due to wantarray + is $dbh->{go_request_count}, $go_request_count + 2*$use_remote; +} + +SKIP: { + skip "caching of metadata methods returning sth not yet implemented", 2; + note "Testing go_request_count and caching of sth"; + $go_request_count = $dbh->{go_request_count}; + my $sth_ti1 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); + is $go_request_count + 1, $dbh->{go_request_count}; + + my $sth_ti2 = $dbh->table_info("%", "%", "%", "TABLE", { foo_bar => $go_request_count }); # should use cache + is $go_request_count + 1, $dbh->{go_request_count}; +} + + ok $dbh->disconnect; +} + +sub get_policy { + my ($policy_class) = @_; + $policy_class = "DBD::Gofer::Policy::$policy_class" unless $policy_class =~ /::/; + _load_class($policy_class) or die $@; + return $policy_class->new(); +} + +sub _load_class { # return true or false+$@ + my $class = shift; + (my $pm = $class) =~ s{::}{/}g; + $pm .= ".pm"; + return 1 if eval { require $pm }; + delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough + undef; # error in $@ +} + +done_testing; + +1; diff --git a/t/86gofer_fail.t b/t/86gofer_fail.t new file mode 100644 index 0000000..9a7b82b --- /dev/null +++ b/t/86gofer_fail.t @@ -0,0 +1,168 @@ +#!perl -w # -*- perl -*- +# vim:sw=4:ts=8 +$|=1; + +use strict; +use warnings; + +use DBI; +use Data::Dumper; +use Test::More; +sub between_ok; + +# here we test the DBI_GOFER_RANDOM mechanism +# and how gofer deals with failures + +plan skip_all => "requires Callbacks which are not supported with PurePerl" if $DBI::PurePerl; + +if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity + plan skip_all => "Gofer DBI_AUTOPROXY" if $ap =~ /^dbi:Gofer/i; + + # this means we have DBD::Gofer => DBD::Gofer => DBD::whatever + # rather than disable it we let it run because we're twisted + # and because it helps find more bugs (though debugging can be painful) + warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n" + unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t +} + +plan 'no_plan'; + +my $tmp; +my $dbh; +my $fails; + +# we'll use the null transport for simplicity and speed +# and the rush policy to limit the number of interactions with the gofer executor + +# silence the "DBI_GOFER_RANDOM..." warnings +my @warns; +$SIG{__WARN__} = sub { ("@_" =~ /^DBI_GOFER_RANDOM/) ? push(@warns, @_) : warn @_; }; + +# --- 100% failure rate + +($fails, $dbh) = trial_impact("fail=100%,do", 10, "", sub { $_->do("set foo=1") }); +is $fails, 100, 'should fail 100% of the time'; +ok $@, '$@ should be set'; +like $@, '/fake error from do method induced by DBI_GOFER_RANDOM/'; +ok $dbh->errstr, 'errstr should be set'; +like $dbh->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain DBI_GOFER_RANDOM'; +ok !$dbh->{go_response}->executed_flag_set, 'go_response executed flag should be false'; + + +# XXX randomness can't be predicted, so it's just possible these will fail +srand(42); # try to limit occasional failures (effect will vary by platform etc) + +sub trial_impact { + my ($spec, $count, $dsn_attr, $code, $verbose) = @_; + local $ENV{DBI_GOFER_RANDOM} = $spec; + my $dbh = dbi_connect("policy=rush;$dsn_attr"); + local $_ = $dbh; + my $fail_percent = percentage_exceptions(200, $code, $verbose); + return $fail_percent unless wantarray; + return ($fail_percent, $dbh); +} + +# --- 50% failure rate, with no retries + +$fails = trial_impact("fail=50%,do", 200, "retry_limit=0", sub { $_->do("set foo=1") }); +print "target approx 50% random failures, got $fails%\n"; +between_ok $fails, 10, 90, "should fail about 50% of the time, but at least between 10% and 90%"; + +# --- 50% failure rate, with many retries (should yield low failure rate) + +$fails = trial_impact("fail=50%,prepare", 200, "retry_limit=5", sub { $_->prepare("set foo=1") }); +print "target less than 20% effective random failures (ideally 0), got $fails%\n"; +cmp_ok $fails, '<', 20, 'should fail < 20%'; + +# --- 10% failure rate, with many retries (should yield zero failure rate) + +$fails = trial_impact("fail=10,do", 200, "retry_limit=10", sub { $_->do("set foo=1") }); +cmp_ok $fails, '<', 1, 'should fail < 1%'; + +# --- 50% failure rate, test is_idempotent + +$ENV{DBI_GOFER_RANDOM} = "fail=50%,do"; # 50% + +# test go_retry_hook and that ReadOnly => 1 retries a non-idempotent statement +ok my $dbh_50r1ro = dbi_connect("policy=rush;retry_limit=1", { + go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 }, + ReadOnly => 1, +} ); +between_ok percentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }), + 10, 40, 'should fail ~25% (ie 50% with one retry)'; +between_ok $dbh_50r1ro->{go_transport}->meta->{request_retry_count}, + 20, 80, 'transport request_retry_count should be around 50'; + +# test as above but with ReadOnly => 0 +ok my $dbh_50r1rw = dbi_connect("policy=rush;retry_limit=1", { + go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 }, + ReadOnly => 0, +} ); +between_ok percentage_exceptions(100, sub { $dbh_50r1rw->do("set foo=1") }), + 20, 80, 'should fail ~50%, ie no retries'; +ok !$dbh_50r1rw->{go_transport}->meta->{request_retry_count}, + 'transport request_retry_count should be zero or undef'; + + +# --- check random is random and non-random is non-random + +my %fail_percents; +for (1..5) { + $fails = trial_impact("fail=50%,do", 10, "", sub { $_->do("set foo=1") }); + ++$fail_percents{$fails}; +} +cmp_ok scalar keys %fail_percents, '>=', 2, 'positive percentage should fail randomly'; + +%fail_percents = (); +for (1..5) { + $fails = trial_impact("fail=-50%,do", 10, "", sub { $_->do("set foo=1") }); + ++$fail_percents{$fails}; +} +is scalar keys %fail_percents, 1, 'negative percentage should fail non-randomly'; + +# --- +print "Testing random delay\n"; + +$ENV{DBI_GOFER_RANDOM} = "delay0.1=51%,do"; # odd percentage to force warn()s +@warns = (); +ok $dbh = dbi_connect("policy=rush;retry_limit=0"); +is percentage_exceptions(20, sub { $dbh->do("set foo=1") }), + 0, "should not fail for DBI_GOFER_RANDOM='$ENV{DBI_GOFER_RANDOM}'"; +my $delays = grep { m/delaying execution/ } @warns; +between_ok $delays, 1, 19, 'should be delayed around 5 times'; + +exit 0; + +# --- subs --- +# +sub between_ok { + my ($got, $min, $max, $label) = @_; + local $Test::Builder::Level = 2; + cmp_ok $got, '>=', $min, "$label (got $got)"; + cmp_ok $got, '<=', $max, "$label (got $got)"; +} + +sub dbi_connect { + my ($gdsn, $attr) = @_; + return DBI->connect("dbi:Gofer:transport=null;$gdsn;dsn=dbi:ExampleP:", 0, 0, { + RaiseError => 1, PrintError => 0, ($attr) ? %$attr : () + }); +} + +sub percentage_exceptions { + my ($count, $sub, $verbose) = @_; + my $i = $count; + my $exceptions = 0; + while ($i--) { + eval { $sub->() }; + warn sprintf("percentage_exceptions $i: %s\n", $@|| $DBI::errstr || '') if $verbose; + if ($@) { + die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM/; + ++$exceptions; + } + } + warn sprintf "percentage_exceptions %f/%f*100 = %f\n", + $exceptions, $count, $exceptions/$count*100 + if $verbose; + return $exceptions/$count*100; +} diff --git a/t/87gofer_cache.t b/t/87gofer_cache.t new file mode 100644 index 0000000..9ad2aeb --- /dev/null +++ b/t/87gofer_cache.t @@ -0,0 +1,108 @@ +#!perl -w # -*- perl -*- +# vim:sw=4:ts=8 +$|=1; + +use strict; +use warnings; + +use DBI; +use Data::Dumper; +use Test::More; +use DBI::Util::CacheMemory; + +plan skip_all => "Gofer DBI_AUTOPROXY" if (($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer/i); + +plan 'no_plan'; + + +my $dsn = "dbi:Gofer:transport=null;policy=classic;dsn=dbi:ExampleP:"; + +my @cache_classes = qw(DBI::Util::CacheMemory); +push @cache_classes, "Cache::Memory" if eval { require Cache::Memory }; +push @cache_classes, "1"; # test alias for DBI::Util::CacheMemory + +for my $cache_class (@cache_classes) { + my $cache_obj = ($cache_class eq "1") ? $cache_class : $cache_class->new(); + run_tests($cache_obj); +} + + +sub run_tests { + my $cache_obj = shift; + + my $tmp; + print " using $cache_obj for $dsn\n"; + + my $dbh = DBI->connect($dsn, undef, undef, { + go_cache => $cache_obj, + RaiseError => 1, PrintError => 0, ShowErrorStatement => 1, + } ); + ok my $go_transport = $dbh->{go_transport}; + ok my $go_cache = $go_transport->go_cache; + + # setup + $go_cache->clear; + is $go_cache->count, 0, 'cache should be empty after clear'; + + $go_transport->transmit_count(0); + is $go_transport->transmit_count, 0, 'transmit_count should be 0'; + + $go_transport->cache_hit(0); + $go_transport->cache_miss(0); + $go_transport->cache_store(0); + + # request 1 + ok my $rows1 = $dbh->selectall_arrayref("select name from ?", {}, "."); + cmp_ok $go_cache->count, '>', 0, 'cache should not be empty after select'; + + my $expected = ($ENV{DBI_AUTOPROXY}) ? 2 : 1; + is $go_transport->cache_hit, 0; + is $go_transport->cache_miss, $expected; + is $go_transport->cache_store, $expected; + + is $go_transport->transmit_count, $expected, 'should make 1 round trip'; + $go_transport->transmit_count(0); + is $go_transport->transmit_count, 0, 'transmit_count should be 0'; + + # request 2 + ok my $rows2 = $dbh->selectall_arrayref("select name from ?", {}, "."); + is_deeply $rows2, $rows1; + is $go_transport->transmit_count, 0, 'should make 1 round trip'; + + is $go_transport->cache_hit, $expected; + is $go_transport->cache_miss, $expected; + is $go_transport->cache_store, $expected; +} + + +print "test per-sth go_cache\n"; + +my $dbh = DBI->connect($dsn, undef, undef, { + go_cache => 1, + RaiseError => 1, PrintError => 0, ShowErrorStatement => 1, +} ); +ok my $go_transport = $dbh->{go_transport}; +ok my $dbh_cache = $go_transport->go_cache; +$dbh_cache->clear; # discard ping from connect + +my $cache2 = DBI::Util::CacheMemory->new( namespace => "foo2" ); +ok $cache2; +ok $cache2 != $dbh_cache; + +my $sth1 = $dbh->prepare("select name from ?"); +is $sth1->go_cache, $dbh_cache; +is $dbh_cache->size, 0; +ok $dbh->selectall_arrayref($sth1, undef, "."); +ok $dbh_cache->size; + +my $sth2 = $dbh->prepare("select * from ?", { go_cache => $cache2 }); +is $sth2->go_cache, $cache2; +is $cache2->size, 0; +ok $dbh->selectall_arrayref($sth2, undef, "."); +ok $cache2->size; + +cmp_ok $cache2->size, '>', $dbh_cache->size; + + + +1; diff --git a/t/90sql_type_cast.t b/t/90sql_type_cast.t new file mode 100644 index 0000000..45a91d4 --- /dev/null +++ b/t/90sql_type_cast.t @@ -0,0 +1,148 @@ +# $Id: 90sql_type_cast.t 13911 2010-04-22 10:41:37Z timbo $ +# Test DBI::sql_type_cast +use strict; +#use warnings; this script generate warnings deliberately as part of the test +use Test::More; +use DBI qw(:sql_types :utils); +use Config; + +my $jx = eval {require JSON::XS;}; +my $dp = eval {require Data::Peek;}; +my $pp = $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning + +# NOTE: would have liked to use DBI::neat to test the cast value is what +# we expect but unfortunately neat uses SvNIOK(sv) so anything that looks +# like a number is printed as a number without quotes even if it has +# a pv. + +use constant INVALID_TYPE => -2; +use constant SV_IS_UNDEF => -1; +use constant NO_CAST_STRICT => 0; +use constant NO_CAST_NO_STRICT => 1; +use constant CAST_OK => 2; + +my @tests = ( + ['undef', undef, SQL_INTEGER, SV_IS_UNDEF, -1, q{[null]}], + ['invalid sql type', '99', 123456789, 0, INVALID_TYPE, q{["99"]}], + ['non numeric cast to int', 'aa', SQL_INTEGER, 0, NO_CAST_NO_STRICT, + q{["aa"]}], + ['non numeric cast to int (strict)', 'aa', SQL_INTEGER, + DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}], + ['small int cast to int', "99", SQL_INTEGER, 0, CAST_OK, q{["99"]}], + ['2 byte max signed int cast to int', "32767", SQL_INTEGER, 0, + CAST_OK, q{["32767"]}], + ['2 byte max unsigned int cast to int', "65535", + SQL_INTEGER, 0, CAST_OK, q{["65535"]}], + ['4 byte max signed int cast to int', "2147483647", + SQL_INTEGER, 0, CAST_OK, q{["2147483647"]}], + ['4 byte max unsigned int cast to int', "4294967295", + SQL_INTEGER, 0, CAST_OK, q{["4294967295"]}], + ['small int cast to int (discard)', + '99', SQL_INTEGER, DBIstcf_DISCARD_STRING, CAST_OK, q{[99]}], + + ['non numeric cast to numeric', 'aa', SQL_NUMERIC, + 0, NO_CAST_NO_STRICT, q{["aa"]}], + ['non numeric cast to numeric (strict)', 'aa', SQL_NUMERIC, + DBIstcf_STRICT, NO_CAST_STRICT, q{["aa"]}], + ); + +if (!$pp) { + # some tests cannot be performed with PurePerl as numbers don't + # overflow in the same way as XS. + push @tests, + ( + ['very large int cast to int', + '99999999999999999999', SQL_INTEGER, 0, NO_CAST_NO_STRICT, + q{["99999999999999999999"]}], + ['very large int cast to int (strict)', + '99999999999999999999', SQL_INTEGER, DBIstcf_STRICT, + NO_CAST_STRICT, q{["99999999999999999999"]}], + ['float cast to int', '99.99', SQL_INTEGER, 0, + NO_CAST_NO_STRICT, q{["99.99"]}], + ['float cast to int (strict)', '99.99', SQL_INTEGER, DBIstcf_STRICT, + NO_CAST_STRICT, q{["99.99"]}], + ['float cast to double', '99.99', SQL_DOUBLE, 0, CAST_OK, + q{["99.99"]}] + ); + if ($Config{ivsize} == 4) { + push @tests, + ['4 byte max unsigned int cast to int (ivsize=4)', "4294967296", + SQL_INTEGER, 0, NO_CAST_NO_STRICT, q{["4294967296"]}]; + } elsif ($Config{ivsize} >= 8) { + push @tests, + ['4 byte max unsigned int cast to int (ivsize>8)', "4294967296", + SQL_INTEGER, 0, CAST_OK, q{["4294967296"]}]; + } +} + +if ($] >= 5.010001) { + # Some numeric tests fail the return value test on Perls before 5.10.1 + # because sv_2nv leaves NOK set - changed in 5.10.1 probably via the + # following change: + # The public IV and NV flags are now not set if the string + # value has trailing "garbage". This behaviour is consistent with not + # setting the public IV or NV flags if the value is out of range for the + # type. + push @tests, ( + ['non numeric cast to double', 'aabb', SQL_DOUBLE, 0, + NO_CAST_NO_STRICT, q{["aabb"]}], + ['non numeric cast to double (strict)', 'aabb', SQL_DOUBLE, + DBIstcf_STRICT, NO_CAST_STRICT, q{["aabb"]}] + ); +} + +my $tests = @tests; +$tests *= 2 if $jx; +foreach (@tests) { + $tests++ if ($dp) && ($_->[3] & DBIstcf_DISCARD_STRING); + $tests++ if ($dp) && ($_->[2] == SQL_DOUBLE); +} + +plan tests => $tests; + +foreach my $test(@tests) { + my $val = $test->[1]; + #diag(join(",", map {neat($_)} Data::Peek::DDual($val))); + my $result; + { + no warnings; # lexical but also affects XS sub + local $^W = 0; # needed for PurePerl tests + $result = sql_type_cast($val, $test->[2], $test->[3]); + } + is($result, $test->[4], "result, $test->[0]"); + if ($jx) { + + SKIP: { + skip 'DiscardString not supported in PurePerl', 1 + if $pp && ($test->[3] & DBIstcf_DISCARD_STRING); + + my $json = JSON::XS->new->encode([$val]); + #diag(neat($val), ",", $json); + is($json, $test->[5], "json $test->[0]"); + }; + } + + my ($pv, $iv, $nv, $rv, $hm); + ($pv, $iv, $nv, $rv, $hm) = Data::Peek::DDual($val) if $dp; + + if ($dp && ($test->[3] & DBIstcf_DISCARD_STRING)) { + #diag("D::P ",neat($pv), ",", neat($iv), ",", neat($nv), + # ",", neat($rv)); + SKIP: { + skip 'DiscardString not supported in PurePerl', 1 if $pp; + + ok(!defined($pv), "discard works, $test->[0]") if $dp; + }; + } + if (($test->[2] == SQL_DOUBLE) && ($dp)) { + #diag("D::P ", neat($pv), ",", neat($iv), ",", neat($nv), + # ",", neat($rv)); + if ($test->[4] == CAST_OK) { + ok(defined($nv), "nv defined $test->[0]"); + } else { + ok(!defined($nv) || !$nv, "nv not defined $test->[0]"); + } + } +} + +1; diff --git a/t/lib.pl b/t/lib.pl new file mode 100644 index 0000000..e1512c6 --- /dev/null +++ b/t/lib.pl @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +# lib.pl is the file where database specific things should live, +# whereever possible. For example, you define certain constants +# here and the like. + +use strict; + +use File::Basename; +use File::Path; +use File::Spec; + +my $test_dir; +END { defined( $test_dir ) and rmtree $test_dir } + +sub test_dir +{ + unless( defined( $test_dir ) ) + { + $test_dir = File::Spec->rel2abs( File::Spec->curdir () ); + $test_dir = File::Spec->catdir ( $test_dir, "test_output_" . $$ ); + $test_dir = VMS::Filespec::unixify($test_dir) if $^O eq 'VMS'; + rmtree $test_dir; + mkpath $test_dir; + # There must be at least one directory in the test directory, + # and nothing guarantees that dot or dot-dot directories will exist. + mkpath ( File::Spec->catdir( $test_dir, '000_just_testing' ) ); + } + + return $test_dir; +} + +1; diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..64c2d58 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,8 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +plan skip_all => "Currently a developer-only test" unless -d '.svn' || -d ".git"; +plan skip_all => "Currently FAILS FOR MANY MODULES!"; +all_pod_coverage_ok(); @@ -0,0 +1,8 @@ +#!perl -w + +use Test::More; +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok(); + +1; @@ -0,0 +1,201 @@ +#!/usr/local/bin/perl -w + +# $Id: test.pl 12537 2009-02-24 22:45:40Z timbo $ +# +# Copyright (c) 1994-1998 Tim Bunce +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. + + +# This is now mostly an empty shell I experiment with. +# The real tests have moved to t/*.t +# See t/*.t for more detailed tests. + + +BEGIN { + print "$0 @ARGV\n"; + print q{DBI test application $Revision: 12537 $}."\n"; + $| = 1; +} + +use blib; + +use DBI; + +use DBI::DBD; # simple test to make sure it's okay + +use Config; +use Getopt::Long; +use strict; + +our $has_devel_leak = eval { + local $^W = 0; # silence "Use of uninitialized value $DynaLoader::args[0] in subroutine entry"; + require Devel::Leak; +}; + +$::opt_d = 0; +$::opt_l = ''; +$::opt_h = 0; +$::opt_m = 0; # basic memory leak test: "perl test.pl -m NullP" +$::opt_t = 0; # thread test +$::opt_n = 0; # counter for other options + +GetOptions(qw(d=i h=i l=s m=i t=i n=i)) + or die "Usage: $0 [-d n] [-h n] [-m n] [-t n] [-n n] [drivername]\n"; + +my $count = 0; +my $ps = (-d '/proc') ? "ps -lp " : "ps -l"; +my $driver = $ARGV[0] || ($::opt_m ? 'NullP' : 'ExampleP'); + +# Now ask for some information from the DBI Switch +my $switch = DBI->internal; +$switch->trace($::opt_h); # 2=detailed handle trace + +DBI->trace($::opt_d, $::opt_l) if $::opt_d || $::opt_l; + +print "Switch: $switch->{'Attribution'}, $switch->{'Version'}\n"; + +print "Available Drivers: ",join(", ",DBI->available_drivers(1)),"\n"; + + +my $dbh = DBI->connect("dbi:$driver:", '', '', { RaiseError=>1 }) or die; +$dbh->trace($::opt_h); + +if (0) { + DBI->trace(3); + my $h = DBI->connect('dbi:NullP:','','', { RootClass=>'MyTestDBI', DbTypeSubclass=>'foo, bar' }); + DBI->trace(0); + { # only works after 5.004_04: + warn "RaiseError= '$h->{RaiseError}' (pre local)\n"; + local($h->{RaiseError});# = undef; + warn "RaiseError= '$h->{RaiseError}' (post local)\n"; + } + warn "RaiseError= '$h->{RaiseError}' (post local block)\n"; + exit 1; +} + +if ($::opt_m) { + #$dbh->trace(9); + my $level = $::opt_m; + my $cnt = $::opt_n || 10000; + + print "Using $driver, same dbh...\n"; + for (my $i=0; $i<$cnt; ++$i) { mem_test($dbh, undef, $level, undef, undef, undef) } + + print "Using NullP, reconnecting each time...\n"; + for (my $i=0; $i<$cnt; ++$i) { mem_test(undef, ['dbi:NullP:'], $level, undef, undef, undef) } + + print "Using ExampleP, reconnecting each time...\n"; + my $r_develleak = 0; + mem_test(undef, ['dbi:NullP:'], $level, undef, undef, \$r_develleak) while 1; + #mem_test(undef, ['dbi:mysql:VC'], $level, "select * from campaigns where length(?)>0", 0, undef) while 1; +} +elsif ($::opt_t) { + thread_test(); +} +else { + + # new experimental connect_test_perf method + DBI->connect_test_perf("dbi:$driver:", '', '', { + dbi_loops=>3, dbi_par=>20, dbi_verb=>1 + }); + + require Benchmark; + print "Testing handle creation speed...\n"; + my $null_dbh = DBI->connect('dbi:NullP:','',''); + my $null_sth = $null_dbh->prepare(''); # create one to warm up + $count = 20_000; + $count /= 10 if $ENV{DBI_AUTOPROXY}; + my $i = $count; + my $t1 = new Benchmark; + $null_dbh->prepare('') while $i--; + my $td = Benchmark::timediff(Benchmark->new, $t1); + my $tds= Benchmark::timestr($td); + my $dur = $td->cpu_a || (1/$count); # fudge if cpu_a==0 + + printf "%5d NullP sth/s perl %8s %s (%s %s %s) %fs\n\n", + $count/$dur, $], $Config{archname}, + $Config{gccversion} ? 'gcc' : $Config{cc}, + (split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'', + $Config{optimize}, + $dur/$count; + + $null_dbh->disconnect; +} + +$dbh->disconnect; + +#DBI->trace(4); +print "$0 done\n"; +exit 0; + + +sub mem_test { # harness to help find basic leaks + my ($orig_dbh, $connect, $level, $select, $params, $r_develleak) = @_; + $select ||= "select mode,ino,name from ?"; + $params ||= [ '.' ]; + + # this can be used to force a 'leak' to check memory use reporting + #$main::leak .= " " x 1000; + system("echo $count; $ps$$") if (($count++ % 2000) == 0); + + my $dbh = $orig_dbh || do { + my ($dsn, $u, $p, $attr) = @$connect; + $attr->{RaiseError} = 1; + DBI->connect($dsn, $u, $p, $attr); + }; + my $cursor_a; + + my ($dl_count, $dl_handle); + if ($has_devel_leak && $$r_develleak++) { + $dbh->trace(2); + $dl_count = Devel::Leak::NoteSV($dl_handle); + } + + my $rows; + $cursor_a = $dbh->prepare($select) if $level >= 2; + $cursor_a->execute(@$params) if $level >= 3; + $cursor_a->fetchrow_hashref() if $level >= 4; + $rows = $cursor_a->fetchall_arrayref({}) if $level >= 4; + $cursor_a->finish if $cursor_a && $cursor_a->{Active}; + undef $cursor_a; + + @{$dbh->{ChildHandles}} = (); + + die Devel::Leak::CheckSV($dl_handle)-$dl_count + if $dl_handle; + + $dbh->disconnect unless $orig_dbh; + undef $dbh; + +} + + +sub thread_test { + require Thread; + my $dbh = DBI->connect("dbi:ExampleP:.", "", "") || die $DBI::err; + #$dbh->trace(4); + my @t; + print "Starting $::opt_t threads:\n"; + foreach(1..$::opt_t) { + print "$_\n"; + push @t, Thread->new(\&thread_test_loop, $dbh, $::opt_n||99); + } + print "Small sleep to allow threads to progress\n"; + sleep 2; + print "Joining threads:\n"; + foreach(@t) { + print "$_\n"; + $_->join + } +} + +sub thread_test_loop { + my $dbh = shift; + my $i = shift || 10; + while($i-- > 0) { + $dbh->selectall_arrayref("select * from ?", undef, "."); + } +} + +# end. @@ -0,0 +1,3 @@ +const char * T_PV +imp_xxh_t * T_PTROBJ +DBI_imp_data_ * T_PTROBJ |