DBI-1.634/000750 000766 000024 00000000000 12557677761 012425 5ustar00timbostaff000000 000000 DBI-1.634/Changes000644 000766 000024 00000351107 12557676326 013730 0ustar00timbostaff000000 000000 =head1 NAME DBI::Changes - List of significant changes to the DBI =encoding ISO8859-1 =cut =head2 Changes in DBI 1.634 - 3rd August 2015 Enabled strictures on all modules (Jose Luis Perez Diez) #22 Note that this might cause new exceptions in existing code. Please take time for extra testing before deploying to production. Improved handling of row counts for compiled drivers and enable them to return larger row counts (IV type) by defining new *_iv macros. Fixed quote_identifier that was adding a trailing separator when there was only a catalog (Martin J. Evans) Removed redundant keys() call in fetchall_arrayref with hash slice (ilmari) #24 Corrected pod xref to Placeholders section (Matthew D. Fuller) Corrected pod grammar (Nick Tonkin) #25 Added support for tables('', '', '', '%') special case (Martin J. Evans) Added support for DBD prefixes with numbers (Jens Rehsack) #19 Added extra initializer for DBI::DBD::SqlEngine based DBD's (Jens Rehsack) Added Memory Leaks section to the DBI docs (Tim) Added Artistic v1 & GPL v1 LICENSE file (Jose Luis Perez Diez) #21 =head2 Changes in DBI 1.633 - 11th Jan 2015 Fixed selectrow_*ref to return undef on error in list context instead if an empty list. Changed t/42prof_data.t more informative Changed $sth->{TYPE} to be NUMERIC in DBD::File drivers as per the DBI docs. Note TYPE_NAME is now also available. [H.Merijn Brand] Fixed compilation error on bleadperl due DEFSV no longer being an lvalue [Dagfinn Ilmari Mannsåker] Added docs for escaping placeholders using a backslash. Added docs for get_info(9000) indicating ability to escape placeholders. Added multi_ prefix for DBD::Multi (Dan Wright) and ad2_ prefix for DBD::AnyData2 =head2 Changes in DBI 1.632 - 9th Nov 2014 Fixed risk of memory corruption with many arguments to methods originally reported by OSCHWALD for Callbacks but may apply to other functionality in DBI method dispatch RT#86744. Fixed DBD::PurePerl to not set $sth->{Active} true by default drivers are expected to set it true as needed. Fixed DBI::DBD::SqlEngine to complain loudly when prerequite driver_prefix is not fulfilled (RT#93204) [Jens Rehsack] Fixed redundant sprintf argument warning RT#97062 [Reini Urban] Fixed security issue where DBD::File drivers would open files from folders other than specifically passed using the f_dir attribute RT#99508 [H.Merijn Brand] Changed delete $h->{$key} to work for keys with 'private_' prefix per request in RT#83156. local $h->{$key} works as before. Added security notice to DBD::Proxy and DBI::ProxyServer because they use Storable which is insecure. Thanks to ppisar@redhat.com RT#90475 Added note to AutoInactiveDestroy docs strongly recommending that it is enabled in all new code. =head2 Changes in DBI 1.631 - 20th Jan 2014 NOTE: This release changes the handle passed to Callbacks from being an 'inner' handle to being an 'outer' handle. If you have code that makes use of Callbacks, ensure that you understand what this change means and review your callback code. Fixed err_hash handling of integer err RT#92172 [Dagfinn Ilmari] Fixed use of \Q vs \E in t/70callbacks.t Changed the handle passed to Callbacks from being an 'inner' handle to being an 'outer' handle. Improved reliability of concurrent testing PR#8 [Peter Rabbitson] Changed optional dependencies to "suggest" PR#9 [Karen Etheridge] Changed to avoid mg_get in neatsvpv during global destruction PR#10 [Matt Phillips] =head2 Changes in DBI 1.630 - 28th Oct 2013 NOTE: This release enables PrintWarn by default regardless of $^W. Your applications may generate more log messages than before. Fixed err for new drh to be undef not to 0 [Martin J. Evans] Fixed RT#83132 - moved DBIstcf* constants to util export tag [Martin J. Evans] PrintWarn is now triggered by warnings recorded in methods like STORE that don't clear err RT#89015 [Tim Bunce] Changed tracing to no longer show quote and quote_identifier calls at trace level 1. Changed DBD::Gofer ping while disconnected set_err from warn to info. Clarified wording of log message when err is cleared. Changed bootstrap to use $XS_VERSION RT#89618 [Andreas Koenig] Added connect_cached.connected Callback PR#3 [David E. Wheeler] Clarified effect of refs in connect_cached attributes [David E. Wheeler] Extended ReadOnly attribute docs for when the driver cannot ensure read only [Martin J. Evans] Corrected SQL_BIGINT docs to say ODBC value is used PR#5 [ilmari] There was no DBI 1.629 release. =head2 Changes in DBI 1.628 - 22nd July 2013 Fixed missing fields on partial insert via DBI::DBD::SqlEngine engines (DBD::CSV, DBD::DBM etc.) [H.Merijn Brand, Jens Rehsack] Fixed stack corruption on callbacks RT#85562 RT#84974 [Aaron Schweiger] Fixed DBI::SQL::Nano_::Statement handling of "0" [Jens Rehsack] Fixed exit op precedence in test RT#87029 [Reni Urban] Added support for finding tables in multiple directories via new DBD::File f_dir_search attribute [H.Merijn Brand] Enable compiling by C++ RT#84285 [Kurt Jaeger] Typo fixes in pod and comment [David Steinbrunner] Change DBI's docs to refer to git not svn [H.Merijn Brand] Clarify bind_col TYPE attribute is sticky [Martin J. Evans] Fixed reference to $sth in selectall_arrayref docs RT#84873 Spelling fixes [Ville Skyttä] Changed $VERSIONs to hardcoded strings [H.Merijn Brand] =head2 Changes in DBI 1.627 - 16th May 2013 Fixed VERSION regression in DBI::SQL::Nano [Tim Bunce] =head2 Changes in DBI 1.626 - 15th May 2013 Fixed pod text/link was reversed in a few cases RT#85168 [H.Merijn Brand] Handle aliasing of STORE'd attributes in DBI::DBD::SqlEngine [Jens Rehsack] Updated repository URI to git [Jens Rehsack] Fixed skip() count arg in t/48dbi_dbd_sqlengine.t [Tim Bunce] =head2 Changes in DBI 1.625 (svn r15595) 28th March 2013 Fixed heap-use-after-free during global destruction RT#75614 thanks to Reini Urban. Fixed ignoring RootClass attribute during connect() by DBI::DBD::SqlEngine reported in RT#84260 by Michael Schout =head2 Changes in DBI 1.624 (svn r15576) 22nd March 2013 Fixed Gofer for hash randomization in perl 5.17.10+ RT#84146 Clarify docs for can() re RT#83207 =head2 Changes in DBI 1.623 (svn r15547) 2nd Jan 2013 Fixed RT#64330 - ping wipes out errstr (Martin J. Evans). Fixed RT#75868 - DBD::Proxy shouldn't call connected() on the server. Fixed RT#80474 - segfault in DESTROY with threads. Fixed RT#81516 - Test failures due to hash randomisation in perl 5.17.6 thanks to Jens Rehsack and H.Merijn Brand and feedback on IRC Fixed RT#81724 - Handle copy-on-write scalars (sprout) Fixed unused variable / self-assignment compiler warnings. Fixed default table_info in DBI::DBD::SqlEngine which passed NAMES attribute instead of NAME to DBD::Sponge RT72343 (Martin J. Evans) Corrected a spelling error thanks to Chris Sanders. Corrected typo in DBI->installed_versions docs RT#78825 thanks to Jan Dubois. Refactored table meta information management from DBD::File into DBI::DBD::SqlEngine (H.Merijn Brand, Jens Rehsack) Prevent undefined f_dir being used in opendir (H.Merijn Brand) Added logic to force destruction of children before parents during global destruction. See RT#75614. Added DBD::File Plugin-Support for table names and data sources (Jens Rehsack, #dbi Team) Added new tests to 08keeperr for RT#64330 thanks to Kenichi Ishigaki. Added extra internal handle type check, RT#79952 thanks to Reini Urban. Added cubrid_ registered prefix for DBD::cubrid, RT#78453 Removed internal _not_impl method (Martin J. Evans). NOTE: The "old-style" DBD::DBM attributes 'dbm_ext' and 'dbm_lockfile' have been deprecated for several years and their use will now generate a warning. =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 accommodate 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 attribute hash. Clarified documentation for ParamValues attribute hash keys. Many good DBI documentation tweaks from Jonathan Leffler, including a major update to the DBI::DBD driver author guide. Clarified that execute() should itself call finish() if it's called on a statement handle that's still active. Clarified $sth->{ParamValues}. Driver authors please note. Removed "NEW" markers on some methods and attributes and added text to each giving the DBI version it was added in, if it was added after DBI 1.21 (Feb 2002). Changes of note for authors of all drivers: Added SQL_DATA_TYPE, SQL_DATETIME_SUB, NUM_PREC_RADIX, and INTERVAL_PRECISION fields to docs for type_info_all. There were already in type_info(), but type_info_all() didn't specify the index values. Please check and update your type_info_all() code. Added DBI::DBD::Metadata module that auto-generates your drivers get_info and type_info_all data and code, thanks mainly to Jonathan Leffler and Steffen Goeldner. If you've not implemented get_info and type_info_all methods and your database has an ODBC driver available then this will do all the hard work for you! Drivers should no longer pass Err, Errstr, or State to _new_drh or _new_dbh functions. Please check that you support the slightly modified behaviour of $sth->{ParamValues}, e.g., always return hash with keys if possible. Changes of note for authors of compiled drivers: Added dbd_db_login6 & dbd_st_finish3 prototypes thanks to Jonathan Leffler. All dbd_*_*() functions implemented by drivers must have a corresponding #define dbd_*_* _*_* otherwise the driver may not work with a future release of the DBI. Changes of note for authors of drivers which use Driver.xst: Some new method hooks have been added are are enabled by defining corresponding macros: $drh->data_sources() - dbd_dr_data_sources $dbh->do() - dbd_db_do4 The following methods won't be compiled into the driver unless the corresponding macro has been #defined: $drh->disconnect_all() - dbd_discon_all =head2 Changes in DBI 1.32, 1st December 2002 Fixed to work with 5.005_03 thanks to Tatsuhiko Miyagawa (I've not tested it). Reenabled taint tests (accidentally left disabled) spotted by Bradley Baetz. Improved docs for FetchHashKeyName attribute thanks to Ian Barwick. Fixed core dump if fetchrow_hashref given bad argument (name of attribute with a value that wasn't an array reference), spotted by Ian Barwick. Fixed some compiler warnings thanks to David Wheeler. Updated Steven Hirsch's enhanced proxy work (seems I left out a bit). Made t/40profile.t tests more reliable, reported by Randy, who is part of the excellent CPAN testers team: http://testers.cpan.org/ (Please visit, see the valuable work they do and, ideally, join in!) =head2 Changes in DBI 1.31, 29th November 2002 The fetchall_arrayref method, when called with a $maxrows parameter, no longer gives an error if called again after all rows have been fetched. This simplifies application logic when fetching in batches. Also added batch-fetch while() loop example to the docs. The proxy now supports non-lazy (synchronous) prepare, positioned updates (for selects containing 'for update'), PlRPC config set via attributes, and accurate propagation of errors, all thanks to Steven Hirsch (plus a minor fix from Sean McMurray and doc tweaks from Michael A Chase). The DBI_AUTOPROXY env var can now hold the full dsn of the proxy driver plus attributes, like "dbi:Proxy(proxy_foo=>1):host=...". Added TaintIn & TaintOut attributes to give finer control over tainting thanks to Bradley Baetz. The RootClass attribute no longer ignores failure to load a module, but also doesn't try to load a module if the class already exists, with thanks to James FitzGibbon. HandleError attribute works for connect failures thanks to David Wheeler. The connect() RaiseError/PrintError message now includes the username. Changed "last handle unknown or destroyed" warning to be a trace message. Removed undocumented $h->event() method. Further enhancements to DBD::PurePerl accuracy. The CursorName attribute now defaults to undef and not an error. DBI::Profile changes: New DBI::ProfileDumper, DBI::ProfileDumper::Apache, and DBI::ProfileData modules (to manage the storage and processing of profile data), plus dbiprof program for analyzing profile data - with many thanks to Sam Tregar. Added $DBI::err (etc) tied variable lookup time to profile. Added time for DESTROY method into parent handles profile (used to be ignored). Documentation changes: Documented $dbh = $sth->{Database} attribute. Documented $dbh->connected(...) post-connection call when subclassing. Updated some minor doc issues thanks to H.Merijn Brand. Updated Makefile.PL example in DBI::DBD thanks to KAWAI,Takanori. Fixed execute_array() example thanks to Peter van Hardenberg. Changes for driver authors, not required but strongly recommended: Change DBIS to DBIc_DBISTATE(imp_xxh) [or imp_dbh, imp_sth etc] Change DBILOGFP to DBIc_LOGPIO(imp_xxh) [or imp_dbh, imp_sth etc] Any function from which all instances of DBIS and DBILOGFP are removed can also have dPERLINTERP removed (a good thing). All use of the DBIh_EVENT* macros should be removed. Major update to DBI::DBD docs thanks largely to Jonathan Leffler. Add these key values: 'Err' => \my $err, 'Errstr' => \my $errstr, to the hash passed to DBI::_new_dbh() in your driver source code. That will make each $dbh have it's own $h->err and $h->errstr values separate from other $dbh belonging to the same driver. If you have a ::db or ::st DESTROY methods that do nothing you can now remove them - which speeds up handle destruction. =head2 Changes in DBI 1.30, 18th July 2002 Fixed problems with selectrow_array, selectrow_arrayref, and selectall_arrayref introduced in DBI 1.29. Fixed FETCHing a handle attribute to not clear $DBI::err etc (broken in 1.29). Fixed core dump at trace level 9 or above. Fixed compilation with perl 5.6.1 + ithreads (i.e. Windows). Changed definition of behaviour of selectrow_array when called in a scalar context to match fetchrow_array. Corrected selectrow_arrayref docs which showed selectrow_array thanks to Paul DuBois. =head2 Changes in DBI 1.29, 15th July 2002 NOTE: This release changes the specified behaviour for the : fetchrow_array method when called in a scalar context: : The DBI spec used to say that it would return the FIRST field. : Which field it returns (i.e., the first or the last) is now undefined. : This does not affect statements that only select one column, which is : usually the case when fetchrow_array is called in a scalar context. : FYI, this change was triggered by discovering that the fetchrow_array : implementation in Driver.xst (used by most compiled drivers) : didn't match the DBI specification. Rather than change the code : to match, and risk breaking existing applications, I've changed the : specification (that part was always of dubious value anyway). NOTE: Future versions of the DBI may not support for perl 5.5 much longer. : If you are still using perl 5.005_03 you should be making plans to : upgrade to at least perl 5.6.1, or 5.8.0. Perl 5.8.0 is due to be : released in the next week or so. (Although it's a "point 0" release, : it is the most thoroughly 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 noticeable with fetchall_arrayref for many rows or selectrow_arrayref with a fast query. For example, using DBD::mysql a selectrow_arrayref for a single row using a primary key is ~20% faster, and fetchall_arrayref for 20000 rows is twice as fast! Drivers just need to be recompiled and reinstalled to enable it. The fetchall_arrayref speed up only applies if $slice parameter is not used. Added $max_rows parameter to fetchall_arrayref() to optionally limit the number of rows returned. Can now fetch batches of rows. Added MaxRows attribute to selectall_arrayref() which then passes it to fetchall_arrayref(). Changed selectrow_array to make use of selectrow_arrayref. Trace level 1 now shows first two parameters of all methods (used to only for that for some, like prepare,execute,do etc) Trace indicator for recursive calls (first char on trace lines) now starts at 1 not 2. Documented that $h->func() does not trigger RaiseError etc so applications must explicitly check for errors. DBI::Profile with DBI_PROFILE now shows percentage time inside DBI. HandleError docs updated to show that handler can edit error message. HandleError subroutine interface is now regarded as stable. =head2 Changes in DBI 1.25, 5th June 2002 Fixed build problem on Windows and some compiler warnings. Fixed $dbh->{Driver} and $sth->{Statement} for driver internals These are 'inner' handles as per behaviour prior to DBI 1.16. Further minor improvements to DBI::PurePerl accuracy. =head2 Changes in DBI 1.24, 4th June 2002 Fixed reference loop causing a handle/memory leak that was introduced in DBI 1.16. Fixed DBI::Format to work with 'filehandles' from IO::Scalar and similar modules thanks to report by Jeff Boes. Fixed $h->func for DBI::PurePerl thanks to Jeff Zucker. Fixed $dbh->{Name} for DBI::PurePerl thanks to Dean Arnold. Added DBI method call profiling and benchmarking. This is a major new addition to the DBI. See $h->{Profile} attribute and DBI::Profile module. For a quick trial, set the DBI_PROFILE environment variable and run your favourite DBI script. Try it with DBI_PROFILE set to 1, then try 2, 4, 8, 10, and -10. Have fun! Added execute_array() and bind_param_array() documentation with thanks to Dean Arnold. Added notes about the DBI having not yet been tested with iThreads (testing and patches for SvLOCK etc welcome). Removed undocumented Handlers attribute (replaced by HandleError). Tested with 5.5.3 and 5.8.0 RC1. =head2 Changes in DBI 1.23, 25th May 2002 Greatly improved DBI::PurePerl in performance and accuracy. Added more detail to DBI::PurePerl docs about what's not supported. Fixed undef warnings from t/15array.t and DBD::Sponge. =head2 Changes in DBI 1.22, 22nd May 2002 Added execute_array() and bind_param_array() with special thanks to Dean Arnold. Not yet documented. See t/15array.t for examples. All drivers now automatically support these methods. Added DBI::PurePerl, a transparent DBI emulation for pure-perl drivers with special thanks to Jeff Zucker. Perldoc DBI::PurePerl for details. Added DBI::Const::GetInfo* modules thanks to Steffen Goeldner. Added write_getinfo_pm utility to DBI::DBD thanks to Steffen Goeldner. Added $allow_active==2 mode for prepare_cached() thanks to Stephen Clouse. Updated DBI::Format to Revision 11.4 thanks to Tom Lowery. Use File::Spec in Makefile.PL (helps VMS etc) thanks to Craig Berry. Extend $h->{Warn} to commit/rollback ineffective warning thanks to Jeff Baker. Extended t/preparse.t and removed "use Devel::Peek" thanks to Scott Hildreth. Only copy Changes to blib/lib/Changes.pm once thanks to Jonathan Leffler. Updated internals for modern perls thanks to Jonathan Leffler and Jeff Urlwin. Tested with perl 5.7.3 (just using default perl config). Documentation changes: Added 'Catalog Methods' section to docs thanks to Steffen Goeldner. Updated README thanks to Michael Schwern. Clarified that driver may choose not to start new transaction until next use of $dbh after commit/rollback. Clarified docs for finish method. Clarified potentials problems with prepare_cached() thanks to Stephen Clouse. =head2 Changes in DBI 1.21, 7th February 2002 The minimum supported perl version is now 5.005_03. Fixed DBD::Proxy support for AutoCommit thanks to Jochen Wiedmann. Fixed DBI::ProxyServer bind_param(_inout) handing thanks to Oleg Mechtcheriakov. Fixed DBI::ProxyServer fetch loop thanks to nobull@mail.com. Fixed install_driver do-the-right-thing with $@ on error. It, and connect(), will leave $@ empty on success and holding the error message on error. Thanks to Jay Lawrence, Gavin Sherlock and others for the bug report. Fixed fetchrow_hashref to assign columns to the hash left-to-right so later fields with the same name overwrite earlier ones as per DBI < 1.15, thanks to Kay Roepke. Changed tables() to use quote_indentifier() if the driver returns a true value for $dbh->get_info(29) # SQL_IDENTIFIER_QUOTE_CHAR Changed ping() so it no longer triggers RaiseError/PrintError. Changed connect() to not call $class->install_driver unless needed. Changed DESTROY to catch fatal exceptions and append to $@. Added ISO SQL/CLI & ODBCv3 data type definitions thanks to Steffen Goeldner. Removed the definition of SQL_BIGINT data type constant as the value is inconsistent between standards (ODBC=-5, SQL/CLI=25). Added $dbh->column_info(...) thanks to Steffen Goeldner. Added $dbh->foreign_key_info(...) thanks to Steffen Goeldner. Added $dbh->quote_identifier(...) insipred by Simon Oliver. Added $dbh->set_err(...) for DBD authors and DBI subclasses (actually been there for a while, now expanded and documented). Added $h->{HandleError} = sub { ... } addition and/or alternative to RaiseError/PrintError. See the docs for more info. Added $h->{TraceLevel} = N attribute to set/get trace level of handle thus can set trace level via an (eg externally specified) DSN using the embedded attribute syntax: $dsn = 'dbi:DB2(PrintError=1,TraceLevel=2):dbname'; Plus, you can also now do: local($h->{TraceLevel}) = N; (but that leaks a little memory in some versions of perl). Added some call tree information to trace output if trace level >= 3 With thanks to Graham Barr for the stack walking code. Added experimental undocumented $dbh->preparse(), see t/preparse.t With thanks to Scott T. Hildreth for much of the work. Added Fowler/Noll/Vo hash type as an option to DBI::hash(). Documentation changes: Added DBI::Changes so now you can "perldoc DBI::Changes", yeah! Added selectrow_arrayref & selectrow_hashref docs thanks to Doug Wilson. Added 'Standards Reference Information' section to docs to gather together all references to relevant on-line standards. Added link to poop.sourceforge.net into the docs thanks to Dave Rolsky. Added link to hyperlinked BNF for SQL92 thanks to Jeff Zucker. Added 'Subclassing the DBI' docs thanks to Stephen Clouse, and then changed some of them to reflect the new approach to subclassing. Added stronger wording to description of $h->{private_*} attributes. Added docs for DBI::hash. Driver API changes: Now a COPY of the DBI->connect() attributes is passed to the driver connect() method, so it can process and delete any elements it wants. Deleting elements reduces/avoids the explicit $dbh->{$_} = $attr->{$_} foreach keys %$attr; that DBI->connect does after the driver connect() method returns. =head2 Changes in DBI 1.20, 24th August 2001 WARNING: This release contains two changes that may affect your code. : Any code using selectall_hashref(), which was added in March 2001, WILL : need to be changed. Any code using fetchall_arrayref() with a non-empty : hash slice parameter may, in a few rare cases, need to be changed. : See the change list below for more information about the changes. : See the DBI documentation for a description of current behaviour. Fixed memory leak thanks to Toni Andjelkovic. Changed fetchall_arrayref({ foo=>1, ...}) specification again (sorry): The key names of the returned hashes is identical to the letter case of the names in the parameter hash, regardless of the L attribute. The letter case is ignored for matching. Changed fetchall_arrayref([...]) array slice syntax specification to clarify that the numbers in the array slice are perl index numbers (which start at 0) and not column numbers (which start at 1). Added { Columns=>... } and { Slice =>... } attributes to selectall_arrayref() which is passed to fetchall_arrayref() so it can fetch hashes now. Added a { Columns => [...] } attribute to selectcol_arrayref() so that the list it returns can be built from more than one column per row. Why? Consider my %hash = @{$dbh->selectcol_arrayref($sql,{ Columns=>[1,2]})} to return id-value pairs which can be used directly to build a hash. Added $hash_ref = $sth->fetchall_hashref( $key_field ) which returns a ref to a hash with, typically, one element per row. $key_field is the name of the field to get the key for each row from. The value of the hash for each row is a hash returned by fetchrow_hashref. Changed selectall_hashref to return a hash ref (from fetchall_hashref) and not an array of hashes as it has since DBI 1.15 (end March 2001). WARNING: THIS CHANGE WILL BREAK ANY CODE USING selectall_hashref()! Sorry, but I think this is an important regularization of the API. To get previous selectall_hashref() behaviour (an array of hash refs) change $ary_ref = $dbh->selectall_hashref( $statement, undef, @bind); to $ary_ref = $dbh->selectall_arrayref($statement, { Columns=>{} }, @bind); Added NAME_lc_hash, NAME_uc_hash, NAME_hash statement handle attributes. which return a ref to a hash of field_name => field_index (0..n-1) pairs. Fixed select_hash() example thanks to Doug Wilson. Removed (unbundled) DBD::ADO and DBD::Multiplex from the DBI distribution. The latest versions of those modules are available from CPAN sites. Added $dbh->begin_work. This method causes AutoCommit to be turned off just until the next commit() or rollback(). Driver authors: if the DBIcf_BegunWork flag is set when your commit or rollback method is called then please turn AutoCommit on and clear the DBIcf_BegunWork flag. If you don't then the DBI will but it'll be much less efficient and won't handle error conditions very cleanly. Retested on perl 5.4.4, but the DBI won't support 5.4.x much longer. Added text to SUPPORT section of the docs: For direct DBI and DBD::Oracle support, enhancement, and related work I am available for consultancy on standard commercial terms. Added text to ACKNOWLEDGEMENTS section of the docs: Much of the DBI and DBD::Oracle was developed while I was Technical Director (CTO) of the Paul Ingram Group (www.ig.co.uk). So I'd especially like to thank Paul for his generosity and vision in supporting this work for many years. =head2 Changes in DBI 1.19, 20th July 2001 Made fetchall_arrayref({ foo=>1, ...}) be more strict to the specification in relation to wanting hash slice keys to be lowercase names. WARNING: If you've used fetchall_arrayref({...}) with a hash slice that contains keys with uppercase letters then your code will break. (As far as I recall the spec has always said don't do that.) Fixed $sth->execute() to update $dbh->{Statement} to $sth->{Statement}. Added row number to trace output for fetch method calls. Trace level 1 no longer shows fetches with row>1 (to reduce output volume). Added $h->{FetchHashKeyName} = 'NAME_lc' or 'NAME_uc' to alter behaviour of fetchrow_hashref() method. See docs. Added type_info quote caching to quote() method thanks to Dean Kopesky. Makes using quote() with second data type param much much faster. Added type_into_all() caching to type_info(), spotted by Dean Kopesky. Added new API definition for table_info() and tables(), driver authors please note! Added primary_key_info() to DBI API thanks to Steffen Goeldner. Added primary_key() to DBI API as simpler interface to primary_key_info(). Indent and other fixes for DBI::DBD doc thanks to H.Merijn Brand. Added prepare_cached() insert_hash() example thanks to Doug Wilson. Removed false docs for fetchall_hashref(), use fetchall_arrayref({}). =head2 Changes in DBI 1.18, 4th June 2001 Fixed that altering ShowErrorStatement also altered AutoCommit! Thanks to Jeff Boes for spotting that clanger. Fixed DBD::Proxy to handle commit() and rollback(). Long overdue, sorry. Fixed incompatibility with perl 5.004 (but no one's using that right? :) Fixed connect_cached and prepare_cached to not be affected by the order of elements in the attribute hash. Spotted by Mitch Helle-Morrissey. Fixed version number of DBI::Shell reported by Stuhlpfarrer Gerhard and others. Defined and documented table_info() attribute semantics (ODBC compatible) thanks to Olga Voronova, who also implemented then in DBD::Oracle. Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. =head2 Changes in DBI 1.16, 30th May 2001 Reimplemented fetchrow_hashref in C, now fetches about 25% faster! Changed behaviour if both PrintError and RaiseError are enabled to simply do both (in that order, obviously :) Slight reduction in DBI handle creation overhead. Fixed $dbh->{Driver} & $sth->{Database} to return 'outer' handles. Fixed execute param count check to honour RaiseError spotted by Belinda Giardie. Fixed build for perl5.6.1 with PERLIO thanks to H.Merijn Brand. Fixed client sql restrictions in ProxyServer.pm thanks to Jochen Wiedmann. Fixed batch mode command parsing in Shell thanks to Christian Lemburg. Fixed typo in selectcol_arrayref docs thanks to Jonathan Leffler. Fixed selectrow_hashref to be available to callers thanks to T.J.Mather. Fixed core dump if statement handle didn't define Statement attribute. Added bind_param_inout docs to DBI::DBD thanks to Jonathan Leffler. Added note to data_sources() method docs that some drivers may require a connected database handle to be supplied as an attribute. Trace of install_driver method now shows path of driver file loaded. Changed many '||' to 'or' in the docs thanks to H.Merijn Brand. Updated DBD::ADO again (improvements in error handling) from Tom Lowery. Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. Updated email and web addresses in DBI::FAQ thanks to Michael A Chase. =head2 Changes in DBI 1.15, 28th March 2001 Added selectrow_arrayref Added selectrow_hashref Added selectall_hashref thanks to Leon Brocard. Added DBI->connect(..., { dbi_connect_method => 'method' }) Added $dbh->{Statement} aliased to most recent child $sth->{Statement}. Added $h->{ShowErrorStatement}=1 to cause the appending of the relevant Statement text to the RaiseError/PrintError text. Modified type_info to always return hash keys in uppercase and to not require uppercase 'DATA_TYPE' key from type_info_all. Thanks to Jennifer Tong and Rob Douglas. Added \%attr param to tables() and table_info() methods. Trace method uses warn() if it can't open the new file. Trace shows source line and filename during global destruction. Updated packages: Updated Win32::DBIODBC (Win32::ODBC emulation) thanks to Roy Lee. Updated DBD::ADO to much improved version 0.4 from Tom Lowery. Updated DBD::Sponge to include $sth->{PRECISION} thanks to Tom Lowery. Changed DBD::ExampleP to use lstat() instead of stat(). Documentation: Documented $DBI::lasth (which has been there since day 1). Documented SQL_* names. Clarified and extended docs for $h->state thanks to Masaaki Hirose. Clarified fetchall_arrayref({}) docs (thanks to, er, someone!). Clarified type_info_all re lettercase and index values. Updated DBI::FAQ to 0.38 thanks to Alligator Descartes. Added cute bind_columns example thanks to H.Merijn Brand. Extended docs on \%attr arg to data_sources method. Makefile.PL Removed obscure potential 'rm -rf /' (thanks to Ulrich Pfeifer). Removed use of glob and find (thanks to Michael A. Chase). Proxy: Removed debug messages from DBD::Proxy AUTOLOAD thanks to Brian McCauley. Added fix for problem using table_info thanks to Tom Lowery. Added better determination of where to put the pid file, and... Added KNOWN ISSUES section to DBD::Proxy docs thanks to Jochen Wiedmann. Shell: Updated DBI::Format to include DBI::Format::String thanks to Tom Lowery. Added describe command thanks to Tom Lowery. Added columnseparator option thanks to Tom Lowery (I think). Added 'raw' format thanks to, er, someone, maybe Tom again. Known issues: Perl 5.005 and 5.006 both leak memory doing local($handle->{Foo}). Perl 5.004 doesn't. The leak is not a DBI or driver bug. =head2 Changes in DBI 1.14, 14th June 2000 NOTE: This version is the one the DBI book is based on. NOTE: This version requires at least Perl 5.004. Perl 5.6 ithreads changes with thanks to Doug MacEachern. Changed trace output to use PerlIO thanks to Paul Moore. Fixed bug in RaiseError/PrintError handling. (% chars in the error string could cause a core dump.) Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt. Major documentation polishing thanks to Linda Mui at O'Reilly. Password parameter now shown as **** in trace output. Added two fields to type_info and type_info_all. Added $dsn to PrintError/RaiseError message from DBI->connect(). Changed prepare_cached() croak to carp if sth still Active. Added prepare_cached() example to the docs. Added further DBD::ADO enhancements from Thomas Lowery. =head2 Changes in DBI 1.13, 11th July 1999 Fixed Win32 PerlEx IIS concurrency bugs thanks to Murray Nesbitt. Fixed problems with DBD::ExampleP long_list test mode. Added SQL_WCHAR SQL_WVARCHAR SQL_WLONGVARCHAR and SQL_BIT to list of known and exportable SQL types. Improved data fetch performance of DBD::ADO. Added GetTypeInfo to DBD::ADO thanks to Thomas Lowery. Actually documented connect_cached thanks to Michael Schwern. Fixed user/key/cipher bug in ProxyServer thanks to Joshua Pincus. =head2 Changes in DBI 1.12, 29th June 1999 Fixed significant DBD::ADO bug (fetch skipped first row). Fixed ProxyServer bug handling non-select statements. Fixed VMS problem with t/examp.t thanks to Craig Berry. Trace only shows calls to trace_msg and _set_fbav at high levels. Modified t/examp.t to workaround Cygwin buffering bug. =head2 Changes in DBI 1.11, 17th June 1999 Fixed bind_columns argument checking to allow a single arg. Fixed problems with internal default_user method. Fixed broken DBD::ADO. Made default $DBI::rows more robust for some obscure cases. =head2 Changes in DBI 1.10, 14th June 1999 Fixed trace_msg.al error when using Apache. Fixed dbd_st_finish enhancement in Driver.xst (internals). Enable drivers to define default username and password and temporarily disabled warning added in 1.09. Thread safety optimised for single thread case. =head2 Changes in DBI 1.09, 9th June 1999 Added optional minimum trace level parameter to trace_msg(). Added warning in Makefile.PL that DBI will require 5.004 soon. Added $dbh->selectcol_arrayref($statement) method. Fixed fetchall_arrayref hash-slice mode undef NAME problem. Fixed problem with tainted parameter checking and t/examp.t. Fixed problem with thread safety code, including 64 bit machines. Thread safety now enabled by default for threaded perls. Enhanced code for MULTIPLICITY/PERL_OBJECT from ActiveState. Enhanced prepare_cached() method. Minor changes to trace levels (less internal info at level 2). Trace log now shows "!! ERROR..." before the "<- method" line. DBI->connect() now warn's if user / password is undefined and DBI_USER / DBI_PASS environment variables are not defined. The t/proxy.t test now ignores any /etc/dbiproxy.conf file. Added portability fixes for MacOS from Chris Nandor. Updated mailing list address from fugue.com to isc.org. =head2 Changes in DBI 1.08, 12th May 1999 Much improved DBD::ADO driver thanks to Phlip Plumlee and others. Connect now allows you to specify attribute settings within the DSN E.g., "dbi:Driver(RaiseError=>1,Taint=>1,AutoCommit=>0):dbname" The $h->{Taint} attribute now also enables taint checking of arguments to almost all DBI methods. Improved trace output in various ways. Fixed bug where $sth->{NAME_xx} was undef in some situations. Fixed code for MULTIPLICITY/PERL_OBJECT thanks to Alex Smishlajev. Fixed and documented DBI->connect_cached. Workaround for Cygwin32 build problem with help from Jong-Pork Park. bind_columns no longer needs undef or hash ref as first parameter. =head2 Changes in DBI 1.07, 6th May 1999 Trace output now shows contents of array refs returned by DBI. Changed names of some result columns from type_info, type_info_all, tables and table_info to match ODBC 3.5 / ISO/IEC standards. Many fixes for DBD::Proxy and ProxyServer. Fixed error reporting in install_driver. Major enhancement to DBI::W32ODBC from Patrick Hollins. Added $h->{Taint} to taint fetched data if tainting (perl -T). Added code for MULTIPLICITY/PERL_OBJECT contributed by ActiveState. Added $sth->more_results (undocumented for now). =head2 Changes in DBI 1.06, 6th January 1999 Fixed Win32 Makefile.PL problem in 1.04 and 1.05. Significant DBD::Proxy enhancements and fixes including support for bind_param_inout (Jochen and I) Added experimental DBI->connect_cached method. Added $sth->{NAME_uc} and $sth->{NAME_lc} attributes. Enhanced fetchrow_hashref to take an attribute name arg. =head2 Changes in DBI 1.05, 4th January 1999 Improved DBD::ADO connect (thanks to Phlip Plumlee). Improved thread safety (thanks to Jochen Wiedmann). [Quick release prompted by truncation of copies on CPAN] =head2 Changes in DBI 1.04, 3rd January 1999 Fixed error in Driver.xst. DBI build now tests Driver.xst. Removed unused variable compiler warnings in Driver.xst. DBI::DBD module now tested during DBI build. Further clarification in the DBI::DBD driver writers manual. Added optional name parameter to $sth->fetchrow_hashref. =head2 Changes in DBI 1.03, 1st January 1999 Now builds with Perl>=5.005_54 (PERL_POLLUTE in DBIXS.h) DBI trace trims path from "at yourfile.pl line nnn". Trace level 1 now shows statement passed to prepare. Assorted improvements to the DBI manual. Assorted improvements to the DBI::DBD driver writers manual. Fixed $dbh->quote prototype to include optional $data_type. Fixed $dbh->prepare_cached problems. $dbh->selectrow_array behaves better in scalar context. Added a (very) experimental DBD::ADO driver for Win32 ADO. Added experimental thread support (perl Makefile.PL -thread). Updated the DBI::FAQ - thanks to Alligator Descartes. The following changes were implemented and/or packaged by Jochen Wiedmann - thanks Jochen: Added a Bundle for CPAN installation of DBI, the DBI proxy server and prerequisites (lib/Bundle/DBI.pm). DBI->available_drivers uses File::Spec, if available. This makes it work on MacOS. (DBI.pm) Modified type_info to work with read-only values returned by type_info_all. (DBI.pm) Added handling of magic values in $sth->execute, $sth->bind_param and other methods (Driver.xst) Added Perl's CORE directory to the linkers path on Win32, required by recent versions of ActiveState Perl. Fixed DBD::Sponge to work with empty result sets. Complete rewrite of DBI::ProxyServer and DBD::Proxy. =head2 Changes in DBI 1.02, 2nd September 1998 Fixed DBI::Shell including @ARGV and /current. Added basic DBI::Shell test. Renamed DBI::Shell /display to /format. =head2 Changes in DBI 1.01, 2nd September 1998 Many enhancements to Shell (with many contributions from Jochen Wiedmann, Tom Lowery and Adam Marks). Assorted fixes to DBD::Proxy and DBI::ProxyServer. Tidied up trace messages - trace(2) much cleaner now. Added $dbh->{RowCacheSize} and $sth->{RowsInCache}. Added experimental DBI::Format (mainly for DBI::Shell). Fixed fetchall_arrayref($slice_hash). DBI->connect now honours PrintError=1 if connect fails. Assorted clarifications to the docs. =head2 Changes in DBI 1.00, 14th August 1998 The DBI is no longer 'alpha' software! Added $dbh->tables and $dbh->table_info. Documented \%attr arg to data_sources method. Added $sth->{TYPE}, $sth->{PRECISION} and $sth->{SCALE}. Added $sth->{Statement}. DBI::Shell now uses neat_list to print results It also escapes "'" chars and converts newlines to spaces. =head2 Changes in DBI 0.95, 10th August 1998 WARNING: THIS IS AN EXPERIMENTAL RELEASE! Fixed 0.94 slip so it will build on pre-5.005 again. Added DBI_AUTOPROXY environment variable. Array ref returned from fetch/fetchrow_arrayref now readonly. Improved connect error reporting by DBD::Proxy. All trace/debug messages from DBI now go to trace file. =head2 Changes in DBI 0.94, 9th August 1998 WARNING: THIS IS AN EXPERIMENTAL RELEASE! Added DBD::Shell and dbish interactive DBI shell. Try it! Any database attribs can be set via DBI->connect(,,, \%attr). Added _get_fbav and _set_fbav methods for Perl driver developers (see ExampleP driver for perl usage). Drivers which don't use one of these methods (either via XS or Perl) are not compliant. DBI trace now shows adds " at yourfile.pl line nnn"! PrintError and RaiseError now prepend driver and method name. The available_drivers method no longer returns NullP or Sponge. Added $dbh->{Name}. Added $dbh->quote($value, $data_type). Added more hints to install_driver failure message. Added DBD::Proxy and DBI::ProxyServer (from Jochen Wiedmann). Added $DBI::neat_maxlen to control truncation of trace output. Added $dbh->selectall_arrayref and $dbh->selectrow_array methods. Added $dbh->tables. Added $dbh->type_info and $dbh->type_info_all. Added $h->trace_msg($msg) to write to trace log. Added @bool = DBI::looks_like_number(@ary). Many assorted improvements to the DBI docs. =head2 Changes in DBI 0.93, 13th February 1998 Fixed DBI::DBD::dbd_postamble bug causing 'Driver.xsi not found' errors. Changes to handling of 'magic' values in neatsvpv (used by trace). execute (in Driver.xst) stops binding after first bind error. This release requires drivers to be rebuilt. =head2 Changes in DBI 0.92, 3rd February 1998 Fixed per-handle memory leak (with many thanks to Irving Reid). Added $dbh->prepare_cached() caching variant of $dbh->prepare. Added some attributes: $h->{Active} is the handle 'Active' (vague concept) (boolean) $h->{Kids} e.g. number of sth's associated with a dbh $h->{ActiveKids} number of the above which are 'Active' $dbh->{CachedKids} ref to prepare_cached sth cache Added support for general-purpose 'private_' attributes. Added experimental support for subclassing the DBI: see t/subclass.t Added SQL_ALL_TYPES to exported :sql_types. Added dbd_dbi_dir() and dbd_dbi_arch_dir() to DBI::DBD module so that DBD Makefile.PLs can work with the DBI installed in non-standard locations. Fixed 'Undefined value' warning and &sv_no output from neatsvpv/trace. Fixed small 'once per interpreter' leak. Assorted minor documentation fixes. =head2 Changes in DBI 0.91, 10th December 1997 NOTE: This fix may break some existing scripts: DBI->connect("dbi:...",$user,$pass) was not setting AutoCommit and PrintError! DBI->connect(..., { ... }) no longer sets AutoCommit or PrintError twice. DBI->connect(..., { RaiseError=>1 }) now croaks if connect fails. Fixed $fh parameter of $sth->dump_results; Added default statement DESTROY method which carps. Added default driver DESTROY method to silence AUTOLOAD/__DIE__/CGI::Carp Added more SQL_* types to %EXPORT_TAGS and @EXPORT_OK. Assorted documentation updates (mainly clarifications). Added workaround for perl's 'sticky lvalue' bug. Added better warning for bind_col(umns) where fields==0. Fixed to build okay with 5.004_54 with or without USE_THREADS. Note that the DBI has not been tested for thread safety yet. =head2 Changes in DBI 0.90, 6th September 1997 Can once again be built with Perl 5.003. The DBI class can be subclassed more easily now. InactiveDestroy fixed for drivers using the *.xst template. Slightly faster handle creation. Changed prototype for dbd_*_*_attrib() to add extra param. Note: 0.90, 0.89 and possibly some other recent versions have a small memory leak. This will be fixed in the next release. =head2 Changes in DBI 0.89, 25th July 1997 Minor fix to neatsvpv (mainly used for debug trace) to workaround bug in perl where SvPV removes IOK flag from an SV. Minor updates to the docs. =head2 Changes in DBI 0.88, 22nd July 1997 Fixed build for perl5.003 and Win32 with Borland. Fixed documentation formatting. Fixed DBI_DSN ignored for old-style connect (with explicit driver). Fixed AutoCommit in DBD::ExampleP Fixed $h->trace. The DBI can now export SQL type values: use DBI ':sql_types'; Modified Driver.xst and renamed DBDI.h to dbd_xsh.h =head2 Changes in DBI 0.87, 18th July 1997 Fixed minor type clashes. Added more docs about placeholders and bind values. =head2 Changes in DBI 0.86, 16th July 1997 Fixed failed connect causing 'unblessed ref' and other errors. Drivers must handle AutoCommit FETCH and STORE else DBI croaks. Added $h->{LongReadLen} and $h->{LongTruncOk} attributes for BLOBS. Added DBI_USER and DBI_PASS env vars. See connect docs for usage. Added DBI->trace() to set global trace level (like per-handle $h->trace). PERL_DBI_DEBUG env var renamed DBI_DEBUG (old name still works for now). Updated docs, including commit, rollback, AutoCommit and Transactions sections. Added bind_param method and execute(@bind_values) to docs. Fixed fetchall_arrayref. Since the DBIS structure has change the internal version numbers have also changed (DBIXS_VERSION == 9 and DBISTATE_VERSION == 9) so drivers will have to be recompiled. The test is also now more sensitive and the version mismatch error message now more clear about what to do. Old drivers are likely to core dump (this time) until recompiled for this DBI. In future DBI/DBD version mismatch will always produce a clear error message. Note that this DBI release contains and documents many new features that won't appear in drivers for some time. Driver writers might like to read perldoc DBI::DBD and comment on or apply the information given. =head2 Changes in DBI 0.85, 25th June 1997 NOTE: New-style connect now defaults to AutoCommit mode unless { AutoCommit => 0 } specified in connect attributes. See the docs. AutoCommit attribute now defined and tracked by DBI core. Drivers should use/honour this and not implement their own. Added pod doc changes from Andreas and Jonathan. New DBI_DSN env var default for connect method. See docs. Documented the func method. Fixed "Usage: DBD::_::common::DESTROY" error. Fixed bug which set some attributes true when there value was fetched. Added new internal DBIc_set() macro for drivers to use. =head2 Changes in DBI 0.84, 20th June 1997 Added $h->{PrintError} attribute which, if set true, causes all errors to trigger a warn(). New-style DBI->connect call now automatically sets PrintError=1 unless { PrintError => 0 } specified in the connect attributes. See the docs. The old-style connect with a separate driver parameter is deprecated. Fixed fetchrow_hashref. Renamed $h->debug to $h->trace() and added a trace filename arg. Assorted other minor tidy-ups. =head2 Changes in DBI 0.83, 11th June 1997 Added driver specification syntax to DBI->connect data_source parameter: DBI->connect('dbi:driver:...', $user, $passwd); The DBI->data_sources method should return data_source names with the appropriate 'dbi:driver:' prefix. DBI->connect will warn if \%attr is true but not a hash ref. Added the new fetchrow methods: @row_ary = $sth->fetchrow_array; $ary_ref = $sth->fetchrow_arrayref; $hash_ref = $sth->fetchrow_hashref; The old fetch and fetchrow methods still work. Driver implementors should implement the new names for fetchrow_array and fetchrow_arrayref ASAP (use the xs ALIAS: directive to define aliases for fetch and fetchrow). Fixed occasional problems with t/examp.t test. Added automatic errstr reporting to the debug trace output. Added the DBI FAQ from Alligator Descartes in module form for easy reading via "perldoc DBI::FAQ". Needs reformatting. Unknown driver specific attribute names no longer croak. Fixed problem with internal neatsvpv macro. =head2 Changes in DBI 0.82, 23rd May 1997 Added $h->{RaiseError} attribute which, if set true, causes all errors to trigger a die(). This makes it much easier to implement robust applications in terms of higher level eval { ... } blocks and rollbacks. Added DBI->data_sources($driver) method for implementation by drivers. The quote method now returns the string NULL (without quotes) for undef. Added VMS support thanks to Dan Sugalski. Added a 'quick start guide' to the README. Added neatsvpv function pointer to DBIS structure to make it available for use by drivers. A macro defines neatsvpv(sv,len) as (DBIS->neatsvpv(sv,len)). Old XS macro SV_YES_NO changes to standard boolSV. Since the DBIS structure has change the internal version numbers have also changed (DBIXS_VERSION == 8 and DBISTATE_VERSION == 8) so drivers will have to be recompiled. =head2 Changes in DBI 0.81, 7th May 1997 Minor fix to let DBI build using less modern perls. Fixed a suprious typo warning. =head2 Changes in DBI 0.80, 6th May 1997 Builds with no changes on NT using perl5.003_99 (with thanks to Jeffrey Urlwin). Automatically supports Apache::DBI (with thanks to Edmund Mergl). DBI scripts no longer need to be modified to make use of Apache::DBI. Added a ping method and an experimental connect_test_perf method. Added a fetchhash and fetch_all methods. The func method no longer pre-clears err and errstr. Added ChopBlanks attribute (currently defaults to off, that may change). Support for the attribute needs to be implemented by individual drivers. Reworked tests into standard t/*.t form. Added more pod text. Fixed assorted bugs. =head2 Changes in DBI 0.79, 7th Apr 1997 Minor release. Tidied up pod text and added some more descriptions (especially disconnect). Minor changes to DBI.xs to remove compiler warnings. =head2 Changes in DBI 0.78, 28th Mar 1997 Greatly extended the pod documentation in DBI.pm, including the under used bind_columns method. Use 'perldoc DBI' to read after installing. Fixed $h->err. Fetching an attribute value no longer resets err. Added $h->{InactiveDestroy}, see documentation for details. Improved debugging of cached ('quick') attribute fetches. errstr will return err code value if there is no string value. Added DBI/W32ODBC to the distribution. This is a pure-perl experimental DBI emulation layer for Win32::ODBC. Note that it's unsupported, your mileage will vary, and bug reports without fixes will probably be ignored. =head2 Changes in DBI 0.77, 21st Feb 1997 Removed erroneous $h->errstate and $h->errmsg methods from DBI.pm. Added $h->err, $h->errstr and $h->state default methods in DBI.xs. Updated informal DBI API notes in DBI.pm. Updated README slightly. DBIXS.h now correctly installed into INST_ARCHAUTODIR. (DBD authors will need to edit their Makefile.PL's to use -I$(INSTALLSITEARCH)/auto/DBI -I$(INSTALLSITEARCH)/DBI) =head2 Changes in DBI 0.76, 3rd Feb 1997 Fixed a compiler type warnings (pedantic IRIX again). =head2 Changes in DBI 0.75, 27th Jan 1997 Fix problem introduced by a change in Perl5.003_XX. Updated README and DBI.pm docs. =head2 Changes in DBI 0.74, 14th Jan 1997 Dispatch now sets dbi_debug to the level of the current handle (this makes tracing/debugging individual handles much easier). The '>> DISPATCH' log line now only logged at debug >= 3 (was 2). The $csr->NUM_OF_FIELDS attribute can be set if not >0 already. You can log to a file using the env var PERL_DBI_DEBUG=/tmp/dbi.log. Added a type cast needed by IRIX. No longer sets perl_destruct_level unless debug set >= 4. Make compatible with PerlIO and sfio. =head2 Changes in DBI 0.73, 10th Oct 1996 Fixed some compiler type warnings (IRIX). Fixed DBI->internal->{DebugLog} = $filename. Made debug log file unbuffered. Added experimental bind_param_inout method to interface. Usage: $dbh->bind_param_inout($param, \$value, $maxlen [, \%attribs ]) (only currently used by DBD::Oracle at this time.) =head2 Changes in DBI 0.72, 23 Sep 1996 Using an undefined value as a handle now gives a better error message (mainly useful for emulators like Oraperl). $dbh->do($sql, @params) now works for binding placeholders. =head2 Changes in DBI 0.71, 10 July 1996 Removed spurious abort() from invalid handle check. Added quote method to DBI interface and added test. =head2 Changes in DBI 0.70, 16 June 1996 Added extra invalid handle check (dbih_getcom) Fixed broken $dbh->quote method. Added check for old GCC in Makefile.PL =head2 Changes in DBI 0.69 Fixed small memory leak. Clarified the behaviour of DBI->connect. $dbh->do now returns '0E0' instead of 'OK'. Fixed "Can't read $DBI::errstr, lost last handle" problem. =head2 Changes in DBI 0.68, 2 Mar 1996 Changes to suit perl5.002 and site_lib directories. Detects old versions ahead of new in @INC. =head2 Changes in DBI 0.67, 15 Feb 1996 Trivial change to test suite to fix a problem shown up by the Perl5.002gamma release Test::Harness. =head2 Changes in DBI 0.66, 29 Jan 1996 Minor changes to bring the DBI into line with 5.002 mechanisms, specifically the xs/pm VERSION checking mechanism. No functionality changes. One no-last-handle bug fix (rare problem). Requires 5.002 (beta2 or later). =head2 Changes in DBI 0.65, 23 Oct 1995 Added $DBI::state to hold SQL CLI / ODBC SQLSTATE value. SQLSTATE "00000" (success) is returned as "" (false), all else is true. If a driver does not explicitly initialise it (via $h->{State} or DBIc_STATE(imp_xxh) then $DBI::state will automatically return "" if $DBI::err is false otherwise "S1000" (general error). As always, this is a new feature and liable to change. The is *no longer* a default error handler! You can add your own using push(@{$h->{Handlers}}, sub { ... }) but be aware that this interface may change (or go away). The DBI now automatically clears $DBI::err, errstr and state before calling most DBI methods. Previously error conditions would persist. Added DBIh_CLEAR_ERROR(imp_xxh) macro. DBI now EXPORT_OK's some utility functions, neat($value), neat_list(@values) and dump_results($sth). Slightly enhanced t/min.t minimal test script in an effort to help narrow down the few stray core dumps that some porters still report. Renamed readblob to blob_read (old name still works but warns). Added default blob_copy_to_file method. Added $sth = $dbh->tables method. This returns an $sth for a query which has these columns: TABLE_CATALOGUE, TABLE_OWNER, TABLE_NAME, TABLE_TYPE, REMARKS in that order. The TABLE_CATALOGUE column should be ignored for now. =head2 Changes in DBI 0.64, 23 Oct 1995 Fixed 'disconnect invalidates 1 associated cursor(s)' problem. Drivers using DBIc_ACTIVE_on/off() macros should not need any changes other than to test for DBIc_ACTIVE_KIDS() instead of DBIc_KIDS(). Fixed possible core dump in dbih_clearcom during global destruction. =head2 Changes in DBI 0.63, 1 Sep 1995 Minor update. Fixed uninitialised memory bug in method attribute handling and streamlined processing and debugging. Revised usage definitions for bind_* methods and readblob. =head2 Changes in DBI 0.62, 26 Aug 1995 Added method redirection method $h->func(..., $method_name). This is now the official way to call private driver methods that are not part of the DBI standard. E.g.: @ary = $sth->func('ora_types'); It can also be used to call existing methods. Has very low cost. $sth->bind_col columns now start from 1 (not 0) to match SQL. $sth->bind_columns now takes a leading attribute parameter (or undef), e.g., $sth->bind_columns($attribs, \$col1 [, \$col2 , ...]); Added handy DBD_ATTRIBS_CHECK macro to vet attribs in XS. Added handy DBD_ATTRIB_GET_SVP, DBD_ATTRIB_GET_BOOL and DBD_ATTRIB_GET_IV macros for handling attributes. Fixed STORE for NUM_OF_FIELDS and NUM_OF_PARAMS. Added FETCH for NUM_OF_FIELDS and NUM_OF_PARAMS. Dispatch no longer bothers to call _untie(). Faster startup via install_method/_add_dispatch changes. =head2 Changes in DBI 0.61, 22 Aug 1995 Added $sth->bind_col($column, \$var [, \%attribs ]); This method enables perl variable to be directly and automatically updated when a row is fetched. It requires no driver support (if the driver has been written to use DBIS->get_fbav). Currently \%attribs is unused. Added $sth->bind_columns(\$var [, \$var , ...]); This method is a short-cut for bind_col which binds all the columns of a query in one go (with no attributes). It also requires no driver support. Added $sth->bind_param($parameter, $var [, \%attribs ]); This method enables attributes to be specified when values are bound to placeholders. It also enables binding to occur away from the execute method to improve execute efficiency. The DBI does not provide a default implementation of this. See the DBD::Oracle module for a detailed example. The DBI now provides default implementations of both fetch and fetchrow. Each is written in terms of the other. A driver is expected to implement at least one of them. More macro and assorted structure changes in DBDXS.h. Sorry! The old dbihcom definitions have gone. All fields have macros. The imp_xxh_t type is now used within the DBI as well as drivers. Drivers must set DBIc_NUM_FIELDS(imp_sth) and DBIc_NUM_PARAMS(imp_sth). test.pl includes a trivial test of bind_param and bind_columns. =head2 Changes in DBI 0.60, 17 Aug 1995 This release has significant code changes but much less dramatic than the previous release. The new implementors data handling mechanism has matured significantly (don't be put off by all the struct typedefs in DBIXS.h, there's just to make it easier for drivers while keeping things type-safe). The DBI now includes two new methods: do $dbh->do($statement) This method prepares, executes and finishes a statement. It is designed to be used for executing one-off non-select statements where there is no benefit in reusing a prepared statement handle. fetch $array_ref = $sth->fetch; This method is the new 'lowest-level' row fetching method. The previous @row = $sth->fetchrow method now defaults to calling the fetch method and expanding the returned array reference. The DBI now provides fallback attribute FETCH and STORE functions which drivers should call if they don't recognise an attribute. THIS RELEASE IS A GOOD STARTING POINT FOR DRIVER DEVELOPERS! Study DBIXS.h from the DBI and Oracle.xs etc from DBD::Oracle. There will be further changes in the interface but nothing as dramatic as these last two releases! (I hope :-) =head2 Changes in DBI 0.59 15 Aug 1995 NOTE: THIS IS AN UNSTABLE RELEASE! Major reworking of internal data management! Performance improvements and memory leaks fixed. Added a new NullP (empty) driver and a -m flag to test.pl to help check for memory leaks. Study DBD::Oracle version 0.21 for more details. (Comparing parts of v0.21 with v0.20 may be useful.) =head2 Changes in DBI 0.58 21 June 1995 Added DBI->internal->{DebugLog} = $filename; Reworked internal logging. Added $VERSION. Made disconnect_all a compulsory 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 DBI-1.634/dbd_xsh.h000644 000766 000024 00000006347 12553731456 014214 0ustar00timbostaff000000 000000 /* @(#)$Id$ * * 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)); IV dbd_db_do4_iv _((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)); IV dbd_st_rows_iv _((SV *sth, imp_sth_t *imp_sth)); int dbd_st_execute _((SV *sth, imp_sth_t *imp_sth)); IV dbd_st_execute_iv _((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 */ DBI-1.634/DBI.pm000644 000766 000024 00001151457 12557676362 013400 0ustar00timbostaff000000 000000 # $Id$ # 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 { our $XS_VERSION = our $VERSION = "1.634"; # ==> ALSO update the version in the pod text below! $VERSION = eval $VERSION; } =head1 NAME DBI - Database independent interface for Perl =head1 SYNOPSIS use DBI; @driver_names = DBI->available_drivers; %drivers = DBI->installed_drivers; @data_sources = DBI->data_sources($driver_name, \%attr); $dbh = DBI->connect($data_source, $username, $auth, \%attr); $rv = $dbh->do($statement); $rv = $dbh->do($statement, \%attr); $rv = $dbh->do($statement, \%attr, @bind_values); $ary_ref = $dbh->selectall_arrayref($statement); $hash_ref = $dbh->selectall_hashref($statement, $key_field); $ary_ref = $dbh->selectcol_arrayref($statement); $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); @row_ary = $dbh->selectrow_array($statement); $ary_ref = $dbh->selectrow_arrayref($statement); $hash_ref = $dbh->selectrow_hashref($statement); $sth = $dbh->prepare($statement); $sth = $dbh->prepare_cached($statement); $rc = $sth->bind_param($p_num, $bind_value); $rc = $sth->bind_param($p_num, $bind_value, $bind_type); $rc = $sth->bind_param($p_num, $bind_value, \%attr); $rv = $sth->execute; $rv = $sth->execute(@bind_values); $rv = $sth->execute_array(\%attr, ...); $rc = $sth->bind_col($col_num, \$col_variable); $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); @row_ary = $sth->fetchrow_array; $ary_ref = $sth->fetchrow_arrayref; $hash_ref = $sth->fetchrow_hashref; $ary_ref = $sth->fetchall_arrayref; $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); $hash_ref = $sth->fetchall_hashref( $key_field ); $rv = $sth->rows; $rc = $dbh->begin_work; $rc = $dbh->commit; $rc = $dbh->rollback; $quoted_string = $dbh->quote($string); $rc = $h->err; $str = $h->errstr; $rv = $h->state; $rc = $dbh->disconnect; I =head2 GETTING HELP =head3 General 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 L You might also like to read the Advanced DBI Tutorial at L 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. =head3 Mailing Lists If you have questions about DBI, or DBD driver modules, you can get help from the I mailing list. This is the best way to get help. 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. Please note that Tim Bunce does not maintain the mailing lists or the web pages (generous volunteers do that). So please don't send mail directly to him; he just doesn't have the time to answer questions personally. The I mailing list has lots of experienced people who should be able to help you if you need it. If you do email Tim he is very likely to just forward it to the mailing list. =head3 IRC DBI IRC Channel: #dbi on irc.perl.org (L) =for html (click for instant chatroom login) =head3 Online StackOverflow has a DBI tag L with over 400 questions. The DBI home page at L and the DBI FAQ at L may be worth a visit. They include links to other resources, but I. I don't recommend the DBI cpanforum (at http://www.cpanforum.com/dist/DBI) because relatively few people read it compared with dbi-users@perl.org. =head3 Reporting a Bug If you think you've found a bug then please read "How to Report Bugs Effectively" by Simon Tatham: L. If you think you've found a memory leak then read L. Your problem is most likely related to the specific DBD driver module you're using. If that's the case then click on the 'Bugs' link on the L page for your driver. Only submit a bug report against the DBI itself if you're sure that your issue isn't related to the driver you're using. =head2 NOTES This is the DBI specification that corresponds to DBI version 1.634 (see L for details). The DBI is evolving at a steady pace, so it's good to check that you have the latest copy. The significant user-visible changes in each release are documented in the L module so you can read them by executing C. Some DBI changes require changes in the drivers, but the drivers can take some time to catch up. Newer versions of the DBI have added features that may not yet be supported by the drivers you use. Talk to the authors of your drivers if you need a new feature that is not yet supported. Features added after DBI 1.21 (February 2002) are marked in the text with the version number of the DBI release they first appeared in. Extensions to the DBI API often use the C namespace. See L. DBI extension modules can be found at L. And all modules related to the DBI can be found at L. =cut # The POD text continues at the end of the file. use Carp(); use DynaLoader (); use Exporter (); BEGIN { @ISA = qw(Exporter DynaLoader); # Make some utility functions available if asked for @EXPORT = (); # we export nothing by default @EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags: %EXPORT_TAGS = ( sql_types => [ qw( SQL_GUID SQL_WLONGVARCHAR SQL_WVARCHAR SQL_WCHAR SQL_BIGINT SQL_BIT SQL_TINYINT SQL_LONGVARBINARY SQL_VARBINARY SQL_BINARY SQL_LONGVARCHAR SQL_UNKNOWN_TYPE SQL_ALL_TYPES SQL_CHAR SQL_NUMERIC SQL_DECIMAL SQL_INTEGER SQL_SMALLINT SQL_FLOAT SQL_REAL SQL_DOUBLE SQL_DATETIME SQL_DATE SQL_INTERVAL SQL_TIME SQL_TIMESTAMP SQL_VARCHAR SQL_BOOLEAN SQL_UDT SQL_UDT_LOCATOR SQL_ROW SQL_REF SQL_BLOB SQL_BLOB_LOCATOR SQL_CLOB SQL_CLOB_LOCATOR SQL_ARRAY SQL_ARRAY_LOCATOR SQL_MULTISET SQL_MULTISET_LOCATOR SQL_TYPE_DATE SQL_TYPE_TIME SQL_TYPE_TIMESTAMP SQL_TYPE_TIME_WITH_TIMEZONE SQL_TYPE_TIMESTAMP_WITH_TIMEZONE SQL_INTERVAL_YEAR SQL_INTERVAL_MONTH SQL_INTERVAL_DAY SQL_INTERVAL_HOUR SQL_INTERVAL_MINUTE SQL_INTERVAL_SECOND SQL_INTERVAL_YEAR_TO_MONTH SQL_INTERVAL_DAY_TO_HOUR SQL_INTERVAL_DAY_TO_MINUTE SQL_INTERVAL_DAY_TO_SECOND SQL_INTERVAL_HOUR_TO_MINUTE SQL_INTERVAL_HOUR_TO_SECOND SQL_INTERVAL_MINUTE_TO_SECOND ) ], 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 DBIstcf_DISCARD_STRING DBIstcf_STRICT ) ], 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 $XS_VERSION } 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 $XS_VERSION; } $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', }, ad2_ => { class => 'DBD::AnyData2', }, ado_ => { class => 'DBD::ADO', }, amzn_ => { class => 'DBD::Amazon', }, best_ => { class => 'DBD::BestWins', }, csv_ => { class => 'DBD::CSV', }, cubrid_ => { class => 'DBD::cubrid', }, db2_ => { class => 'DBD::DB2', }, dbi_ => { class => 'DBI', }, dbm_ => { class => 'DBD::DBM', }, df_ => { class => 'DBD::DF', }, examplep_ => { class => 'DBD::ExampleP', }, 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', }, multi_ => { class => 'DBD::Multi' }, mx_ => { class => 'DBD::Multiplex', }, neo_ => { class => 'DBD::Neo4p', }, 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 }, 'DELETE' => { O=>0x0404 }, 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, T=>2 }, quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 }, 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 method 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 successfully # 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; 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; } $version{"DBI"} = $DBI::VERSION; $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl; if (!defined wantarray) { # void context require Config; # add more detail $version{OS} = "$^O\t($Config::Config{osvers})"; $version{Perl} = "$]\t($Config::Config{archname})"; $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_}) for keys %error; printf " %-16s: %s\n",$_,$version{$_} for reverse sort keys %version; } return \%version; } sub data_sources { my ($class, $driver, @other) = @_; my $drh = $class->install_driver($driver); my @ds = $drh->data_sources(@other); return @ds; } sub neat_list { my ($listref, $maxlen, $sep) = @_; $maxlen = 0 unless defined $maxlen; # 0 == use internal default $sep = ", " unless defined $sep; join($sep, map { neat($_,$maxlen) } @$listref); } sub dump_results { # also aliased as a method in DBD::_::st my ($sth, $maxlen, $lsep, $fsep, $fh) = @_; return 0 unless $sth; $maxlen ||= 35; $lsep ||= "\n"; $fh ||= \*STDOUT; my $rows = 0; my $ref; while($ref = $sth->fetch) { print $fh $lsep if $rows++ and $lsep; my $str = neat_list($ref,$maxlen,$fsep); print $fh $str; # done on two lines to avoid 5.003 errors } print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n"; $rows; } sub data_diff { my ($a, $b, $logical) = @_; my $diff = data_string_diff($a, $b); return "" if $logical and !$diff; my $a_desc = data_string_desc($a); my $b_desc = data_string_desc($b); return "" if !$diff and $a_desc eq $b_desc; $diff ||= "Strings contain the same sequence of characters" if length($a); $diff .= "\n" if $diff; return "a: $a_desc\nb: $b_desc\n$diff"; } sub data_string_diff { # Compares 'logical' characters, not bytes, so a latin1 string and an # an equivalent Unicode string will compare as equal even though their # byte encodings are different. my ($a, $b) = @_; unless (defined $a and defined $b) { # one undef return "" if !defined $a and !defined $b; return "String a is undef, string b has ".length($b)." characters" if !defined $a; return "String b is undef, string a has ".length($a)." characters" if !defined $b; } require utf8; # hack to cater for perl 5.6 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a); my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b); my $i = 0; while (@a_chars && @b_chars) { ++$i, shift(@a_chars), shift(@b_chars), next if $a_chars[0] == $b_chars[0];# compare ordinal values my @desc = map { $_ > 255 ? # if wide character... sprintf("\\x{%04X}", $_) : # \x{...} chr($_) =~ /[[:cntrl:]]/ ? # else if control character ... sprintf("\\x%02X", $_) : # \x.. chr($_) # else as themselves } ($a_chars[0], $b_chars[0]); # highlight probable double-encoding? foreach my $c ( @desc ) { next unless $c =~ m/\\x\{08(..)}/; $c .= "='" .chr(hex($1)) ."'" } return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]"; } return "String a truncated after $i characters" if @b_chars; return "String b truncated after $i characters" if @a_chars; return ""; } sub data_string_desc { # describe a data string my ($a) = @_; require bytes; require utf8; # hacks to cater for perl 5.6 *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; *utf8::valid = sub { 1 } unless defined &utf8::valid; # Give sufficient info to help diagnose at least these kinds of situations: # - valid UTF8 byte sequence but UTF8 flag not set # (might be ascii so also need to check for hibit to make it worthwhile) # - UTF8 flag set but invalid UTF8 byte sequence # could do better here, but this'll do for now my $utf8 = sprintf "UTF8 %s%s", utf8::is_utf8($a) ? "on" : "off", utf8::valid($a||'') ? "" : " but INVALID encoding"; return "$utf8, undef" unless defined $a; my $is_ascii = $a =~ m/^[\000-\177]*$/; return sprintf "%s, %s, %d characters %d bytes", $utf8, $is_ascii ? "ASCII" : "non-ASCII", length($a), bytes::length($a); } sub connect_test_perf { my($class, $dsn,$dbuser,$dbpass, $attr) = @_; Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr; # these are non standard attributes just for this special method my $loops ||= $attr->{dbi_loops} || 5; my $par ||= $attr->{dbi_par} || 1; # parallelism my $verb ||= $attr->{dbi_verb} || 1; my $meth ||= $attr->{dbi_meth} || 'connect'; print "$dsn: testing $loops sets of $par connections:\n"; require "FileHandle.pm"; # don't let toke.c create empty FileHandle package local $| = 1; my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n"); # test the connection and warm up caches etc $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr"); my $t1 = dbi_time(); my $loop; for $loop (1..$loops) { my @cons; print "Connecting... " if $verb; for (1..$par) { print "$_ "; push @cons, ($drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr\n")); } print "\nDisconnecting...\n" if $verb; for (@cons) { $_->disconnect or warn "disconnect failed: $DBI::errstr" } } my $t2 = dbi_time(); my $td = $t2 - $t1; printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n", $par, $loops, $td, $loops*$par, $td/($loops*$par); return $td; } # Help people doing DBI->errstr, might even document it one day # XXX probably best moved to cheaper XS code if this gets documented sub err { $DBI::err } sub errstr { $DBI::errstr } # --- Private Internal Function for Creating New DBI Handles # XXX move to PurePerl? *DBI::dr::TIEHASH = \&DBI::st::TIEHASH; *DBI::db::TIEHASH = \&DBI::st::TIEHASH; # These three special constructors are called by the drivers # The way they are called is likely to change. our $shared_profile; sub _new_drh { # called by DBD::::driver() my ($class, $initial_attr, $imp_data) = @_; # Provide default storage for State,Err and Errstr. # Note that these are shared by all child handles by default! XXX # State must be undef to get automatic faking in DBI::var::FETCH my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, ''); my $attr = { # these attributes get copied down to child handles by default 'State' => \$h_state_store, # Holder for DBI::state 'Err' => \$h_err_store, # Holder for DBI::err 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr 'TraceLevel' => 0, FetchHashKeyName=> 'NAME', %$initial_attr, }; my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class); # XXX DBI_PROFILE unless DBI::PurePerl because for some reason # it kills the t/zz_*_pp.t tests (they silently exit early) if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) { # The profile object created here when the first driver is loaded # is shared by all drivers so we end up with just one set of profile # data and thus the 'total time in DBI' is really the true total. if (!$shared_profile) { # first time $h->{Profile} = $ENV{DBI_PROFILE}; # write string $shared_profile = $h->{Profile}; # read and record object } else { $h->{Profile} = $shared_profile; } } return $h unless wantarray; ($h, $i); } sub _new_dbh { # called by DBD::::dr::connect() my ($drh, $attr, $imp_data) = @_; my $imp_class = $drh->{ImplementorClass} or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); substr($imp_class,-4,4) = '::db'; my $app_class = ref $drh; substr($app_class,-4,4) = '::db'; $attr->{Err} ||= \my $err; $attr->{Errstr} ||= \my $errstr; $attr->{State} ||= \my $state; _new_handle($app_class, $drh, $attr, $imp_data, $imp_class); } sub _new_sth { # called by DBD::::db::prepare) my ($dbh, $attr, $imp_data) = @_; my $imp_class = $dbh->{ImplementorClass} or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); substr($imp_class,-4,4) = '::st'; my $app_class = ref $dbh; substr($app_class,-4,4) = '::st'; _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class); } # end of DBI package # -------------------------------------------------------------------- # === The internal DBI Switch pseudo 'driver' class === { package # hide from PAUSE DBD::Switch::dr; DBI->setup_driver('DBD::Switch'); # sets up @ISA $DBD::Switch::dr::imp_data_size = 0; $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning my $drh; sub driver { return $drh if $drh; # a package global my $inner; ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', { 'Name' => 'Switch', 'Version' => $DBI::VERSION, 'Attribution' => "DBI $DBI::VERSION by Tim Bunce", }); Carp::croak("DBD::Switch init failed!") unless ($drh && $inner); return $drh; } sub CLONE { undef $drh; } sub FETCH { my($drh, $key) = @_; return DBI->trace if $key eq 'DebugDispatch'; return undef if $key eq 'DebugLog'; # not worth fetching, sorry return $drh->DBD::_::dr::FETCH($key); undef; } sub STORE { my($drh, $key, $value) = @_; if ($key eq 'DebugDispatch') { DBI->trace($value); } elsif ($key eq 'DebugLog') { DBI->trace(-1, $value); } else { $drh->DBD::_::dr::STORE($key, $value); } } } # -------------------------------------------------------------------- # === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES === # We only define default methods for harmless functions. # We don't, for example, define a DBD::_::st::prepare() { package # hide from PAUSE DBD::_::common; # ====== Common base class methods ====== use strict; # methods common to all handle types: # 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][a-z0-9]*_)\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 (my $new_cb = $cb->{"connect_cached.new"})) { local $_ = "connect_cached.new"; $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef } $dbh = $drh->connect(@_); $cache->{$key} = $dbh; # replace prev entry, even if connect failed if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) { local $_ = "connect_cached.connected"; $conn_cb->($dbh, $dsn, $user, $auth, $attr); } 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 if ($quoted_id) { $quoted_id = ($info->[2] == 2) # SQL_CL_END ? $quoted_id . $info->[1] . $catalog : $catalog . $info->[1] . $quoted_id; } else { $quoted_id = $catalog; } } 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 undef; $sth->execute(@bind) or return undef; 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; # "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 (defined($args[3]) && $args[3] eq '%' # special case for tables('','','','%') && grep {defined($_) && $_ eq ''} @args[0,1,2] ) { @tables = map { $_->[3] } @$tables; } elsif ($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, or again)"); } # 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) { # resets the iterator my $name2idx = $sth->FETCH('NAME_lc_hash'); while ( my ($name, $unused) = each %$slice ) { my $idx = $name2idx->{lc $name}; return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice") if not defined $idx; $sth->bind_col($idx+1, \$row{$name}); } } else { $sth->bind_columns( \( @row{ @{$sth->FETCH($sth->FETCH('FetchHashKeyName')) } } ) ); } } else { return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid"); } if (not defined $max_rows) { push @rows, { %row } while ($sth->fetch); # full speed ahead! } else { push @rows, { %row } while ($max_rows-- and $sth->fetch); } return \@rows; } sub fetchall_hashref { my ($sth, $key_field) = @_; my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; my $names_hash = $sth->FETCH("${hash_key_name}_hash"); my @key_fields = (ref $key_field) ? @$key_field : ($key_field); my @key_indexes; my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS'); foreach (@key_fields) { my $index = $names_hash->{$_}; # perl index not column $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields; return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})") unless defined $index; push @key_indexes, $index; } my $rows = {}; my $NAME = $sth->FETCH($hash_key_name); my @row = (undef) x $num_of_fields; $sth->bind_columns(\(@row)); while ($sth->fetch) { my $ref = $rows; $ref = $ref->{$row[$_]} ||= {} for @key_indexes; @{$ref}{@$NAME} = @row; } return $rows; } *dump_results = \&DBI::dump_results; sub blob_copy_to_file { # returns length or undef on error my($self, $field, $filename_or_handleref, $blocksize) = @_; my $fh = $filename_or_handleref; my($len, $buf) = (0, ""); $blocksize ||= 512; # not too ambitious local(*FH); unless(ref $fh) { open(FH, ">$fh") || return undef; $fh = \*FH; } while(defined($self->blob_read($field, $len, $blocksize, \$buf))) { print $fh $buf; $len += length $buf; } close(FH); $len; } sub more_results { shift->{syb_more_results}; # handy grandfathering } } unless ($DBI::PurePerl) { # See install_driver { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); } { @DBD::_mem::db::ISA = qw(DBD::_mem::common); } { @DBD::_mem::st::ISA = qw(DBD::_mem::common); } # DBD::_mem::common::DESTROY is implemented in DBI.xs } 1; __END__ =head1 DESCRIPTION The DBI is a database access module for the Perl programming language. It defines a set of methods, variables, and conventions that provide a consistent database interface, independent of the actual database being used. It is important to remember that the DBI is just an interface. The DBI is a layer of "glue" between an application and one or more database I modules. It is the driver modules which do most of the real work. The DBI provides a standard interface and framework for the drivers to operate within. This document often uses terms like I, I, I. If you're not familiar with those terms then it would be a good idea to read at least the following perl manuals first: L, L, L, and L. =head2 Architecture of a DBI Application |<- Scope of DBI ->| .-. .--------------. .-------------. .-------. | |---| XYZ Driver |---| XYZ Engine | | Perl | | | `--------------' `-------------' | script| |A| |D| .--------------. .-------------. | using |--|P|--|B|---|Oracle Driver |---|Oracle Engine| | DBI | |I| |I| `--------------' `-------------' | API | | |... |methods| | |... Other drivers `-------' | |... `-' The API, or Application Programming Interface, defines the call interface and variables for Perl scripts to use. The API is implemented by the Perl DBI extension. The DBI "dispatches" the method calls to the appropriate driver for actual execution. The DBI is also responsible for the dynamic loading of drivers, error checking and handling, providing default implementations for methods, and many other non-database specific duties. Each driver contains implementations of the DBI methods using the private interface functions of the corresponding database engine. Only authors of sophisticated/multi-database applications or generic library functions need be concerned with drivers. =head2 Notation and Conventions The following conventions are used in this document: $dbh Database handle object $sth Statement handle object $drh Driver handle object (rarely seen or used in applications) $h Any of the handle types above ($dbh, $sth, or $drh) $rc General Return Code (boolean: true=ok, false=error) $rv General Return Value (typically an integer) @ary List of values returned from the database, typically a row of data $rows Number of rows processed (if available, else -1) $fh A filehandle undef NULL values are represented by undefined values in Perl \%attr Reference to a hash of attribute values passed to methods Note that Perl will automatically destroy database and statement handle objects if all references to them are deleted. =head2 Outline Usage To use DBI, first you need to load the DBI module: use DBI; use strict; (The C isn't required but is strongly recommended.) Then you need to L to your data source and get a I for that connection: $dbh = DBI->connect($dsn, $user, $password, { RaiseError => 1, AutoCommit => 0 }); Since connecting can be expensive, you generally just connect at the start of your program and disconnect at the end. Explicitly defining the required C behaviour is strongly recommended and may become mandatory in a later version. This determines whether changes are automatically committed to the database when executed, or need to be explicitly committed later. The DBI allows an application to "prepare" statements for later execution. A prepared statement is identified by a statement handle held in a Perl variable. We'll call the Perl variable C<$sth> in our examples. The typical method call sequence for a C statement is: prepare, execute, execute, execute. for example: $sth = $dbh->prepare("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)"); while() { chomp; my ($foo,$bar,$baz) = split /,/; $sth->execute( $foo, $bar, $baz ); } The C method can be used for non repeated I-C statement. =head1 THE DBI PACKAGE AND CLASS In this section, we cover the DBI class methods, utility functions, and the dynamic attributes associated with generic DBI handles. =head2 DBI Constants Constants representing the values of the SQL standard types can be imported individually by name, or all together by importing the special C<:sql_types> tag. The names and values of all the defined SQL standard types can be produced like this: foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) { printf "%s=%d\n", $_, &{"DBI::$_"}; } These constants are defined by SQL/CLI, ODBC or both. C has conflicting codes in SQL/CLI and ODBC, DBI uses the ODBC one. See the L, L, and L methods for possible uses. Note that just because the DBI defines a named constant for a given data type doesn't mean that drivers will support that data type. =head2 DBI Class Methods The following methods are provided by the DBI class: =head3 C ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn($dsn) or die "Can't parse DBI DSN '$dsn'"; Breaks apart a DBI Data Source Name (DSN) and returns the individual parts. If $dsn doesn't contain a valid DSN then parse_dsn() returns an empty list. $scheme is the first part of the DSN and is currently always 'dbi'. $driver is the driver name, possibly defaulted to $ENV{DBI_DRIVER}, and may be undefined. $attr_string is the contents of the optional attribute string, which may be undefined. If $attr_string is not empty then $attr_hash is a reference to a hash containing the parsed attribute names and values. $driver_dsn is the last part of the DBI DSN string. For example: ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn("DBI:MyDriver(RaiseError=>1):db=test;port=42"); $scheme = 'dbi'; $driver = 'MyDriver'; $attr_string = 'RaiseError=>1'; $attr_hash = { 'RaiseError' => '1' }; $driver_dsn = 'db=test;port=42'; The parse_dsn() method was added in DBI 1.43. =head3 C $dbh = DBI->connect($data_source, $username, $password) or die $DBI::errstr; $dbh = DBI->connect($data_source, $username, $password, \%attr) or die $DBI::errstr; Establishes a database connection, or session, to the requested C<$data_source>. Returns a database handle object if the connection succeeds. Use C<$dbh-Edisconnect> to terminate the connection. If the connect fails (see below), it returns C and sets both C<$DBI::err> and C<$DBI::errstr>. (It does I explicitly set C<$!>.) You should generally test the return status of C and C if it has failed. Multiple simultaneous connections to multiple databases through multiple drivers can be made via the DBI. Simply make one C call for each database and keep a copy of each returned database handle. The C<$data_source> value must begin with "CIC<:>". The I specifies the driver that will be used to make the connection. (Letter case is significant.) As a convenience, if the C<$data_source> parameter is undefined or empty, the DBI will substitute the value of the environment variable C. If just the I part is empty (i.e., the C<$data_source> prefix is "C"), the environment variable C is used. If neither variable is set, then C dies. Examples of C<$data_source> values are: dbi:DriverName:database_name dbi:DriverName:database_name@hostname:port dbi:DriverName:database=database_name;host=hostname;port=port There is I for the text following the driver name. Each driver is free to use whatever syntax it wants. The only requirement the DBI makes is that all the information is supplied in a single string. You must consult the documentation for the drivers you are using for a description of the syntax they require. It is recommended that drivers support the ODBC style, shown in the last example above. It is also recommended that they support the three common names 'C', 'C', and 'C' (plus 'C' as an alias for C). This simplifies automatic construction of basic DSNs: C<"dbi:$driver:database=$db;host=$host;port=$port">. Drivers should aim to 'do something reasonable' when given a DSN in this form, but if any part is meaningless for that driver (such as 'port' for Informix) it should generate an error if that part is not empty. If the environment variable C is defined (and the driver in C<$data_source> is not "C") then the connect request will automatically be changed to: $ENV{DBI_AUTOPROXY};dsn=$data_source C is typically set as "C". If $ENV{DBI_AUTOPROXY} doesn't begin with 'C' then "dbi:Proxy:" will be prepended to it first. See the DBD::Proxy documentation for more details. If C<$username> or C<$password> are undefined (rather than just empty), then the DBI will substitute the values of the C and C environment variables, respectively. The DBI will warn if the environment variables are not defined. However, the everyday use of these environment variables is not recommended for security reasons. The mechanism is primarily intended to simplify testing. See below for alternative way to specify the username and password. Cconnect> automatically installs the driver if it has not been installed yet. Driver installation either returns a valid driver handle, or it I with an error message that includes the string "C" and the underlying problem. So Cconnect> will die on a driver installation failure and will only return C on a connect failure, in which case C<$DBI::errstr> will hold the error message. Use C if you need to catch the "C" error. The C<$data_source> argument (with the "C" prefix removed) and the C<$username> and C<$password> arguments are then passed to the driver for processing. The DBI does not define any interpretation for the contents of these fields. The driver is free to interpret the C<$data_source>, C<$username>, and C<$password> fields in any way, and supply whatever defaults are appropriate for the engine being accessed. (Oracle, for example, uses the ORACLE_SID and TWO_TASK environment variables if no C<$data_source> is specified.) The C and C attributes for each connection default to "on". (See L and L for more information.) However, it is strongly recommended that you explicitly define C rather than rely on the default. The C attribute defaults to true. The C<\%attr> parameter can be used to alter the default settings of C, C, C, and other attributes. For example: $dbh = DBI->connect($data_source, $user, $pass, { PrintError => 0, AutoCommit => 0 }); The username and password can also be specified using the attributes C and C, in which case they take precedence over the C<$username> and C<$password> parameters. You can also define connection attribute values within the C<$data_source> parameter. For example: dbi:DriverName(PrintWarn=>0,PrintError=>0,Taint=>1):... Individual attributes values specified in this way take precedence over any conflicting values specified via the C<\%attr> parameter to C. The C attribute can be used to specify which driver method should be called to establish the connection. The only useful values are 'connect', 'connect_cached', or some specialized case like 'Apache::DBI::connect' (which is automatically the default when running within Apache). Where possible, each session (C<$dbh>) is independent from the transactions in other sessions. This is useful when you need to hold cursors open across transactions--for example, if you use one session for your long lifespan cursors (typically read-only) and another for your short update transactions. For compatibility with old DBI scripts, the driver can be specified by passing its name as the fourth argument to C (instead of C<\%attr>): $dbh = DBI->connect($data_source, $user, $pass, $driver); In this "old-style" form of C, the C<$data_source> should not start with "C". (If it does, the embedded driver_name will be ignored). Also note that in this older form of C, the C<$dbh-E{AutoCommit}> attribute is I, the C<$dbh-E{PrintError}> attribute is off, and the old C environment variable is checked if C is not defined. Beware that this "old-style" C will soon be withdrawn in a future version of DBI. =head3 C $dbh = DBI->connect_cached($data_source, $username, $password) or die $DBI::errstr; $dbh = DBI->connect_cached($data_source, $username, $password, \%attr) or die $DBI::errstr; C is like L, except that the database handle returned is also stored in a hash associated with the given parameters. If another call is made to C with the same parameter values, then the corresponding cached C<$dbh> will be returned if it is still valid. The cached database handle is replaced with a new connection if it has been disconnected or if the C method fails. Note that the behaviour of this method differs in several respects from the behaviour of persistent connections implemented by Apache::DBI. However, if Apache::DBI is loaded then C will use it. Caching connections can be useful in some applications, but it can also cause problems, such as too many connections, and so should be used with care. In particular, avoid changing the attributes of a database handle created via connect_cached() because it will affect other code that may be using the same handle. When connect_cached() returns a handle the attributes will be reset to their initial values. This can cause problems, especially with the C attribute. Also, to ensure that the attributes passed are always the same, avoid passing references inline. For example, the C attribute is specified as a hash reference. Be sure to declare it external to the call to connect_cached(), such that the hash reference is not re-created on every call. A package-level lexical works well: package MyDBH; my $cb = { 'connect_cached.reused' => sub { delete $_[4]->{AutoCommit} }, }; sub dbh { DBI->connect_cached( $dsn, $username, $auth, { Callbacks => $cb }); } Where multiple separate parts of a program are using connect_cached() to connect to the same database with the same (initial) attributes it is a good idea to add a private attribute to the connect_cached() call to effectively limit the scope of the caching. For example: DBI->connect_cached(..., { private_foo_cachekey => "Bar", ... }); Handles returned from that connect_cached() call will only be returned by other connect_cached() call elsewhere in the code if those other calls also pass in the same attribute values, including the private one. (I've used C here as an example, you can use any attribute name with a C prefix.) Taking that one step further, you can limit a particular connect_cached() call to return handles unique to that one place in the code by setting the private attribute to a unique value for that place: DBI->connect_cached(..., { private_foo_cachekey => __FILE__.__LINE__, ... }); By using a private attribute you still get connection caching for the individual calls to connect_cached() but, by making separate database connections for separate parts of the code, the database handles are isolated from any attribute changes made to other handles. The cache can be accessed (and cleared) via the L attribute: my $CachedKids_hashref = $dbh->{Driver}->{CachedKids}; %$CachedKids_hashref = () if $CachedKids_hashref; =head3 C @ary = DBI->available_drivers; @ary = DBI->available_drivers($quiet); Returns a list of all available drivers by searching for C modules through the directories in C<@INC>. By default, a warning is given if some drivers are hidden by others of the same name in earlier directories. Passing a true value for C<$quiet> will inhibit the warning. =head3 C %drivers = DBI->installed_drivers(); Returns a list of driver name and driver handle pairs for all drivers 'installed' (loaded) into the current process. The driver name does not include the 'DBD::' prefix. To get a list of all drivers available in your perl installation you can use L. Added in DBI 1.49. =head3 C DBI->installed_versions; @ary = DBI->installed_versions; $hash = DBI->installed_versions; Calls available_drivers() and attempts to load each of them in turn using install_driver(). For each load that succeeds the driver name and version number are added to a hash. When running under L drivers which appear not be pure-perl are ignored. When called in array context the list of successfully loaded drivers is returned (without the 'DBD::' prefix). When called in scalar context an extra entry for the C is added (and C if appropriate) and a reference to the hash is returned. When called in a void context the installed_versions() method will print out a formatted list of the hash contents, one per line, along with some other information about the DBI version and OS. Due to the potentially high memory cost and unknown risks of loading in an unknown number of drivers that just happen to be installed on the system, this method is not recommended for general use. Use available_drivers() instead. The installed_versions() method is primarily intended as a quick way to see from the command line what's installed. For example: perl -MDBI -e 'DBI->installed_versions' The installed_versions() method was added in DBI 1.38. =head3 C @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); Returns a list of data sources (databases) available via the named driver. If C<$driver> is empty or C, then the value of the C environment variable is used. The driver will be loaded if it hasn't been already. Note that if the driver loading fails then data_sources() I with an error message that includes the string "C" and the underlying problem. Data sources are returned in a form suitable for passing to the L method (that is, they will include the "C" prefix). Note that many drivers have no way of knowing what data sources might be available for it. These drivers return an empty or incomplete list or may require driver-specific attributes. There is also a data_sources() method defined for database handles. =head3 C DBI->trace($trace_setting) DBI->trace($trace_setting, $trace_filename) DBI->trace($trace_setting, $trace_filehandle) $trace_setting = DBI->trace; The Ctrace> method sets the I trace settings and returns the I trace settings. It can also be used to change where the trace output is sent. There's a similar method, C<$h-Etrace>, which sets the trace settings for the specific handle it's called on. See the L section for full details about the DBI's powerful tracing facilities. =head3 C DBI->visit_handles( $coderef ); DBI->visit_handles( $coderef, $info ); Where $coderef is a reference to a subroutine and $info is an arbitrary value which, if undefined, defaults to a reference to an empty hash. Returns $info. For each installed driver handle, if any, $coderef is invoked as: $coderef->($driver_handle, $info); If the execution of $coderef returns a true value then L is called on that child handle and passed the returned value as $info. For example: my $info = $dbh->{Driver}->visit_child_handles(sub { my ($h, $info) = @_; ++$info->{ $h->{Type} }; # count types of handles (dr/db/st) return $info; # visit kids }); See also L. =head2 DBI Utility Functions In addition to the DBI methods listed in the previous section, the DBI package also provides several utility functions. These can be imported into your code by listing them in the C statement. For example: use DBI qw(neat data_diff); Alternatively, all these utility functions (except hash) can be imported using the C<:utils> import tag. For example: use DBI qw(:utils); =head3 C $description = data_string_desc($string); Returns an informal description of the string. For example: UTF8 off, ASCII, 42 characters 42 bytes UTF8 off, non-ASCII, 42 characters 42 bytes UTF8 on, non-ASCII, 4 characters 6 bytes UTF8 on but INVALID encoding, non-ASCII, 4 characters 6 bytes UTF8 off, undef The initial C on/off refers to Perl's internal SvUTF8 flag. If $string has the SvUTF8 flag set but the sequence of bytes it contains are not a valid UTF-8 encoding then data_string_desc() will report C. The C vs C portion shows C if I the characters in the string are ASCII (have code points <= 127). The data_string_desc() function was added in DBI 1.46. =head3 C $diff = data_string_diff($a, $b); Returns an informal description of the first character difference between the strings. If both $a and $b contain the same sequence of characters then data_string_diff() returns an empty string. For example: Params a & b Result ------------ ------ 'aaa', 'aaa' '' 'aaa', 'abc' 'Strings differ at index 2: a[2]=a, b[2]=b' 'aaa', undef 'String b is undef, string a has 3 characters' 'aaa', 'aa' 'String b truncated after 2 characters' Unicode characters are reported in C<\x{XXXX}> format. Unicode code points in the range U+0800 to U+08FF are unassigned and most likely to occur due to double-encoding. Characters in this range are reported as C<\x{08XX}='C'> where C is the corresponding latin-1 character. The data_string_diff() function only considers logical I and not the underlying encoding. See L for an alternative. The data_string_diff() function was added in DBI 1.46. =head3 C $diff = data_diff($a, $b); $diff = data_diff($a, $b, $logical); Returns an informal description of the difference between two strings. It calls L and L and returns the combined results as a multi-line string. For example, C will return: a: UTF8 off, ASCII, 3 characters 3 bytes b: UTF8 on, non-ASCII, 3 characters 5 bytes Strings differ at index 2: a[2]=c, b[2]=\x{263A} If $a and $b are identical in both the characters they contain I their physical encoding then data_diff() returns an empty string. If $logical is true then physical encoding differences are ignored (but are still reported if there is a difference in the characters). The data_diff() function was added in DBI 1.46. =head3 C $str = neat($value); $str = neat($value, $maxlen); Return a string containing a neat (and tidy) representation of the supplied value. Strings will be quoted, although internal quotes will I be escaped. Values known to be numeric will be unquoted. Undefined (NULL) values will be shown as C (without quotes). If the string is flagged internally as utf8 then double quotes will be used, otherwise single quotes are used and unprintable characters will be replaced by dot (.). For result strings longer than C<$maxlen> the result string will be truncated to C<$maxlen-4> and "C<...'>" will be appended. If C<$maxlen> is 0 or C, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400. This function is designed to format values for human consumption. It is used internally by the DBI for L output. It should typically I be used for formatting values for database use. (See also L.) =head3 C $str = neat_list(\@listref, $maxlen, $field_sep); Calls C on each element of the list and returns a string containing the results joined with C<$field_sep>. C<$field_sep> defaults to C<", ">. =head3 C @bool = looks_like_number(@array); Returns true for each element that looks like a number. Returns false for each element that does not look like a number. Returns C for each element that is undefined or empty. =head3 C $hash_value = DBI::hash($buffer, $type); Return a 32-bit integer 'hash' value corresponding to the contents of $buffer. The $type parameter selects which kind of hash algorithm should be used. For the technically curious, type 0 (which is the default if $type isn't specified) is based on the Perl 5.1 hash except that the value is forced to be negative (for obscure historical reasons). Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See L for more information. Both types are implemented in C and are very fast. This function doesn't have much to do with databases, except that it can be handy to store hash values in a database. =head3 C $sts = DBI::sql_type_cast($sv, $sql_type, $flags); sql_type_cast attempts to cast C<$sv> to the SQL type (see L) specified in C<$sql_type>. At present only the SQL types C, C and C are supported. For C the effect is similar to using the value in an expression that requires an integer. It gives the perl scalar an 'integer aspect'. (Technically the value gains an IV, or possibly a UV or NV if the value is too large for an IV.) For C the effect is similar to using the value in an expression that requires a general numeric value. It gives the perl scalar a 'numeric aspect'. (Technically the value gains an NV.) C is similar to C or C but more general and more cautious. It will look at the string first and if it looks like an integer (that will fit in an IV or UV) it will act like C, if it looks like a floating point value it will act like C, if it looks like neither then it will do nothing - and thereby avoid the warnings that would be generated by C and C when given non-numeric data. C<$flags> may be: =over 4 =item C If this flag is specified then when the driver successfully casts the bound perl scalar to a non-string type then the string portion of the scalar will be discarded. =item C If C<$sv> cannot be cast to the requested C<$sql_type> then by default it is left untouched and no error is generated. If you specify C and the cast fails, this will generate an error. =back The returned C<$sts> value is: -2 sql_type is not handled -1 sv is undef so unchanged 0 sv could not be cast cleanly and DBIstcf_STRICT was used 1 sv could not be cast and DBIstcf_STRICT was not used 2 sv was cast successfully This method is exported by the :utils tag and was introduced in DBI 1.611. =head2 DBI Dynamic Attributes Dynamic attributes are always associated with the I (that handle is represented by C<$h> in the descriptions below). Where an attribute is equivalent to a method call, then refer to the method call for all related documentation. Warning: these attributes are provided as a convenience but they do have limitations. Specifically, they have a short lifespan: because they are associated with the last handle used, they should only be used I after calling the method that "sets" them. If in any doubt, use the corresponding method call. =head3 C<$DBI::err> Equivalent to C<$h-Eerr>. =head3 C<$DBI::errstr> Equivalent to C<$h-Eerrstr>. =head3 C<$DBI::state> Equivalent to C<$h-Estate>. =head3 C<$DBI::rows> Equivalent to C<$h-Erows>. Please refer to the documentation for the L method. =head3 C<$DBI::lasth> Returns the DBI object handle used for the most recent DBI method call. If the last DBI method call was a DESTROY then $DBI::lasth will return the handle of the parent of the destroyed handle, if there is one. =head1 METHODS COMMON TO ALL HANDLES The following methods can be used by all types of DBI handles. =head3 C $rv = $h->err; Returns the I database engine error code from the last driver method called. The code is typically an integer but you should not assume that. The DBI resets $h->err to undef before almost all DBI method calls, so the value only has a short lifespan. Also, for most drivers, the statement handles share the same error variable as the parent database handle, so calling a method on one handle may reset the error on the related handles. (Methods which don't reset err before being called include err() and errstr(), obviously, state(), rows(), func(), trace(), trace_msg(), ping(), and the tied hash attribute FETCH() and STORE() methods.) If you need to test for specific error conditions I have your program be portable to different database engines, then you'll need to determine what the corresponding error codes are for all those engines and test for all of them. The DBI uses the value of $DBI::stderr as the C value for internal errors. Drivers should also do likewise. The default value for $DBI::stderr is 2000000000. A driver may return C<0> from err() to indicate a warning condition after a method call. Similarly, a driver may return an empty string to indicate a 'success with information' condition. In both these cases the value is false but not undef. The errstr() and state() methods may be used to retrieve extra information in these cases. See L for more information. =head3 C $str = $h->errstr; Returns the native database engine error message from the last DBI method called. This has the same lifespan issues as the L method described above. The returned string may contain multiple messages separated by newline characters. The errstr() method should not be used to test for errors, use err() for that, because drivers may return 'success with information' or warning messages via errstr() for methods that have not 'failed'. See L for more information. =head3 C $str = $h->state; Returns a state code in the standard SQLSTATE five character format. Note that the specific success code C<00000> is translated to any empty string (false). If the driver does not support SQLSTATE (and most don't), then state() will return C (General Error) for all errors. The driver is free to return any value via C, e.g., warning codes, even if it has not declared an error by returning a true value via the L method described above. The state() method should not be used to test for errors, use err() for that, because drivers may return a 'success with information' or warning state code via state() for methods that have not 'failed'. =head3 C $rv = $h->set_err($err, $errstr); $rv = $h->set_err($err, $errstr, $state); $rv = $h->set_err($err, $errstr, $state, $method); $rv = $h->set_err($err, $errstr, $state, $method, $rv); Set the C, C, and C values for the handle. This method is typically only used by DBI drivers and DBI subclasses. If the L attribute holds a reference to a subroutine it is called first. The subroutine can alter the $err, $errstr, $state, and $method values. See L for full details. If the subroutine returns a true value then the handle C, C, and C values are not altered and set_err() returns an empty list (it normally returns $rv which defaults to undef, see below). Setting C to a I value indicates an error and will trigger the normal DBI error handling mechanisms, such as C and C, if they are enabled, when execution returns from the DBI back to the application. Setting C to C<""> indicates an 'information' state, and setting it to C<"0"> indicates a 'warning' state. Setting C to C also sets C to undef, and C to C<"">, irrespective of the values of the $errstr and $state parameters. The $method parameter provides an alternate method name for the C/C/C error string instead of the fairly unhelpful 'C'. The C method normally returns undef. The $rv parameter provides an alternate return value. Some special rules apply if the C or C values for the handle are I set... If C is true then: "C< [err was %s now %s]>" is appended if $err is true and C is already true and the new err value differs from the original one. Similarly "C< [state was %s now %s]>" is appended if $state is true and C is already true and the new state value differs from the original one. Finally "C<\n>" and the new $errstr are appended if $errstr differs from the existing errstr value. Obviously the C<%s>'s above are replaced by the corresponding values. The handle C value is set to $err if: $err is true; or handle C value is undef; or $err is defined and the length is greater than the handle C length. The effect is that an 'information' state only overrides undef; a 'warning' overrides undef or 'information', and an 'error' state overrides anything. The handle C value is set to $state if $state is true and the handle C value was set (by the rules above). Support for warning and information states was added in DBI 1.41. =head3 C $h->trace($trace_settings); $h->trace($trace_settings, $trace_filename); $trace_settings = $h->trace; The trace() method is used to alter the trace settings for a handle (and any future children of that handle). It can also be used to change where the trace output is sent. There's a similar method, Ctrace>, which sets the global default trace settings. See the L section for full details about the DBI's powerful tracing facilities. =head3 C $h->trace_msg($message_text); $h->trace_msg($message_text, $min_level); Writes C<$message_text> to the trace file if the trace level is greater than or equal to $min_level (which defaults to 1). Can also be called as Ctrace_msg($msg)>. See L for more details. =head3 C $h->func(@func_arguments, $func_name) or die ...; The C method can be used to call private non-standard and non-portable methods implemented by the driver. Note that the function name is given as the I argument. It's also important to note that the func() method does not clear a previous error ($DBI::err etc.) and it does not trigger automatic error detection (RaiseError etc.) so you must check the return status and/or $h->err to detect errors. (This method is not directly related to calling stored procedures. Calling stored procedures is currently not defined by the DBI. Some drivers, such as DBD::Oracle, support it in non-portable ways. See driver documentation for more details.) See also install_method() in L for how you can avoid needing to use func() and gain direct access to driver-private methods. =head3 C $is_implemented = $h->can($method_name); Returns true if $method_name is implemented by the driver or a default method is provided by the DBI's driver base class. It returns false where a driver hasn't implemented a method and the default method is provided by the DBI's driver base class is just an empty stub. =head3 C $trace_settings_integer = $h->parse_trace_flags($trace_settings); Parses a string containing trace settings and returns the corresponding integer value used internally by the DBI and drivers. The $trace_settings argument is a string containing a trace level between 0 and 15 and/or trace flag names separated by vertical bar ("C<|>") or comma ("C<,>") characters. For example: C<"SQL|3|foo">. It uses the parse_trace_flag() method, described below, to process the individual trace flag names. The parse_trace_flags() method was added in DBI 1.42. =head3 C $bit_flag = $h->parse_trace_flag($trace_flag_name); Returns the bit flag corresponding to the trace flag name in $trace_flag_name. Drivers are expected to override this method and check if $trace_flag_name is a driver specific trace flags and, if not, then call the DBI's default parse_trace_flag(). The parse_trace_flag() method was added in DBI 1.42. =head3 C $hash_ref = $h->private_attribute_info(); Returns a reference to a hash whose keys are the names of driver-private handle attributes available for the kind of handle (driver, database, statement) that the method was called on. For example, the return value when called with a DBD::Sybase $dbh could look like this: { syb_dynamic_supported => undef, syb_oc_version => undef, syb_server_version => undef, syb_server_version_string => undef, } and when called with a DBD::Sybase $sth they could look like this: { syb_types => undef, syb_proc_status => undef, syb_result_type => undef, } The values should be undef. Meanings may be assigned to particular values in future. =head3 C $rc = $h1->swap_inner_handle( $h2 ); $rc = $h1->swap_inner_handle( $h2, $allow_reparent ); Brain transplants for handles. You don't need to know about this unless you want to become a handle surgeon. A DBI handle is a reference to a tied hash. A tied hash has an I hash that actually holds the contents. The swap_inner_handle() method swaps the inner hashes between two handles. The $h1 and $h2 handles still point to the same tied hashes, but what those hashes are tied to has been swapped. In effect $h1 I $h2 and vice-versa. This is powerful stuff, expect problems. Use with care. As a small safety measure, the two handles, $h1 and $h2, have to share the same parent unless $allow_reparent is true. The swap_inner_handle() method was added in DBI 1.44. Here's a quick kind of 'diagram' as a worked example to help think about what's happening: Original state: dbh1o -> dbh1i sthAo -> sthAi(dbh1i) dbh2o -> dbh2i swap_inner_handle dbh1o with dbh2o: dbh2o -> dbh1i sthAo -> sthAi(dbh1i) dbh1o -> dbh2i create new sth from dbh1o: dbh2o -> dbh1i sthAo -> sthAi(dbh1i) dbh1o -> dbh2i sthBo -> sthBi(dbh2i) swap_inner_handle sthAo with sthBo: dbh2o -> dbh1i sthBo -> sthAi(dbh1i) dbh1o -> dbh2i sthAo -> sthBi(dbh2i) =head3 C $h->visit_child_handles( $coderef ); $h->visit_child_handles( $coderef, $info ); Where $coderef is a reference to a subroutine and $info is an arbitrary value which, if undefined, defaults to a reference to an empty hash. Returns $info. For each child handle of $h, if any, $coderef is invoked as: $coderef->($child_handle, $info); If the execution of $coderef returns a true value then C is called on that child handle and passed the returned value as $info. For example: # count database connections with names (DSN) matching a pattern my $connections = 0; $dbh->{Driver}->visit_child_handles(sub { my ($h, $info) = @_; ++$connections if $h->{Name} =~ /foo/; return 0; # don't visit kids }) See also L. =head1 ATTRIBUTES COMMON TO ALL HANDLES These attributes are common to all types of DBI handles. Some attributes are inherited by child handles. That is, the value of an inherited attribute in a newly created statement handle is the same as the value in the parent database handle. Changes to attributes in the new statement handle do not affect the parent database handle and changes to the database handle do not affect existing statement handles, only future ones. Attempting to set or get the value of an unknown attribute generates a warning, except for private driver specific attributes (which all have names starting with a lowercase letter). Example: $h->{AttributeName} = ...; # set/write ... = $h->{AttributeName}; # get/read =head3 C Type: boolean, inherited The C attribute enables useful warnings for certain bad practices. It is enabled by default and should only be disabled in rare circumstances. Since warnings are generated using the Perl C function, they can be intercepted using the Perl C<$SIG{__WARN__}> hook. The C attribute is not related to the C attribute. =head3 C Type: boolean, read-only The C attribute is true if the handle object is "active". This is rarely used in applications. The exact meaning of active is somewhat vague at the moment. For a database handle it typically means that the handle is connected to a database (C<$dbh-Edisconnect> sets C off). For a statement handle it typically means that the handle is a C statements that either cannot be prepared in advance (due to a limitation of the driver) or do not need to be executed repeatedly. It should not be used for C". Drivers using any approach like this should issue a warning if C is true because it is generally unsafe - another process may have modified the table between your insert and the select. For situations where you know it is safe, such as when you have locked the table, you can silence the warning by passing C => 0 in \%attr. B<*> If no insert has been performed yet, or the last insert failed, then the value is implementation defined. Given all the caveats above, it's clear that this method must be used with care. The C method was added in DBI 1.38. =head3 C @row_ary = $dbh->selectrow_array($statement); @row_ary = $dbh->selectrow_array($statement, \%attr); @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); This utility method combines L, L and L into a single call. If called in a list context, it returns the first row of data from the statement. The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. If any method fails, and L is not set, C will return an empty list. If called in a scalar context for a statement handle that has more than one column, it is undefined whether the driver will return the value of the first column or the last. So don't do that. Also, in a scalar context, an C is returned if there are no more rows or if an error occurred. That C can't be distinguished from an C returned because the first field value was NULL. For these reasons you should exercise some caution if you use C in a scalar context, or just don't do that. =head3 C $ary_ref = $dbh->selectrow_arrayref($statement); $ary_ref = $dbh->selectrow_arrayref($statement, \%attr); $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values); This utility method combines L, L and L into a single call. It returns the first row of data from the statement. The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. If any method fails, and L is not set, C will return undef. =head3 C $hash_ref = $dbh->selectrow_hashref($statement); $hash_ref = $dbh->selectrow_hashref($statement, \%attr); $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values); This utility method combines L, L and L into a single call. It returns the first row of data from the statement. The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. If any method fails, and L is not set, C will return undef. =head3 C $ary_ref = $dbh->selectall_arrayref($statement); $ary_ref = $dbh->selectall_arrayref($statement, \%attr); $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); This utility method combines L, L and L into a single call. It returns a reference to an array containing a reference to an array (or hash, see below) for each row of data fetched. The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. This is recommended if the statement is going to be executed many times. If L is not set and any method except C fails then C will return C; if C fails then it will return with whatever data has been fetched thus far. You should check C<$dbh-Eerr> afterwards (or use the C attribute) to discover if the data is complete or was truncated due to an error. The L method called by C supports a $max_rows parameter. You can specify a value for $max_rows by including a 'C' attribute in \%attr. In which case finish() is called for you after fetchall_arrayref() returns. The L method called by C also supports a $slice parameter. You can specify a value for $slice by including a 'C' or 'C' attribute in \%attr. The only difference between the two is that if C is not defined and C is an array ref, then the array is assumed to contain column index values (which count from 1), rather than perl array index values. In which case the array is copied and each value decremented before passing to C. You may often want to fetch an array of rows where each row is stored as a hash. That can be done simply using: my $emps = $dbh->selectall_arrayref( "SELECT ename FROM emp ORDER BY ename", { Slice => {} } ); foreach my $emp ( @$emps ) { print "Employee: $emp->{ename}\n"; } Or, to fetch into an array instead of an array ref: @result = @{ $dbh->selectall_arrayref($sql, { Slice => {} }) }; See L method for more details. =head3 C $hash_ref = $dbh->selectall_hashref($statement, $key_field); $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr); $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr, @bind_values); This utility method combines L, L and L into a single call. It returns a reference to a hash containing one entry, at most, for each row, as returned by fetchall_hashref(). The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. This is recommended if the statement is going to be executed many times. The C<$key_field> parameter defines which column, or columns, are used as keys in the returned hash. It can either be the name of a single field, or a reference to an array containing multiple field names. Using multiple names yields a tree of nested hashes. If a row has the same key as an earlier row then it replaces the earlier row. If any method except C fails, and L is not set, C will return C. If C fails and L is not set, then it will return with whatever data it has fetched thus far. $DBI::err should be checked to catch that. See fetchall_hashref() for more details. =head3 C $ary_ref = $dbh->selectcol_arrayref($statement); $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); This utility method combines L, L, and fetching one column from all the rows, into a single call. It returns a reference to an array containing the values of the first column from each row. The C<$statement> parameter can be a previously prepared statement handle, in which case the C is skipped. This is recommended if the statement is going to be executed many times. If any method except C fails, and L is not set, C will return C. If C fails and L is not set, then it will return with whatever data it has fetched thus far. $DBI::err should be checked to catch that. The C method defaults to pushing a single column value (the first) from each row into the result array. However, it can also push another column, or even multiple columns per row, into the result array. This behaviour can be specified via a 'C' attribute which must be a ref to an array containing the column number or numbers to use. For example: # get array of id and name pairs: my $ary_ref = $dbh->selectcol_arrayref("select id, name from table", { Columns=>[1,2] }); my %hash = @$ary_ref; # build hash from key-value pairs so $hash{$id} => name You can specify a maximum number of rows to fetch by including a 'C' attribute in \%attr. =head3 C $sth = $dbh->prepare($statement) or die $dbh->errstr; $sth = $dbh->prepare($statement, \%attr) or die $dbh->errstr; Prepares a statement for later execution by the database engine and returns a reference to a statement handle object. The returned statement handle can be used to get attributes of the statement and invoke the L method. See L. Drivers for engines without the concept of preparing a statement will typically just store the statement in the returned handle and process it when C<$sth-Eexecute> is called. Such drivers are unlikely to give much useful information about the statement, such as C<$sth-E{NUM_OF_FIELDS}>, until after C<$sth-Eexecute> has been called. Portable applications should take this into account. In general, DBI drivers do not parse the contents of the statement (other than simply counting any L). The statement is passed directly to the database engine, sometimes known as pass-thru mode. This has advantages and disadvantages. On the plus side, you can access all the functionality of the engine being used. On the downside, you're limited if you're using a simple engine, and you need to take extra care if writing applications intended to be portable between engines. Portable applications should not assume that a new statement can be prepared and/or executed while still fetching results from a previous statement. Some command-line SQL tools use statement terminators, like a semicolon, to indicate the end of a statement. Such terminators should not normally be used with the DBI. =head3 C $sth = $dbh->prepare_cached($statement) $sth = $dbh->prepare_cached($statement, \%attr) $sth = $dbh->prepare_cached($statement, \%attr, $if_active) Like L except that the statement handle returned will be stored in a hash associated with the C<$dbh>. If another call is made to C with the same C<$statement> and C<%attr> parameter values, then the corresponding cached C<$sth> will be returned without contacting the database server. The C<$if_active> parameter lets you adjust the behaviour if an already cached statement handle is still Active. There are several alternatives: =over 4 =item B<0>: A warning will be generated, and finish() will be called on the statement handle before it is returned. This is the default behaviour if $if_active is not passed. =item B<1>: finish() will be called on the statement handle, but the warning is suppressed. =item B<2>: Disables any checking. =item B<3>: The existing active statement handle will be removed from the cache and a new statement handle prepared and cached in its place. This is the safest option because it doesn't affect the state of the old handle, it just removes it from the cache. [Added in DBI 1.40] =back Here are some examples of C: sub insert_hash { my ($table, $field_values) = @_; # sort to keep field order, and thus sql, stable for prepare_cached my @fields = sort keys %$field_values; my @values = @{$field_values}{@fields}; my $sql = sprintf "insert into %s (%s) values (%s)", $table, join(",", @fields), join(",", ("?")x@fields); my $sth = $dbh->prepare_cached($sql); return $sth->execute(@values); } sub search_hash { my ($table, $field_values) = @_; # sort to keep field order, and thus sql, stable for prepare_cached my @fields = sort keys %$field_values; my @values = @{$field_values}{@fields}; my $qualifier = ""; $qualifier = "where ".join(" and ", map { "$_=?" } @fields) if @fields; $sth = $dbh->prepare_cached("SELECT * FROM $table $qualifier"); return $dbh->selectall_arrayref($sth, {}, @values); } I This caching can be useful in some applications, but it can also cause problems and should be used with care. Here is a contrived case where caching would cause a significant problem: my $sth = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); $sth->execute(...); while (my $data = $sth->fetchrow_hashref) { # later, in some other code called within the loop... my $sth2 = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); $sth2->execute(...); while (my $data2 = $sth2->fetchrow_arrayref) { do_stuff(...); } } In this example, since both handles are preparing the exact same statement, C<$sth2> will not be its own statement handle, but a duplicate of C<$sth> returned from the cache. The results will certainly not be what you expect. Typically the inner fetch loop will work normally, fetching all the records and terminating when there are no more, but now that $sth is the same as $sth2 the outer fetch loop will also terminate. You'll know if you run into this problem because prepare_cached() will generate a warning by default (when $if_active is false). The cache used by prepare_cached() is keyed by both the statement and any attributes so you can also avoid this issue by doing something like: $sth = $dbh->prepare_cached("...", { dbi_dummy => __FILE__.__LINE__ }); which will ensure that prepare_cached only returns statements cached by that line of code in that source file. If you'd like the cache to managed intelligently, you can tie the hashref returned by C to an appropriate caching module, such as L: my $cache; tie %$cache, 'Tie::Cache::LRU', 500; $dbh->{CachedKids} = $cache; =head3 C $rc = $dbh->commit or die $dbh->errstr; Commit (make permanent) the most recent series of database changes if the database supports transactions and AutoCommit is off. If C is on, then calling C will issue a "commit ineffective with AutoCommit" warning. See also L in the L section below. =head3 C $rc = $dbh->rollback or die $dbh->errstr; Rollback (undo) the most recent series of uncommitted database changes if the database supports transactions and AutoCommit is off. If C is on, then calling C will issue a "rollback ineffective with AutoCommit" warning. See also L in the L section below. =head3 C $rc = $dbh->begin_work or die $dbh->errstr; Enable transactions (by turning C off) until the next call to C or C. After the next C or C, C will automatically be turned on again. If C is already off when C is called then it does nothing except return an error. If the driver does not support transactions then when C attempts to set C off the driver will trigger a fatal error. See also L in the L section below. =head3 C $rc = $dbh->disconnect or warn $dbh->errstr; Disconnects the database from the database handle. C is typically only used before exiting the program. The handle is of little use after disconnecting. The transaction behaviour of the C method is, sadly, undefined. Some database systems (such as Oracle and Ingres) will automatically commit any outstanding changes, but others (such as Informix) will rollback any outstanding changes. Applications not using C should explicitly call C or C before calling C. The database is automatically disconnected by the C method if still connected when there are no longer any references to the handle. The C method for each driver should implicitly call C to undo any uncommitted changes. This is vital behaviour to ensure that incomplete transactions don't get committed simply because Perl calls C on every object before exiting. Also, do not rely on the order of object destruction during "global destruction", as it is undefined. Generally, if you want your changes to be committed or rolled back when you disconnect, then you should explicitly call L or L before disconnecting. If you disconnect from a database while you still have active statement handles (e.g., SELECT statement handles that may have more data to fetch), you will get a warning. The warning may indicate that a fetch loop terminated early, perhaps due to an uncaught error. To avoid the warning call the C method on the active handles. =head3 C $rc = $dbh->ping; Attempts to determine, in a reasonably efficient way, if the database server is still running and the connection to it is still working. Individual drivers should implement this function in the most suitable manner for their database engine. The current I implementation always returns true without actually doing anything. Actually, it returns "C<0 but true>" which is true but zero. That way you can tell if the return value is genuine or just the default. Drivers should override this method with one that does the right thing for their type of database. Few applications would have direct use for this method. See the specialized Apache::DBI module for one example usage. =head3 C $value = $dbh->get_info( $info_type ); Returns information about the implementation, i.e. driver and data source capabilities, restrictions etc. It returns C for unknown or unimplemented information types. For example: $database_version = $dbh->get_info( 18 ); # SQL_DBMS_VER $max_select_tables = $dbh->get_info( 106 ); # SQL_MAXIMUM_TABLES_IN_SELECT See L for more detailed information about the information types and their meanings and possible return values. The L module exports a %GetInfoType hash that can be used to map info type names to numbers. For example: $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} ); The names are a merging of the ANSI and ODBC standards (which differ in some cases). See L for more details. Because some DBI methods make use of get_info(), drivers are strongly encouraged to support I the following very minimal set of information types to ensure the DBI itself works properly: Type Name Example A Example B ---- -------------------------- ------------ ---------------- 17 SQL_DBMS_NAME 'ACCESS' 'Oracle' 18 SQL_DBMS_VER '03.50.0000' '08.01.0721 ...' 29 SQL_IDENTIFIER_QUOTE_CHAR '`' '"' 41 SQL_CATALOG_NAME_SEPARATOR '.' '@' 114 SQL_CATALOG_LOCATION 1 2 Values from 9000 to 9999 for get_info are officially reserved for use by Perl DBI. Values in that range which have been assigned a meaning are defined here: C<9000>: true if a backslash character (C<\>) before placeholder-like text (e.g. C, C<:foo>) will prevent it being treated as a placeholder by the driver. The backslash will be removed before the text is passed to the backend. =head3 C $sth = $dbh->table_info( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Returns an active statement handle that can be used to fetch information about tables and views that exist in the database. The arguments $catalog, $schema and $table may accept search patterns according to the database/driver, for example: $table = '%FOO%'; Remember that the underscore character ('C<_>') is a search pattern that means match any character, so 'FOO_%' is the same as 'FOO%' and 'FOO_BAR%' will match names like 'FOO1BAR'. The value of $type is a comma-separated list of one or more types of tables to be returned in the result set. Each value may optionally be quoted, e.g.: $type = "TABLE"; $type = "'TABLE','VIEW'"; In addition the following special cases may also be supported by some drivers: =over 4 =item * If the value of $catalog is '%' and $schema and $table name are empty strings, the result set contains a list of catalog names. For example: $sth = $dbh->table_info('%', '', ''); =item * If the value of $schema is '%' and $catalog and $table are empty strings, the result set contains a list of schema names. =item * If the value of $type is '%' and $catalog, $schema, and $table are all empty strings, the result set contains a list of table types. =back If your driver doesn't support one or more of the selection filter parameters then you may get back more than you asked for and can do the filtering yourself. This method can be expensive, and can return a large amount of data. (For example, small Oracle installation returns over 2000 rows.) So it's a good idea to use the filters to limit the data as much as possible. The statement handle returned has at least the following fields in the order show below. Other fields, after these, may also be present. B: Table catalog identifier. This field is NULL (C) if not applicable to the data source, which is usually the case. This field is empty if not applicable to the table. B: The name of the schema containing the TABLE_NAME value. This field is NULL (C) if not applicable to data source, and empty if not applicable to the table. B: Name of the table (or view, synonym, etc). B: One of the following: "TABLE", "VIEW", "SYSTEM TABLE", "GLOBAL TEMPORARY", "LOCAL TEMPORARY", "ALIAS", "SYNONYM" or a type identifier that is specific to the data source. B: A description of the table. May be NULL (C). Note that C might not return records for all tables. Applications can use any valid table regardless of whether it's returned by C. See also L, L and L. =head3 C $sth = $dbh->column_info( $catalog, $schema, $table, $column ); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Returns an active statement handle that can be used to fetch information about columns in specified tables. The arguments $schema, $table and $column may accept search patterns according to the database/driver, for example: $table = '%FOO%'; Note: The support for the selection criteria is driver specific. If the driver doesn't support one or more of them then you may get back more than you asked for and can do the filtering yourself. Note: If your driver does not support column_info an undef is returned. This is distinct from asking for something which does not exist in a driver which supports column_info as a valid statement handle to an empty result-set will be returned in this case. If the arguments don't match any tables then you'll still get a statement handle, it'll just return no rows. The statement handle returned has at least the following fields in the order shown below. Other fields, after these, may also be present. B: The catalog identifier. This field is NULL (C) if not applicable to the data source, which is often the case. This field is empty if not applicable to the table. B: The schema identifier. This field is NULL (C) if not applicable to the data source, and empty if not applicable to the table. B: The table identifier. Note: A driver may provide column metadata not only for base tables, but also for derived objects like SYNONYMS etc. B: The column identifier. B: The concise data type code. B: A data source dependent data type name. B: The column size. This is the maximum length in characters for character data types, the number of digits or bits for numeric data types or the length in the representation of temporal types. See the relevant specifications for detailed information. B: The length in bytes of transferred data. B: The total number of significant digits to the right of the decimal point. B: The radix for numeric precision. The value is 10 or 2 for numeric data types and NULL (C) if not applicable. B: Indicates if a column can accept NULLs. The following values are defined: SQL_NO_NULLS 0 SQL_NULLABLE 1 SQL_NULLABLE_UNKNOWN 2 B: A description of the column. B: The default value of the column, in a format that can be used directly in an SQL statement. Note that this may be an expression and not simply the text used for the default value in the original CREATE TABLE statement. For example, given: col1 char(30) default current_user -- a 'function' col2 char(30) default 'string' -- a string literal where "current_user" is the name of a function, the corresponding C values would be: Database col1 col2 -------- ---- ---- Oracle: current_user 'string' Postgres: "current_user"() 'string'::text MS SQL: (user_name()) ('string') B: The SQL data type. B: The subtype code for datetime and interval data types. B: The maximum length in bytes of a character or binary data type column. B: The column sequence number (starting with 1). B: Indicates if the column can accept NULLs. Possible values are: 'NO', 'YES' and ''. SQL/CLI defines the following additional columns: CHAR_SET_CAT CHAR_SET_SCHEM CHAR_SET_NAME COLLATION_CAT COLLATION_SCHEM COLLATION_NAME UDT_CAT UDT_SCHEM UDT_NAME DOMAIN_CAT DOMAIN_SCHEM DOMAIN_NAME SCOPE_CAT SCOPE_SCHEM SCOPE_NAME MAX_CARDINALITY DTD_IDENTIFIER IS_SELF_REF Drivers capable of supplying any of those values should do so in the corresponding column and supply undef values for the others. Drivers wishing to provide extra database/driver specific information should do so in extra columns beyond all those listed above, and use lowercase field names with the driver-specific prefix (i.e., 'ora_...'). Applications accessing such fields should do so by name and not by column number. The result set is ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME and ORDINAL_POSITION. Note: There is some overlap with statement handle attributes (in perl) and SQLDescribeCol (in ODBC). However, SQLColumns provides more metadata. See also L and L. =head3 C $sth = $dbh->primary_key_info( $catalog, $schema, $table ); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Returns an active statement handle that can be used to fetch information about columns that make up the primary key for a table. The arguments don't accept search patterns (unlike table_info()). The statement handle will return one row per column, ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME, and KEY_SEQ. If there is no primary key then the statement handle will fetch no rows. Note: The support for the selection criteria, such as $catalog, is driver specific. If the driver doesn't support catalogs and/or schemas, it may ignore these criteria. The statement handle returned has at least the following fields in the order shown below. Other fields, after these, may also be present. B: The catalog identifier. This field is NULL (C) if not applicable to the data source, which is often the case. This field is empty if not applicable to the table. B: The schema identifier. This field is NULL (C) if not applicable to the data source, and empty if not applicable to the table. B: The table identifier. B: The column identifier. B: The column sequence number (starting with 1). Note: This field is named B in SQL/CLI. B: The primary key constraint identifier. This field is NULL (C) if not applicable to the data source. See also L and L. =head3 C @key_column_names = $dbh->primary_key( $catalog, $schema, $table ); Simple interface to the primary_key_info() method. Returns a list of the column names that comprise the primary key of the specified table. The list is in primary key column sequence order. If there is no primary key then an empty list is returned. =head3 C $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table , $fk_catalog, $fk_schema, $fk_table ); $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table , $fk_catalog, $fk_schema, $fk_table , \%attr ); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Returns an active statement handle that can be used to fetch information about foreign keys in and/or referencing the specified table(s). The arguments don't accept search patterns (unlike table_info()). C<$pk_catalog>, C<$pk_schema>, C<$pk_table> identify the primary (unique) key table (B). C<$fk_catalog>, C<$fk_schema>, C<$fk_table> identify the foreign key table (B). If both B and B are given, the function returns the foreign key, if any, in table B that refers to the primary (unique) key of table B. (Note: In SQL/CLI, the result is implementation-defined.) If only B is given, then the result set contains the primary key of that table and all foreign keys that refer to it. If only B is given, then the result set contains all foreign keys in that table and the primary keys to which they refer. (Note: In SQL/CLI, the result includes unique keys too.) For example: $sth = $dbh->foreign_key_info( undef, $user, 'master'); $sth = $dbh->foreign_key_info( undef, undef, undef , undef, $user, 'detail'); $sth = $dbh->foreign_key_info( undef, $user, 'master', undef, $user, 'detail'); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Note: The support for the selection criteria, such as C<$catalog>, is driver specific. If the driver doesn't support catalogs and/or schemas, it may ignore these criteria. The statement handle returned has the following fields in the order shown below. Because ODBC never includes unique keys, they define different columns in the result set than SQL/CLI. SQL/CLI column names are shown in parentheses. B: The primary (unique) key table catalog identifier. This field is NULL (C) if not applicable to the data source, which is often the case. This field is empty if not applicable to the table. B: The primary (unique) key table schema identifier. This field is NULL (C) if not applicable to the data source, and empty if not applicable to the table. B: The primary (unique) key table identifier. B: The primary (unique) key column identifier. B: The foreign key table catalog identifier. This field is NULL (C) if not applicable to the data source, which is often the case. This field is empty if not applicable to the table. B: The foreign key table schema identifier. This field is NULL (C) if not applicable to the data source, and empty if not applicable to the table. B: The foreign key table identifier. B: The foreign key column identifier. B: The column sequence number (starting with 1). B: The referential action for the UPDATE rule. The following codes are defined: CASCADE 0 RESTRICT 1 SET NULL 2 NO ACTION 3 SET DEFAULT 4 B: The referential action for the DELETE rule. The codes are the same as for UPDATE_RULE. B: The foreign key name. B: The primary (unique) key name. B: The deferrability of the foreign key constraint. The following codes are defined: INITIALLY DEFERRED 5 INITIALLY IMMEDIATE 6 NOT DEFERRABLE 7 B< ( UNIQUE_OR_PRIMARY )>: This column is necessary if a driver includes all candidate (i.e. primary and alternate) keys in the result set (as specified by SQL/CLI). The value of this column is UNIQUE if the foreign key references an alternate key and PRIMARY if the foreign key references a primary key, or it may be undefined if the driver doesn't have access to the information. See also L and L. =head3 C B This method is experimental and may change. $sth = $dbh->statistics_info( $catalog, $schema, $table, $unique_only, $quick ); # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc Returns an active statement handle that can be used to fetch statistical information about a table and its indexes. The arguments don't accept search patterns (unlike L). If the boolean argument $unique_only is true, only UNIQUE indexes will be returned in the result set, otherwise all indexes will be returned. If the boolean argument $quick is set, the actual statistical information columns (CARDINALITY and PAGES) will only be returned if they are readily available from the server, and might not be current. Some databases may return stale statistics or no statistics at all with this flag set. The statement handle will return at most one row per column name per index, plus at most one row for the entire table itself, ordered by NON_UNIQUE, TYPE, INDEX_QUALIFIER, INDEX_NAME, and ORDINAL_POSITION. Note: The support for the selection criteria, such as $catalog, is driver specific. If the driver doesn't support catalogs and/or schemas, it may ignore these criteria. The statement handle returned has at least the following fields in the order shown below. Other fields, after these, may also be present. B: The catalog identifier. This field is NULL (C) if not applicable to the data source, which is often the case. This field is empty if not applicable to the table. B: The schema identifier. This field is NULL (C) if not applicable to the data source, and empty if not applicable to the table. B: The table identifier. B: Unique index indicator. Returns 0 for unique indexes, 1 for non-unique indexes B: Index qualifier identifier. The identifier that is used to qualify the index name when doing a C; NULL (C) is returned if an index qualifier is not supported by the data source. If a non-NULL (defined) value is returned in this column, it must be used to qualify the index name on a C statement; otherwise, the TABLE_SCHEM should be used to qualify the index name. B: The index identifier. B: The type of information being returned. Can be any of the following values: 'table', 'btree', 'clustered', 'content', 'hashed', or 'other'. In the case that this field is 'table', all fields other than TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TYPE, CARDINALITY, and PAGES will be NULL (C). B: Column sequence number (starting with 1). B: The column identifier. B: Column sort sequence. C for Ascending, C for Descending, or NULL (C) if not supported for this index. B: Cardinality of the table or index. For indexes, this is the number of unique values in the index. For tables, this is the number of rows in the table. If not supported, the value will be NULL (C). B: Number of storage pages used by this table or index. If not supported, the value will be NULL (C). B: The index filter condition as a string. If the index is not a filtered index, or it cannot be determined whether the index is a filtered index, this value is NULL (C). If the index is a filtered index, but the filter condition cannot be determined, this value is the empty string C<''>. Otherwise it will be the literal filter condition as a string, such as C. See also L and L. =head3 C @names = $dbh->tables( $catalog, $schema, $table, $type ); @names = $dbh->tables; # deprecated Simple interface to table_info(). Returns a list of matching table names, possibly including a catalog/schema prefix. See L for a description of the parameters. If C<$dbh-Eget_info(29)> returns true (29 is SQL_IDENTIFIER_QUOTE_CHAR) then the table names are constructed and quoted by L to ensure they are usable even if they contain whitespace or reserved words etc. This means that the table names returned will include quote characters. =head3 C $type_info_all = $dbh->type_info_all; Returns a reference to an array which holds information about each data type variant supported by the database and driver. The array and its contents should be treated as read-only. The first item is a reference to an 'index' hash of CE C pairs. The items following that are references to arrays, one per supported data type variant. The leading index hash defines the names and order of the fields within the arrays that follow it. For example: $type_info_all = [ { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, # was PRECISION originally LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE=> 9, FIXED_PREC_SCALE => 10, # was MONEY originally AUTO_UNIQUE_VALUE => 11, # was AUTO_INCREMENT originally LOCAL_TYPE_NAME => 12, MINIMUM_SCALE => 13, MAXIMUM_SCALE => 14, SQL_DATA_TYPE => 15, SQL_DATETIME_SUB => 16, NUM_PREC_RADIX => 17, INTERVAL_PRECISION=> 18, }, [ 'VARCHAR', SQL_VARCHAR, undef, "'","'", undef,0, 1,1,0,0,0,undef,1,255, undef ], [ 'INTEGER', SQL_INTEGER, undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0, 10 ], ]; More than one row may have the same value in the C field if there are different ways to spell the type name and/or there are variants of the type with different attributes (e.g., with and without C set, with and without C, etc). The rows are ordered by C first and then by how closely each type maps to the corresponding ODBC SQL data type, closest first. The meaning of the fields is described in the documentation for the L method. An 'index' hash is provided so you don't need to rely on index values defined above. However, using DBD::ODBC with some old ODBC drivers may return older names, shown as comments in the example above. Another issue with the index hash is that the lettercase of the keys is not defined. It is usually uppercase, as show here, but drivers may return names with any lettercase. Drivers are also free to return extra driver-specific columns of information - though it's recommended that they start at column index 50 to leave room for expansion of the DBI/ODBC specification. The type_info_all() method is not normally used directly. The L method provides a more usable and useful interface to the data. =head3 C @type_info = $dbh->type_info($data_type); Returns a list of hash references holding information about one or more variants of $data_type. The list is ordered by C first and then by how closely each type maps to the corresponding ODBC SQL data type, closest first. If called in a scalar context then only the first (best) element is returned. If $data_type is undefined or C, then the list will contain hashes for all data type variants supported by the database and driver. If $data_type is an array reference then C returns the information for the I type in the array that has any matches. The keys of the hash follow the same letter case conventions as the rest of the DBI (see L). The following uppercase items should always exist, though may be undef: =over 4 =item TYPE_NAME (string) Data type name for use in CREATE TABLE statements etc. =item DATA_TYPE (integer) SQL data type number. =item COLUMN_SIZE (integer) For numeric types, this is either the total number of digits (if the NUM_PREC_RADIX value is 10) or the total number of bits allowed in the column (if NUM_PREC_RADIX is 2). For string types, this is the maximum size of the string in characters. For date and interval types, this is the maximum number of characters needed to display the value. =item LITERAL_PREFIX (string) Characters used to prefix a literal. A typical prefix is "C<'>" for characters, or possibly "C<0x>" for binary values passed as hexadecimal. NULL (C) is returned for data types for which this is not applicable. =item LITERAL_SUFFIX (string) Characters used to suffix a literal. Typically "C<'>" for characters. NULL (C) is returned for data types where this is not applicable. =item CREATE_PARAMS (string) Parameter names for data type definition. For example, C for a C would be "C" if the DECIMAL type should be declared as CIC<)> where I and I are integer values. For a C it would be "C". NULL (C) is returned for data types for which this is not applicable. =item NULLABLE (integer) Indicates whether the data type accepts a NULL value: C<0> or an empty string = no, C<1> = yes, C<2> = unknown. =item CASE_SENSITIVE (boolean) Indicates whether the data type is case sensitive in collations and comparisons. =item SEARCHABLE (integer) Indicates how the data type can be used in a WHERE clause, as follows: 0 - Cannot be used in a WHERE clause 1 - Only with a LIKE predicate 2 - All comparison operators except LIKE 3 - Can be used in a WHERE clause with any comparison operator =item UNSIGNED_ATTRIBUTE (boolean) Indicates whether the data type is unsigned. NULL (C) is returned for data types for which this is not applicable. =item FIXED_PREC_SCALE (boolean) Indicates whether the data type always has the same precision and scale (such as a money type). NULL (C) is returned for data types for which this is not applicable. =item AUTO_UNIQUE_VALUE (boolean) Indicates whether a column of this data type is automatically set to a unique value whenever a new row is inserted. NULL (C) is returned for data types for which this is not applicable. =item LOCAL_TYPE_NAME (string) Localized version of the C for use in dialog with users. NULL (C) is returned if a localized name is not available (in which case C should be used). =item MINIMUM_SCALE (integer) The minimum scale of the data type. If a data type has a fixed scale, then C holds the same value. NULL (C) is returned for data types for which this is not applicable. =item MAXIMUM_SCALE (integer) The maximum scale of the data type. If a data type has a fixed scale, then C holds the same value. NULL (C) is returned for data types for which this is not applicable. =item SQL_DATA_TYPE (integer) This column is the same as the C column, except for interval and datetime data types. For interval and datetime data types, the C field will return C or C, and the C field below will return the subcode for the specific interval or datetime data type. If this field is NULL, then the driver does not support or report on interval or datetime subtypes. =item SQL_DATETIME_SUB (integer) For interval or datetime data types, where the C field above is C or C, this field will hold the I for the specific interval or datetime data type. Otherwise it will be NULL (C). Although not mentioned explicitly in the standards, it seems there is a simple relationship between these values: DATA_TYPE == (10 * SQL_DATA_TYPE) + SQL_DATETIME_SUB =item NUM_PREC_RADIX (integer) The radix value of the data type. For approximate numeric types, C contains the value 2 and C holds the number of bits. For exact numeric types, C contains the value 10 and C holds the number of decimal digits. NULL (C) is returned either for data types for which this is not applicable or if the driver cannot report this information. =item INTERVAL_PRECISION (integer) The interval leading precision for interval types. NULL is returned either for data types for which this is not applicable or if the driver cannot report this information. =back For example, to find the type name for the fields in a select statement you can do: @names = map { scalar $dbh->type_info($_)->{TYPE_NAME} } @{ $sth->{TYPE} } Since DBI and ODBC drivers vary in how they map their types into the ISO standard types you may need to search for more than one type. Here's an example looking for a usable type to store a date: $my_date_type = $dbh->type_info( [ SQL_DATE, SQL_TIMESTAMP ] ); Similarly, to more reliably find a type to store small integers, you could use a list starting with C, C, C, etc. See also L. =head3 C $sql = $dbh->quote($value); $sql = $dbh->quote($value, $data_type); Quote a string literal for use as a literal value in an SQL statement, by escaping any special characters (such as quotation marks) contained within the string and adding the required type of outer quotation marks. $sql = sprintf "SELECT foo FROM bar WHERE baz = %s", $dbh->quote("Don't"); For most database types, at least those that conform to SQL standards, quote would return C<'Don''t'> (including the outer quotation marks). For others it may return something like C<'Don\'t'> An undefined C<$value> value will be returned as the string C (without single quotation marks) to match how NULLs are represented in SQL. If C<$data_type> is supplied, it is used to try to determine the required quoting behaviour by using the information returned by L. As a special case, the standard numeric types are optimized to return C<$value> without calling C. Quote will probably I be able to deal with all possible input (such as binary data or data containing newlines), and is not related in any way with escaping or quoting shell meta-characters. It is valid for the quote() method to return an SQL expression that evaluates to the desired string. For example: $quoted = $dbh->quote("one\ntwo\0three") may return something like: CONCAT('one', CHAR(12), 'two', CHAR(0), 'three') The quote() method should I be used with L. =head3 C $sql = $dbh->quote_identifier( $name ); $sql = $dbh->quote_identifier( $catalog, $schema, $table, \%attr ); Quote an identifier (table name etc.) for use in an SQL statement, by escaping any special characters (such as double quotation marks) it contains and adding the required type of outer quotation marks. Undefined names are ignored and the remainder are quoted and then joined together, typically with a dot (C<.>) character. For example: $id = $dbh->quote_identifier( undef, 'Her schema', 'My table' ); would, for most database types, return C<"Her schema"."My table"> (including all the double quotation marks). If three names are supplied then the first is assumed to be a catalog name and special rules may be applied based on what L returns for SQL_CATALOG_NAME_SEPARATOR (41) and SQL_CATALOG_LOCATION (114). For example, for Oracle: $id = $dbh->quote_identifier( 'link', 'schema', 'table' ); would return C<"schema"."table"@"link">. =head3 C $imp_data = $dbh->take_imp_data; Leaves the $dbh in an almost dead, zombie-like, state and returns a binary string of raw implementation data from the driver which describes the current database connection. Effectively it detaches the underlying database API connection data from the DBI handle. After calling take_imp_data(), all other methods except C will generate a warning and return undef. Why would you want to do this? You don't, forget I even mentioned it. Unless, that is, you're implementing something advanced like a multi-threaded connection pool. See L. The returned $imp_data can be passed as a C attribute to a later connect() call, even in a separate thread in the same process, where the driver can use it to 'adopt' the existing connection that the implementation data was taken from. Some things to keep in mind... B<*> the $imp_data holds the only reference to the underlying database API connection data. That connection is still 'live' and won't be cleaned up properly unless the $imp_data is used to create a new $dbh which is then allowed to disconnect() normally. B<*> using the same $imp_data to create more than one other new $dbh at a time may well lead to unpleasant problems. Don't do that. Any child statement handles are effectively destroyed when take_imp_data() is called. The C method was added in DBI 1.36 but wasn't useful till 1.49. =head2 Database Handle Attributes This section describes attributes specific to database handles. Changes to these database handle attributes do not affect any other existing or future database handles. Attempting to set or get the value of an unknown attribute generates a warning, except for private driver-specific attributes (which all have names starting with a lowercase letter). Example: $h->{AutoCommit} = ...; # set/write ... = $h->{AutoCommit}; # get/read =head3 C Type: boolean If true, then database changes cannot be rolled-back (undone). If false, then database changes automatically occur within a "transaction", which must either be committed or rolled back using the C or C methods. Drivers should always default to C mode (an unfortunate choice largely forced on the DBI by ODBC and JDBC conventions.) Attempting to set C to an unsupported value is a fatal error. This is an important feature of the DBI. Applications that need full transaction behaviour can set C<$dbh-E{AutoCommit} = 0> (or set C to 0 via L) without having to check that the value was assigned successfully. For the purposes of this description, we can divide databases into three categories: Databases which don't support transactions at all. Databases in which a transaction is always active. Databases in which a transaction must be explicitly started (C<'BEGIN WORK'>). B<* Databases which don't support transactions at all> For these databases, attempting to turn C off is a fatal error. C and C both issue warnings about being ineffective while C is in effect. B<* Databases in which a transaction is always active> These are typically mainstream commercial relational databases with "ANSI standard" transaction behaviour. If C is off, then changes to the database won't have any lasting effect unless L is called (but see also L). If L is called then any changes since the last commit are undone. If C is on, then the effect is the same as if the DBI called C automatically after every successful database operation. So calling C or C explicitly while C is on would be ineffective because the changes would have already been committed. Changing C from off to on will trigger a L. For databases which don't support a specific auto-commit mode, the driver has to commit each statement automatically using an explicit C after it completes successfully (and roll it back using an explicit C if it fails). The error information reported to the application will correspond to the statement which was executed, unless it succeeded and the commit or rollback failed. B<* Databases in which a transaction must be explicitly started> For these databases, the intention is to have them act like databases in which a transaction is always active (as described above). To do this, the driver will automatically begin an explicit transaction when C is turned off, or after a L or L (or when the application issues the next database operation after one of those events). In this way, the application does not have to treat these databases as a special case. See L, L and L for other important notes about transactions. =head3 C Type: handle Holds the handle of the parent driver. The only recommended use for this is to find the name of the driver using: $dbh->{Driver}->{Name} =head3 C Type: string Holds the "name" of the database. Usually (and recommended to be) the same as the "C" string used to connect to the database, but with the leading "C" removed. =head3 C Type: string, read-only Returns the statement string passed to the most recent L or L method called in this database handle, even if that method failed. This is especially useful where C is enabled and the exception handler checks $@ and sees that a 'prepare' method call failed. =head3 C Type: integer A hint to the driver indicating the size of the local row cache that the application would like the driver to use for future C 1 - Disable the local row cache >1 - Cache this many rows <0 - Cache as many rows that will fit into this much memory for each C statement, C returns the number of rows affected, if known. If no rows were affected, then C returns "C<0E0>", which Perl will treat as 0 but will regard as true. Note that it is I an error for no rows to be affected by a statement. If the number of rows affected is not known, then C returns -1. For C statement by checking if C<$sth-E{NUM_OF_FIELDS}> is greater than zero after calling C. If any arguments are given, then C will effectively call L for each value before executing the statement. Values bound in this way are usually treated as C types unless the driver can determine the correct type (which is rare), or unless C (or C) has already been used to specify the type. Note that passing C an empty array is the same as passing no arguments at all, which will execute the statement with previously bound values. That's probably not what you want. If execute() is called on a statement handle that's still active ($sth->{Active} is true) then it should effectively call finish() to tidy up the previous execution results before starting this new execution. =head3 C $tuples = $sth->execute_array(\%attr) or die $sth->errstr; $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr; ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; Execute the prepared statement once for each parameter tuple (group of values) provided either in the @bind_values, or by prior calls to L, or via a reference passed in \%attr. When called in scalar context the execute_array() method returns the number of tuples executed, or C if an error occurred. Like execute(), a successful execute_array() always returns true regardless of the number of tuples executed, even if it's zero. If there were any errors the ArrayTupleStatus array can be used to discover which tuples failed and with what errors. When called in list context the execute_array() method returns two scalars; $tuples is the same as calling execute_array() in scalar context and $rows is the number of rows affected for each tuple, if available or -1 if the driver cannot determine this. NOTE, some drivers cannot determine the number of rows affected per tuple but can provide the number of rows affected for the batch. If you are doing an update operation the returned rows affected may not be what you expect if, for instance, one or more of the tuples affected the same row multiple times. Some drivers may not yet support list context, in which case $rows will be undef, or may not be able to provide the number of rows affected when performing this batch operation, in which case $rows will be -1. Bind values for the tuples to be executed may be supplied row-wise by an C attribute, or else column-wise in the C<@bind_values> argument, or else column-wise by prior calls to L. Where column-wise binding is used (via the C<@bind_values> argument or calls to bind_param_array()) the maximum number of elements in any one of the bound value arrays determines the number of tuples executed. Placeholders with fewer values in their parameter arrays are treated as if padded with undef (NULL) values. If a scalar value is bound, instead of an array reference, it is treated as a I length array with all elements having the same value. It does not influence the number of tuples executed, so if all bound arrays have zero elements then zero tuples will be executed. If I bound values are scalars then one tuple will be executed, making execute_array() act just like execute(). The C attribute can be used to specify a reference to a subroutine that will be called to provide the bind values for each tuple execution. The subroutine should return an reference to an array which contains the appropriate number of bind values, or return an undef if there is no more data to execute. As a convenience, the C attribute can also be used to specify a statement handle. In which case the fetchrow_arrayref() method will be called on the given statement handle in order to provide the bind values for each tuple execution. The values specified via bind_param_array() or the @bind_values parameter may be either scalars, or arrayrefs. If any C<@bind_values> are given, then C will effectively call L for each value before executing the statement. Values bound in this way are usually treated as C types unless the driver can determine the correct type (which is rare), or unless C, C, C, or C has already been used to specify the type. See L for details. The C attribute can be used to specify a reference to an array which will receive the execute status of each executed parameter tuple. Note the C attribute was mandatory until DBI 1.38. For tuples which are successfully executed, the element at the same ordinal position in the status array is the resulting rowcount (or -1 if unknown). If the execution of a tuple causes an error, then the corresponding status array element will be set to a reference to an array containing L, L and L set by the failed execution. If B tuple execution returns an error, C will return C. In that case, the application should inspect the status array to determine which parameter tuples failed. Some databases may not continue executing tuples beyond the first failure. In this case the status array will either hold fewer elements, or the elements beyond the failure will be undef. If all parameter tuples are successfully executed, C returns the number tuples executed. If no tuples were executed, then execute_array() returns "C<0E0>", just like execute() does, which Perl will treat as 0 but will regard as true. For example: $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name) VALUES (?, ?)"); my $tuples = $sth->execute_array( { ArrayTupleStatus => \my @tuple_status }, \@first_names, \@last_names, ); if ($tuples) { print "Successfully inserted $tuples records\n"; } else { for my $tuple (0..@last_names-1) { my $status = $tuple_status[$tuple]; $status = [0, "Skipped"] unless defined $status; next unless ref $status; printf "Failed to insert (%s, %s): %s\n", $first_names[$tuple], $last_names[$tuple], $status->[1]; } } Support for data returning statements such as SELECT is driver-specific and subject to change. At present, the default implementation provided by DBI only supports non-data returning statements. Transaction semantics when using array binding are driver and database specific. If C is on, the default DBI implementation will cause each parameter tuple to be individually committed (or rolled back in the event of an error). If C is off, the application is responsible for explicitly committing the entire set of bound parameter tuples. Note that different drivers and databases may have different behaviours when some parameter tuples cause failures. In some cases, the driver or database may automatically rollback the effect of all prior parameter tuples that succeeded in the transaction; other drivers or databases may retain the effect of prior successfully executed parameter tuples. Be sure to check your driver and database for its specific behaviour. Note that, in general, performance will usually be better with C turned off, and using explicit C after each C call. The C method was added in DBI 1.22, and ArrayTupleFetch was added in 1.36. =head3 C $tuples = $sth->execute_for_fetch($fetch_tuple_sub); $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub); ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); The execute_for_fetch() method is used to perform bulk operations and although it is most often used via the execute_array() method you can use it directly. The main difference between execute_array and execute_for_fetch is the former does column or row-wise binding and the latter uses row-wise binding. The fetch subroutine, referenced by $fetch_tuple_sub, is expected to return a reference to an array (known as a 'tuple') or undef. The execute_for_fetch() method calls $fetch_tuple_sub, without any parameters, until it returns a false value. Each tuple returned is used to provide bind values for an $sth->execute(@$tuple) call. In scalar context execute_for_fetch() returns C if there were any errors and the number of tuples executed otherwise. Like execute() and execute_array() a zero is returned as "0E0" so execute_for_fetch() is only false on error. If there were any errors the @tuple_status array can be used to discover which tuples failed and with what errors. When called in list context execute_for_fetch() returns two scalars; $tuples is the same as calling execute_for_fetch() in scalar context and $rows is the sum of the number of rows affected for each tuple, if available or -1 if the driver cannot determine this. If you are doing an update operation the returned rows affected may not be what you expect if, for instance, one or more of the tuples affected the same row multiple times. Some drivers may not yet support list context, in which case $rows will be undef, or may not be able to provide the number of rows affected when performing this batch operation, in which case $rows will be -1. If \@tuple_status is passed then the execute_for_fetch method uses it to return status information. The tuple_status array holds one element per tuple. If the corresponding execute() did not fail then the element holds the return value from execute(), which is typically a row count. If the execute() did fail then the element holds a reference to an array containing ($sth->err, $sth->errstr, $sth->state). If the driver detects an error that it knows means no further tuples can be executed then it may return, with an error status, even though $fetch_tuple_sub may still have more tuples to be executed. Although each tuple returned by $fetch_tuple_sub is effectively used to call $sth->execute(@$tuple_array_ref) the exact timing may vary. Drivers are free to accumulate sets of tuples to pass to the database server in bulk group operations for more efficient execution. However, the $fetch_tuple_sub is specifically allowed to return the same array reference each time (which is what fetchrow_arrayref() usually does). For example: my $sel = $dbh1->prepare("select foo, bar from table1"); $sel->execute; my $ins = $dbh2->prepare("insert into table2 (foo, bar) values (?,?)"); my $fetch_tuple_sub = sub { $sel->fetchrow_arrayref }; my @tuple_status; $rc = $ins->execute_for_fetch($fetch_tuple_sub, \@tuple_status); my @errors = grep { ref $_ } @tuple_status; Similarly, if you already have an array containing the data rows to be processed you'd use a subroutine to shift off and return each array ref in turn: $ins->execute_for_fetch( sub { shift @array_of_arrays }, \@tuple_status); The C method was added in DBI 1.38. =head3 C $ary_ref = $sth->fetchrow_arrayref; $ary_ref = $sth->fetch; # alias Fetches the next row of data and returns a reference to an array holding the field values. Null fields are returned as C values in the array. This is the fastest way to fetch data, particularly if used with C<$sth-Ebind_columns>. If there are no more rows or if an error occurs, then C returns an C. You should check C<$sth-Eerr> afterwards (or use the C attribute) to discover if the C returned was due to an error. Note that the same array reference is returned for each fetch, so don't store the reference and then use it after a later fetch. Also, the elements of the array are also reused for each row, so take care if you want to take a reference to an element. See also L. =head3 C @ary = $sth->fetchrow_array; An alternative to C. Fetches the next row of data and returns it as a list containing the field values. Null fields are returned as C values in the list. If there are no more rows or if an error occurs, then C returns an empty list. You should check C<$sth-Eerr> afterwards (or use the C attribute) to discover if the empty list returned was due to an error. If called in a scalar context for a statement handle that has more than one column, it is undefined whether the driver will return the value of the first column or the last. So don't do that. Also, in a scalar context, an C is returned if there are no more rows or if an error occurred. That C can't be distinguished from an C returned because the first field value was NULL. For these reasons you should exercise some caution if you use C in a scalar context. =head3 C $hash_ref = $sth->fetchrow_hashref; $hash_ref = $sth->fetchrow_hashref($name); An alternative to C. Fetches the next row of data and returns it as a reference to a hash containing field name and field value pairs. Null fields are returned as C values in the hash. If there are no more rows or if an error occurs, then C returns an C. You should check C<$sth-Eerr> afterwards (or use the C attribute) to discover if the C returned was due to an error. The optional C<$name> parameter specifies the name of the statement handle attribute. For historical reasons it defaults to "C", however using either "C" or "C" is recommended for portability. The keys of the hash are the same names returned by C<$sth-E{$name}>. If more than one field has the same name, there will only be one entry in the returned hash for those fields, so statements like "C" or "C statement, the driver will automatically call C for you. So you should I call it explicitly I when you know that you've not fetched all the data from a statement handle I the handle won't be destroyed soon. The most common example is when you only want to fetch just one row, but in that case the C methods are usually better anyway. Consider a query like: SELECT foo FROM table WHERE bar=? ORDER BY baz on a very large table. When executed, the database server will have to use temporary buffer space to store the sorted rows. If, after executing the handle and selecting just a few rows, the handle won't be re-executed for some time and won't be destroyed, the C method can be used to tell the server that the buffer space can be freed. Calling C resets the L attribute for the statement. It may also make some statement handle attributes (such as C and C) unavailable if they have not already been accessed (and thus cached). The C method does not affect the transaction status of the database connection. It has nothing to do with transactions. It's mostly an internal "housekeeping" method that is rarely needed. See also L and the L attribute. The C method should have been called C. =head3 C $rv = $sth->rows; Returns the number of rows affected by the last row affecting command, or -1 if the number of rows is not known or not available. Generally, you can only rely on a row count after a I-C statement. For C statements is not recommended. One alternative method to get a row count for a C statement. Column numbers count up from 1. You do not need to bind output columns in order to fetch data. For maximum portability between drivers, bind_col() should be called after execute() and not before. See also L for an example. The binding is performed at a low level using Perl aliasing. Whenever a row is fetched from the database $var_to_bind appears to be automatically updated simply because it now refers to the same memory location as the corresponding column value. This makes using bound variables very efficient. Binding a tied variable doesn't work, currently. The L method performs a similar, but opposite, function for input variables. B The C<\%attr> parameter can be used to hint at the data type formatting the column should have. For example, you can use: $sth->bind_col(1, undef, { TYPE => SQL_DATETIME }); to specify that you'd like the column (which presumably is some kind of datetime type) to be returned in the standard format for SQL_DATETIME, which is 'YYYY-MM-DD HH:MM:SS', rather than the native formatting the database would normally use. There's no $var_to_bind in that example to emphasize the point that bind_col() works on the underlying column and not just a particular bound variable. As a short-cut for the common case, the data type can be passed directly, in place of the C<\%attr> hash reference. This example is equivalent to the one above: $sth->bind_col(1, undef, SQL_DATETIME); The C value indicates the standard (non-driver-specific) type for this parameter. To specify the driver-specific type, the driver may support a driver-specific attribute, such as C<{ ora_type =E 97 }>. The SQL_DATETIME and other related constants can be imported using use DBI qw(:sql_types); See L for more information. Few drivers support specifying a data type via a C call (most will simply ignore the data type). Fewer still allow the data type to be altered once set. If you do set a column type the type should remain sticky through further calls to bind_col for the same column if the type is not overridden (this is important for instance when you are using a slice in fetchall_arrayref). The TYPE attribute for bind_col() was first specified in DBI 1.41. From DBI 1.611, drivers can use the C attribute to attempt to cast the bound scalar to a perl type which more closely matches C. At present DBI supports C, C and C. See L for details of how types are cast. B The C<\%attr> parameter may also contain the following attributes: =over =item C If a C attribute is passed to bind_col, then the driver will attempt to change the bound perl scalar to match the type more closely. If the bound value cannot be cast to the requested C then by default it is left untouched and no error is generated. If you specify C as 1 and the cast fails, this will generate an error. This attribute was first added in DBI 1.611. When 1.611 was released few drivers actually supported this attribute but DBD::Oracle and DBD::ODBC should from versions 1.24. =item C When the C attribute is passed to L and the driver successfully casts the bound perl scalar to a non-string type then if C is set to 1, the string portion of the scalar will be discarded. By default, C is not set. This attribute was first added in DBI 1.611. When 1.611 was released few drivers actually supported this attribute but DBD::Oracle and DBD::ODBC should from versions 1.24. =back =head3 C $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); Calls L for each column of the C statement. If it doesn't then C will bind the elements given, up to the number of columns, and then return an error. For maximum portability between drivers, bind_columns() should be called after execute() and not before. For example: $dbh->{RaiseError} = 1; # do this, or check every call for errors $sth = $dbh->prepare(q{ SELECT region, sales FROM sales_by_region }); $sth->execute; my ($region, $sales); # Bind Perl variables to columns: $rv = $sth->bind_columns(\$region, \$sales); # you can also use Perl's \(...) syntax (see perlref docs): # $sth->bind_columns(\($region, $sales)); # Column binding is the most efficient way to fetch data while ($sth->fetch) { print "$region: $sales\n"; } For compatibility with old scripts, the first parameter will be ignored if it is C or a hash reference. Here's a more fancy example that binds columns to the values I a hash (thanks to H.Merijn Brand): $sth->execute; my %row; $sth->bind_columns( \( @row{ @{$sth->{NAME_lc} } } )); while ($sth->fetch) { print "$row{region}: $row{sales}\n"; } =head3 C $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); Fetches all the rows from C<$sth>, calls C for each row, and prints the results to C<$fh> (defaults to C) separated by C<$lsep> (default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35. This method is designed as a handy utility for prototyping and testing queries. Since it uses L to format and edit the string for reading by humans, it is not recommended for data transfer applications. =head2 Statement Handle Attributes This section describes attributes specific to statement handles. Most of these attributes are read-only. Changes to these statement handle attributes do not affect any other existing or future statement handles. Attempting to set or get the value of an unknown attribute generates a warning, except for private driver specific attributes (which all have names starting with a lowercase letter). Example: ... = $h->{NUM_OF_FIELDS}; # get/read Some drivers cannot provide valid values for some or all of these attributes until after C<$sth-Eexecute> has been successfully called. Typically the attribute will be C in these situations. Some attributes, like NAME, are not appropriate to some types of statement, like SELECT. Typically the attribute will be C in these situations. For drivers which support stored procedures and multiple result sets (see L) these attributes relate to the I result set. See also L to learn more about the effect it may have on some attributes. =head3 C Type: integer, read-only Number of fields (columns) in the data the prepared statement may return. Statements that don't return rows of data, like C and C set C to 0 (though it may be undef in some drivers). =head3 C Type: integer, read-only The number of parameters (placeholders) in the prepared statement. See SUBSTITUTION VARIABLES below for more details. =head3 C Type: array-ref, read-only Returns a reference to an array of field names for each column. The names may contain spaces but should not be truncated or have any trailing space. Note that the names have the letter case (upper, lower or mixed) as returned by the driver being used. Portable applications should use L or L. print "First column name: $sth->{NAME}->[0]\n"; Also note that the name returned for (aggregate) functions like C or C is determined by the database server and not by C or the C backend. =head3 C Type: array-ref, read-only Like C but always returns lowercase names. =head3 C Type: array-ref, read-only Like C but always returns uppercase names. =head3 C Type: hash-ref, read-only =head3 C Type: hash-ref, read-only =head3 C Type: hash-ref, read-only The C, C, and C attributes return column name information as a reference to a hash. The keys of the hash are the names of the columns. The letter case of the keys corresponds to the letter case returned by the C, C, and C attributes respectively (as described above). The value of each hash entry is the perl index number of the corresponding column (counting from 0). For example: $sth = $dbh->prepare("select Id, Name from table"); $sth->execute; @row = $sth->fetchrow_array; print "Name $row[ $sth->{NAME_lc_hash}{name} ]\n"; =head3 C Type: array-ref, read-only Returns a reference to an array of integer values for each column. The value indicates the data type of the corresponding column. The values correspond to the international standards (ANSI X3.135 and ISO/IEC 9075) which, in general terms, means ODBC. Driver-specific types that don't exactly match standard types should generally return the same values as an ODBC driver supplied by the makers of the database. That might include private type numbers in ranges the vendor has officially registered with the ISO working group: ftp://sqlstandards.org/SC32/SQL_Registry/ Where there's no vendor-supplied ODBC driver to be compatible with, the DBI driver can use type numbers in the range that is now officially reserved for use by the DBI: -9999 to -9000. All possible values for C should have at least one entry in the output of the C method (see L). =head3 C Type: array-ref, read-only Returns a reference to an array of integer values for each column. For numeric columns, the value is the maximum number of digits (without considering a sign character or decimal point). Note that the "display size" for floating point types (REAL, FLOAT, DOUBLE) can be up to 7 characters greater than the precision (for the sign + decimal point + the letter E + a sign + 2 or 3 digits). For any character type column the value is the OCTET_LENGTH, in other words the number of bytes, not characters. (More recent standards refer to this as COLUMN_SIZE but we stick with PRECISION for backwards compatibility.) =head3 C Type: array-ref, read-only Returns a reference to an array of integer values for each column. NULL (C) values indicate columns where scale is not applicable. =head3 C Type: array-ref, read-only Returns a reference to an array indicating the possibility of each column returning a null. Possible values are C<0> (or an empty string) = no, C<1> = yes, C<2> = unknown. print "First column may return NULL\n" if $sth->{NULLABLE}->[0]; =head3 C Type: string, read-only Returns the name of the cursor associated with the statement handle, if available. If not available or if the database driver does not support the C<"where current of ..."> SQL syntax, then it returns C. =head3 C Type: dbh, read-only Returns the parent $dbh of the statement handle. =head3 C Type: string, read-only Returns the statement string passed to the L method. =head3 C Type: hash ref, read-only Returns a reference to a hash containing the values currently bound to placeholders. The keys of the hash are the 'names' of the placeholders, typically integers starting at 1. Returns undef if not supported by the driver. See L for an example of how this is used. * Keys: If the driver supports C but no values have been bound yet then the driver should return a hash with placeholders names in the keys but all the values undef, but some drivers may return a ref to an empty hash because they can't pre-determine the names. It is possible that the keys in the hash returned by C are not exactly the same as those implied by the prepared statement. For example, DBD::Oracle translates 'C' placeholders into 'C<:pN>' where N is a sequence number starting at 1. * Values: It is possible that the values in the hash returned by C are not I the same as those passed to bind_param() or execute(). The driver may have slightly modified values in some way based on the TYPE the value was bound with. For example a floating point value bound as an SQL_INTEGER type may be returned as an integer. The values returned by C can be passed to another bind_param() method with the same TYPE and will be seen by the database as the same value. See also L below. The C attribute was added in DBI 1.28. =head3 C Type: hash ref, read-only Returns a reference to a hash containing the type information currently bound to placeholders. Returns undef if not supported by the driver. * Keys: See L above. * Values: The hash values are hashrefs of type information in the same form as that passed to the various bind_param() methods (See L for the format and values). It is possible that the values in the hash returned by C are not exactly the same as those passed to bind_param() or execute(). Param attributes specified using the abbreviated form, like this: $sth->bind_param(1, SQL_INTEGER); are returned in the expanded form, as if called like this: $sth->bind_param(1, { TYPE => SQL_INTEGER }); The driver may have modified the type information in some way based on the bound values, other hints provided by the prepare()'d SQL statement, or alternate type mappings required by the driver or target database system. The driver may also add private keys (with names beginning with the drivers reserved prefix, e.g., odbc_xxx). * Example: The keys and values in the returned hash can be passed to the various bind_param() methods to effectively reproduce a previous param binding. For example: # assuming $sth1 is a previously prepared statement handle my $sth2 = $dbh->prepare( $sth1->{Statement} ); my $ParamValues = $sth1->{ParamValues} || {}; my $ParamTypes = $sth1->{ParamTypes} || {}; $sth2->bind_param($_, $ParamValues->{$_}, $ParamTypes->{$_}) for keys %{ {%$ParamValues, %$ParamTypes} }; $sth2->execute(); The C attribute was added in DBI 1.49. Implementation is the responsibility of individual drivers; the DBI layer default implementation simply returns undef. =head3 C Type: hash ref, read-only Returns a reference to a hash containing the values currently bound to placeholders with L or L. The keys of the hash are the 'names' of the placeholders, typically integers starting at 1. Returns undef if not supported by the driver or no arrays of parameters are bound. Each key value is an array reference containing a list of the bound parameters for that column. For example: $sth = $dbh->prepare("INSERT INTO staff (id, name) values (?,?)"); $sth->execute_array({},[1,2], ['fred','dave']); if ($sth->{ParamArrays}) { foreach $param (keys %{$sth->{ParamArrays}}) { printf "Parameters for %s : %s\n", $param, join(",", @{$sth->{ParamArrays}->{$param}}); } } It is possible that the values in the hash returned by C are not I the same as those passed to L or L. The driver may have slightly modified values in some way based on the TYPE the value was bound with. For example a floating point value bound as an SQL_INTEGER type may be returned as an integer. It is also possible that the keys in the hash returned by C are not exactly the same as those implied by the prepared statement. For example, DBD::Oracle translates 'C' placeholders into 'C<:pN>' where N is a sequence number starting at 1. =head3 C Type: integer, read-only If the driver supports a local row cache for C statement handle that's a child of the same database handle. A typical way round this is to connect the the database twice and use one connection for C statement (unlike other data types), some special handling is required. In this situation, the value of the C<$h-E{LongReadLen}> attribute is used to determine how much buffer space to allocate when fetching such fields. The C<$h-E{LongTruncOk}> attribute is used to determine how to behave if a fetched value can't fit into the buffer. See the description of L for more information. When trying to insert long or binary values, placeholders should be used since there are often limits on the maximum size of an C statement and the L method generally can't cope with binary data. See L. =head2 Simple Examples Here's a complete example program to select and fetch some data: my $data_source = "dbi::DriverName:db_name"; my $dbh = DBI->connect($data_source, $user, $password) or die "Can't connect to $data_source: $DBI::errstr"; my $sth = $dbh->prepare( q{ SELECT name, phone FROM mytelbook }) or die "Can't prepare statement: $DBI::errstr"; my $rc = $sth->execute or die "Can't execute statement: $DBI::errstr"; print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n"; print "Field names: @{ $sth->{NAME} }\n"; while (($name, $phone) = $sth->fetchrow_array) { print "$name: $phone\n"; } # check for problems which may have terminated the fetch early die $sth->errstr if $sth->err; $dbh->disconnect; Here's a complete example program to insert some data from a file. (This example uses C to avoid needing to check each call). my $dbh = DBI->connect("dbi:DriverName:db_name", $user, $password, { RaiseError => 1, AutoCommit => 0 }); my $sth = $dbh->prepare( q{ INSERT INTO table (name, phone) VALUES (?, ?) }); open FH, ") { chomp; my ($name, $phone) = split /,/; $sth->execute($name, $phone); } close FH; $dbh->commit; $dbh->disconnect; Here's how to convert fetched NULLs (undefined values) into empty strings: while($row = $sth->fetchrow_arrayref) { # this is a fast and simple way to deal with nulls: foreach (@$row) { $_ = '' unless defined } print "@$row\n"; } The C style quoting used in these examples avoids clashing with quotes that may be used in the SQL statement. Use the double-quote like C operator if you want to interpolate variables into the string. See L for more details. =head2 Threads and Thread Safety Perl 5.7 and later support a new threading model called iThreads. (The old "5.005 style" threads are not supported by the DBI.) In the iThreads model each thread has its own copy of the perl interpreter. When a new thread is created the original perl interpreter is 'cloned' to create a new copy for the new thread. If the DBI and drivers are loaded and handles created before the thread is created then it will get a cloned copy of the DBI, the drivers and the handles. However, the internal pointer data within the handles will refer to the DBI and drivers in the original interpreter. Using those handles in the new interpreter thread is not safe, so the DBI detects this and croaks on any method call using handles that don't belong to the current thread (except for DESTROY). Because of this (possibly temporary) restriction, newly created threads must make their own connections to the database. Handles can't be shared across threads. But BEWARE, some underlying database APIs (the code the DBD driver uses to talk to the database, often supplied by the database vendor) are not thread safe. If it's not thread safe, then allowing more than one thread to enter the code at the same time may cause subtle/serious problems. In some cases allowing more than one thread to enter the code, even if I at the same time, can cause problems. You have been warned. Using DBI with perl threads is not yet recommended for production environments. For more information see L Note: There is a bug in perl 5.8.2 when configured with threads and debugging enabled (bug #24463) which causes a DBI test to fail. =head2 Signal Handling and Canceling Operations [The following only applies to systems with unix-like signal handling. I'd welcome additions for other systems, especially Windows.] The first thing to say is that signal handling in Perl versions less than 5.8 is I safe. There is always a small risk of Perl crashing and/or core dumping when, or after, handling a signal because the signal could arrive and be handled while internal data structures are being changed. If the signal handling code used those same internal data structures it could cause all manner of subtle and not-so-subtle problems. The risk was reduced with 5.4.4 but was still present in all perls up through 5.8.0. Beginning in perl 5.8.0 perl implements 'safe' signal handling if your system has the POSIX sigaction() routine. Now when a signal is delivered perl just makes a note of it but does I run the %SIG handler. The handling is 'deferred' until a 'safe' moment. Although this change made signal handling safe, it also lead to a problem with signals being deferred for longer than you'd like. If a signal arrived while executing a system call, such as waiting for data on a network connection, the signal is noted and then the system call that was executing returns with an EINTR error code to indicate that it was interrupted. All fine so far. The problem comes when the code that made the system call sees the EINTR code and decides it's going to call it again. Perl doesn't do that, but database code sometimes does. If that happens then the signal handler doesn't get called until later. Maybe much later. Fortunately there are ways around this which we'll discuss below. Unfortunately they make signals unsafe again. The two most common uses of signals in relation to the DBI are for canceling operations when the user types Ctrl-C (interrupt), and for implementing a timeout using C and C<$SIG{ALRM}>. =over 4 =item Cancel The DBI provides a C method for statement handles. The C method should abort the current operation and is designed to be called from a signal handler. For example: $SIG{INT} = sub { $sth->cancel }; However, few drivers implement this (the DBI provides a default method that just returns C) and, even if implemented, there is still a possibility that the statement handle, and even the parent database handle, will not be usable afterwards. If C returns true, then it has successfully invoked the database engine's own cancel function. If it returns false, then C failed. If it returns C, then the database driver does not have cancel implemented - very few do. =item Timeout The traditional way to implement a timeout is to set C<$SIG{ALRM}> to refer to some code that will be executed when an ALRM signal arrives and then to call alarm($seconds) to schedule an ALRM signal to be delivered $seconds in the future. For example: eval { local $SIG{ALRM} = sub { die "TIMEOUT\n" }; # N.B. \n required eval { alarm($seconds); ... code to execute with timeout here (which may die) ... }; # outer eval catches alarm that might fire JUST before this alarm(0) alarm(0); # cancel alarm (if code ran fast) die "$@" if $@; }; if ( $@ eq "TIMEOUT\n" ) { ... } elsif ($@) { ... } # some other error The first (outer) eval is used to avoid the unlikely but possible chance that the "code to execute" dies and the alarm fires before it is cancelled. Without the outer eval, if this happened your program will die if you have no ALRM handler or a non-local alarm handler will be called. Unfortunately, as described above, this won't always work as expected, depending on your perl version and the underlying database code. With Oracle for instance (DBD::Oracle), if the system which hosts the database is down the DBI->connect() call will hang for several minutes before returning an error. =back The solution on these systems is to use the C routine to gain low level access to how the signal handler is installed. The code would look something like this (for the DBD-Oracle connect()): use POSIX qw(:signal_h); my $mask = POSIX::SigSet->new( SIGALRM ); # signals to mask in the handler my $action = POSIX::SigAction->new( sub { die "connect timeout\n" }, # the handler code ref $mask, # not using (perl 5.8.2 and later) 'safe' switch or sa_flags ); my $oldaction = POSIX::SigAction->new(); sigaction( SIGALRM, $action, $oldaction ); my $dbh; eval { eval { alarm(5); # seconds before time out $dbh = DBI->connect("dbi:Oracle:$dsn" ... ); }; alarm(0); # cancel alarm (if connect worked fast) die "$@\n" if $@; # connect died }; sigaction( SIGALRM, $oldaction ); # restore original signal handler if ( $@ ) { if ($@ eq "connect timeout\n") {...} else { # connect died } } See previous example for the reasoning around the double eval. Similar techniques can be used for canceling statement execution. Unfortunately, this solution is somewhat messy, and it does I work with perl versions less than perl 5.8 where C appears to be broken. For a cleaner implementation that works across perl versions, see Lincoln Baxter's Sys::SigAction module at L. The documentation for Sys::SigAction includes an longer discussion of this problem, and a DBD::Oracle test script. Be sure to read all the signal handling sections of the L manual. And finally, two more points to keep firmly in mind. Firstly, remember that what we've done here is essentially revert to old style I handling of these signals. So do as little as possible in the handler. Ideally just die(). Secondly, the handles in use at the time the signal is handled may not be safe to use afterwards. =head2 Subclassing the DBI DBI can be subclassed and extended just like any other object oriented module. Before we talk about how to do that, it's important to be clear about the various DBI classes and how they work together. By default C<$dbh = DBI-Econnect(...)> returns a $dbh blessed into the C class. And the C<$dbh-Eprepare> method returns an $sth blessed into the C class (actually it simply changes the last four characters of the calling handle class to be C<::st>). The leading 'C' is known as the 'root class' and the extra 'C<::db>' or 'C<::st>' are the 'handle type suffixes'. If you want to subclass the DBI you'll need to put your overriding methods into the appropriate classes. For example, if you want to use a root class of C and override the do(), prepare() and execute() methods, then your do() and prepare() methods should be in the C class and the execute() method should be in the C class. To setup the inheritance hierarchy the @ISA variable in C should include C and the @ISA variable in C should include C. The C root class itself isn't currently used for anything visible and so, apart from setting @ISA to include C, it can be left empty. So, having put your overriding methods into the right classes, and setup the inheritance hierarchy, how do you get the DBI to use them? You have two choices, either a static method call using the name of your subclass: $dbh = MySubDBI->connect(...); or specifying a C attribute: $dbh = DBI->connect(..., { RootClass => 'MySubDBI' }); If both forms are used then the attribute takes precedence. The only differences between the two are that using an explicit RootClass attribute will a) make the DBI automatically attempt to load a module by that name if the class doesn't exist, and b) won't call your MySubDBI::connect() method, if you have one. When subclassing is being used then, after a successful new connect, the DBI->connect method automatically calls: $dbh->connected($dsn, $user, $pass, \%attr); The default method does nothing. The call is made just to simplify any post-connection setup that your subclass may want to perform. The parameters are the same as passed to DBI->connect. If your subclass supplies a connected method, it should be part of the MySubDBI::db package. One more thing to note: you must let the DBI do the handle creation. If you want to override the connect() method in your *::dr class then it must still call SUPER::connect to get a $dbh to work with. Similarly, an overridden prepare() method in *::db must still call SUPER::prepare to get a $sth. If you try to create your own handles using bless() then you'll find the DBI will reject them with an "is not a DBI handle (has no magic)" error. Here's a brief example of a DBI subclass. A more thorough example can be found in F in the DBI distribution. package MySubDBI; use strict; use DBI; use vars qw(@ISA); @ISA = qw(DBI); package MySubDBI::db; use vars qw(@ISA); @ISA = qw(DBI::db); sub prepare { my ($dbh, @args) = @_; my $sth = $dbh->SUPER::prepare(@args) or return; $sth->{private_mysubdbi_info} = { foo => 'bar' }; return $sth; } package MySubDBI::st; use vars qw(@ISA); @ISA = qw(DBI::st); sub fetch { my ($sth, @args) = @_; my $row = $sth->SUPER::fetch(@args) or return; do_something_magical_with_row_data($row) or return $sth->set_err(1234, "The magic failed", undef, "fetch"); return $row; } When calling a SUPER::method that returns a handle, be careful to check the return value before trying to do other things with it in your overridden method. This is especially important if you want to set a hash attribute on the handle, as Perl's autovivification will bite you by (in)conveniently creating an unblessed hashref, which your method will then return with usually baffling results later on like the error "dbih_getcom handle HASH(0xa4451a8) is not a DBI handle (has no magic". It's best to check right after the call and return undef immediately on error, just like DBI would and just like the example above. If your method needs to record an error it should call the set_err() method with the error code and error string, as shown in the example above. The error code and error string will be recorded in the handle and available via C<$h-Eerr> and C<$DBI::errstr> etc. The set_err() method always returns an undef or empty list as appropriate. Since your method should nearly always return an undef or empty list as soon as an error is detected it's handy to simply return what set_err() returns, as shown in the example above. If the handle has C, C, or C etc. set then the set_err() method will honour them. This means that if C is set then set_err() won't return in the normal way but will 'throw an exception' that can be caught with an C block. You can stash private data into DBI handles via C<$h-E{private_..._*}>. See the entry under L for info and important caveats. =head2 Memory Leaks When tracking down memory leaks using tools like L you'll find that some DBI internals are reported as 'leaking' memory. This is very unlikely to be a real leak. The DBI has various caches to improve performance and the apparrent leaks are simply the normal operation of these caches. The most frequent sources of the apparrent leaks are L, L and L. For example http://stackoverflow.com/questions/13338308/perl-dbi-memory-leak Given how widely the DBI is used, you can rest assured that if a new release of the DBI did have a real leak it would be discovered, reported, and fixed immediately. The leak you're looking for is probably elsewhere. Good luck! =head1 TRACING The DBI has a powerful tracing mechanism built in. It enables you to see what's going on 'behind the scenes', both within the DBI and the drivers you're using. =head2 Trace Settings Which details are written to the trace output is controlled by a combination of a I, an integer from 0 to 15, and a set of I that are either on or off. Together these are known as the I and are stored together in a single integer. For normal use you only need to set the trace level, and generally only to a value between 1 and 4. Each handle has its own trace settings, and so does the DBI. When you call a method the DBI merges the handles settings into its own for the duration of the call: the trace flags of the handle are OR'd into the trace flags of the DBI, and if the handle has a higher trace level then the DBI trace level is raised to match it. The previous DBI trace settings are restored when the called method returns. =head2 Trace Levels Trace I are as follows: 0 - Trace disabled. 1 - Trace top-level DBI method calls returning with results or errors. 2 - As above, adding tracing of top-level method entry with parameters. 3 - As above, adding some high-level information from the driver and some internal information from the DBI. 4 - As above, adding more detailed information from the driver. This is the first level to trace all the rows being fetched. 5 to 15 - As above but with more and more internal information. Trace level 1 is best for a simple overview of what's happening. Trace levels 2 thru 4 a good choice for general purpose tracing. Levels 5 and above are best reserved for investigating a specific problem, when you need to see "inside" the driver and DBI. The trace output is detailed and typically very useful. Much of the trace output is formatted using the L function, so strings in the trace output may be edited and truncated by that function. =head2 Trace Flags Trace I are used to enable tracing of specific activities within the DBI and drivers. The DBI defines some trace flags and drivers can define others. DBI trace flag names begin with a capital letter and driver specific names begin with a lowercase letter, as usual. Currently the DBI defines these trace flags: ALL - turn on all DBI and driver flags (not recommended) SQL - trace SQL statements executed (not yet implemented in DBI but implemented in some DBDs) CON - trace connection process ENC - trace encoding (unicode translations etc) (not yet implemented in DBI but implemented in some DBDs) DBD - trace only DBD messages (not implemented by all DBDs yet) TXN - trace transactions (not implemented in all DBDs yet) The L and L methods are used to convert trace flag names into the corresponding integer bit flags. =head2 Enabling Trace The C<$h-Etrace> method sets the trace settings for a handle and Ctrace> does the same for the DBI. In addition to the L method, you can enable the same trace information, and direct the output to a file, by setting the C environment variable before starting Perl. See L for more information. Finally, you can set, or get, the trace settings for a handle using the C attribute. All of those methods use parse_trace_flags() and so allow you set both the trace level and multiple trace flags by using a string containing the trace level and/or flag names separated by vertical bar ("C<|>") or comma ("C<,>") characters. For example: local $h->{TraceLevel} = "3|SQL|foo"; =head2 Trace Output Initially trace output is written to C. Both the C<$h-Etrace> and Ctrace> methods take an optional $trace_file parameter, which may be either the name of a file to be opened by DBI in append mode, or a reference to an existing writable (possibly layered) filehandle. If $trace_file is a filename, and can be opened in append mode, or $trace_file is a writable filehandle, then I trace output (currently including that from other handles) is redirected to that file. A warning is generated if $trace_file can't be opened or is not writable. Further calls to trace() without $trace_file do not alter where the trace output is sent. If $trace_file is undefined, then trace output is sent to C and, if the prior trace was opened with $trace_file as a filename, the previous trace file is closed; if $trace_file was a filehandle, the filehandle is B closed. B: If $trace_file is specified as a filehandle, the filehandle should not be closed until all DBI operations are completed, or the application has reset the trace file via another call to C that changes the trace file. =head2 Tracing to Layered Filehandles B: =over 4 =item * Tied filehandles are not currently supported, as tie operations are not available to the PerlIO methods used by the DBI. =item * PerlIO layer support requires Perl version 5.8 or higher. =back As of version 5.8, Perl provides the ability to layer various "disciplines" on an open filehandle via the L module. A simple example of using PerlIO layers is to use a scalar as the output: my $scalar = ''; open( my $fh, "+>:scalar", \$scalar ); $dbh->trace( 2, $fh ); Now all trace output is simply appended to $scalar. A more complex application of tracing to a layered filehandle is the use of a custom layer (IL I). Consider an application with the following logger module: package MyFancyLogger; sub new { my $self = {}; my $fh; open $fh, '>', 'fancylog.log'; $self->{_fh} = $fh; $self->{_buf} = ''; return bless $self, shift; } sub log { my $self = shift; return unless exists $self->{_fh}; my $fh = $self->{_fh}; $self->{_buf} .= shift; # # DBI feeds us pieces at a time, so accumulate a complete line # before outputing # print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and $self->{_buf} = '' if $self->{_buf}=~tr/\n//; } sub close { my $self = shift; return unless exists $self->{_fh}; my $fh = $self->{_fh}; print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and $self->{_buf} = '' if $self->{_buf}; close $fh; delete $self->{_fh}; } 1; To redirect DBI traces to this logger requires creating a package for the layer: package PerlIO::via::MyFancyLogLayer; sub PUSHED { my ($class,$mode,$fh) = @_; my $logger; return bless \$logger,$class; } sub OPEN { my ($self, $path, $mode, $fh) = @_; # # $path is actually our logger object # $$self = $path; return 1; } sub WRITE { my ($self, $buf, $fh) = @_; $$self->log($buf); return length($buf); } sub CLOSE { my $self = shift; $$self->close(); return 0; } 1; The application can then cause DBI traces to be routed to the logger using use PerlIO::via::MyFancyLogLayer; open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new(); $dbh->trace('SQL', $fh); Now all trace output will be processed by MyFancyLogger's log() method. =head2 Trace Content Many of the values embedded in trace output are formatted using the neat() utility function. This means they may be quoted, sanitized, and possibly truncated if longer than C<$DBI::neat_maxlen>. See L for more details. =head2 Tracing Tips You can add tracing to your own application code using the L method. It can sometimes be handy to compare trace files from two different runs of the same script. However using a tool like C on the original log output doesn't work well because the trace file is full of object addresses that may differ on each run. The DBI includes a handy utility called dbilogstrip that can be used to 'normalize' the log content. It can be used as a filter like this: DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log diff -u dbitrace1.log dbitrace2.log See L for more information. =head1 DBI ENVIRONMENT VARIABLES The DBI module recognizes a number of environment variables, but most of them should not be used most of the time. It is better to be explicit about what you are doing to avoid the need for environment variables, especially in a web serving system where web servers are stingy about which environment variables are available. =head2 DBI_DSN The DBI_DSN environment variable is used by DBI->connect if you do not specify a data source when you issue the connect. It should have a format such as "dbi:Driver:databasename". =head2 DBI_DRIVER The DBI_DRIVER environment variable is used to fill in the database driver name in DBI->connect if the data source string starts "dbi::" (thereby omitting the driver). If DBI_DSN omits the driver name, DBI_DRIVER can fill the gap. =head2 DBI_AUTOPROXY The DBI_AUTOPROXY environment variable takes a string value that starts "dbi:Proxy:" and is typically followed by "hostname=...;port=...". It is used to alter the behaviour of DBI->connect. For full details, see DBI::Proxy documentation. =head2 DBI_USER The DBI_USER environment variable takes a string value that is used as the user name if the DBI->connect call is given undef (as distinct from an empty string) as the username argument. Be wary of the security implications of using this. =head2 DBI_PASS The DBI_PASS environment variable takes a string value that is used as the password if the DBI->connect call is given undef (as distinct from an empty string) as the password argument. Be extra wary of the security implications of using this. =head2 DBI_DBNAME (obsolete) The DBI_DBNAME environment variable takes a string value that is used only when the obsolescent style of DBI->connect (with driver name as fourth parameter) is used, and when no value is provided for the first (database name) argument. =head2 DBI_TRACE The DBI_TRACE environment variable specifies the global default trace settings for the DBI at startup. Can also be used to direct trace output to a file. When the DBI is loaded it does: DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; So if C contains an "C<=>" character then what follows it is used as the name of the file to append the trace to. output appended to that file. If the name begins with a number followed by an equal sign (C<=>), then the number and the equal sign are stripped off from the name, and the number is used to set the trace level. For example: DBI_TRACE=1=dbitrace.log perl your_test_script.pl On Unix-like systems using a Bourne-like shell, you can do this easily on the command line: DBI_TRACE=2 perl your_test_script.pl See L for more information. =head2 PERL_DBI_DEBUG (obsolete) An old variable that should no longer be used; equivalent to DBI_TRACE. =head2 DBI_PROFILE The DBI_PROFILE environment variable can be used to enable profiling of DBI method calls. See L for more information. =head2 DBI_PUREPERL The DBI_PUREPERL environment variable can be used to enable the use of DBI::PurePerl. See L for more information. =head1 WARNING AND ERROR MESSAGES =head2 Fatal Errors =over 4 =item Can't call method "prepare" without a package or object reference The C<$dbh> handle you're using to call C is probably undefined because the preceding C failed. You should always check the return status of DBI methods, or use the L attribute. =item Can't call method "execute" without a package or object reference The C<$sth> handle you're using to call C is probably undefined because the preceding C failed. You should always check the return status of DBI methods, or use the L attribute. =item DBI/DBD internal version mismatch The DBD driver module was built with a different version of DBI than the one currently being used. You should rebuild the DBD module under the current version of DBI. (Some rare platforms require "static linking". On those platforms, there may be an old DBI or DBD driver version actually embedded in the Perl executable being used.) =item DBD driver has not implemented the AutoCommit attribute The DBD driver implementation is incomplete. Consult the author. =item Can't [sg]et %s->{%s}: unrecognised attribute You attempted to set or get an unknown attribute of a handle. Make sure you have spelled the attribute name correctly; case is significant (e.g., "Autocommit" is not the same as "AutoCommit"). =back =head1 Pure-Perl DBI A pure-perl emulation of the DBI is included in the distribution for people using pure-perl drivers who, for whatever reason, can't install the compiled DBI. See L. =head1 SEE ALSO =head2 Driver and Database Documentation Refer to the documentation for the DBD driver that you are using. Refer to the SQL Language Reference Manual for the database engine that you are using. =head2 ODBC and SQL/CLI Standards Reference Information More detailed information about the semantics of certain DBI methods that are based on ODBC and SQL/CLI standards is available on-line via microsoft.com, for ODBC, and www.jtc1sc32.org for the SQL/CLI standard: DBI method ODBC function SQL/CLI Working Draft ---------- ------------- --------------------- column_info SQLColumns Page 124 foreign_key_info SQLForeignKeys Page 163 get_info SQLGetInfo Page 214 primary_key_info SQLPrimaryKeys Page 254 table_info SQLTables Page 294 type_info SQLGetTypeInfo Page 239 statistics_info SQLStatistics To find documentation on the ODBC function you can use the MSDN search facility at: http://msdn.microsoft.com/Search and search for something like C<"SQLColumns returns">. And for SQL/CLI standard information on SQLColumns you'd read page 124 of the (very large) SQL/CLI Working Draft available from: http://jtc1sc32.org/doc/N0701-0750/32N0744T.pdf =head2 Standards Reference Information A hyperlinked, browsable version of the BNF syntax for SQL92 (plus Oracle 7 SQL and PL/SQL) is available here: http://cui.unige.ch/db-research/Enseignement/analyseinfo/SQL92/BNFindex.html A BNF syntax for SQL3 is available here: http://www.sqlstandards.org/SC32/WG3/Progression_Documents/Informal_working_drafts/iso-9075-2-1999.bnf The following links provide further useful information about SQL. Some of these are rather dated now but may still be useful. http://www.jcc.com/SQLPages/jccs_sql.htm http://www.contrib.andrew.cmu.edu/~shadow/sql.html http://www.altavista.com/query?q=sql+tutorial =head2 Books and Articles Programming the Perl DBI, by Alligator Descartes and Tim Bunce. L Programming Perl 3rd Ed. by Larry Wall, Tom Christiansen & Jon Orwant. L Learning Perl by Randal Schwartz. L Details of many other books related to perl can be found at L =head2 Perl Modules Index of DBI related modules available from CPAN: https://metacpan.org/search?q=DBD%3A%3A https://metacpan.org/search?q=DBIx%3A%3A https://metacpan.org/search?q=DBI For a good comparison of RDBMS-OO mappers and some OO-RDBMS mappers (including Class::DBI, Alzabo, and DBIx::RecordSet in the former category and Tangram and SPOPS in the latter) see the Perl Object-Oriented Persistence project pages at: http://poop.sourceforge.net A similar page for Java toolkits can be found at: http://c2.com/cgi-bin/wiki?ObjectRelationalToolComparison =head2 Mailing List The I mailing list is the primary means of communication among users of the DBI and its related modules. For details send email to: dbi-users-help@perl.org There are typically between 700 and 900 messages per month. You have to subscribe in order to be able to post. However you can opt for a 'post-only' subscription. Mailing list archives (of variable quality) are held at: http://groups.google.com/groups?group=perl.dbi.users http://www.xray.mpe.mpg.de/mailing-lists/dbi/ http://www.mail-archive.com/dbi-users%40perl.org/ =head2 Assorted Related WWW Links The DBI "Home Page": http://dbi.perl.org/ Other DBI related links: http://tegan.deltanet.com/~phlip/DBUIdoc.html http://dc.pm.org/perl_db.html http://wdvl.com/Authoring/DB/Intro/toc.html http://www.hotwired.com/webmonkey/backend/tutorials/tutorial1.html http://bumppo.net/lists/macperl/1999/06/msg00197.html http://www.perlmonks.org/?node=DBI%20recipes http://www.perlmonks.org/?node=Speeding%20up%20the%20DBI Other database related links: http://www.jcc.com/sql_stnd.html http://cuiwww.unige.ch/OSG/info/FreeDB/FreeDB.home.html http://www.connectionstrings.com/ Security, especially the "SQL Injection" attack: http://www.ngssoftware.com/research/papers.html http://www.ngssoftware.com/papers/advanced_sql_injection.pdf http://www.ngssoftware.com/papers/more_advanced_sql_injection.pdf http://www.esecurityplanet.com/trends/article.php/2243461 http://www.spidynamics.com/papers/SQLInjectionWhitePaper.pdf http://www.imperva.com/application_defense_center/white_papers/blind_sql_server_injection.html http://online.securityfocus.com/infocus/1644 Commercial and Data Warehouse Links http://www.dwinfocenter.org http://www.datawarehouse.com http://www.datamining.org http://www.olapcouncil.org http://www.idwa.org http://www.knowledgecenters.org/dwcenter.asp Recommended Perl Programming Links http://language.perl.com/style/ =head2 FAQ See L =head1 AUTHORS DBI by Tim Bunce, L This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others. Perl by Larry Wall and the C. =head1 COPYRIGHT The DBI module is Copyright (c) 1994-2012 Tim Bunce. Ireland. All rights reserved. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl 5.10.0 README file. =head1 SUPPORT / WARRANTY The DBI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND. =head2 Support My consulting company, Data Plan Services, offers annual and multi-annual support contracts for the DBI. These provide sustained support for DBI development, and sustained value for you in return. Contact me for details. =head2 Sponsor Enhancements 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 the Paul Ingram Group in the UK. So I'd especially like to thank Paul for his generosity and vision in supporting this work for many years. A couple of specific DBI features have been sponsored by enlightened companies: The development of the swap_inner_handle() method was sponsored by BizRate.com (L) The development of DBD::Gofer and related modules was sponsored by Shopzilla.com (L), where I currently work. =head1 CONTRIBUTING As you can see above, many people have contributed to the DBI and drivers in many ways over many years. If you'd like to help then see L. 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 https://github.com/perl5-dbi/dbi =head2 How to create a patch using Git The DBI source code is maintained using Git. To access the source you'll need to install a Git client. Then, to get the source code, do: git clone https://github.com/perl5-dbi/dbi.git DBI-git The source code will now be available in the new subdirectory C. When you want to synchronize later, issue the command git pull --all Make your changes, test them, test them again until everything passes. If there are no tests for the new feature you added or a behaviour change, the change should include a new test. Then commit the changes. Either use git gui or git commit -a -m 'Message to my changes' If you get any conflicts reported you'll need to fix them first. Then generate the patch file to be mailed: git format-patch -1 --attach which will create a file 0001-*.patch (where * relates to the commit message). Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org. If you have a L account, you can also fork the repository, commit your changes to the forked repository and then do a pull request. =head2 How to create a patch without Git Unpack a fresh copy of the distribution: wget http://cpan.metacpan.org/authors/id/T/TI/TIMB/DBI-1.627.tar.gz tar xfz DBI-1.627.tar.gz Rename the newly created top level directory: mv DBI-1.627 DBI-1.627.your_foo Edit the contents of DBI-1.627.your_foo/* till it does what you want. Test your changes and then remove all temporary files: make test && make distclean Go back to the directory you originally unpacked the distribution: cd .. Unpack I copy of the original distribution you started with: tar xfz DBI-1.627.tar.gz Then create a patch file by performing a recursive C on the two top level directories: diff -purd DBI-1.627 DBI-1.627.your_foo > DBI-1.627.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. You can also reach the developers on IRC (chat). If they are on-line, the most likely place to talk to them is the #dbi channel on irc.perl.org =head1 TRANSLATIONS A German translation of this manual (possibly slightly out of date) is available, thanks to O'Reilly, at: http://www.oreilly.de/catalog/perldbiger/ Some other translations: http://cronopio.net/perl/ - Spanish http://member.nifty.ne.jp/hippo2000/dbimemo.htm - Japanese =head1 TRAINING References to DBI related training resources. No recommendation implied. http://www.treepax.co.uk/ http://www.keller.com/dbweb/ (If you offer professional DBI related training services, please send me your details so I can add them here.) =head1 OTHER RELATED WORK AND PERL MODULES =over 4 =item Apache::DBI by E.Mergl@bawue.de To be used with the Apache daemon together with an embedded Perl interpreter like C. Establishes a database connection which remains open for the lifetime of the HTTP daemon. This way the CGI connect and disconnect for every database access becomes superfluous. =item SQL Parser See also the L module, SQL parser and engine. =back =cut # LocalWords: DBI DBI-1.634/DBI.xs000644 000766 000024 00000617727 12552723565 013415 0ustar00timbostaff000000 000000 /* vim: ts=8:sw=4:expandtab * * $Id$ * * Copyright (c) 1994-2012 Tim Bunce Ireland. * * See COPYRIGHT section in DBI.pm for usage and distribution rights. */ #define NEED_grok_number #define NEED_grok_numeric_radix #define NEED_newRV_noinc #define NEED_sv_2pv_flags #define IN_DBI_XS 1 /* see DBIXS.h */ #define PERL_NO_GET_CONTEXT #include "DBIXS.h" /* DBI public interface for DBD's written in C */ # if (defined(_WIN32) && (! defined(HAS_GETTIMEOFDAY))) #include # endif /* The XS dispatcher code can optimize calls to XS driver methods, * bypassing the usual call_sv() and argument handling overheads. * Just-in-case it causes problems there's an (undocumented) way * to disable it by setting an env var. */ static int use_xsbypass = 1; /* set in dbi_bootinit() */ #ifndef CvISXSUB #define CvISXSUB(sv) CvXSUB(sv) #endif #define DBI_MAGIC '~' /* HvMROMETA introduced in 5.9.5, but mro_meta_init not exported in 5.10.0 */ #if (PERL_VERSION < 10) # define MY_cache_gen(stash) 0 #else # if ((PERL_VERSION == 10) && (PERL_SUBVERSION == 0)) # define MY_cache_gen(stash) \ (HvAUX(stash)->xhv_mro_meta \ ? HvAUX(stash)->xhv_mro_meta->cache_gen \ : 0) # else # define MY_cache_gen(stash) HvMROMETA(stash)->cache_gen # endif #endif /* If the tests fail with errors about 'setlinebuf' then try */ /* deleting the lines in the block below except the setvbuf one */ #ifndef PerlIO_setlinebuf #ifdef HAS_SETLINEBUF #define PerlIO_setlinebuf(f) setlinebuf(f) #else #ifndef USE_PERLIO #define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0) #endif #endif #endif #ifndef CopFILEGV # define CopFILEGV(cop) cop->cop_filegv # define CopLINE(cop) cop->cop_line # define CopSTASH(cop) cop->cop_stash # define CopSTASHPV(cop) (CopSTASH(cop) ? HvNAME(CopSTASH(cop)) : Nullch) #endif #ifndef PERL_GET_THX #define PERL_GET_THX ((void*)0) #endif #ifndef PerlProc_getpid #define PerlProc_getpid() getpid() extern Pid_t getpid (void); #endif #ifndef aTHXo_ #define aTHXo_ #endif #if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION == 0)) #define DBI_save_hv_fetch_ent #endif /* prior to 5.8.9: when a CV is duped, the mg dup method is called, * then *afterwards*, any_ptr is copied from the old CV to the new CV. * This wipes out anything which the dup method did to any_ptr. * This needs working around */ #if defined(USE_ITHREADS) && (PERL_VERSION == 8) && (PERL_SUBVERSION < 9) # define BROKEN_DUP_ANY_PTR #endif /* types of method name */ typedef enum { methtype_ordinary, /* nothing special about this method name */ methtype_DESTROY, methtype_FETCH, methtype_can, methtype_fetch_star, /* fetch*, i.e. fetch() or fetch_...() */ methtype_set_err } meth_types; static imp_xxh_t *dbih_getcom _((SV *h)); static imp_xxh_t *dbih_getcom2 _((pTHX_ SV *h, MAGIC **mgp)); static void dbih_clearcom _((imp_xxh_t *imp_xxh)); static int dbih_logmsg _((imp_xxh_t *imp_xxh, const char *fmt, ...)); static SV *dbih_make_com _((SV *parent_h, imp_xxh_t *p_imp_xxh, const char *imp_class, STRLEN imp_size, STRLEN extra, SV *copy)); static SV *dbih_make_fdsv _((SV *sth, const char *imp_class, STRLEN imp_size, const char *col_name)); static AV *dbih_get_fbav _((imp_sth_t *imp_sth)); static SV *dbih_event _((SV *h, const char *name, SV*, SV*)); static int dbih_set_attr_k _((SV *h, SV *keysv, int dbikey, SV *valuesv)); static SV *dbih_get_attr_k _((SV *h, SV *keysv, int dbikey)); static int dbih_sth_bind_col _((SV *sth, SV *col, SV *ref, SV *attribs)); static int set_err_char _((SV *h, imp_xxh_t *imp_xxh, const char *err_c, IV err_i, const char *errstr, const char *state, const char *method)); static int set_err_sv _((SV *h, imp_xxh_t *imp_xxh, SV *err, SV *errstr, SV *state, SV *method)); static int quote_type _((int sql_type, int p, int s, int *base_type, void *v)); static int sql_type_cast_svpv _((pTHX_ SV *sv, int sql_type, U32 flags, void *v)); static I32 dbi_hash _((const char *string, long i)); static void dbih_dumphandle _((pTHX_ SV *h, const char *msg, int level)); static int dbih_dumpcom _((pTHX_ imp_xxh_t *imp_xxh, const char *msg, int level)); static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg); #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param); #endif char *neatsvpv _((SV *sv, STRLEN maxlen)); SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void *foo); static meth_types get_meth_type(const char * const name); struct imp_drh_st { dbih_drc_t com; }; struct imp_dbh_st { dbih_dbc_t com; }; struct imp_sth_st { dbih_stc_t com; }; struct imp_fdh_st { dbih_fdc_t com; }; /* identify the type of a method name for dispatch behaviour */ /* (should probably be folded into the IMA flags mechanism) */ static meth_types get_meth_type(const char * const name) { switch (name[0]) { case 'D': if strEQ(name,"DESTROY") return methtype_DESTROY; break; case 'F': if strEQ(name,"FETCH") return methtype_FETCH; break; case 'c': if strEQ(name,"can") return methtype_can; break; case 'f': if strnEQ(name,"fetch", 5) /* fetch* */ return methtype_fetch_star; break; case 's': if strEQ(name,"set_err") return methtype_set_err; break; } return methtype_ordinary; } /* Internal Method Attributes (attached to dispatch methods when installed) */ /* NOTE: when adding SVs to dbi_ima_t, update dbi_ima_dup() dbi_ima_free() * to ensure that they are duped and correctly ref-counted */ typedef struct dbi_ima_st { U8 minargs; U8 maxargs; IV hidearg; /* method_trace controls tracing of method calls in the dispatcher: - if the current trace flags include a trace flag in method_trace then set trace_level to min(2,trace_level) for duration of the call. - else, if trace_level < (method_trace & DBIc_TRACE_LEVEL_MASK) then don't trace the call */ U32 method_trace; const char *usage_msg; U32 flags; meth_types meth_type; /* cached outer to inner method mapping */ HV *stash; /* the stash we found the GV in */ GV *gv; /* the GV containing the inner sub */ U32 generation; /* cache invalidation */ #ifdef BROKEN_DUP_ANY_PTR PerlInterpreter *my_perl; /* who owns this struct */ #endif } dbi_ima_t; /* These values are embedded in the data passed to install_method */ #define IMA_HAS_USAGE 0x00000001 /* check parameter usage */ #define IMA_FUNC_REDIRECT 0x00000002 /* is $h->func(..., "method") */ #define IMA_KEEP_ERR 0x00000004 /* don't reset err & errstr */ #define IMA_KEEP_ERR_SUB 0x00000008 /* '' if in a nested call */ #define IMA_NO_TAINT_IN 0x00000010 /* don't check for tainted args */ #define IMA_NO_TAINT_OUT 0x00000020 /* don't taint results */ #define IMA_COPY_UP_STMT 0x00000040 /* copy sth Statement to dbh */ #define IMA_END_WORK 0x00000080 /* method is commit or rollback */ #define IMA_STUB 0x00000100 /* donothing eg $dbh->connected */ #define IMA_CLEAR_STMT 0x00000200 /* clear Statement before call */ #define IMA_UNRELATED_TO_STMT 0x00000400 /* profile as empty Statement */ #define IMA_NOT_FOUND_OKAY 0x00000800 /* no error if not found */ #define IMA_EXECUTE 0x00001000 /* do/execute: DBIcf_Executed */ #define IMA_SHOW_ERR_STMT 0x00002000 /* dbh meth relates to Statement*/ #define IMA_HIDE_ERR_PARAMVALUES 0x00004000 /* ParamValues are not relevant */ #define IMA_IS_FACTORY 0x00008000 /* new h ie connect and prepare */ #define IMA_CLEAR_CACHED_KIDS 0x00010000 /* clear CachedKids before call */ #define DBIc_STATE_adjust(imp_xxh, state) \ (SvOK(state) /* SQLSTATE is implemented by driver */ \ ? (strEQ(SvPV_nolen(state),"00000") ? &PL_sv_no : sv_mortalcopy(state))\ : (SvTRUE(DBIc_ERR(imp_xxh)) \ ? sv_2mortal(newSVpv("S1000",5)) /* General error */ \ : &PL_sv_no) /* Success ("00000") */ \ ) #define DBI_LAST_HANDLE g_dbi_last_h /* special fake inner handle */ #define DBI_IS_LAST_HANDLE(h) ((DBI_LAST_HANDLE) == SvRV(h)) #define DBI_SET_LAST_HANDLE(h) ((DBI_LAST_HANDLE) = SvRV(h)) #define DBI_UNSET_LAST_HANDLE ((DBI_LAST_HANDLE) = &PL_sv_undef) #define DBI_LAST_HANDLE_OK ((DBI_LAST_HANDLE) != &PL_sv_undef) #define DBIS_TRACE_LEVEL (DBIS->debug & DBIc_TRACE_LEVEL_MASK) #define DBIS_TRACE_FLAGS (DBIS->debug) /* includes level */ #ifdef PERL_LONG_MAX #define MAX_LongReadLen PERL_LONG_MAX #else #define MAX_LongReadLen 2147483647L #endif #ifdef DBI_USE_THREADS static char *dbi_build_opt = "-ithread"; #else static char *dbi_build_opt = "-nothread"; #endif /* 32 bit magic FNV-0 and FNV-1 prime */ #define FNV_32_PRIME ((UV)0x01000193) /* perl doesn't know anything about the dbi_ima_t struct attached to the * CvXSUBANY(cv).any_ptr slot, so add some magic to the CV to handle * duping and freeing. */ static MGVTBL dbi_ima_vtbl = { 0, 0, 0, 0, dbi_ima_free, 0, #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) dbi_ima_dup #else 0 #endif #if (PERL_VERSION > 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION >= 9)) , 0 #endif }; static int dbi_ima_free(pTHX_ SV* sv, MAGIC* mg) { dbi_ima_t *ima = (dbi_ima_t *)(CvXSUBANY((CV*)sv).any_ptr); #ifdef BROKEN_DUP_ANY_PTR if (ima->my_perl != my_perl) return 0; #endif SvREFCNT_dec(ima->stash); SvREFCNT_dec(ima->gv); Safefree(ima); return 0; } #if defined(USE_ITHREADS) && !defined(BROKEN_DUP_ANY_PTR) static int dbi_ima_dup(pTHX_ MAGIC* mg, CLONE_PARAMS *param) { dbi_ima_t *ima, *nima; CV *cv = (CV*) mg->mg_ptr; CV *ncv = (CV*)ptr_table_fetch(PL_ptr_table, (cv)); PERL_UNUSED_VAR(param); mg->mg_ptr = (char *)ncv; ima = (dbi_ima_t*) CvXSUBANY(cv).any_ptr; Newx(nima, 1, dbi_ima_t); *nima = *ima; /* structure copy */ CvXSUBANY(ncv).any_ptr = nima; nima->stash = NULL; nima->gv = NULL; return 0; } #endif /* --- make DBI safe for multiple perl interpreters --- */ /* Originally contributed by Murray Nesbitt of ActiveState, */ /* but later updated to use MY_CTX */ #define MY_CXT_KEY "DBI::_guts" XS_VERSION typedef struct { SV *dbi_last_h; /* maybe better moved into dbistate_t? */ dbistate_t* dbi_state; } my_cxt_t; START_MY_CXT #undef DBIS #define DBIS (MY_CXT.dbi_state) #define g_dbi_last_h (MY_CXT.dbi_last_h) /* allow the 'static' dbi_state struct to be accessed from other files */ dbistate_t** _dbi_state_lval(pTHX) { dMY_CXT; return &(MY_CXT.dbi_state); } /* --- */ static void * malloc_using_sv(STRLEN len) { dTHX; SV *sv = newSV(len); void *p = SvPVX(sv); memzero(p, len); return p; } static char * savepv_using_sv(char *str) { char *buf = malloc_using_sv(strlen(str)); strcpy(buf, str); return buf; } /* --- support functions for concat_hash_sorted --- */ typedef struct str_uv_sort_pair_st { char *key; UV numeric; } str_uv_sort_pair_t; static int _cmp_number(const void *val1, const void *val2) { UV first = ((str_uv_sort_pair_t *)val1)->numeric; UV second = ((str_uv_sort_pair_t *)val2)->numeric; if (first > second) return 1; if (first < second) return -1; /* only likely to reach here if numeric sort forced for non-numeric keys */ /* fallback to comparing the key strings */ return strcmp( ((str_uv_sort_pair_t *)val1)->key, ((str_uv_sort_pair_t *)val2)->key ); } static int _cmp_str (const void *val1, const void *val2) { return strcmp( *(char **)val1, *(char **)val2); } static char ** _sort_hash_keys (HV *hash, int num_sort, STRLEN *total_length) { dTHX; I32 hv_len, key_len; HE *entry; char **keys; unsigned int idx = 0; STRLEN tot_len = 0; bool has_non_numerics = 0; str_uv_sort_pair_t *numbers; hv_len = hv_iterinit(hash); if (!hv_len) return 0; Newz(0, keys, hv_len, char *); Newz(0, numbers, hv_len, str_uv_sort_pair_t); while ((entry = hv_iternext(hash))) { *(keys+idx) = hv_iterkey(entry, &key_len); tot_len += key_len; if (grok_number(*(keys+idx), key_len, &(numbers+idx)->numeric) != IS_NUMBER_IN_UV) { has_non_numerics = 1; (numbers+idx)->numeric = 0; } (numbers+idx)->key = *(keys+idx); ++idx; } if (total_length) *total_length = tot_len; if (num_sort < 0) num_sort = (has_non_numerics) ? 0 : 1; if (!num_sort) { qsort(keys, hv_len, sizeof(char*), _cmp_str); } else { qsort(numbers, hv_len, sizeof(str_uv_sort_pair_t), _cmp_number); for (idx = 0; idx < hv_len; ++idx) *(keys+idx) = (numbers+idx)->key; } Safefree(numbers); return keys; } static SV * _join_hash_sorted(HV *hash, char *kv_sep, STRLEN kv_sep_len, char *pair_sep, STRLEN pair_sep_len, int use_neat, int num_sort) { dTHX; I32 hv_len; STRLEN total_len = 0; char **keys; unsigned int i = 0; SV *return_sv; keys = _sort_hash_keys(hash, num_sort, &total_len); if (!keys) return newSVpv("", 0); if (!kv_sep_len) kv_sep_len = strlen(kv_sep); if (!pair_sep_len) pair_sep_len = strlen(pair_sep); hv_len = hv_iterinit(hash); /* total_len += Separators + quotes + term null */ total_len += kv_sep_len*hv_len + pair_sep_len*hv_len+2*hv_len+1; return_sv = newSV(total_len); sv_setpv(return_sv, ""); /* quell undef warnings */ for (i=0; icheck_version = check_version; DBIS->version = DBISTATE_VERSION; DBIS->size = sizeof(*DBIS); DBIS->xs_version = DBIXS_VERSION; DBIS->logmsg = dbih_logmsg; DBIS->logfp = PerlIO_stderr(); DBIS->debug = (parent_dbis) ? parent_dbis->debug : SvIV(get_sv("DBI::dbi_debug",0x5)); DBIS->neatsvpvlen = (parent_dbis) ? parent_dbis->neatsvpvlen : get_sv("DBI::neat_maxlen", GV_ADDMULTI); #ifdef DBI_USE_THREADS DBIS->thr_owner = PERL_GET_THX; #endif /* store some function pointers so DBD's can call our functions */ DBIS->getcom = dbih_getcom; DBIS->clearcom = dbih_clearcom; DBIS->event = dbih_event; DBIS->set_attr_k = dbih_set_attr_k; DBIS->get_attr_k = dbih_get_attr_k; DBIS->get_fbav = dbih_get_fbav; DBIS->make_fdsv = dbih_make_fdsv; DBIS->neat_svpv = neatsvpv; DBIS->bind_as_num = quote_type; /* XXX deprecated */ DBIS->hash = dbi_hash; DBIS->set_err_sv = set_err_sv; DBIS->set_err_char= set_err_char; DBIS->bind_col = dbih_sth_bind_col; DBIS->sql_type_cast_svpv = sql_type_cast_svpv; /* Remember the last handle used. BEWARE! Sneaky stuff here! */ /* We want a handle reference but we don't want to increment */ /* the handle's reference count and we don't want perl to try */ /* to destroy it during global destruction. Take care! */ DBI_UNSET_LAST_HANDLE; /* ensure setup the correct way */ /* trick to avoid 'possible typo' warnings */ gv_fetchpv("DBI::state", GV_ADDMULTI, SVt_PV); gv_fetchpv("DBI::err", GV_ADDMULTI, SVt_PV); gv_fetchpv("DBI::errstr", GV_ADDMULTI, SVt_PV); gv_fetchpv("DBI::lasth", GV_ADDMULTI, SVt_PV); gv_fetchpv("DBI::rows", GV_ADDMULTI, SVt_PV); /* we only need to check the env var on the initial boot * which is handy because it can core dump during CLONE on windows */ if (!parent_dbis && getenv("PERL_DBI_XSBYPASS")) use_xsbypass = atoi(getenv("PERL_DBI_XSBYPASS")); } /* ----------------------------------------------------------------- */ /* Utility functions */ static char * dbih_htype_name(int htype) { switch(htype) { case DBIt_DR: return "dr"; case DBIt_DB: return "db"; case DBIt_ST: return "st"; case DBIt_FD: return "fd"; default: return "??"; } } char * neatsvpv(SV *sv, STRLEN maxlen) /* return a tidy ascii value, for debugging only */ { dTHX; dMY_CXT; STRLEN len; SV *nsv = Nullsv; SV *infosv = Nullsv; char *v, *quote; /* We take care not to alter the supplied sv in any way at all. */ /* (but if it is SvGMAGICAL we have to call mg_get and that can */ /* have side effects, especially as it may be called twice overall.) */ if (!sv) return "Null!"; /* should never happen */ /* try to do the right thing with magical values */ if (SvMAGICAL(sv)) { if (DBIS_TRACE_LEVEL >= 5) { /* add magic details to help debugging */ MAGIC* mg; infosv = sv_2mortal(newSVpv(" (magic-",0)); if (SvSMAGICAL(sv)) sv_catpvn(infosv,"s",1); if (SvGMAGICAL(sv)) sv_catpvn(infosv,"g",1); if (SvRMAGICAL(sv)) sv_catpvn(infosv,"r",1); sv_catpvn(infosv,":",1); for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) sv_catpvn(infosv, &mg->mg_type, 1); sv_catpvn(infosv, ")", 1); } if (SvGMAGICAL(sv) && !PL_dirty) 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; } /* err_hash returns a U32 'hash' value representing the current err 'level' * (err/warn/info) and errstr. It's used by the dispatcher as a way to detect * a new or changed warning during a 'keep err' method like STORE. Always returns >0. * The value is 1 for no err/warn/info and guarantees that err > warn > info. * (It's a bit of a hack but the original approach in 70fe6bd76 using a new * ErrChangeCount attribute would break binary compatibility with drivers.) * The chance that two realistic errstr values would hash the same, even with * only 30 bits, is deemed to small to even bother documenting. */ static U32 err_hash(pTHX_ imp_xxh_t *imp_xxh) { SV *err_sv = DBIc_ERR(imp_xxh); SV *errstr_sv; I32 hash = 1; if (SvOK(err_sv)) { errstr_sv = DBIc_ERRSTR(imp_xxh); if (SvOK(errstr_sv)) hash = -dbi_hash(SvPV_nolen(errstr_sv), 0); /* make positive */ else hash = 0; hash >>= 1; /* free up extra bit (top bit is already free) */ hash |= (SvTRUE(err_sv)) ? 0x80000000 /* err */ : (SvPOK(err_sv) && !SvCUR(err_sv)) ? 0x20000000 /* '' = info */ : 0x40000000;/* 0 or '0' = warn */ } return hash; } 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); (void)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); (void)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; if (!mg) /* may happen during global destruction */ return (imp_xxh_t *) 0; 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; PERL_UNUSED_VAR(extra); 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, 1); } 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; } } else die("panic: invalid DBIc_TYPE"); /* 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) { PERL_UNUSED_VAR(attribs); croak("Statement has no result columns to bind%s", DBIc_ACTIVE(imp_sth) ? "" : " (perhaps you need to successfully call execute first, or again)"); } 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); sv_force_normal(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_set(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; dORIGMARK; 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; U32 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 */ } #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 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; } /* 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) && !PL_dirty && 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) { /* force destruction of any outstanding children */ if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) && SvROK(*tmp_svp)) { AV *av = (AV*)SvRV(*tmp_svp); I32 kidslots; PerlIO *logfp = DBILOGFP; for (kidslots = AvFILL(av); kidslots >= 0; --kidslots) { SV **hp = av_fetch(av, kidslots, FALSE); if (!hp || !SvROK(*hp) || SvTYPE(SvRV(*hp))!=SVt_PVHV) break; if (trace_level >= 1) { PerlIO_printf(logfp, "on DESTROY handle %s still has child %s (refcnt %ld, obj %d, dirty=%d)\n", neatsvpv(h,0), neatsvpv(*hp, 0), (long)SvREFCNT(*hp), !!sv_isobject(*hp), PL_dirty); if (trace_level >= 9) sv_dump(SvRV(*hp)); } if (sv_isobject(*hp)) { /* call DESTROY on the handle */ PUSHMARK(SP); XPUSHs(*hp); PUTBACK; call_method("DESTROY", G_DISCARD|G_EVAL|G_KEEPERR); MSPAGAIN; } else { imp_xxh_t *imp_xxh = dbih_getcom2(aTHX_ *hp, 0); if (imp_xxh && DBIc_COMSET(imp_xxh)) { dbih_clearcom(imp_xxh); sv_setsv(*hp, &PL_sv_undef); } } } } if (DBIc_TYPE(imp_xxh) <= DBIt_DB ) { /* is dbh or drh */ imp_xxh_t *parent_imp; if (SvOK(DBIc_ERR(imp_xxh)) && (parent_imp = DBIc_PARENT_COM(imp_xxh)) && !PL_dirty /* XXX - remove? */ ) { /* 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; is_nested_call = 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 || (!PL_dirty /* not in global destruction [CPAN #75614] */ && 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, " !! The %s '%s' was 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/err_hash during call */ ErrCount = DBIc_ErrCount(imp_xxh); if (keep_error) keep_error = err_hash(aTHX_ 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 with %ld args\n", (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), (long)items); /* 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 die-ing, * but after the callback we manually restore the original $_. */ orig_defsv = DEFSV; /* remember the current $_ */ SAVE_DEFSV; /* local($_) = $method_name */ DEFSV_set(sv_2mortal(newSVpv(meth_name,0))); EXTEND(SP, items+1); PUSHMARK(SP); PUSHs(orig_h); /* push outer 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 */ MSPAGAIN; /* 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_set(SvREFCNT_inc(orig_defsv)); if (trace_level) PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s\n", (PL_dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), skip_dispatch ? ", actual method will not be called" : "" ); if (skip_dispatch) { /* XXX experimental */ int ix = outitems; /* copy the new items down to the destination list */ while (ix-- > 0) { if(0)warn("\tcopy down %d: %s overwriting %s\n", ix, SvPV_nolen(TOPs), SvPV_nolen(ST(ix)) ); ST(ix) = POPs; } imp_msv = *hook_svp; /* for trace and profile */ goto post_dispatch; } else { if (outitems != 0) die("Callback for %s returned %d values but must not return any (temporary restriction in current version)", meth_name, (int)outitems); /* POP's and PUTBACK? to clear stack */ } } /* set Executed after Callbacks so it's not set if callback elects to skip the method */ if (ima_flags & IMA_EXECUTE) { imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh); DBIc_on(imp_xxh, DBIcf_Executed); if (parent) DBIc_on(parent, DBIcf_Executed); } /* The "quick_FETCH" logic... */ /* Shortcut for fetching attributes to bypass method call overheads */ if (meth_type == methtype_FETCH && !DBIc_COMPAT(imp_xxh)) { STRLEN kl; const char *key = SvPV(st1, kl); SV **attr_svp; if (*key != '_' && (attr_svp=hv_fetch((HV*)SvRV(h), key, kl, 0))) { qsv = *attr_svp; /* disable FETCH from cache for special attributes */ if (SvROK(qsv) && SvTYPE(SvRV(qsv))==SVt_PVHV && *key=='D' && ( (kl==6 && DBIc_TYPE(imp_xxh)==DBIt_DB && strEQ(key,"Driver")) || (kl==8 && DBIc_TYPE(imp_xxh)==DBIt_ST && strEQ(key,"Database")) ) ) { qsv = Nullsv; } /* disable profiling of FETCH of Profile data */ if (*key == 'P' && strEQ(key, "Profile")) profile_t1 = 0.0; } if (qsv) { /* skip real method call if we already have a 'quick' value */ ST(0) = sv_mortalcopy(qsv); outitems = 1; goto post_dispatch; } } { CV *meth_cv; #ifdef DBI_save_hv_fetch_ent HE save_mh; if (meth_type == methtype_FETCH) save_mh = PL_hv_fetch_ent_mh; /* XXX nested tied FETCH bug17575 workaround */ #endif if (trace_flags) { SAVEI32(DBIS->debug); /* fall back to orig value later */ DBIS->debug = trace_flags; /* make new value global (for now) */ if (ima) { /* enabling trace via flags takes precedence over disabling due to min level */ if ((trace_flags & DBIc_TRACE_FLAGS_MASK) & (ima->method_trace & DBIc_TRACE_FLAGS_MASK)) trace_level = (trace_level < 2) ? 2 : trace_level; /* min */ else if (trace_level < (DBIc_TRACE_LEVEL_MASK & ima->method_trace)) trace_level = 0; /* silence dispatch log for this method */ } } if (is_orig_method_name && ima->stash == DBIc_IMP_STASH(imp_xxh) && ima->generation == PL_sub_generation + MY_cache_gen(DBIc_IMP_STASH(imp_xxh)) ) imp_msv = (SV*)ima->gv; else { imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), meth_name, FALSE); if (is_orig_method_name) { /* clear stale entry, if any */ SvREFCNT_dec(ima->stash); SvREFCNT_dec(ima->gv); if (!imp_msv) { ima->stash = NULL; ima->gv = NULL; } else { ima->stash = (HV*)SvREFCNT_inc(DBIc_IMP_STASH(imp_xxh)); ima->gv = (GV*)SvREFCNT_inc(imp_msv); ima->generation = PL_sub_generation + MY_cache_gen(DBIc_IMP_STASH(imp_xxh)); } } } /* if method was a 'func' then try falling back to real 'func' method */ if (!imp_msv && (ima_flags & IMA_FUNC_REDIRECT)) { imp_msv = (SV*)gv_fetchmethod_autoload(DBIc_IMP_STASH(imp_xxh), "func", FALSE); if (imp_msv) { /* driver does have func method so undo the earlier 'func' stack changes */ PUSHs(sv_2mortal(newSVpv(meth_name,0))); PUTBACK; ++items; meth_name = "func"; meth_type = methtype_ordinary; } } if (trace_level >= (is_nested_call ? 4 : 2)) { PerlIO *logfp = DBILOGFP; /* Full pkg method name (or just meth_name for ANON CODE) */ const char *imp_meth_name = (imp_msv && isGV(imp_msv)) ? GvNAME(imp_msv) : meth_name; HV *imp_stash = DBIc_IMP_STASH(imp_xxh); PerlIO_printf(logfp, "%c -> %s ", call_depth>1 ? '0'+call_depth-1 : (PL_dirty?'!':' '), imp_meth_name); if (imp_meth_name[0] == 'A' && strEQ(imp_meth_name,"AUTOLOAD")) PerlIO_printf(logfp, "\"%s\" ", meth_name); if (imp_msv && isGV(imp_msv) && GvSTASH(imp_msv) != imp_stash) PerlIO_printf(logfp, "in %s ", HvNAME(GvSTASH(imp_msv))); PerlIO_printf(logfp, "for %s (%s", HvNAME(imp_stash), SvPV_nolen(orig_h)); if (h != orig_h) /* show inner handle to aid tracing */ PerlIO_printf(logfp, "~0x%lx", (long)SvRV(h)); else PerlIO_printf(logfp, "~INNER"); for(i=1; ihidearg) ? "****" : neatsvpv(ST(i),0)); } #ifdef DBI_USE_THREADS PerlIO_printf(logfp, ") thr#%p\n", (void*)DBIc_THR_USER(imp_xxh)); #else PerlIO_printf(logfp, ")\n"); #endif PerlIO_flush(logfp); } if (!imp_msv || ! ((meth_cv = GvCV(imp_msv))) ) { if (PL_dirty || is_DESTROY) { outitems = 0; goto post_dispatch; } if (ima_flags & IMA_NOT_FOUND_OKAY) { outitems = 0; goto post_dispatch; } croak("Can't locate DBI object method \"%s\" via package \"%s\"", meth_name, HvNAME(DBIc_IMP_STASH(imp_xxh))); } PUSHMARK(mark); /* mark arguments again so we can pass them on */ /* Note: the handle on the stack is still an object blessed into a * DBI::* class and not the DBD::*::* class whose method is being * invoked. This is correct and should be largely transparent. */ /* SHORT-CUT ALERT! */ if (use_xsbypass && CvISXSUB(meth_cv) && CvXSUB(meth_cv)) { /* If we are calling an XSUB we jump directly to its C code and * bypass perl_call_sv(), pp_entersub() etc. This is fast. * This code is based on a small section of pp_entersub(). */ (void)(*CvXSUB(meth_cv))(aTHXo_ meth_cv); /* Call the C code directly */ if (gimme == G_SCALAR) { /* Enforce sanity in scalar context */ if (ax != PL_stack_sp - PL_stack_base ) { /* outitems != 1 */ ST(0) = (ax > PL_stack_sp - PL_stack_base) ? &PL_sv_undef /* outitems == 0 */ : *PL_stack_sp; /* outitems > 1 */ PL_stack_sp = PL_stack_base + ax; } outitems = 1; } else { outitems = PL_stack_sp - (PL_stack_base + ax - 1); } } else { /* sv_dump(imp_msv); */ outitems = call_sv((SV*)meth_cv, (is_DESTROY ? gimme | G_EVAL | G_KEEPERR : gimme) ); } XSprePUSH; /* reset SP to base of stack frame */ #ifdef DBI_save_hv_fetch_ent if (meth_type == methtype_FETCH) PL_hv_fetch_ent_mh = save_mh; /* see start of block */ #endif } post_dispatch: if (is_DESTROY && DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */ SV *lhp = DBIc_PARENT_H(imp_xxh); if (lhp && SvROK(lhp)) { DBI_SET_LAST_HANDLE(lhp); } else { DBI_UNSET_LAST_HANDLE; } } if (keep_error) { /* if we didn't clear err before the call, check to see if a new error * or warning has been recorded. If so, turn off keep_error so it gets acted on */ if (DBIc_ErrCount(imp_xxh) > ErrCount || err_hash(aTHX_ imp_xxh) != keep_error) { 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 IV 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%"IVdf, 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); MSPAGAIN; } } } 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); MSPAGAIN; 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 = NULL; 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; PERL_UNUSED_VAR(MY_CXT); } PERL_UNUSED_VAR(cv); PERL_UNUSED_VAR(items); dbi_bootinit(NULL); /* make this sub into a fake XS so it can bee seen by DBD::* modules; * never actually call it as an XS sub, or it will crash and burn! */ (void) newXS("DBI::_dbi_state_lval", (XSUBADDR_t)_dbi_state_lval, __FILE__); I32 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)); PERL_UNUSED_VAR(cv); } (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 */ if (GIMME != G_SCALAR) { 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) { PERL_UNUSED_VAR(ix); 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; PERL_UNUSED_VAR(cv); 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) { PERL_UNUSED_VAR(cv); PERL_UNUSED_VAR(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: PERL_UNUSED_VAR(cv); /* * Remove and return the imp_xxh_t structure that's attached to the inner * hash of the handle. Effectively this removes the 'brain' of the handle * 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) { PERL_UNUSED_VAR(ix); 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) { PERL_UNUSED_VAR(ix); 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 DELETE(h, keysv) SV * h SV * keysv CODE: /* only private_* keys can be deleted, for others DELETE acts like FETCH */ /* because the DBI internals rely on certain handle attributes existing */ if (strnEQ(SvPV_nolen(keysv),"private_",8)) ST(0) = hv_delete_ent((HV*)SvRV(h), keysv, 0, 0); else 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; } (void)SvREFCNT_inc(h1i); (void)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 DBI-1.634/dbi_sql.h000644 000766 000024 00000007167 12127375757 014224 0ustar00timbostaff000000 000000 /* $Id$ * * 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 */ DBI-1.634/dbilogstrip.PL000644 000766 000024 00000003621 12127375757 015204 0ustar00timbostaff000000 000000 # -*- perl -*- my $file = $ARGV[0] || 'dbilogstrip'; my $script = <<'SCRIPT'; ~startperl~ =head1 NAME dbilogstrip - filter to normalize DBI trace logs for diff'ing =head1 SYNOPSIS Read DBI trace file C and write out a stripped version to C dbilogstrip dbitrace.log > dbitrace_stripped.log Run C twice, each with different sets of arguments, with DBI_TRACE enabled. Filter the output and trace through C into a separate file for each run. Then compare using diff. (This example assumes you're using a standard shell.) DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log diff -u dbitrace1.log dbitrace2.log =head1 DESCRIPTION Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>. Replaces any references to process id or thread id, like C with C. So a DBI trace line like this: -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400 will look like this: -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN =cut use strict; while (<>) { # normalize hex addresses: 0xDEADHEAD => 0xN s/ \b 0x [0-9a-f]+ /0xN/gx; # normalize process and thread id number s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx; } continue { print or die "-p destination: $!\n"; } SCRIPT require Config; my $config = {}; $config->{'startperl'} = $Config::Config{'startperl'}; $script =~ s/\~(\w+)\~/$config->{$1}/eg; if (!(open(FILE, ">$file")) || !(print FILE $script) || !(close(FILE))) { die "Error while writing $file: $!\n"; } chmod 0755, $file; print "Extracted $file from ",__FILE__," with variable substitutions.\n"; # syntax check resulting file, but only for developers exit 1 if -d ".svn" and system($^X, '-wc', '-Mblib', $file) != 0; DBI-1.634/dbipport.h000644 000766 000024 00000540044 12127375757 014426 0ustar00timbostaff000000 000000 #if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.20 Automatically created by Devel::PPPort running under perl 5.010001. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.20 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.11.5. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagially add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2010, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.20; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| BhkDISABLE||5.014000| BhkENABLE||5.014000| BhkENTRY_set||5.014000| BhkENTRY||| BhkFLAGS||| CALL_BLOCK_HOOKS||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV_set|5.010001||p DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSVn|5.009003||p GvSV||| Gv_AMupdate||5.011000| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeUTF8||5.010001| HeVAL||5.004000| HvENAME||5.013007| HvNAMELEN_get|5.009003||p HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LINKLIST||5.013006| LVRET||| MARK||| MULTICALL||5.014000| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| OP_CLASS||5.013007| OP_DESC||5.007003| OP_NAME||5.007003| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_DUP||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.014000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.004000||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.014000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.014000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.014000| PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.014000||p PL_bufptr|5.014000||p PL_compiling|5.004050||p PL_copline|5.014000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.014000||p PL_expect|5.014000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.014000||p PL_in_my|5.014000||p PL_keyword_plugin||5.011002| PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.014000||p PL_lex_stuff|5.014000||p PL_linestr|5.014000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_opfreehook||5.011000|n PL_parser|5.009005|5.009005|p PL_peepp||5.007003|n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rpeepp||5.013005|n PL_rsfp_filters|5.014000||p PL_rsfp|5.014000||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.014000||p POP_MULTICALL||5.014000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.014000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_nomg||5.013002| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg_nolen||5.013007| SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK||5.009005| SvRX||5.009005| SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE_nomg||5.013006| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8_MAXBYTES|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.014000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_APIVERSION_BOOTCHECK||5.013004| XS_VERSION_BOOTCHECK||| XS_VERSION||| XSprePUSH|5.006000||p XS||| XopDISABLE||5.014000| XopENABLE||5.014000| XopENTRY_set||5.014000| XopENTRY||5.014000| XopFLAGS||5.013007| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _append_range_to_invlist||| _new_invlist||| _pMY_CXT|5.007003||p _swash_inversion_hash||| _swash_to_invlist||| aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.014000||p aTHXR|5.014000||p aTHX_|5.006000||p aTHX|5.006000||p add_alternate||| add_cp_to_invlist||| add_data|||n add_range_to_invlist||| add_utf16_textfilter||| addmad||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_deref_call||5.013007| amagic_i_ncmp||| amagic_ncmp||| anonymise_cv_maybe||| any_dup||| ao||| append_madprops||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| assert_uft8_cache_coherent||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| blockhook_register||5.013003| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_cmp_utf8||5.013007| bytes_from_utf8||5.007001| bytes_to_uni|||n bytes_to_utf8||5.006001| call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p caller_cx||5.013005| calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_type_and_open||| check_uni||| check_utf8_print||| checkcomma||| checkposixcc||| ckWARN|5.006000||p ck_entersub_args_list||5.013006| ck_entersub_args_proto_or_list||5.013006| ck_entersub_args_proto||5.013006| ck_warner_d||5.011001|v ck_warner||5.011001|v ckwarn_common||| ckwarn_d||5.009003| ckwarn||5.009003| cl_and|||n cl_anything|||n cl_init|||n cl_is_anything|||n cl_or|||n clear_placeholders||| clone_params_del|||n clone_params_new|||n closest_cop||| convert||| cop_free||| cop_hints_2hv||5.013007| cop_hints_fetch_pvn||5.013007| cop_hints_fetch_pvs||5.013007| cop_hints_fetch_pv||5.013007| cop_hints_fetch_sv||5.013007| cophh_2hv||5.013007| cophh_copy||5.013007| cophh_delete_pvn||5.013007| cophh_delete_pvs||5.013007| cophh_delete_pv||5.013007| cophh_delete_sv||5.013007| cophh_fetch_pvn||5.013007| cophh_fetch_pvs||5.013007| cophh_fetch_pv||5.013007| cophh_fetch_sv||5.013007| cophh_free||5.013007| cophh_new_empty||5.014000| cophh_store_pvn||5.013007| cophh_store_pvs||5.013007| cophh_store_pv||5.013007| cophh_store_sv||5.013007| cr_textfilter||| create_eval_scope||| croak_no_modify||5.013003| croak_nocontext|||vn croak_sv||5.013001| croak_xs_usage||5.010001| croak|||v csighandler||5.009003|n curmad||| curse||| custom_op_desc||5.007003| custom_op_name||5.007003| custom_op_register||5.013007| custom_op_xop||5.013007| cv_ckproto_len||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_get_call_checker||5.013006| cv_set_call_checker||5.013006| cv_undef||| cvgv_set||| cvstash_set||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.014000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v del_sv||| delete_eval_scope||| delimcpy||5.004000|n deprecate_commaless_var_list||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_sv||5.013001| die_unwind||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_close||| do_delete_local||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_op_xmldump||| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pmop_dump||5.006000| do_pmop_xmldump||| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogiven||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| dump_all_perl||| dump_all||5.006000| dump_eval||5.006000| dump_exec_pos||| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs_perl||| dump_packsubs||5.006000| dump_sub_perl||| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| fetch_cop_label||5.011000| filter_add||| filter_del||| filter_gets||| filter_read||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_hash_subscript||| find_in_my_stash||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_rundefsv||5.013002| find_script||| find_uninit_var||| first_symbol|||n foldEQ_latin1||5.013008|n foldEQ_locale||5.013002|n foldEQ_utf8_flags||5.013010| foldEQ_utf8||5.013002| foldEQ||5.013002|n fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_strict_version||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_aux_mg||| get_av|5.006000||p get_context||5.006000|n get_cvn_flags|5.009005||p get_cvs|5.011000||p get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| glob_assign_ref||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_bslash_c||| grok_bslash_o||| grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_add_by_type||5.011000| gv_autoload4||5.004000| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_flags||5.011000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv|5.009002||p gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_get_super_pkg||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_magicalize_isa||| gv_magicalize_overload||| gv_name_set||5.009004| gv_stashpvn|5.004000||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsv||| gv_try_downgrade||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||| hv_auxinit|||n hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||5.009004| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_ename_add||| hv_ename_delete||| hv_exists_ent||5.004000| hv_exists||| hv_fetch_ent||5.004000| hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.004000| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef_flags||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_dbargs||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr|||n intro_my||| intuit_method||| intuit_more||| invert||| invlist_array||| invlist_destroy||| invlist_extend||| invlist_intersection||| invlist_len||| invlist_max||| invlist_set_array||| invlist_set_len||| invlist_set_max||| invlist_trim||| invlist_union||| invoke_exception_hook||| io_close||| isALNUMC|5.006000||p isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isGRAPH|5.006000||p isGV_with_GP|5.009004||p isLOWER||| isOCTAL||5.013005| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSPACE||| isUPPER||| isWORDCHAR||5.013006| isXDIGIT|5.006000||p is_an_int||| is_ascii_string||5.011000|n is_gv_magical_sv||| is_handle_constructor|||n is_inplace_av||| is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_X_LVT||| is_utf8_X_LV_LVT_V||| is_utf8_X_LV||| is_utf8_X_L||| is_utf8_X_T||| is_utf8_X_V||| is_utf8_X_begin||| is_utf8_X_extend||| is_utf8_X_non_hangul||| is_utf8_X_prepend||| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow|||n is_utf8_char||5.006000|n is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_perl_space||5.011001| is_utf8_perl_word||5.011001| is_utf8_posix_digit||5.011001| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003|n is_utf8_string_loc||5.008001|n is_utf8_string||5.006001|n is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| is_utf8_xidcont||5.013010| is_utf8_xidfirst||5.013010| isa_lookup||| items|||n ix|||n jmaybe||| join_exact||| keyword_plugin_standard||| keyword||| leave_scope||| lex_bufutf8||5.011002| lex_discard_to||5.011002| lex_grow_linestr||5.011002| lex_next_chunk||5.011002| lex_peek_unichar||5.011002| lex_read_space||5.011002| lex_read_to||5.011002| lex_read_unichar||5.011002| lex_start||5.009005| lex_stuff_pvn||5.011002| lex_stuff_pvs||5.013005| lex_stuff_pv||5.013006| lex_stuff_sv||5.011002| lex_unstuff||5.011002| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.010001||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.010001||p mXPUSHu|5.009002||p mad_free||| madlex||| madparse||| magic_clear_all_env||| magic_clearenv||| magic_clearhints||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall1||| magic_methcall|||v magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie_failtable||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||| matcher_matches_sv||| measure_struct||| memEQs|5.009005||p memEQ|5.004000||p memNEs|5.009005||p memNE|5.004000||p mem_collxfrm||| mem_log_common|||n mess_alloc||| mess_nocontext|||vn mess_sv||5.013001| mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_findext||5.013008| mg_find||| mg_free_type||5.013006| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| more_bodies||| more_sv||| moreswitches||| mro_clean_isarev||| mro_gather_and_rename||| mro_get_from_name||5.010001| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.010001| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_package_moved||| mro_register||5.010001| mro_set_mro||5.010001| mro_set_private_data||5.010001| mul128||| mulexp10|||n munge_qwlist_to_paren_list||| my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat_flags||| my_lstat||5.014000| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat_flags||| my_stat||5.014000| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_swabn|||n my_swap||| my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||5.013007| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMADPROP||| newMADsv||| newMYSUB||| newNULLLIST||| newOP||| newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVhek||5.009003| newSViv||| newSVnv||| newSVpv_share||5.013006| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.010001||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.010001||p newSVpvn|5.004050||p newSVpvs_flags|5.010001||p newSVpvs_share|5.009003||p newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newTOKEN||| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.013007| newXS_flags||5.009004| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr|||n no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n oopsAV||| oopsHV||| op_append_elem||5.013006| op_append_list||5.013006| op_clear||| op_const_sv||| op_contextualize||5.013006| op_dump||5.006000| op_free||| op_getmad_weak||| op_getmad||| op_linklist||5.013006| op_lvalue||5.013007| op_null||5.007002| op_prepend_elem||5.013006| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_scope||5.013007| op_xmldump||| open_script||| opt_scalarhv||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package_version||| package||| packlist||5.008001| pad_add_anon||| pad_add_name_sv||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||5.011002| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_peg|||n pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| pad_tidy||| padlist_dup||| parse_arithexpr||5.013008| parse_barestmt||5.013007| parse_block||5.013007| parse_body||| parse_fullexpr||5.013008| parse_fullstmt||5.013005| parse_label||5.013007| parse_listexpr||5.013008| parse_stmtseq||5.013006| parse_termexpr||5.013008| parse_unicode_opts||| parser_dup||| parser_free||| path_is_absolute|||n peep||| pending_Slabs_to_ro||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmop_dump||5.006000| pmop_xmldump||| pmruntime||| pmtrans||| pop_scope||| populate_isa|||v pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prepend_madprops||| prescan_version||5.011004| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_byte||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| re_compile||5.009005| re_croak2||| re_dup_guts||| re_intuit_start||5.009005| re_intuit_string||5.006000| readpipe_override||| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch_pvn||| refcounted_he_fetch_pvs||| refcounted_he_fetch_pv||| refcounted_he_fetch_sv||| refcounted_he_free||| refcounted_he_inc||| refcounted_he_new_pvn||| refcounted_he_new_pvs||| refcounted_he_new_pv||| refcounted_he_new_sv||| refcounted_he_value||| refkids||| refto||| ref||5.014000| reg_check_named_buff_matched||| reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_namedseq||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment||| reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly||| regdump_extflags||| regdump||5.005000| regdupe_internal||| regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regpiece||| regpposixcc||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reguni||| regwhite|||n reg||| repeatcpy|||n report_evil_fh||| report_uninit||| report_wrongway_fh||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr|||n rpeep||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rv2cv_op_cv||5.013006| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem_flags||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hdelete||5.011000| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||5.010001| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||5.005000| save_padsv_and_mortalize||5.010001| save_pptr||| save_pushi32ptr||5.010001| save_pushptri32ptr||| save_pushptrptr||5.010001| save_pushptr||5.010001| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpvs||5.013006| savesharedpv||5.007003| savesharedsvpv||5.013006| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| screaminstr||5.005000| search_const||| seed||5.008001| sequence_num||| sequence_tail||| sequence||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| set_regclass_bit_fold||| set_regclass_bit||| setdefout||| share_hek_flags||| share_hek||5.004000| si_dup||| sighandler|||n simplify_sort||| skipspace0||| skipspace1||| skipspace2||| skipspace||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| stack_grow||| start_force||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.014000| stdize_locale||| store_cop_label||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool_flags||5.013006| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv_flags||5.013001| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_flags||5.013006| sv_catpv_mg|5.004050||p sv_catpv_nomg||5.013006| sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs_flags||5.013006| sv_catpvs_mg||5.013006| sv_catpvs_nomg||5.013006| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_catxmlpvn||| sv_catxmlpv||| sv_catxmlsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_flags||5.013006| sv_cmp_locale_flags||5.013006| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm_flags||5.013006| sv_collxfrm||| sv_compile_2op_is_broken||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec_nomg||5.013002| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_does||5.009004| sv_dump||| sv_dup_common||| sv_dup_inc_multiple||| sv_dup_inc||| sv_dup||| sv_eq_flags||5.013006| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_i_ncmp||| sv_inc_nomg||5.013002| sv_inc||| sv_insert_flags||5.010001| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.014000|5.004000|p sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_flags||5.011005| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs_mg||5.013006| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pvs||5.013006| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagicext||5.013008| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p sv_xmlpeek||| svtype||| swallow_bom||| swash_fetch||5.007002| swash_get||| swash_init||5.006000| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tied_method|||v tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| token_free||| token_getmad||| tokenize_use||| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| try_amagic_bin||| try_amagic_un||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unreferenced_to_tmp_stack||| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_len_cache_update||| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warn_sv||5.013001| warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v watch||| whichsig||| with_queued_errors||| write_no_mem||| write_to_stderr||| xmldump_all_perl||| xmldump_all||| xmldump_attr||| xmldump_eval||| xmldump_form||| xmldump_indent|||v xmldump_packsubs_perl||| xmldump_packsubs||| xmldump_sub_perl||| xmldump_sub||| xmldump_vindent||| xs_apiversion_bootcheck||| xs_version_bootcheck||| yyerror||| yylex||| yyparse||| yyunlex||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs # define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((U8) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((U8) (c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doint. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* Hint: newSVpvn_share * The SVs created by this function only mimic the behaviour of * shared PVs without really being shared. Only use if you know * what you're doing. */ #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) #endif #ifndef gv_fetchsv # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags # define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef newSVpvs_share # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%"UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%"UVxf"}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ DBI-1.634/dbiprof.PL000644 000766 000024 00000015166 12162132031 014265 0ustar00timbostaff000000 000000 # -*- perl -*- my $file = $ARGV[0] || 'dbiprof'; my $script = <<'SCRIPT'; ~startperl~ use strict; my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); use Data::Dumper; use DBI::ProfileData; use Getopt::Long; # default options my $number = 10; my $sort = 'total'; my $filename = 'dbi.prof'; my $reverse = 0; my $case_sensitive = 0; my (%match, %exclude); # get options from command line GetOptions( 'version' => sub { die "dbiprof $VERSION\n" }, 'help' => sub { exit usage() }, 'number=i' => \$number, 'sort=s' => \$sort, 'dumpnodes!' => \my $dumpnodes, 'reverse' => \$reverse, 'match=s' => \%match, 'exclude=s' => \%exclude, 'case-sensitive' => \$case_sensitive, 'delete!' => \my $opt_delete, ) or exit usage(); sub usage { print <new( Files => \@files, DeleteFiles => $opt_delete, ); }; die "Unable to load profile data: $@\n" if $@; if (%match) { # handle matches while (my ($key, $val) = each %match) { if ($val =~ m!^/(.+)/$!) { $val = $case_sensitive ? qr/$1/ : qr/$1/i; } $prof->match($key, $val, case_sensitive => $case_sensitive); } } if (%exclude) { # handle excludes while (my ($key, $val) = each %exclude) { if ($val =~ m!^/(.+)/$!) { $val = $case_sensitive ? qr/$1/ : qr/$1/i; } $prof->exclude($key, $val, case_sensitive => $case_sensitive); } } # sort the data $prof->sort(field => $sort, reverse => $reverse); # all done, print it out if ($dumpnodes) { $Data::Dumper::Indent = 1; $Data::Dumper::Terse = 1; $Data::Dumper::Useqq = 1; $Data::Dumper::Deparse = 0; print Dumper($prof->nodes); } else { print $prof->report(number => $number); } exit 0; __END__ =head1 NAME dbiprof - command-line client for DBI::ProfileData =head1 SYNOPSIS See a report of the ten queries with the longest total runtime in the profile dump file F: dbiprof prof1.out See the top 10 most frequently run queries in the profile file F (the default): dbiprof --sort count See the same report with 15 entries: dbiprof --sort count --number 15 =head1 DESCRIPTION This tool is a command-line client for the DBI::ProfileData. It allows you to analyze the profile data file produced by DBI::ProfileDumper and produce various useful reports. =head1 OPTIONS This program accepts the following options: =over 4 =item --number N Produce this many items in the report. Defaults to 10. If set to "all" then all results are shown. =item --sort field Sort results by the given field. Sorting by multiple fields isn't currently supported (patches welcome). The available sort fields are: =over 4 =item total Sorts by total time run time across all runs. This is the default sort. =item longest Sorts by the longest single run. =item count Sorts by total number of runs. =item first Sorts by the time taken in the first run. =item shortest Sorts by the shortest single run. =item key1 Sorts by the value of the first element in the Path, which should be numeric. You can also sort by C and C. =back =item --reverse Reverses the selected sort. For example, to see a report of the shortest overall time: dbiprof --sort total --reverse =item --match keyN=value Consider only items where the specified key matches the given value. Keys are numbered from 1. For example, let's say you used a DBI::Profile Path of: [ DBIprofile_Statement, DBIprofile_Methodname ] And called dbiprof as in: dbiprof --match key2=execute Your report would only show execute queries, leaving out prepares, fetches, etc. If the value given starts and ends with slashes (C) then it will be treated as a regular expression. For example, to only include SELECT queries where key1 is the statement: dbiprof --match key1=/^SELECT/ By default the match expression is matched case-insensitively, but this can be changed with the --case-sensitive option. =item --exclude keyN=value Remove items for where the specified key matches the given value. For example, to exclude all prepare entries where key2 is the method name: dbiprof --exclude key2=prepare Like C<--match>, If the value given starts and ends with slashes (C) then it will be treated as a regular expression. For example, to exclude UPDATE queries where key1 is the statement: dbiprof --match key1=/^UPDATE/ By default the exclude expression is matched case-insensitively, but this can be changed with the --case-sensitive option. =item --case-sensitive Using this option causes --match and --exclude to work case-sensitively. Defaults to off. =item --delete Sets the C option to L which causes the files to be deleted after reading. See L for more details. =item --dumpnodes Print the list of nodes in the form of a perl data structure. Use the C<-sort> option if you want the list sorted. =item --version Print the dbiprof version number and exit. =back =head1 AUTHOR Sam Tregar =head1 COPYRIGHT AND LICENSE Copyright (C) 2002 Sam Tregar This program is free software; you can redistribute it and/or modify it under the same terms as Perl 5 itself. =head1 SEE ALSO L, L, L. =cut SCRIPT require Config; my $config = {}; $config->{'startperl'} = $Config::Config{'startperl'}; $script =~ s/\~(\w+)\~/$config->{$1}/eg; if (!(open(FILE, ">$file")) || !(print FILE $script) || !(close(FILE))) { die "Error while writing $file: $!\n"; } chmod 0755, $file; print "Extracted $file from ",__FILE__," with variable substitutions.\n"; # syntax check resulting file, but only for developers exit 1 if -d ".svn"|| -d ".git" and system($^X, '-wc', '-Mblib', $file) != 0; DBI-1.634/dbiproxy.PL000644 000766 000024 00000013510 12162132031 014467 0ustar00timbostaff000000 000000 # -*- perl -*- my $file = $ARGV[0] || 'dbiproxy'; my $script = <<'SCRIPT'; ~startperl~ use strict; my $VERSION = sprintf("1.%06d", q$Revision$ =~ /(\d+)/o); my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test'; $ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//; require DBI::ProxyServer; # XXX these should probably be moved into DBI::ProxyServer delete $ENV{IFS}; delete $ENV{CDPATH}; delete $ENV{ENV}; delete $ENV{BASH_ENV}; if ($arg_test) { require RPC::PlServer::Test; @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI); } DBI::ProxyServer::main(@ARGV); exit(0); __END__ =head1 NAME dbiproxy - A proxy server for the DBD::Proxy driver =head1 SYNOPSIS dbiproxy --localport= =head1 DESCRIPTION This tool is just a front end for the DBI::ProxyServer package. All it does is picking options from the command line and calling DBI::ProxyServer::main(). See L for details. Available options include: =over 4 =item B<--chroot=dir> (UNIX only) After doing a bind(), change root directory to the given directory by doing a chroot(). This is useful for security, but it restricts the environment a lot. For example, you need to load DBI drivers in the config file or you have to create hard links to Unix sockets, if your drivers are using them. For example, with MySQL, a config file might contain the following lines: my $rootdir = '/var/dbiproxy'; my $unixsockdir = '/tmp'; my $unixsockfile = 'mysql.sock'; foreach $dir ($rootdir, "$rootdir$unixsockdir") { mkdir 0755, $dir; } link("$unixsockdir/$unixsockfile", "$rootdir$unixsockdir/$unixsockfile"); require DBD::mysql; { 'chroot' => $rootdir, ... } If you don't know chroot(), think of an FTP server where you can see a certain directory tree only after logging in. See also the --group and --user options. =item B<--configfile=file> Config files are assumed to return a single hash ref that overrides the arguments of the new method. However, command line arguments in turn take precedence over the config file. See the "CONFIGURATION FILE" section in the L documentation for details on the config file. =item B<--debug> Turn debugging mode on. Mainly this asserts that logging messages of level "debug" are created. =item B<--facility=mode> (UNIX only) Facility to use for L. The default is B. =item B<--group=gid> After doing a bind(), change the real and effective GID to the given. This is useful, if you want your server to bind to a privileged port (<1024), but don't want the server to execute as root. See also the --user option. GID's can be passed as group names or numeric values. =item B<--localaddr=ip> By default a daemon is listening to any IP number that a machine has. This attribute allows to restrict the server to the given IP number. =item B<--localport=port> This attribute sets the port on which the daemon is listening. It must be given somehow, as there's no default. =item B<--logfile=file> Be default logging messages will be written to the syslog (Unix) or to the event log (Windows NT). On other operating systems you need to specify a log file. The special value "STDERR" forces logging to stderr. See L for details. =item B<--mode=modename> The server can run in three different modes, depending on the environment. If you are running Perl 5.005 and did compile it for threads, then the server will create a new thread for each connection. The thread will execute the server's Run() method and then terminate. This mode is the default, you can force it with "--mode=threads". If threads are not available, but you have a working fork(), then the server will behave similar by creating a new process for each connection. This mode will be used automatically in the absence of threads or if you use the "--mode=fork" option. Finally there's a single-connection mode: If the server has accepted a connection, he will enter the Run() method. No other connections are accepted until the Run() method returns (if the client disconnects). This operation mode is useful if you have neither threads nor fork(), for example on the Macintosh. For debugging purposes you can force this mode with "--mode=single". =item B<--pidfile=file> (UNIX only) If this option is present, a PID file will be created at the given location. Default is to not create a pidfile. =item B<--user=uid> After doing a bind(), change the real and effective UID to the given. This is useful, if you want your server to bind to a privileged port (<1024), but don't want the server to execute as root. See also the --group and the --chroot options. UID's can be passed as group names or numeric values. =item B<--version> Suppresses startup of the server; instead the version string will be printed and the program exits immediately. =back =head1 AUTHOR Copyright (c) 1997 Jochen Wiedmann Am Eisteich 9 72555 Metzingen Germany Email: joe@ispsoft.de Phone: +49 7123 14881 The DBI::ProxyServer module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. In particular permission is granted to Tim Bunce for distributing this as a part of the DBI. =head1 SEE ALSO L, L, L =cut SCRIPT require Config; my $config = {}; $config->{'startperl'} = $Config::Config{'startperl'}; $script =~ s/\~(\w+)\~/$config->{$1}/eg; if (!(open(FILE, ">$file")) || !(print FILE $script) || !(close(FILE))) { die "Error while writing $file: $!\n"; } chmod 0755, $file; print "Extracted $file from ",__FILE__," with variable substitutions.\n"; # syntax check resulting file, but only for developers exit 1 if -d ".svn" || -d ".git" and system($^X, '-wc', '-Mblib', $file) != 0; DBI-1.634/dbivport.h000644 000766 000024 00000003740 12127375757 014431 0ustar00timbostaff000000 000000 /* 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 */ DBI-1.634/DBIXS.h000644 000766 000024 00000062616 12226531547 013447 0ustar00timbostaff000000 000000 /* vim: ts=8:sw=4:expandtab * * $Id$ * * Copyright (c) 1994-2010 Tim Bunce Ireland * * See COPYRIGHT section in DBI.pm for usage and distribution rights. */ /* DBI Interface Definitions for DBD Modules */ #ifndef DBIXS_VERSION /* prevent multiple inclusion */ #ifndef DBIS #define DBIS dbis /* default name for dbistate_t variable */ #endif /* Here for backwards compat. PERL_POLLUTE was removed in perl 5.13.3 */ #define PERL_POLLUTE /* first pull in the standard Perl header files for extensions */ #include #include #include #ifdef debug /* causes problems with DBIS->debug */ #undef debug #endif #ifdef std /* causes problems with STLport */ #undef std #endif /* define DBIXS_REVISION */ #include "dbixs_rev.h" /* Perl backwards compatibility definitions */ #include "dbipport.h" /* DBI SQL_* type definitions */ #include "dbi_sql.h" #define DBIXS_VERSION 93 /* superseded 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 */ DBI-1.634/dbixs_rev.h000644 000766 000024 00000000154 12226531555 014547 0ustar00timbostaff000000 000000 /* Fri Jul 13 13:32:02 2012 */ /* Mixed revision working copy (15349:15353) */ #define DBIXS_REVISION 15349 DBI-1.634/dbixs_rev.pl000644 000766 000024 00000002775 12127375757 014760 0ustar00timbostaff000000 000000 #!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"); } DBI-1.634/Driver.xst000644 000766 000024 00000055033 12557444464 014423 0ustar00timbostaff000000 000000 # $Id$ # 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" # Historically dbd_db_do4, dbd_st_execute, and dbd_st_rows returned an 'int' type. # That's only 32 bits (31+sign) so isn't sufficient for very large row counts # So now instead of defining those macros, drivers can define dbd_db_do4_iv, # dbd_st_execute_iv, and dbd_st_rows_iv to be the names of functions that # return an 'IV' type. They could also set DBIc_ROW_COUNT(imp_sth). # # To save a mess of #ifdef's we arrange for dbd_st_execute (etc) to work # as dbd_st_execute_iv if that's defined # #if defined(dbd_st_execute_iv) #undef dbd_st_execute #define dbd_st_execute dbd_st_execute_iv #endif #if defined(dbd_st_rows_iv) #undef dbd_st_rows #define dbd_st_rows dbd_st_rows_iv #endif #if defined(dbd_db_do4_iv) #undef dbd_db_do4 #define dbd_db_do4 dbd_db_do4_iv #endif MODULE = DBD::~DRIVER~ PACKAGE = DBD::~DRIVER~ REQUIRE: 1.929 PROTOTYPES: DISABLE BOOT: PERL_UNUSED_VAR(items); 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); PERL_UNUSED_VAR(ix); 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*)""; char *p = (SvOK(password)) ? SvPV(password,lna) : (char*)""; #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 *tmp_sv; 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); tmp_sv = dbdxst_fetchall_arrayref(sth, &PL_sv_undef, (maxrows_svp) ? *maxrows_svp : &PL_sv_undef); SPAGAIN; ST(0) = tmp_sv; 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); /* might be dbd_db_do4_iv via macro */ /* 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) ? (char*)"" : (char*)"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); IV 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 */ DBIc_ROW_COUNT(imp_sth) = 0; retval = dbd_st_execute(sth, imp_sth); /* might be dbd_st_execute_iv via macro */ /* 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; PERL_UNUSED_VAR(ix); 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]); } PERL_UNUSED_VAR(ix); } 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 { SV *tmp = dbdxst_fetchall_arrayref(sth, slice, batch_row_count); SPAGAIN; ST(0) = tmp; } 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; PERL_UNUSED_VAR(ix); 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 DBI-1.634/Driver_xst.h000644 000766 000024 00000007560 12127375757 014735 0ustar00timbostaff000000 000000 /* # $Id$ # 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); PERL_UNUSED_VAR(xxx); } 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 DBI-1.634/ex/000750 000766 000024 00000000000 12557677761 013041 5ustar00timbostaff000000 000000 DBI-1.634/INSTALL000644 000766 000024 00000003543 12162132031 013430 0ustar00timbostaff000000 000000 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 --- 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 referring 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. DBI-1.634/lib/000750 000766 000024 00000000000 12557677761 013173 5ustar00timbostaff000000 000000 DBI-1.634/Makefile.PL000644 000766 000024 00000026732 12407531733 014374 0ustar00timbostaff000000 000000 # -*- perl -*- # # $Id$ # # 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 = $Config{useithreads}; # 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; } 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://github.com/perl5-dbi/dbi', MailingList => 'mailto:dbi-dev@perl.org', license => 'http://dev.perl.org/licenses/', homepage => 'http://dbi.perl.org/', IRC => 'irc://irc.perl.org/#dbi', }, suggests => { 'RPC::PlServer' => 0.2001, 'Net::Daemon' => 0, 'SQL::Statement' => 1.402, 'Clone' => 0.34, 'MLDBM' => 0, 'DB_File' => 0, }, }, PREREQ_PM => { ( $^O eq 'MSWin32' ? ( 'File::Spec' => 3.31, ) : () ), }, CONFLICTS => { 'SQL::Statement' => '1.33', 'DBD::AnyData' => '0.110', 'DBD::CSV' => '0.36', 'DBD::RAM' => '0.072', 'DBD::PO' => '2.10', 'DBD::Google' => '0.51', 'DBD::Amazon' => '0.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* test_output_*" ." 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 $_; } my $conflictMsg = < 1, create_nano_tests => 1, create_gap_tests => 1, }) ); # WriteMakefile call is last thing executed # so return value is propagated # ===================================================================== package MY; sub postamble { warn <SUPER::const_cccmd(@_); # If perl Makefile.PL *-g* then switch on debugging if ($::opt_g) { s/\s-O\d?\b//; # delete optimise option s/\s-/ -g -/; # add -g option } $_; } sub post_initialize { my($self) = shift; if ($cfg_privlibexp ne $cfg_sitelibexp) { # this block could probably be removed now my %old; File::Find::find( sub { local $_ = $File::Find::name; s:\\:/:g if $os eq 'MSWin32'; $File::Find::prune = 1, return if -d $_ && ( $_ eq $cfg_sitelibexp || $_ eq $cfg_sitearchexp || $_ eq $cfg_man3direxp ); ++$old{$_} if m:\bDB(I|D$):; # DBI files, but just DBD dirs }, $cfg_privlibexp, $cfg_archlibexp ); if ( %old ) { warn " Warning: By default new modules are installed into your 'site_lib' directories. Since site_lib directories come after the normal library directories you must delete old DBI files and directories from your 'privlib' and 'archlib' directories and their auto subdirectories. Reinstall DBI and your DBD::* drivers after deleting the old directories. Here's a list of probable old files and directories: " . join( "\n ", ( sort keys %old ), "\n" ); } } # install files that DBD's may need File::Find::find( sub { # may be '.' or '[]' depending on File::Find version $_ = '.' if $^O eq 'VMS' && $_ eq File::Spec->curdir; $File::Find::prune = 1, return if -d $_ && '.' ne $_; $self->{PM}->{$_} = File::Spec->catfile($self->{INST_ARCHAUTODIR}, $_) if '.h' eq substr( $_, -2 ) || '.xst' eq substr( $_, -4 ); }, '.' ); delete $self->{$_}{"git-svn-vsn.pl"} for qw( PM MAN3PODS ); return ''; } sub post_constants { my($self) = shift; # ensure that Driver.xst and related code gets tested my $xst = main::dbd_postamble(); $xst =~ s/\$\(BASEEXT\)/Perl/g; $xst .= ' dbixs_rev.h: DBIXS.h Driver_xst.h dbipport.h dbivport.h dbixs_rev.pl $(PERL) dbixs_rev.pl DBI.c: Perl$(OBJ_EXT) # make Changes file available as installed pod docs "perldoc DBI::Changes" inst_libdbi = ' . File::Spec->catdir($self->{INST_LIB}, 'DBI') . ' changes_pm = ' . File::Spec->catfile($self->{INST_LIB}, 'DBI', 'Changes.pm') . ' '.q{ config :: $(changes_pm) $(NOECHO) $(NOOP) $(changes_pm): Changes $(MKPATH) $(inst_libdbi) $(RM_F) $(changes_pm) $(CP) Changes $(changes_pm) ptest: all prove --blib --jobs 8 --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. DBI-1.634/MANIFEST000644 000766 000024 00000012512 12557677761 013564 0ustar00timbostaff000000 000000 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 INSTALL MANIFEST Makefile.PL The Makefile generator Perl.xs Test harness (currently) for Driver.xst README.md 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) DBI-1.634/META.json000640 000766 000024 00000003325 12557677761 014052 0ustar00timbostaff000000 000000 { "abstract" : "Database independent interface for Perl", "author" : [ "Tim Bunce (dbi-users@perl.org)" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150005", "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::Amazon" : "0.10", "DBD::AnyData" : "0.110", "DBD::CSV" : "0.36", "DBD::Google" : "0.51", "DBD::PO" : "2.10", "DBD::RAM" : "0.072", "SQL::Statement" : "1.33" }, "requires" : { "perl" : "5.008" } } }, "release_status" : "stable", "resources" : { "homepage" : "http://dbi.perl.org/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/perl5-dbi/dbi" }, "x_IRC" : "irc://irc.perl.org/#dbi", "x_MailingList" : "mailto:dbi-dev@perl.org" }, "version" : "1.634", "x_serialization_backend" : "JSON::PP version 2.27203", "x_suggests" : { "Clone" : 0.34, "DB_File" : 0, "MLDBM" : 0, "Net::Daemon" : 0, "RPC::PlServer" : 0.2001, "SQL::Statement" : 1.402 } } DBI-1.634/META.yml000640 000766 000024 00000002043 12557677761 013676 0ustar00timbostaff000000 000000 --- 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::Amazon: '0.10' DBD::AnyData: '0.110' DBD::CSV: '0.36' DBD::Google: '0.51' DBD::PO: '2.10' DBD::RAM: '0.072' SQL::Statement: '1.33' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150005' 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 requires: perl: '5.008' resources: IRC: irc://irc.perl.org/#dbi MailingList: mailto:dbi-dev@perl.org homepage: http://dbi.perl.org/ license: http://dev.perl.org/licenses/ repository: https://github.com/perl5-dbi/dbi version: '1.634' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' x_suggests: Clone: 0.34 DB_File: 0 MLDBM: 0 Net::Daemon: 0 RPC::PlServer: 0.2001 SQL::Statement: 1.402 DBI-1.634/Perl.xs000644 000766 000024 00000003171 12553726610 013672 0ustar00timbostaff000000 000000 /* 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_iv(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; PERL_UNUSED_VAR(h); 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 DBI-1.634/README.md000644 000766 000024 00000006746 12127517101 013674 0ustar00timbostaff000000 000000 # DBI - The Perl Database Interface. [![Build Status](https://secure.travis-ci.org/perl5-dbi/dbi.png)](http://travis-ci.org/perl5-dbi/dbi/) See [COPYRIGHT](https://metacpan.org/module/DBI#COPYRIGHT) section in DBI.pm for usage and distribution rights. See [GETTING HELP](https://metacpan.org/module/DBI#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. Install the DBI using a installer like cpanm, cpanplus, cpan, or whatever is recommened by the perl distribution you're using. Make sure the DBI tests run successfully before installing. Use the 'perldoc DBI' command to read the DBI documentation. Install the DBD::* driver module you wish to use in the same way. It is often important to read the driver README file carefully. Make sure the driver tests run successfully before installing. 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 You can post to the mailing list without subscribing. (Your first post may be delayed a day or so while it's being moderated.) 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://metacpan.org/ # IF YOU HAVE PROBLEMS: First, read the notes in the INSTALL file. If you can't fix it your self please post details to dbi-users@perl.org. 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 usenet, google groups 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 we're very likely to simply say "upgrade to the latest". You would do yourself a favour by upgrading beforehand. Please remember that we're all busy. Try to help yourself first, then try to help us help you by following these guidelines carefully. Regards, Tim Bunce and the perl5-dbi team. DBI-1.634/t/000750 000766 000024 00000000000 12557677761 012670 5ustar00timbostaff000000 000000 DBI-1.634/test.pl000755 000766 000024 00000012464 12127375757 013751 0ustar00timbostaff000000 000000 #!/usr/local/bin/perl -w # $Id$ # # 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$}."\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. DBI-1.634/typemap000644 000766 000024 00000000100 12127375757 014014 0ustar00timbostaff000000 000000 const char * T_PV imp_xxh_t * T_PTROBJ DBI_imp_data_ * T_PTROBJ DBI-1.634/t/01basics.t000755 000766 000024 00000033471 12453511132 014450 0ustar00timbostaff000000 000000 #!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/separator and maxlen'); is(neat_list([ 1 + 1, "2", undef, "foobarbaz"]), "2, '2', undef, 'foobarbaz'", '... test array argument w/out separator 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; DBI-1.634/t/02dbidrv.t000755 000766 000024 00000016664 12127375757 014507 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/03handle.t000644 000766 000024 00000035201 12162132031 014421 0ustar00timbostaff000000 000000 #!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 statement handle should be in the CachedKids'); ok($sth1->{Active}, '... our first statement 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 statement 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 statement 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 statement 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 statement 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 because 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; DBI-1.634/t/04mods.t000644 000766 000024 00000003507 12127375757 014166 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/05concathash.t000644 000766 000024 00000012511 12127375757 015333 0ustar00timbostaff000000 000000 # 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; DBI-1.634/t/06attrs.t000644 000766 000024 00000035416 12407544027 014354 0ustar00timbostaff000000 000000 #!perl -w use strict; use Test::More; ## ---------------------------------------------------------------------------- ## 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 InactiveDestroy attribute for dbh'); ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy 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'; is delete $dbh->{examplep_private_dbh_attrib}, 42, 'delete on non-private attribute acts like fetch'; is $dbh->{examplep_private_dbh_attrib}, 42, 'value unchanged after delete'; $dbh->{private_foo} = 42; is $dbh->{private_foo}, 42, 'should see private_foo dbh attribute value'; is delete $dbh->{private_foo}, 42, 'delete should return private_foo dbh attribute value'; is $dbh->{private_foo}, undef, 'value of private_foo after delete should be undef'; # 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 InactiveDestroy attribute for drh'); ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy 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'); $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); } done_testing(); 1; # end DBI-1.634/t/07kids.t000644 000766 000024 00000007047 12127375757 014164 0ustar00timbostaff000000 000000 #!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'); DBI-1.634/t/08keeperr.t000644 000766 000024 00000026510 12241133607 014643 0ustar00timbostaff000000 000000 #!perl -w use strict; use Test::More; ## ---------------------------------------------------------------------------- ## 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 corresponding 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; my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i; # 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"; # for a driver which doesn't have its own ping $dbh = DBI->connect('DBI:Sponge:', undef, undef, { PrintError => 0 }); $dbh->STORE(Active => 1); $dbh->set_err(42, "ERROR 42"); is $dbh->err, 42; is $dbh->errstr, "ERROR 42"; ok $dbh->ping, "ping returns true: ".$dbh->ping; is $dbh->err, 42, "err unchanged after ping"; is $dbh->errstr, "ERROR 42", "errstr unchanged after ping"; $dbh->disconnect; $dbh->STORE(Active => 0); $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; my @handlewarn; sub reset_warn_counts { %warn = ( failed => 0, warning => 0 ); @handlewarn = (0,0,0); } reset_warn_counts(); $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'); # ---- reset_warn_counts(); # ---- 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(); # --- reset_warn_counts(); SKIP: { # we could test this with gofer is we used a different keep_err method other than STORE # to trigger the set_err calls skip 'set_err keep_error skipped for Gofer', 2 if $using_dbd_gofer; $dbh->{examplep_set_err} = ""; # set information state cmp_ok($warn{warning}, '==', 0, 'no extra warning generated for set_err("") in STORE'); $dbh->{examplep_set_err} = "0"; # set warning state cmp_ok($warn{warning}, '==', 1, 'warning generated for set_err("0") in STORE'); } # --- # ---- done_testing(); 1; # end DBI-1.634/t/09trace.t000644 000766 000024 00000006652 12127375757 014333 0ustar00timbostaff000000 000000 #!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 DBI-1.634/t/10examp.t000644 000766 000024 00000045570 12553731564 014334 0ustar00timbostaff000000 000000 #!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 => 234; 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); } { # some tests on special cases for the older tables call # uses DBD::NullP and relies on 2 facts about DBD::NullP: # 1) it has a get_info for for 29 - the quote chr # 2) it has a table_info which returns some types and catalogs my $dbhnp = DBI->connect('dbi:NullP:test'); # this special case should just return a list of table types my @types = $dbhnp->tables('','','','%'); ok(scalar(@types), 'we got some table types'); my $defined = grep {defined($_)} @types; is($defined, scalar(@types), 'all table types are defined'); SKIP: { skip "some table types were not defined", 1 if ($defined != scalar(@types)); my $found_sep = grep {$_ =~ '\.'} @types; is($found_sep, 0, 'no name separators in table types') or diag(Dumper(\@types)); }; # this special case should just return a list of catalogs my @catalogs = $dbhnp->tables('%', '', ''); ok(scalar(@catalogs), 'we got some catalogs'); SKIP: { skip "no catalogs found", 1 if !scalar(@catalogs); my $found_sep = grep {$_ =~ '\.'} @catalogs; is($found_sep, 0, 'no name separators in catalogs') or diag(Dumper(\@catalogs)); }; $dbhnp->disconnect; } $dbh->disconnect; ok(!$dbh->{Active}); ok(!$dbh->ping, "ping should return false after disconnect"); 1; DBI-1.634/t/11fetch.t000644 000766 000024 00000005642 12127375757 014315 0ustar00timbostaff000000 000000 #!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 DBI-1.634/t/12quote.t000644 000766 000024 00000003222 12127375757 014352 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/13taint.t000644 000766 000024 00000005451 12127375757 014343 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/14utf8.t000644 000766 000024 00000003226 12127375757 014111 0ustar00timbostaff000000 000000 #!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 DBI-1.634/t/15array.t000644 000766 000024 00000017147 12127375757 014351 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/16destroy.t000644 000766 000024 00000007761 12173223576 014716 0ustar00timbostaff000000 000000 #!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; } } DBI-1.634/t/19fhtrace.t000644 000766 000024 00000014772 12263215224 014633 0ustar00timbostaff000000 000000 #!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 = ; 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 = ; is $result, "Layered logline\n", "... layered fh: trace_msg: $result\n"; $dbh->trace(1, "STDOUT"); # close $trace_file $result = ; is $result, "Layered logline\n", "... layered fh: close doesn't close: $result\n"; $dbh->trace_msg("Next logline\n", 1); $result = ; 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 DBI-1.634/t/20meta.t000644 000766 000024 00000001426 12127375757 014146 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/30subclass.t000644 000766 000024 00000010125 12162132031 015003 0ustar00timbostaff000000 000000 #!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 exaggerate",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 exaggerate/); 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; DBI-1.634/t/31methcache.t000644 000766 000024 00000007025 12453511141 015121 0ustar00timbostaff000000 000000 #!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; skip "weaken itself is buggy on 5.8.1 (magic killbackrefs panic " ."triggered by threads, fixed in 5.8.2)" , 12 unless $] > 5.008001; # 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; DBI-1.634/t/35thrclone.t000644 000766 000024 00000004310 12263215224 015016 0ustar00timbostaff000000 000000 #!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 my $subthread = threads->new(sub {}); # 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 }; $subthread->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) { # 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 }; $thread->join; } pass('... all tests have passed'); 1; DBI-1.634/t/40profile.t000644 000766 000024 00000040220 12265740764 014652 0ustar00timbostaff000000 000000 #!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 = "test_output_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 < -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 (a,b) values (,"")' => [ 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; } DBI-1.634/t/41prof_dump.t000644 000766 000024 00000005513 12127375757 015217 0ustar00timbostaff000000 000000 #!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 = ; 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; DBI-1.634/t/42prof_data.t000644 000766 000024 00000010377 12427410424 015150 0ustar00timbostaff000000 000000 #!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' ); require DBI::Profile; DBI::Profile->import(qw(dbi_time)); # do enough work to avoid 0's on systems that are very fast or have low res timers my $t1 = dbi_time(); foreach (1..20) { $dbh->do("set dummy=$_"); my $sth = $dbh->prepare($sql); for my $loop (1..90) { $sth->execute("."); $sth->fetchrow_hashref; $sth->finish; } $sth->{Profile}->flush_to_disk(); } $dbh->disconnect; undef $dbh; my $t2 = dbi_time(); note sprintf "DBI work done in %fs (%f - %f)", $t2-$t1, $t2, $t1; # 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; DBI-1.634/t/43prof_env.t000644 000766 000024 00000002166 12127375757 015045 0ustar00timbostaff000000 000000 #!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__ DBI-1.634/t/48dbi_dbd_sqlengine.t000644 000766 000024 00000005402 12144655324 016632 0ustar00timbostaff000000 000000 #!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" ); } SKIP: { skip( 'not running with DBIx::ContextualFetch', 2 ) unless eval { require DBIx::ContextualFetch; 1; }; my $dbh; ok ($dbh = DBI->connect('dbi:File:','','', {RootClass => 'DBIx::ContextualFetch'})); is ref $dbh, 'DBIx::ContextualFetch::db', 'root class is DBIx::ContextualFetch'; } done_testing (); DBI-1.634/t/49dbd_file.t000644 000766 000024 00000020004 12531107446 014737 0ustar00timbostaff000000 000000 #!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"); my @tables = sort $dbh->func ("list_tables"); is_deeply (\@tables, [sort "000_just_testing", $tbl], "Listing tables gives test table"); ok ($sth = $dbh->table_info (), "table_info"); @tables = sort { $a->[2] cmp $b->[2] } @{$sth->fetchall_arrayref}; is_deeply (\@tables, [ map { [ undef, undef, $_, 'TABLE', 'FILE' ] } sort "000_just_testing", $tbl ], "table_info gives test table"); SKIP: { $using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 6; 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($dbh->f_new_meta("t_bsgdf_3544G2z", { f_ext => undef, f_dir => $dir, }), "initialize new table (meta) with settings"); my $t_bsgdf_file = File::Spec->catfile (Cwd::abs_path ($dir), "t_bsgdf_3544G2z"); is($t_bsgdf_file, $dbh->f_get_meta ("t_bsgdf_3544G2z", "f_fqfn"), "verify create meta from scratch"); } 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 $dbh->errstr; } 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 $dbh->errstr; } # ==================== ReadOnly tests ============================= ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { f_ext => ".txt", f_dir => $dir, f_schema => undef, f_encoding => $encoding, f_lock => 0, sql_meta => { $tbl => { col_names => [qw(txt)], } }, RaiseError => 0, PrintError => 0, ReadOnly => 1, }), "ReadOnly connect with driver attributes in hash"); 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", 3; ok ($sth->execute, "execute on $tbl"); like ($_, qr{^[0-9]+$}, "TYPE is numeric") for @{$sth->{TYPE}}; like ($_, qr{^[A-Z]\w+$}, "TYPE_NAME is set") for @{$sth->{TYPE_NAME}}; $dbh->errstr and diag $dbh->errstr; } ok ($sth = $dbh->prepare ("insert into $tbl (txt) values (?)"), "prepare 'insert into $tbl'"); is ($sth->execute ("Perl rules"), undef, "insert failed intensionally"); ok ($sth = $dbh->prepare ("delete from $tbl"), "prepare 'delete from $tbl'"); is ($sth->execute (), undef, "delete failed intensionally"); is ($dbh->do ("drop table $tbl"), undef, "table drop failed intensionally"); is (-f $tbl_file, 1, "Test table not removed"); # ==================== ReadWrite again tests ====================== 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, }), "ReadWrite for drop connect with driver attributes in hash"); # XXX add a truncate test ok ($dbh->do ("drop table $tbl"), "table drop"); is (-s $tbl_file, undef, "Test table removed"); # -s => size test # ==================== Nonexisting top-dir ======================== my %drh = DBI->installed_drivers; my $qer = qr{\bNo such directory}; foreach my $tld ("./non-existing", "nonexisting_folder", "/Fr-dle/hurd0k/ok$$") { is (DBI->connect ("dbi:File:", undef, undef, { f_dir => $tld, RaiseError => 0, PrintError => 0, }), undef, "Should not be able to open a DB to $tld"); like ($DBI::errstr, $qer, "Error message"); $drh{File}->set_err (undef, ""); is ($DBI::errstr, undef, "Cleared error"); my $dbh; eval { $dbh = DBI->connect ("dbi:File:", undef, undef, { f_dir => $tld, RaiseError => 1, PrintError => 0, })}; is ($dbh, undef, "connect () should die on $tld with RaiseError"); like ($@, $qer, "croak message"); like ($DBI::errstr, $qer, "Error message"); } 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 DBI-1.634/t/50dbm_simple.t000755 000766 000024 00000020155 12127375757 015341 0ustar00timbostaff000000 000000 #!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;f_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' ); } my $sth = $dbh->table_info(); ok ($sth, "prepare table_info (without tables)"); my @tables = $sth->fetchall_arrayref; is_deeply( \@tables, [ [] ], "No tables delivered by table_info" ); $dbh->disconnect; return 1; } 1; DBI-1.634/t/51dbm_file.t000644 000766 000024 00000013322 12162615070 014743 0ustar00timbostaff000000 000000 #!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 }, } ); my @tbl; @tbl = $dbh->tables (undef, undef, undef, undef); is( scalar @tbl, 1, "Found 1 tables"); $r = $dbh->selectall_arrayref(q/select * from Fred/); ok( @$r == 2, 'rows found after reconnect using "dbm_tables"' ); my $deep_dir = File::Spec->catdir( $dir, 'deep' ); mkpath $deep_dir; $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $deep_dir, sql_identifier_case => 2, # SQL_IC_LOWER } ); ok( $dbh->do( q{create table wilma (a integer, b char (10))} ), "Create wilma" ); ok( $dbh->do( q{insert into wilma values (1, 'Barney')} ), "insert Barney" ); ok( $dbh->disconnect(), "disconnect" ); $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, sql_identifier_case => 2, # SQL_IC_LOWER } ); # Make sure wilma is not found without f_dir_search @tbl = $dbh->tables (undef, undef, undef, undef); is( scalar @tbl, 1, "Found 1 table"); ok( $dbh->disconnect(), "disconnect" ); $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, f_dir_search => [ $deep_dir ], sql_identifier_case => 2, # SQL_IC_LOWER } ); @tbl = $dbh->tables (undef, undef, undef, undef); is( scalar @tbl, 2, "Found 2 tables"); # f_dir should always appear before f_dir_search like( $tbl[0], qr{(?:^|\.)fred$}i, "Fred first" ); like( $tbl[1], qr{(?:^|\.)wilma$}i, "Fred second" ); my( $n, $sth ); ok( $sth = $dbh->prepare( 'select * from fred' ), "select from fred" ); ok( $sth->execute, "execute fred" ); $n = 0; $n++ while $sth->fetch; is( $n, 2, "2 entry in fred" ); ok( $sth = $dbh->prepare( 'select * from wilma' ), "select from wilma" ); ok( $sth->execute, "execute wilma" ); $n = 0; $n++ while $sth->fetch; is( $n, 1, "1 entry in wilma" ); ok( $dbh->do(q/drop table if exists FRED/), 'drop table fred' ); ok( !-f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext removed" ); ok( !-f File::Spec->catfile( $dir, "fred$tblfext" ), "fred$tblfext removed" ); ok( $dbh->do(q/drop table if exists wilma/), 'drop table wilma' ); ok( !-f File::Spec->catfile( $deep_dir, "wilma$dirfext" ), "wilma$dirfext removed" ); ok( !-f File::Spec->catfile( $deep_dir, "wilma$tblfext" ), "wilma$tblfext removed" ); } done_testing(); DBI-1.634/t/52dbm_complex.t000644 000766 000024 00000034405 12127375757 015521 0ustar00timbostaff000000 000000 #!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(); DBI-1.634/t/60preparse.t000755 000766 000024 00000010672 12127375757 015053 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/65transact.t000644 000766 000024 00000001202 12127375757 015040 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/70callbacks.t000644 000766 000024 00000017475 12407554544 015151 0ustar00timbostaff000000 000000 #!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 } $| = 1; my $dsn = "dbi:ExampleP:drv_foo=drv_bar"; 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'; ok tied(%{$_[0]}), '$dbh is tied (outer) handle' or DBI::dump_handle($_[0], 'tied?', 10); $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 $driver_dsn = (DBI->parse_dsn($dsn))[4] or die 'panic'; my @args = ( $dsn, 'u', 'p', { Callbacks => { "connect_cached.new" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.new $h is tied (outer) handle' if $dbh; # $dbh is typically undef or a dead/disconnected $dbh like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{new}++; return; }, "connect_cached.reused" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.reused $h is tied (outer) handle'; like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{cached}++; return; }, "connect_cached.connected" => sub { my ($dbh, $cb_dsn, $user, $auth, $attr) = @_; ok tied(%$dbh), 'connect_cached.connected $h is tied (outer) handle'; like $cb_dsn, qr/\Q$driver_dsn/, 'dsn'; is $user, 'u', 'user'; is $auth, 'p', 'pass'; $called{connected}++; 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"; is $called{connected}, 1, "connect_cached.connected 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"; is $called{connected}, 1, "connect_cached.connected not called called"; # --- 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'; # stress test for stack reallocation and mark handling -- RT#86744 my $stress_count = 3000; my $place_holders = join(',', ('?') x $stress_count); my @params = ('t') x $stress_count; my $stress_dbh = DBI->connect( 'DBI:NullP:test'); my $stress_sth = $stress_dbh->prepare("select 1"); $stress_sth->{Callbacks}{execute} = sub { return; }; $stress_sth->execute(@params); done_testing(); __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).. DBI-1.634/t/72childhandles.t000644 000766 000024 00000007200 12127375757 015645 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/80proxy.t000644 000766 000024 00000032602 12127375757 014407 0ustar00timbostaff000000 000000 #!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; DBI-1.634/t/85gofer.t000644 000766 000024 00000022534 12162132031 014307 0ustar00timbostaff000000 000000 #!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_lock => 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 dependent 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; $use_remote = 1; # XXX since DBI::DBD::SqlEngine::db implements own data_sources this is always done remotely note sprintf "use_remote=%s (policy=%s, transport=%s) %s", $use_remote, $policy_name, $transport, DBI::neat($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; DBI-1.634/t/86gofer_fail.t000644 000766 000024 00000013411 12127375757 015326 0ustar00timbostaff000000 000000 #!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; } DBI-1.634/t/87gofer_cache.t000644 000766 000024 00000006047 12127375757 015466 0ustar00timbostaff000000 000000 #!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 "\n --- 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 $expected 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 0 round trip'; is $go_transport->cache_hit, $expected, 'cache_hit'; is $go_transport->cache_miss, $expected, 'cache_miss'; is $go_transport->cache_store, $expected, 'cache_store'; } 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; DBI-1.634/t/90sql_type_cast.t000644 000766 000024 00000013114 12127375757 016076 0ustar00timbostaff000000 000000 # $Id$ # 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); # This test is about quotation of the value, not about the # style/formatting of JSON. Strip all leading/trailing # whitespace that is not part of the test, treating '[99]' # identical to ' [ 99 ] ' or '[99 ]' $json =~ s{^\s*\[\s*(.*?)\s*\]\s*$}{[$1]}; 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; DBI-1.634/t/lib.pl000644 000766 000024 00000001460 12162132031 013741 0ustar00timbostaff000000 000000 #!/usr/bin/perl # lib.pl is the file where database specific things should live, # wherever 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; DBI-1.634/t/pod-coverage.t000644 000766 000024 00000000464 12127375757 015432 0ustar00timbostaff000000 000000 #!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(); DBI-1.634/t/pod.t000644 000766 000024 00000000220 12127375757 013627 0ustar00timbostaff000000 000000 #!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; DBI-1.634/lib/Bundle/000750 000766 000024 00000000000 12557677761 014404 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBD/000750 000766 000024 00000000000 12557677761 013564 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/000750 000766 000024 00000000000 12557677761 013571 5ustar00timbostaff000000 000000 DBI-1.634/lib/Win32/000750 000766 000024 00000000000 12557677761 014075 5ustar00timbostaff000000 000000 DBI-1.634/lib/Win32/DBIODBC.pm000644 000766 000024 00000010664 12531110275 015443 0ustar00timbostaff000000 000000 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 erroneous 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 something 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 basic I 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 =cut DBI-1.634/lib/DBI/Const/000750 000766 000024 00000000000 12557677761 014657 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/DBD/000750 000766 000024 00000000000 12557677761 014162 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/DBD.pm000644 000766 000024 00000367112 12553730414 014514 0ustar00timbostaff000000 000000 package DBI::DBD; # vim:ts=8:sw=4 use strict; 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 = "12.015129"; # $Id: DBD.pm 15128 2012-02-04 20:51:39Z Tim $ # # 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 a minimal draft which is in need of further work. Please read the B documentation first and fully. Then look at the implementation of some high-profile and regularly maintained drivers like DBD::Oracle, DBD::ODBC, DBD::Pg etc. (Those are no no particular order.) Then reread the B specification and the code of those drivers again as you're reading this. It'll help. Where this document and the driver code differ it's likely that the driver code is more correct, especially if multiple drivers do the same thing. 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 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 doubt at all, please do contact the I 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 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 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) is the way to go.] The second rule for creating a new database driver for the Perl DBI is also very simple: B 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 software and information is http://dbi.perl.org/ There are two main and one auxiliary mailing lists for people working with B. The primary lists are I for general users of B and B drivers, and I mainly for B driver writers (don't join the I list unless you have a good reason). The auxiliary list is I for announcing new releases of B or B drivers. You can join these lists by accessing the web-site L. 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 newsgroups, especially I. =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' 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. 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 and B links at the top to see those subsets. See the B docs for information on B 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 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 has the name I and the prefix 'I'. The prefix must be lowercase and contain no underscores other than the one at the end. This information will be recorded in the B module. Apart from documentation purposes, registration is a prerequisite for L. If you are writing a driver which will not be distributed on CPAN, then you should choose a prefix beginning with 'I', to avoid potential prefix collisions with drivers registered in the future. Thus, if you wrote a non-CPAN distributed driver called B, the prefix might be 'I'. This document assumes you are writing a driver called B, and that the prefix 'I' 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 and B. 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, these files are: =over 4 =item * F =item * F =item * F =item * F =item * F =item * F =item * F =item * F =back The first four files are mandatory. F is used to control how the driver is built and installed. The F file tells people who download the file about how to build the module and any prerequisite software that must be installed. The F 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 is what is loaded by the B code; it contains the methods peculiar to your driver. Although the F file is not B you are advised to create one. Of particular importance are the I and I 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. You can find a reasonable example of a F in DBD::ODBC. The F 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 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 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'. =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 that depends upon the successful running of F, people cannot run the single test case F. Further, running F twice in a row is likely to fail (at least, if F 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 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 for any of a variety of different reasons, such as to support the metadata methods (see the discussion of L below). Such sub-modules are conventionally stored in the directory F. The module itself would usually be in a file F. 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 =item * F =item * F =item * F =back The F 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 header is a stylized header that ensures you can access the necessary Perl and B macros, types, and function declarations. The F is used to specify which functions have been implemented by your driver. The F 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 and F 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 and L). 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 and B. As an example we take a look at the B driver, a driver for accessing plain files as tables, which is part of the B package. The minimal set of files we have to implement are F, F, F and F. =head2 Pure Perl version of Makefile.PL You typically start with writing F, a Makefile generator. The contents of this file are described in detail in the L man pages. It is definitely a good idea if you start reading them. At least you should know about the variables I, I, I, I, I, I, I, I, I, I, I, I, I, I, I, I from the L man page: these are used in almost any F. Additionally read the section on I and the descriptions of the I, I and I targets: They will definitely be useful for you. Of special importance for B drivers is the I method from the L man page. For Emacs users, I recommend the I 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 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 and C. The second hash reference in the call to C (containing C) 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 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. Note that the C code will fail if you do not have a F sub-directory containing at least one test case. I 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 below for why this does not work reliably in stopping cpan testers failing your module if DBI is not installed. I is a subroutine called by MakeMaker during C. By putting the C 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 but I does not cause C to fail (unless you also specify PREREQ_FATAL which is strongly discouraged by MakeMaker) so C would continue to call C and fail. All drivers must use C or risk running into problems. Note the specification of I; the named file (F) 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 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. If you need to check for the existence of an external library and perhaps modify I 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 (success) B calling C or CPAN testers will fail your module if the external library is not found. A full-fledged I can be quite large (for example, the files for B and B are both over 1000 lines long, and the Informix one uses - and creates - auxiliary modules too). See also L and L. Consider using L in place of I. =head2 README The L 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 from one of the established drivers as a basis for your own; the version in B 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 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 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 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; 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 section, with the official name of the module followed by a dash and an informal name or description. =over 4 =item * Listing B 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 =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 =head1 SEE ALSO Bundle::DBI =head1 AUTHOR Your Name EFE =head1 THANKS This bundle was created by ripping off Bundle::libnet created by Graham Barr EFE, and radically simplified with some information from Jochen Wiedmann EFE. The template was then included in the DBI::DBD documentation by Jonathan Leffler EFE. =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 or B or B, to name but three), and adapting it to describe the facilities available via B when accessing the Driver database. =head2 Pure Perl version of Driver.pm The F file defines the Perl module B for your driver. It will define a package B along with some version information, some variable definitions, and a function C which will have a more or less standard structure. It will also define three sub-packages of B: =over 4 =item DBD::Driver::dr with methods C, C and C; =item DBD::Driver::db with methods such as C; =item DBD::Driver::st with methods such as C and C. =back The F file will also contain the documentation specific to B in the format used by perldoc. In a pure Perl driver, the F file is the core of the implementation. You will need to provide all the key methods needed by B. Now let's take a closer look at an excerpt of F as an example. We ignore things that are common to any module (even non-DBI modules) or really specific to the B 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 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 = "12.012346"; (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 = "11.22"; 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 method is the driver handle constructor. Note that the C method is in the B package, not in one of the sub-packages B, B, or B. 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 implements its handles. There are three kinds: B (typically stored in I<$drh>; from now on called I or I<$drh>), B (from now on called I or I<$dbh>) and B (from now on called I or I<$sth>). The prototype of C 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 method. =item I<$public_attrs> is a hash ref to attributes like I, I, and I. These are processed and used by B. 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 will store them and otherwise leave them alone. =back The C method and the C method both return C 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', and for DBD::AnyData it must begin with 'C'. 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 package, is a C method that will be called by perl when an interpreter is cloned. All your C 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 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 classes, because the B 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 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 above. The arguments are described in L. The constructor C 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, except that the I<$class> is replaced by I<$drh>. The I attribute is a standard B attribute (see L). In scalar context, only the outer handle is returned. Note the use of the C method for setting the I 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 like I, don't actually exist in the hash and must be read via C<$h-EFETCH($attrib)> and set via C<$h-ESTORE($attrib, $value)>. If in any doubt, use these methods. =head4 The data_sources() method The C method must populate and return a list of valid data sources, prefixed with the "I" incantation that allows them to be used in the first argument of the Cconnect()> 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 for example, you might catch an error when setting the current directory to something not existent by using the (driver-specific) I attribute. To report an error, you use the C method: $h->set_err($err, $errmsg, $state); This will ensure that the error is recorded correctly and that I and I etc are handled correctly. Typically you'll always use the method instance, aka your method's first argument. As C always returns C 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 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. Again, in scalar context, only the outer handle is returned. The I attribute should be cached as shown. Note the prefix I 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 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. 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 in the C method instead because the B specification explicitly allows a driver to defer this, but then the user could not call C. =head4 Transaction handling Pure Perl drivers will rarely support transactions. Thus your C and C 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 that do nothing except return C. The B's default C 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 for details on tied hash refs to understand why these methods are required. The B will handle most attributes for you, in particular attributes like I or I. All you have to do is handle your driver's private attributes and any attributes, like I and I, that the B 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 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 and C 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 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 method and possibly a C method if B's default isn't correct for you. You may also need the C and C methods, as described elsewhere in this document. Where reasonable use C<$h-ESUPER::foo()> to call the B'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 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 methods to function correctly (see L below). We present a simplified implementation by using the I 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 and I attributes here, because they are essential for C to work. We use attribute C<$sth-E{Statement}> which we created within C. The attribute C<$sth-E{Database}>, which is nothing else than the I, was automatically created by B. Finally, note that (as specified in the B 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 and C. DBI's default C will invoke the DBD's C as needed. The following sequence describes the interaction between DBI C and a DBD's C: =over =item 1 App calls C<$sth-Eexecute_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. Alternately, App may have directly called C =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, 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'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 named placeholders must either emulate positional placeholders (e.g., see L), 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. The other methods, C, C, etc, as well as the database handle's C methods are part of B, and call C 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 and C work. If an error occurs which leaves the I<$sth> in a state where remaining rows can't be fetched then I should be turned off before the method returns. The C 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'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) 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 and I attributes is, that you should implement a lot of attributes here that are required by the B, such as I, I, I, etc. See L for a complete list. Pay attention to attributes which are marked as read only, such as I. 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 and I 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 is I. Many B methods, including C, depend on this attribute. Besides that the C and C methods are mainly the same as above for I's. =head4 Other statement methods A trivial C method to discard stored data, reset any attributes (such as I) and do C<$sth-ESUPER::finish()>. If you've defined a C 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 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. If C is called on a statement handle that's still active (C<$sth-E{Active}> is true) then it should effectively call C. 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 sub-directory, and should simply produce an C when run under C. For details on how this is done, see the Camel book and the section in Chapter 7, "The Standard Perl Library" on L. 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 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 code and look at the code in F which is used throughout the B tests in the F sub-directory. =head1 CREATING A C/XS DRIVER Please also see the section under L regarding the creation of the F. 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 written by Tim Bunce, who is also the author of the B package. The B module is a good example of a driver implemented around a C-level API. Nowadays it it seems better to base on B, 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 digs deeper into the Oracle 8 OCI interface it'll get even more hairy than it is now.) The B driver is one driver implemented using embedded SQL instead of a function-based API. B may also be worth a look. =head2 C/XS version of Driver.pm A lot of the code in the F 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, C, C, C and the C and C methods. =item * Other methods are still part of F, but have callbacks to the XS code. =item * If the driver-specific parts of the I 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, and you define the corresponding function in F, and you define the C code in F and the prototype in F. For example, B has such a requirement, and adds the following call after the call to C<_new_drh()> in F: DBD::Informix::dr::driver_init($drh); and the following code in F: # 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 declares: extern int dbd_ix_dr_driver_init(SV *drh); and the code in F (equivalent to F) 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 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 (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 (you should not implement it) and calls C or C from F. 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 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 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 method must call onto compiled functions, then you will need to define I in your F file, which will trigger F (in B 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 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 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 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 here: B 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, 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 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 /* installed by the DBI module */ #include "dbdimp.h" #include "dbivport.h" /* see below */ #include /* installed by the DBI module */ #endif /* DRIVER_H_INCLUDED */ The F header defines most of the interesting information that the writer of a driver needs. The file F header provides prototype declarations for the C functions that you might decide to implement. Note that you should normally only define one of C, C or C unless you are intent on supporting really old versions of B (prior to B 1.06) as well as modern versions. The only standard, B-mandated functions that you need write are those specified in the F header. You might also add extra driver-specific functions in F. The F file should be I from the latest B 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 API while still allowing your driver to be compiled and used with older versions of the B (for example, when the C macro was added to B 1.41, an emulation of it was added to F). This makes users happy and your life easier. Always read the notes in F to check for any limitations in the emulation that you should be aware of. With B v1.51 or better I recommend that the driver defines I before F 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 is defined, then every function that calls the Perl API will need to start out with a C declaration. =item * You'll know which functions need this, because the C compiler will complain that the undeclared identifier C is used if I 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 with C prepended to the parameter list and then C prepended to the argument list where the function is called. =back See L for additional information about I. =head2 Implementation header dbdimp.h This header file has two jobs: First it defines data structures for your private part of the handles. Note that the DBI provides many common fields for you. For example the statement handle (imp_sth) already has a row_count field with an IV type that accessed via the DBIc_ROW_COUNT(imp_sth) macro. Using this is strongly recommended as it's built in to some DBI internals so the DBI can 'just work' in more cases and you'll have less driver-specific code to write. Study DBIXS.h to see what's included with each type of handle. Second it defines macros that rename the generic names like C to database specific names like C. 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 function is not passed the attribute hash. Since B v1.06, if a C 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 post v1.607, if a C 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. Similarly defining dbd_db_do4_iv is prefered over dbd_db_do4, dbd_st_rows_iv over dbd_st_rows, and dbd_st_execute_iv over dbd_st_execute. The *_iv forms are declared to return the IV type instead of an int. People used to just pick Oracle's F 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 specific parts, Oracle specific parts, mSQL specific parts and mysql specific parts in B's I and I. (B was a port of B which was based on B.) [Seconded, based on the experience taking B apart, even though the version inherited in 1996 was only based on B.] This part of the driver is I. 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 to use the name C and the first field I be of type I and I be called C. You should never access these fields directly, except by using the I macros below. =head2 Implementation source dbdimp.c Conventionally, F is the main implementation file (but B calls the file F). This section includes a short note on each function that is used in the F template and thus I 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. If they are placed in other files, you need to list those files in F (and F) 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, you might call externally visible functions I. 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 or the mapped names such as C in the F file. B 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, 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 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 header. The exceptions are optional functions (such as C) and those functions with alternative signatures, such as C, C and I. 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 function will be called when your driver is first loaded; the bootstrap command in C triggers this, and the call is generated in the I section of F. These statements are needed to allow your driver to use the B macros. They will include your private header file F in turn. Note that I requires the name of the argument to C to be called C. =head3 The dbd_drv_error method You need a function to record errors so B can access them properly. You can call it whatever you like, but we'll call it C 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 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 with a pointer to your private handle pointer. You may cast this to to I, I or I. To record the error correctly, equivalent to the C method, use one of the C or C macros, which were added in B 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 the I, I, I, and I parameters are C (use &sv_undef instead of NULL). For C the I, I, I, I parameters are C. The I parameter is an C that's used instead of I if I is C. The I parameter can be ignored. The C 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. To make drivers compatible with B < 1.41 you should be using F as described in L above. The (obsolete) macros such as C should be removed from drivers. The names C and C, which were used in previous versions of this document, should be replaced with the C macro. The name C, which was also used in previous versions of this document, should be replaced by C. Your code should not call the C Cstdio.hE> I/O functions; you should use C 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 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. You can define up to 8 private trace flags using the top 8 bits of C, that is: C<0xFF000000>. See the C method elsewhere in this document. =head3 The dbd_dr_data_sources method This method is optional; the support for it was added in B v1.33. As noted in the discussion of F, if the data sources can be determined by pure Perl code, do it that way. If, as in B, 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 follows, assuming that the C 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 implementation has a number of extra lines of code, logs function entry and exit, reports the error from C, 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 is the database handle. I is the pointer to the handles private data, as is I in C above. The arguments I, I, I and I correspond to the arguments of the driver handle's C 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 method and pass the segments of the DSN via the attributes parameter through C<_login()> to C. Here's how you fetch them; as an example we use I 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 (as above with DBD_ATTRIB_DELETE). If you don't delete your handled attributes DBI will call C for each attribute after the connect/login and this is at best redundant for attributes you have already processed. B hv_delete((HV*)SvRV(attr), key, key_len, G_DISCARD) Note that you can also obtain standard attributes such as I and I from the attributes parameter, using C for integer attributes. If, for example, your database does not support transactions but I 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 structure and that the implementors private C 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 function should be called before the handle is destroyed. Note that if you do need to fail, you should report errors via the I or I rather than via I or I because I will be destroyed by the failure, so errors recorded in that handle will not be visible to B, and hence not the user either. Note too, that the function is passed I and I, and there is a macro C which can recover the I from the I. However, there is no B macro to provide you with the I given either the I or the I or the I (and there's no way to recover the I given just the I). This suggests that, despite the above notes about C taking an C, it may be better to have two error routines, one taking I and one taking I 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 1.05.00 for more information. The C function should return I for success, I otherwise. Drivers implemented long ago may define the five-argument function C instead of C. 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 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 for success, I for error. The arguments I and I are the same as for C above; I will omit describing them in what follows, as they appear always. These functions should return I for success, I otherwise. =head3 The dbd_db_disconnect method This is your private part of the C method. Any I with the I flag on must be disconnected. (Note that you have to set it in C above.) int dbd_db_disconnect(SV* dbh, imp_dbh_t* imp_dbh); The database handle will return I for success, I otherwise. In any case it should do a: DBIc_ACTIVE_off(imp_dbh); before returning so B knows that C was executed. Note that there's nothing to stop a I being I while it still have active children. If your database API reacts badly to trying to use an I in this situation then you'll need to add code like this to all I 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. 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 for success, I 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 for success, I 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 with the I flag on must be destroyed, so that you can safely free resources. (Note that you have to set it in C above.) void dbd_db_destroy(SV* dbh, imp_dbh_t* imp_dbh) { DBIc_IMPSET_off(imp_dbh); } The B F code will have called C for you, if the handle is still 'active', before calling C. Before returning the function must switch I to off, so B knows that the destructor was called. A B handle doesn't keep references to its children. But children do keep references to their parents. So a database handle won't be C'd until all its children have been C'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 attributes here: leave this to B. (There are two exceptions, I and I, which you should care about.) The return value is I if you have handled the attribute or I otherwise. If you are handling an attribute and something fails, you should call C, so B can raise exceptions, if desired. If C returns, however, you have a problem: the user will never know about the error, because he typically will not check C<$dbh-Eerrstr()>. I cannot recommend a general way of going on, if C returns, but there are examples where even the B specification expects that you C. (See the I method in L.) If you have to store attributes, you should either use your private data structure I, the handle hash (via C<(HV*)SvRV(dbh)>), or use the private I. 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 is an additional C 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, 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 with the value. Note that you should normally execute C, if you return a nonconstant value. (Constant values are C<&sv_undef>, C<&sv_no> and C<&sv_yes>.) Note, that B implements a caching algorithm for attribute values. If you think, that an attribute may be fetched, you store it in the I 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 method. Note that you B 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 code that set the I attribute on the handle. This attribute can then be used by C. If the driver supports placeholders then the I attribute must be set correctly by C: DBIc_NUM_PARAMS(imp_sth) = ... If you can, you should also setup attributes like I, I, etc. here, but B 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 flag, as you did in C 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 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 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, I, etc when the statement is successfully executed if the driver has not already done so: they may be used even before a potential C. In particular you have to tell B the number of fields that the statement has, because it will be used by B 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 flag only be set for C statement? Count them. Read the DBI docs for the C 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 entering 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 database handle can fetch using the C 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 provided no column values were larger than the specified value. If the BLOB data is longer than the value of C, 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 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 attribute which is set to a false value by default ( 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, an Oracle database, you can use C<$dbh>->C to immediately execute the procedure. For example, $dbh->do( "BEGIN someProcedure; END;" ); # Oracle-specific You should also be able to C and C, 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 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 essentially I 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 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 or C a statement with DBI? See the C and C 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 values handled by DBI? C values in DBI are specified to be treated as the value C. Cs can be inserted into databases as C, for example: $rv = $dbh->do( "INSERT INTO table VALUES( NULL )" ); but when queried back, the Cs should be tested against C. This is standard across all drivers. =head2 5.8 What are these C methods all about? The C method is defined within DBI as being an entry point for database-specific functionality, I, the ability to create or drop databases. Invoking these driver-specific methods is simple, for example, to invoke a C method that has one argument, we would write: $rv =$dbh->func( 'argument', 'createDatabase' ); Software developers should note that the C 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 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. =head2 Commercial Support =over 4 =item The Perl Clinic The Perl Clinic provides commercial support for I and Perl related problems, including the I and its drivers. Support is provided by the company with whom Tim Bunce, author of I and I, 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 and I 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 DBI-1.634/lib/DBI/Gofer/000750 000766 000024 00000000000 12557677761 014633 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/Profile.pm000644 000766 000024 00000077510 12407536674 015535 0ustar00timbostaff000000 000000 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 and L. For Apache/mod_perl applications see L. =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. =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 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' 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'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 method called. If not present it defaults to DBI::Profile. Any other values are passed as arguments to the C 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 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 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 Use the name of the DBI method that the profile sample relates to. B 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 Use a string showing the filename and line number of the code calling the method. B 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 Same as !Caller above except that only the filename is included, not the line number. B Same as !Caller2 above except that only the filenames are included, not the line number. B Use the current value of time(). Rarely used. See the more useful C below. B Where C 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. 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 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 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 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. =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 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 and arguments are passed to as_node_path_list(). The C argument is used to join the elements of the path for each leaf node. The C 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 argument is a C 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 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 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 end 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 = "2.015065"; @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; # silently 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; ++$idx; if ($format_path_element eq "%s") { $_ = sprintf $format_path_element, $_; } else { $_ = 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; DBI-1.634/lib/DBI/ProfileData.pm000644 000766 000024 00000047020 12162132031 016271 0ustar00timbostaff000000 000000 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 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 = "2.010008"; 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 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. =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. =head3 Filter The C 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 and all quoted strings to C. 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. =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 forced 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 (different program or path) $self->{_header}{$1} = unescape_key($2) if $keep; } } sub unescape_key { # inverse of escape_key() in DBI::ProfileDumper local $_ = shift; s/(?{_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 = <[TOTAL] / $node->[COUNT]) . $keys; } else { $format = <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 = <{_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(<{_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 =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 DBI-1.634/lib/DBI/ProfileDumper/000750 000766 000024 00000000000 12557677761 016346 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/ProfileDumper.pm000644 000766 000024 00000024222 12162132031 016653 0ustar00timbostaff000000 000000 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) with L: 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 which dumps profile data to disk instead of printing a summary to your screen. You can then use L to analyze the data in a number of interesting ways, or you can roll your own analysis using L. B For Apache/mod_perl applications, use L. =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. 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 option takes the same values as in L. The C 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 written 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 option to L 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 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 =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 = "2.015325"; 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; DBI-1.634/lib/DBI/ProfileSubs.pm000644 000766 000024 00000002220 12162132031 016325 0ustar00timbostaff000000 000000 package DBI::ProfileSubs; our $VERSION = "0.009396"; =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//g; # 42 -> s/\b0x[0-9A-Fa-f]+\b//g; # 0xFE -> s/'.*?'/''/g; # single quoted strings (doesn't handle escapes) s/".*?"/""/g; # double quoted strings (doesn't handle escapes) # convert names like log20001231 into log s/([a-z_]+)(\d{3,})\b/${1}/ig; # abbreviate massive "in (...)" statements and similar s!((\s*<[NS]>\s*,\s*){100,})!sprintf("$2,",length($1)/2)!eg; return $_; } 1; DBI-1.634/lib/DBI/ProxyServer.pm000644 000766 000024 00000063535 12407541171 016433 0ustar00timbostaff000000 000000 # $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. The provided driver script, L, 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. See L. Available options include =over 4 =item I (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 An array ref with a list of clients. Clients are hash refs, the attributes I (0 for denying access and 1 for permitting) and I, a Perl regular expression for the clients IP number or its host name. =item I (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 (B<--debug>) Turn debugging mode on. Mainly this asserts that logging messages of level "debug" are created. =item I (B<--facility=mode>) (UNIX only) Facility to use for L. The default is B. =item I (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 (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 (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 (B<--logfile=file>) Be default logging messages will be written to the syslog (Unix) or to the event log (Windows NT). On other operating systems you need to specify a log file. The special value "STDERR" forces logging to stderr. See L for details. =item I (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 (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 (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 (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 which is, in turn, built on L. You should refer to L 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 or I 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 # then 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 detailed 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 whether 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 omitting "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 SECURITY WARNING L used underneath is not secure due to serializing and deserializing data with L module. Use the proxy driver only in trusted environment. =head1 AUTHOR Copyright (c) 1997 Jochen Wiedmann Am Eisteich 9 72555 Metzingen Germany Email: joe@ispsoft.de Phone: +49 7123 14881 The DBI::ProxyServer module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. In particular permission is granted to Tim Bunce for distributing this as a part of the DBI. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L DBI-1.634/lib/DBI/PurePerl.pm000644 000766 000024 00000113140 12407544506 015652 0ustar00timbostaff000000 000000 ######################################################################## 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 with cc to # ######################################################################## 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 = "2.014286"; $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; #/* do nothing 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 = DBI::_err_hash($h); }; } else { my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) ? q{= ($h->{dbi_pp_parent}->{dbi_pp_call_depth} && DBI::_err_hash($h)) } : ""; push @pre_call_frag, qq{ my \$keep_error $ke_init; }; my $clear_error_code = q{ #warn "$method_name cleared err"; $h->{err} = $DBI::err = undef; $h->{errstr} = $DBI::errstr = undef; $h->{state} = $DBI::state = ''; }; $clear_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; }. $clear_error_code if exists $ENV{DBI_TRACE}; push @pre_call_frag, ($ke_init) ? qq{ unless (\$keep_error) { $clear_error_code }} : $clear_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{ if ($keep_error) { $keep_error = 0 if $h->{ErrCount} > $ErrCount or DBI::_err_hash($h) ne $keep_error; } $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$/) { # is sth $h_inner->{Database} = $parent; $parent->{Statement} = $h_inner->{Statement}; $h_inner->{NUM_OF_PARAMS} = 0; $h_inner->{Active} = 0; # driver sets true when there's data to fetch } elsif (ref($parent) =~ /::dr$/){ # is dbh $h_inner->{Driver} = $parent; $h_inner->{Active} = 0; } else { warn "panic: ".ref($parent); # should never happen } $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} = 1; $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->{Active} = 1; } $h_inner->{"dbi_pp_call_depth"} = 0; $h_inner->{"dbi_pp_pid"} = $$; $h_inner->{ErrCount} = 0; } 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; } sub _err_hash { return 1 unless defined $_[0]->{err}; return "$_[0]->{err} $_[0]->{errstr}" } 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 DELETE { my ($h, $key) = @_; return $h->FETCH($key) unless $key =~ /^private_/; return delete $h->{$key}; } 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 ending 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 with a cc to . =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 environment 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. =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 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 DBI-1.634/lib/DBI/SQL/000750 000766 000024 00000000000 12557677761 014230 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/Util/000750 000766 000024 00000000000 12557677761 014506 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/W32ODBC.pm000644 000766 000024 00000011000 12147372762 015113 0ustar00timbostaff000000 000000 package DBI; # hide this non-DBI package from simple indexers # $Id: W32ODBC.pm 8696 2007-01-24 23:12:38Z Tim $ # # 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'} }; ## certain 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; DBI-1.634/lib/DBI/Util/_accessor.pm000644 000766 000024 00000003202 12162132031 016747 0ustar00timbostaff000000 000000 package DBI::Util::_accessor; use strict; use Carp; our $VERSION = "0.009479"; # 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; DBI-1.634/lib/DBI/Util/CacheMemory.pm000644 000766 000024 00000004425 12162132031 017212 0ustar00timbostaff000000 000000 package DBI::Util::CacheMemory; # $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z Tim $ # # 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 destroy the data. =head1 METHODS WITH CHANGES =head2 new All options except C 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 = "0.010315"; 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; DBI-1.634/lib/DBI/SQL/Nano.pm000644 000766 000024 00000072763 12162141233 015451 0ustar00timbostaff000000 000000 ####################################################################### # # 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 = "1.015544"; $versions->{nano_version} = $VERSION; if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.400' } ) { @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; defined $2 and $2 ne "" and $self->{column_names} = parse_coldef_list($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; defined $1 and $1 ne "" and $self->{ignore_missing_table} = 1; }; /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is && do { $self->{command} = 'SELECT'; defined $1 and $1 ne "" and $self->{column_names} = parse_comma_list($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; defined $2 and $2 ne "" and $self->{column_names} = parse_comma_list($2); defined $4 and $4 ne "" and $self->{values} = $self->parse_values_list($4); $self->{values} or croak "Can't parse values"; }; /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is && do { $self->{command} = 'DELETE'; $self->{table_name} = $1; defined $3 and $3 ne "" and $self->{where_clause} = $self->parse_where_clause($3); }; /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is && do { $self->{command} = 'UPDATE'; $self->{table_name} = $1; defined $2 and $2 ne "" and $self->parse_set_clause($2); defined $3 and $3 ne "" and $self->{where_clause} = $self->parse_where_clause($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); my $all_columns = $table->{col_names}; $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; $cNum or croak "Bad col names in INSERT"; my $maxCol = $#$all_columns; for ( $i = 0; $i < $cNum; $i++ ) { $col = $self->{column_names}->[$i]; $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i); } # Extend row to put values in ALL fields $#$array < $maxCol and $array->[$maxCol] = undef; $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]; } return wantarray ? @{ $self->{"params"} } : 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 minimal SQL engine for use in situations where SQL::Statement is not available. In most situations you are better off installing L although DBI::SQL::Nano may be faster for some B 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, L, L, and L. 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] | CREATE TABLE | INSERT INTO [] VALUES | DELETE FROM [] | UPDATE SET | SELECT FROM [] [] 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 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 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 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 DBI-1.634/lib/DBI/ProfileDumper/Apache.pm000644 000766 000024 00000014631 12162132031 020037 0ustar00timbostaff000000 000000 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: PerlSetEnv DBI_PROFILE 2/DBI::ProfileDumper::Apache (If you're using mod_perl2, see L 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 files in your Apache log directory. Get a profiling report with L: 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: 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 for more possibilities, and L 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 value when creating the profile (like C in the L docs), or you can use the C 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 env var, or enable the mod_perl2 C 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 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 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 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 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 =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 = "2.014121"; 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; DBI-1.634/lib/DBI/Gofer/Execute.pm000644 000766 000024 00000074634 12162132031 016556 0ustar00timbostaff000000 000000 package DBI::Gofer::Execute; # $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $ # # 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 = "0.014283"; 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 attributes 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 preceded 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" namespace. Examples include: L and L. =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 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 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. =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. 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 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 configuration item, or else the DBI_GOFER_RANDOM environment variable. =head2 DBI_GOFER_RANDOM The value of the C 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. 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. 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) 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" will mean every fifth call will fail. Each method has a distinct sequence number. =head1 AUTHOR Tim Bunce, L =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. =cut DBI-1.634/lib/DBI/Gofer/Request.pm000644 000766 000024 00000012164 12162132031 016572 0ustar00timbostaff000000 000000 package DBI::Gofer::Request; # $Id: Request.pm 12536 2009-02-24 22:37:09Z Tim $ # # 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 = "0.012537"; 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 =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. =cut DBI-1.634/lib/DBI/Gofer/Response.pm000644 000766 000024 00000014123 12162132031 016735 0ustar00timbostaff000000 000000 package DBI::Gofer::Response; # $Id: Response.pm 11565 2008-07-22 20:17:33Z Tim $ # # 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 = "0.011566"; 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 =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. =cut DBI-1.634/lib/DBI/Gofer/Serializer/000750 000766 000024 00000000000 12557677761 016744 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/Gofer/Transport/000750 000766 000024 00000000000 12557677761 016627 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/Gofer/Transport/Base.pm000644 000766 000024 00000011664 12162132031 020014 0ustar00timbostaff000000 000000 package DBI::Gofer::Transport::Base; # $Id: Base.pm 12536 2009-02-24 22:37:09Z Tim $ # # 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 = "0.012537"; __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. This is an internal class. =head1 AUTHOR Tim Bunce, L =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. =cut DBI-1.634/lib/DBI/Gofer/Transport/pipeone.pm000644 000766 000024 00000002466 12162132031 020601 0ustar00timbostaff000000 000000 package DBI::Gofer::Transport::pipeone; # $Id: pipeone.pm 12536 2009-02-24 22:37:09Z Tim $ # # 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 = "0.012537"; 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 $/; }; 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. =head1 AUTHOR Tim Bunce, L =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. =cut DBI-1.634/lib/DBI/Gofer/Transport/stream.pm000644 000766 000024 00000003756 12162132031 020440 0ustar00timbostaff000000 000000 package DBI::Gofer::Transport::stream; # $Id: stream.pm 12536 2009-02-24 22:37:09Z Tim $ # # 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 = "0.012537"; 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 = ) ) { 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. =head1 AUTHOR Tim Bunce, L =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. =cut DBI-1.634/lib/DBI/Gofer/Serializer/Base.pm000644 000766 000024 00000002735 12162132031 020130 0ustar00timbostaff000000 000000 package DBI::Gofer::Serializer::Base; # $Id: Base.pm 9949 2007-09-18 09:38:15Z Tim $ # # 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 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 = "0.009950"; 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; DBI-1.634/lib/DBI/Gofer/Serializer/DataDumper.pm000644 000766 000024 00000002437 12162132031 021303 0ustar00timbostaff000000 000000 package DBI::Gofer::Serializer::DataDumper; use strict; use warnings; our $VERSION = "0.009950"; # $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z Tim $ # # 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. =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; DBI-1.634/lib/DBI/Gofer/Serializer/Storable.pm000644 000766 000024 00000002641 12162132031 021025 0ustar00timbostaff000000 000000 package DBI::Gofer::Serializer::Storable; use strict; use warnings; use base qw(DBI::Gofer::Serializer::Base); # $Id: Storable.pm 15585 2013-03-22 20:31:22Z Tim $ # # 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. =cut use Storable qw(nfreeze thaw); our $VERSION = "0.015586"; use base qw(DBI::Gofer::Serializer::Base); sub serialize { my $self = shift; local $Storable::forgive_me = 1; # for CODE refs etc local $Storable::canonical = 1; # for go_cache my $frozen = nfreeze(shift); return $frozen unless wantarray; return ($frozen, $self->{deserializer_class}); } sub deserialize { my $self = shift; return thaw(shift); } 1; DBI-1.634/lib/DBI/DBD/Metadata.pm000644 000766 000024 00000035305 12531110515 016216 0ustar00timbostaff000000 000000 package DBI::DBD::Metadata; # $Id: Metadata.pm 14213 2010-06-30 19:29:18Z Martin $ # # 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 strict; use Exporter (); use Carp; use DBI; use DBI::Const::GetInfoType qw(%GetInfoType); our @ISA = qw(Exporter); our @EXPORT = qw(write_getinfo_pm write_typeinfo_pm); our $VERSION = "2.014214"; =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 is the connection to use to extract the data, and C 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 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 "") 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 = "" unless defined $driver; print <(\$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 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 "") 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 = "" unless defined $driver; print < 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 (previously ), Jochen Wiedmann , Steffen Goeldner , and Tim Bunce . =cut DBI-1.634/lib/DBI/DBD/SqlEngine/000750 000766 000024 00000000000 12557677761 016047 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/DBD/SqlEngine.pm000644 000766 000024 00000177103 12531107446 016377 0ustar00timbostaff000000 000000 # -*- 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-2013 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.06"; $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", new_meta => "new_sql_engine_meta", get_meta => "get_sql_engine_meta", set_meta => "set_sql_engine_meta", clear_meta => "clear_sql_engine_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 to 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); } } else { warn "Using DBI::DBD::SqlEngine with unregistered driver $class.\n" . "Reading documentation how to prevent is strongly recommended.\n"; } # XXX inject DBD::XXX::Statement unless exists my $stclass = $class . "::st"; $stclass->install_method("sql_get_colnames") unless ( $methods_installed{__PACKAGE__}++ ); 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); use Carp qw/carp/; $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 @func_inits; # this must be done to allow DBI.pm reblessing got handle after successful connecting exists $attr->{RootClass} and $second_phase_attrs{RootClass} = delete $attr->{RootClass}; 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; exists $attr->{$var} and carp("$var is given in DSN *and* \$attr during DBI->connect()") if ($^W); exists $attr->{$var} or $attr->{$var} = $val; } elsif ( $var =~ m/^(.+?)=>(.*)/s ) { $var = $1; ( $val = $2 ) =~ s/\\(.)/$1/g; my $ref = eval $val; # $dbh->$var($ref); push( @func_inits, $var, $ref ); } } # The attributes need to be sorted in a specific way as the # assignment is through tied hashes and calls STORE on each # attribute. Some attributes require to be called prior to # others # e.g. f_dir *must* be done before xx_tables in DBD::File # The dbh attribute sql_init_order is a hash with the order # as key (low is first, 0 .. 100) and the attributes that # are set to that oreder as anon-list as value: # { 0 => [qw( AutoCommit PrintError RaiseError Profile ... )], # 10 => [ list of attr to be dealt with immediately after first ], # 50 => [ all fields that are unspecified or default sort order ], # 90 => [ all fields that are needed after other initialisation ], # } my %order = map { my $order = $_; map { ( $_ => $order ) } @{ $dbh->{sql_init_order}{$order} }; } sort { $a <=> $b } keys %{ $dbh->{sql_init_order} || {} }; my @ordered_attr = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, defined $order{$_} ? $order{$_} : 50 ] } keys %$attr; # initialize given attributes ... lower weighted before higher weighted foreach my $a (@ordered_attr) { exists $attr->{$a} or next; $two_phased_init and eval { $dbh->{$a} = $attr->{$a}; delete $attr->{$a}; }; $@ and $second_phase_attrs{$a} = delete $attr->{$a}; $two_phased_init or $dbh->STORE( $a, delete $attr->{$a} ); } $two_phased_init and $dbh->func( 1, "init_default_attributes" ); %$attr = %second_phase_attrs; for ( my $i = 0; $i < scalar(@func_inits); $i += 2 ) { my $func = $func_inits[$i]; my $arg = $func_inits[ $i + 1 ]; $dbh->$func($arg); } $dbh->func("init_done"); $dbh->STORE( Active => 1 ); } return $dbh; } # connect sub data_sources ($;$) { my ( $drh, $attr ) = @_; my $tbl_src; $attr and defined $attr->{sql_table_source} and $attr->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') and $tbl_src = $attr->{sql_table_source}; !defined($tbl_src) and $drh->{ImplementorClass}->can('default_table_source') and $tbl_src = $drh->{ImplementorClass}->default_table_source(); defined($tbl_src) or return; $tbl_src->data_sources( $drh, $attr ); } # data_sources 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 data_sources { my ( $dbh, $attr, @other ) = @_; my $drh = $dbh->{Driver}; # XXX proxy issues? ref($attr) eq 'HASH' or $attr = {}; defined( $attr->{sql_table_source} ) or $attr->{sql_table_source} = $dbh->{sql_table_source}; return $drh->data_sources( $attr, @other ); } 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 sql_meta => 1, # meta data for tables sql_meta_map => 1, # mapping table for identifier case sql_data_source => 1, # reasonable datasource class }; $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"; # check whether we're running in a Gofer server or not (see # validate_FETCH_attr for details) $dbh->{sql_engine_in_gofer} = ( defined $INC{"DBD/Gofer.pm"} && ( caller(5) )[0] eq "DBI::Gofer::Execute" ); $dbh->{sql_meta} = {}; $dbh->{sql_meta_map} = {}; # choose new name because it contains other keys # init_default_attributes calls inherited routine before derived DBD's # init their default attributes, so we don't override something here # # defining an order of attribute initialization from connect time # specified ones with a magic baarier (see next statement) my $drv_pfx_meta = $drv_prefix . "meta"; $dbh->{sql_init_order} = { 0 => [qw( Profile RaiseError PrintError AutoCommit )], 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ], }; # ensuring Profile, RaiseError, PrintError, AutoCommit are initialized # first when initializing attributes from connect time specified # attributes # further, initializations to predefined tables are happens after any # unspecified attribute initialization (that default to order 50) my @comp_attrs = qw(valid_attrs version readonly_attrs); if ( exists $dbh->{$drv_pfx_meta} and !$dbh->{sql_engine_in_gofer} ) { my $attr = $dbh->{$drv_pfx_meta}; defined $attr and defined $dbh->{$valid_attrs} and !defined $dbh->{$valid_attrs}{$attr} and $dbh->{$valid_attrs}{$attr} = 1; my %h; tie %h, "DBI::DBD::SqlEngine::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 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]->{sql_meta} } = (); %{ $_[0]->{sql_meta_map} } = (); $_[0]->STORE( Active => 0 ); return 1; } # 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 # sql_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->{sql_engine_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 = "sql_meta"; } 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 sql_meta/sql_meta_map is required here } ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; my $drv_prefix = DBI->driver_prefix($drv_class); exists $dbh->{ $drv_prefix . "meta" } and $attrib eq $dbh->{ $drv_prefix . "meta" } and $attrib = "sql_meta"; 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 ( $attrib, $value ) = $dbh->func( $attrib, $value, "validate_STORE_attr" ); $attrib 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 return $dbh->set_err( $DBI::stderr, "attribute '$attrib' is readonly and must not be modified" ); if ( $attrib eq "sql_meta" ) { while ( my ( $k, $v ) = each %$value ) { $dbh->{$attrib}{$k} = $v; } } else { $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 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_sql_engine_meta { my ( $dbh, $table, $attr ) = @_; my $gstm = $dbh->{ImplementorClass}->can("get_single_table_meta"); $table eq "*" and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; $table eq "+" and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; ref $table eq "Regexp" and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_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 return $dbh->set_err( $DBI::stderr, "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table ); "ARRAY" eq ref $attr or return $dbh->set_err( "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_sql_engine_meta sub new_sql_engine_meta { my ( $dbh, $table, $values ) = @_; my $respect_case = 0; "HASH" eq ref $values or croak "Invalid argument for \$values - SCALAR or HASH expected but got " . ref $values; $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers $table =~ s/\"$//; unless ($respect_case) { defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; } $dbh->{sql_meta}{$table} = { %{$values} }; my $class; defined $values->{sql_table_class} and $class = $values->{sql_table_class}; defined $class or ( $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; # XXX we should never hit DBD::File::Table::get_table_meta here ... my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, $respect_case ); 1; } # new_sql_engine_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 ); # 1 means: respect case $meta or croak "No such table '$table'"; $class->set_table_meta_attr( $meta, $attr, $value ); return $dbh; } # set_single_table_meta sub set_sql_engine_meta { my ( $dbh, $table, $attr, $value ) = @_; my $sstm = $dbh->{ImplementorClass}->can("set_single_table_meta"); $table eq "*" and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; $table eq "+" and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; ref($table) eq "Regexp" and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_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} ) { while ( my ( $aname, $aval ) = each %$attr ) { $sstm->( $dbh, $tname, $aname, $aval ); } } return $dbh; } # set_file_meta sub clear_sql_engine_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 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} ) { # XXX map +[ undef, undef, $_, "TABLE", "TEMP" ], keys %{...} foreach my $table ( keys %{ $dbh->{sql_ram_tables} } ) { push @tables, [ undef, undef, $table, "TABLE", "TEMP" ]; } } my $tbl_src; defined $dbh->{sql_table_source} and $dbh->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') and $tbl_src = $dbh->{sql_table_source}; !defined($tbl_src) and $dbh->{Driver}->{ImplementorClass}->can('default_table_source') and $tbl_src = $dbh->{Driver}->{ImplementorClass}->default_table_source(); defined($tbl_src) and push( @tables, $tbl_src->avail_tables($dbh) ); 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. :-( # this no longer seems to be true @tables or return; my $dbh2 = $dbh->func("sql_sponge_driver"); my $sth = $dbh2->prepare( "TABLE_INFO", { rows => \@tables, NAME => $names, } ); $sth or return $dbh->set_err( $DBI::stderr, $dbh2->errstr ); $sth->execute or return; 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 # ====== Tie-Meta ============================================================== package DBI::DBD::SqlEngine::TieMeta; use Carp qw(croak); require Tie::Hash; @DBI::DBD::SqlEngine::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 DBI::DBD::SqlEngine::TieTables; use Carp qw(croak); require Tie::Hash; @DBI::DBD::SqlEngine::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, "DBI::DBD::SqlEngine::TieMeta", $self->{tblClass}, $meta; return \%h; } # FETCH sub FIRSTKEY { my $a = scalar keys %{ $_[0]->{dbh}->{sql_meta} }; each %{ $_[0]->{dbh}->{sql_meta} }; } # FIRSTKEY sub NEXTKEY { each %{ $_[0]->{dbh}->{sql_meta} }; } # NEXTKEY sub EXISTS { exists $_[0]->{dbh}->{sql_meta}->{ $_[1] } or exists $_[0]->{dbh}->{sql_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}->{sql_meta}->{ $meta->{table_name} }; } # DELETE sub CLEAR { %{ $_[0]->{dbh}->{sql_meta} } = (); %{ $_[0]->{dbh}->{sql_meta_map} } = (); } # CLEAR sub SCALAR { scalar %{ $_[0]->{dbh}->{sql_meta} }; } # SCALAR # ====== 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}; # must not proved when already executed - SQL::Statement modifies # received params unless ( $sth->{sql_params_checked}++ ) { # SQL::Statement and DBI::SQL::Nano will return the list of required params # when called in list context. Do not look into the several items, they're # implementation specific and may change without warning unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) ) { my $msg = "You passed $nparm parameters where $req_prm required"; return $sth->set_err( $DBI::stderr, $msg ); } } 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 preceding 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 # ====== TableSource =========================================================== package DBI::DBD::SqlEngine::TableSource; use strict; use warnings; use Carp; sub data_sources ($;$) { my ( $class, $drh, $attrs ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement data_sources" ); } sub avail_tables { my ( $self, $dbh ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement avail_tables" ); } # ====== DataSource ============================================================ package DBI::DBD::SqlEngine::DataSource; use strict; use warnings; use Carp; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement complete_table_name" ); } sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement open_data" ); } # ====== SQL::STATEMENT ======================================================== package DBI::DBD::SqlEngine::Statement; use strict; use warnings; use Carp; @DBI::DBD::SqlEngine::Statement::ISA = qw(DBI::SQL::Nano::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; my ( $tblnm, $table_meta ) = $class->get_table_meta( $data->{Database}, $table, 1 ) or croak "Cannot find appropriate meta for table '$table'"; defined $table_meta->{sql_table_class} and $class = $table_meta->{sql_table_class}; # because column name mapping is initialized in constructor ... # and therefore specific opening operations might be done before # reaching DBI::DBD::SqlEngine::Table->new(), we need to intercept # ReadOnly here my $write_op = $createMode || $lockMode || $flags->{dropMode}; if ($write_op) { $table_meta->{readonly} and croak "Table '$table' is marked readonly - " . $self->{command} . ( $lockMode ? " with locking" : "" ) . " command forbidden"; } return $class->new( $data, { table => $table }, $flags ); } # open_table # ====== SQL::TABLE ============================================================ package DBI::DBD::SqlEngine::Table; use strict; use warnings; use Carp; @DBI::DBD::SqlEngine::Table::ISA = qw(DBI::SQL::Nano::Table); sub bootstrap_table_meta { my ( $self, $dbh, $meta, $table ) = @_; defined $dbh->{ReadOnly} and !defined( $meta->{readonly} ) and $meta->{readonly} = $dbh->{ReadOnly}; defined $meta->{sql_identifier_case} or $meta->{sql_identifier_case} = $dbh->{sql_identifier_case}; exists $meta->{sql_data_source} or $meta->{sql_data_source} = $dbh->{sql_data_source}; $meta; } sub init_table_meta { my ( $self, $dbh, $meta, $table ) = @_ if (0); return; } # init_table_meta sub get_table_meta ($$$;$) { my ( $self, $dbh, $table, $respect_case, @other ) = @_; unless ( defined $respect_case ) { $respect_case = 0; $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers $table =~ s/\"$//; } unless ($respect_case) { defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; } my $meta = {}; defined $dbh->{sql_meta}{$table} and $meta = $dbh->{sql_meta}{$table}; do_initialize: unless ( $meta->{initialized} ) { $self->bootstrap_table_meta( $dbh, $meta, $table, @other ); $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) or return; if ( defined $meta->{table_name} and $table ne $meta->{table_name} ) { $dbh->{sql_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->{sql_meta}{$table} ) { $meta = delete $dbh->{sql_meta}{$table}; # avoid endless loop $meta->{initialized} or goto do_initialize; #or $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) #or return; } unless ( $dbh->{sql_meta}{$table}{initialized} ) { $self->init_table_meta( $dbh, $meta, $table ); $meta->{initialized} = 1; $dbh->{sql_meta}{$table} = $meta; } } return ( $table, $meta ); } # get_table_meta my %reset_on_modify = (); my %compat_map = (); sub register_reset_on_modify { my ( $proto, $extra_resets ) = @_; foreach my $cv ( keys %$extra_resets ) { #%reset_on_modify = ( %reset_on_modify, %$extra_resets ); push @{ $reset_on_modify{$cv} }, ref $extra_resets->{$cv} ? @{ $extra_resets->{$cv} } : ( $extra_resets->{$cv} ); } 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 sub open_data { my ( $self, $meta, $attrs, $flags ) = @_; $meta->{sql_data_source} or croak "Table " . $meta->{table_name} . " not completely initialized"; $meta->{sql_data_source}->open_data( $meta, $attrs, $flags ); return; } # open_data # ====== 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 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}; # open_file must be called before inherited new is invoked # because column name mapping is initialized in constructor ... $className->open_data( $meta, $attrs, $flags ); my $tbl = { %{$attrs}, meta => $meta, col_names => $meta->{col_names} || [], }; return $className->SUPER::new($tbl); } # new sub DESTROY { my $self = shift; my $meta = $self->{meta}; $self->{row} and undef $self->{row}; () } 1; =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 and L, 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. DBI::DBD::SqlEngine expects that any driver in inheritance chain has a L. =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) =head4 sql_nano_version Contains the module version of DBI::SQL::Nano (B) =head4 sql_statement_version Contains the module version of SQL::Statement, if available (B) =head4 sql_handler Contains the SQL Statement engine, either DBI::SQL::Nano or SQL::Statement (B). =head4 sql_parser_object Contains an instantiated instance of SQL::Parser (B). 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). =head4 sql_valid_attrs Contains the list of valid attributes for each DBI::DBD::SqlEngine based driver (B). =head4 sql_readonly_attrs Contains the list of those attributes which are readonly (B). =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 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). 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). =head4 sql_engine_in_gofer This value has a true value in case of this driver is operated via L. The impact of being operated via Gofer is a read-only driver (not read-only databases!), so you cannot modify any attributes later - neither any table settings. B you won't get an error in cases you modify table attributes, so please carefully watch C. =head4 sql_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. DBI::DBD::SqlEngine recognizes the (public) attributes C, C, C, C and C. Be very careful when modifying attributes you do not know, the consequence might be a destroyed or corrupted table. While C 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 for L, C for L and C for L. =head4 sql_table_source Controls the class which will be used for fetching available tables. See L for details. =head4 sql_data_source Contains the class name to be used for opening tables. See L for details. =head2 Driver private methods =head3 Default DBI methods =head4 data_sources The C 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 DBI::DBD::SQlEngine 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 in the method name with the driver prefix. =head4 sql_versions Signature: sub sql_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 $sql_versions = $dbh->func( "sql_versions" ); print "$sql_versions\n"; __END__ # DBI::DBD::SqlEngine 0.05 using SQL::Statement 1.402 # DBI 1.623 # OS netbsd (6.99.12) # Perl 5.016002 (x86_64-netbsd-thread-multi) Called in list context, sql_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 sql_get_meta Signature: sub sql_get_meta ($$) { my ($table_name, $attrib) = @_; ... } Returns the value of a meta attribute set for a specific table, if any. See L 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 sql_set_meta Signature: sub sql_set_meta ($$$) { my ($table_name, $attrib, $value) = @_; ... } Sets the value of a meta attribute set for a specific table. See L 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 sql_clear_meta Signature: sub sql_clear_meta ($) { my ($table_name) = @_; ... } Clears the table specific meta information in the private storage of the dbh. =head2 Extensibility =head3 DBI::DBD::SqlEngine::TableSource Provides data sources and table information on database driver and database handle level. package DBI::DBD::SqlEngine::TableSource; sub data_sources ($;$) { my ( $class, $drh, $attrs ) = @_; ... } sub avail_tables { my ( $class, $drh ) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); @ary = $dbh->data_sources(); @ary = $dbh->data_sources(\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); $dbh->func( "list_tables" ); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default, eg. @ary = DBI->data_sources("dbi:CSV:", { f_dir => "/your/csv/tables", # note: this class doesn't comes with DBI sql_table_source => "DBD::File::Archive::Tar::TableSource", # scan tarballs instead of directories }); When you're going to implement such a DBD::File::Archive::Tar::TableSource class, remember to add correct attributes (including C and C) to the returned DSN's. =head3 DBI::DBD::SqlEngine::DataSource Provides base functionality for dealing with tables. It is primarily designed for allowing transparent access to files on disk or already opened (file-)streams (eg. for DBD::CSV). Derived classes shall be restricted to similar functionality, too (eg. opening streams from an archive, transparently compress/uncompress log files before parsing them, package DBI::DBD::SqlEngine::DataSource; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; ... } The method C is called when first setting up the I for a table: "SELECT user.id, user.name, user.shell FROM user WHERE ..." results in opening the table C. First step of the table open process is completing the name. Let's imagine you're having a L handle with following settings: $dbh->{sql_identifier_case} = SQL_IC_LOWER; $dbh->{f_ext} = '.lst'; $dbh->{f_dir} = '/data/web/adrmgr'; Those settings will result in looking for files matching C<[Uu][Ss][Ee][Rr](\.lst)?$> in C. The scanning of the directory C and the pattern match check will be done in C by the C method. If you intend to provide other sources of data streams than files, in addition to provide an appropriate C method, a method to open the resource is required: package DBI::DBD::SqlEngine::DataSource; sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; ... } After the method C has been run successfully, the table's meta information are in a state which allowes the table's data accessor methods will be able to fetch/store row information. Implementation details heavily depends on the table implementation, whereby the most famous is surely L. =head1 SQL ENGINES DBI::DBD::SqlEngine currently supports two SQL engines: L and L. DBI::SQL::Nano supports a I 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.401 of SQL::Statement and the environment variable C must not be set to a true value. =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 L =item * AnnoCPAN: Annotated CPAN documentation L L =item * CPAN Ratings L =item * Search CPAN L =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-2013 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, L, L and L. =cut DBI-1.634/lib/DBI/DBD/SqlEngine/Developers.pod000644 000766 000024 00000065306 12144651530 020654 0ustar00timbostaff000000 000000 =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); 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_data { ... } 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 and L, 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 and C. Pure Perl DBI drivers derived from DBI::DBD::SqlEngine usually don't need to override any of the methods provided through the DBD::XXX::dr package. However if you need additional initialization not fitting in C and C of you're ::db class, the connect method might be the final place to be modified. =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::TieMeta; Provides the tie-magic for C<< $dbh->{$drv_pfx . "_meta"} >>. Routes C through C<< $drv->set_sql_engine_meta() >> and C through C<< $drv->get_sql_engine_meta() >>. C is not supported, you have to execute a C statement, where applicable. =item DBI::DBD::SqlEngine::TieTables; Provides the tie-magic for tables in C<< $dbh->{$drv_pfx . "_meta"} >>. Routes C though C<< $tblClass->set_table_meta_attr() >> and C though C<< $tblClass->get_table_meta_attr() >>. C removes an attribute from the I retrieved by C<< $tblClass->get_table_meta() >>. =item DBI::DBD::SqlEngine::st Contains the methods to deal with prepared statement handles. e.g., $sth->execute () or die $sth->errstr; =item DBI::DBD::SqlEngine::TableSource; Base class for 3rd party table sources: $dbh->{sql_table_source} = "DBD::Foo::TableSource"; =item DBI::DBD::SqlEngine::DataSource; Base class for 3rd party data sources: $dbh->{sql_data_source} = "DBD::Foo::DataSource"; =item DBI::DBD::SqlEngine::Statement; Base class for derived drivers statement engine. Implements C. =item DBI::DBD::SqlEngine::Table; Contains tailoring between SQL engine's requirements and C magic for finding the right tables and storage. Builds bridges between C handling of C, table initialization for SQL engines and I's attribute management for derived drivers. =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::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"; =head3 Methods provided by C<< DBI::DBD::SqlEngine::dr >>: =over 4 =item connect Supervises the driver bootstrap when calling DBI->connect( "dbi:Foo", , , { ... } ); First it instantiates a new driver using C. After that, initial bootstrap of the newly instantiated driver is done by $dbh->func( 0, "init_default_attributes" ); The first argument (C<0>) signals that this is the very first call to C. Modern drivers understand that and do early stage setup here after calling package DBD::Foo::db; our @DBD::Foo::db::ISA = qw(DBI::DBD::SqlEngine::db); sub init_default_attributes { my ($dbh, $phase) = @_; $dbh->SUPER::init_default_attributes($phase); ...; # own setup code, maybe separated by phases } When the C<$phase> argument is passed down until C, C recognizes a I driver and initializes the attributes from I and I<$attr> arguments passed via C<< DBI->connect( $dsn, $user, $pass, \%attr ) >>. At the end of the attribute initialization after I, C invoked C again for I: $dbh->func( 1, "init_default_attributes" ); =item data_sources Returns a list of I's using the C method of the class specified in C<< $dbh->{sql_table_source} >> or via C<\%attr>: @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); =item disconnect_all C doesn't have an overall driver cache, so nothing happens here at all. =back =head2 DBI::DBD::SqlEngine::db This package defines the database methods, which are called via the DBI database handle C<< $dbh >>. =head3 Methods provided by C<< DBI::DBD::SqlEngine::db >>: =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 validate_FETCH_attr Called by C to allow inherited drivers do their own attribute name validation. Calling convention is similar to C and the return value is the approved attribute name. return $validated_attribute_name; In case of validation fails (e.g. accessing private attribute or similar), C is permitted to throw an exception. =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 from outside of DBI::DBD::SqlEngine::db or a derived class. =item validate_STORE_attr Called by C to allow inherited drivers do their own attribute name validation. Calling convention is similar to C and the return value is the approved attribute name followed by the approved new value. return ($validated_attribute_name, $validated_attribute_value); In case of validation fails (e.g. accessing private attribute or similar), C is permitted to throw an exception (C throws an exception when someone tries to assign value other than C to C<< $dbh->{sql_identifier_case} >> or C<< $dbh->{sql_quoted_identifier_case} >>). =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 and C. 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. It expects one argument: C<$phase>. If C<$phase> is not given, C of C expects this is an old-fashioned driver which isn't capable of multi-phased initialization. C<< DBI::DBD::SqlEngine::db::init_default_attributes >> initializes the attributes C, C, C, C, C, C, C and C when L is available. It sets C to the given C<$phase>. 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, C and C are added (when available) to the list of valid and immutable attributes (where C 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 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, 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 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 =head3 Attributes used by C<< DBI::DBD::SqlEngine::db >>: This section describes attributes which are important to developers of DBI Database Drivers derived from C. =over 4 =item sql_init_order This attribute contains a hash with priorities as key and an array containing the C<$dbh> attributes to be initialized during before/after other attributes. C initializes following attributes: $dbh->{sql_init_order} = { 0 => [qw( Profile RaiseError PrintError AutoCommit )], 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ] } The default priority of not listed attribute keys is C<50>. It is well known that a lot of attributes needed to be set before some table settings are initialized. For example, for L, when using my $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => "/path/to/dbm/databases", dbm_type => "BerkeleyDB", dbm_mldbm => "JSON", # use MLDBM::Serializer::JSON dbm_tables => { quick => { dbm_type => "GDBM_File", dbm_MLDBM => "FreezeThaw" } } }); This defines a known table C which uses the L backend and L as serializer instead of the overall default L and L. B all files containing the table data have to be searched in C<< $dbh->{f_dir} >>, which requires C<< $dbh->{f_dir} >> must be initialized before C<< $dbh->{sql_meta}->{quick} >> is initialized by C method of L to get C<< $dbh->{sql_meta}->{quick}->{f_dir} >> being initialized properly. =item sql_init_phase This attribute is only set during the initialization steps of the DBI Database Driver. It contains the value of the currently run initialization phase. Currently supported phases are I and I. This attribute is set in C and removed in C. =item sql_engine_in_gofer This value has a true value in case of this driver is operated via L. The impact of being operated via Gofer is a read-only driver (not read-only databases!), so you cannot modify any attributes later - neither any table settings. B you won't get an error in cases you modify table attributes, so please carefully watch C. =item sql_table_source Names a class which is responsible for delivering I and I (Database Driver related). I here refers to L, not C. See L for details. =item sql_data_source Name a class which is responsible for handling table resources open and completing table names requested via SQL statements. See L for details. =item 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). =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) are C, C, C and C. Each column is returned as C 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 that statement attributes are not associated with any table used in this statement. This method usually requires extending in a derived implementation. See L or L 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. =back =head2 DBI::DBD::SqlEngine::TableSource Provides data sources and table information on database driver and database handle level. package DBI::DBD::SqlEngine::TableSource; sub data_sources ($;$) { my ( $class, $drh, $attrs ) = @_; ... } sub avail_tables { my ( $class, $drh ) = @_; ... } The C method is called when the user invokes any of the following: @ary = DBI->data_sources($driver); @ary = DBI->data_sources($driver, \%attr); @ary = $dbh->data_sources(); @ary = $dbh->data_sources(\%attr); The C method is called when the user invokes any of the following: @names = $dbh->tables( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type ); $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); $dbh->func( "list_tables" ); Every time where an C<\%attr> argument can be specified, this C<\%attr> object's C attribute is preferred over the C<$dbh> attribute or the driver default. =head2 DBI::DBD::SqlEngine::DataSource Provides base functionality for dealing with tables. It is primarily designed for allowing transparent access to files on disk or already opened (file-)streams (e.g. for DBD::CSV). Derived classes shall be restricted to similar functionality, too (e.g. opening streams from an archive, transparently compress/uncompress log files before parsing them, package DBI::DBD::SqlEngine::DataSource; sub complete_table_name ($$;$) { my ( $self, $meta, $table, $respect_case ) = @_; ... } The method C is called when first setting up the I for a table: "SELECT user.id, user.name, user.shell FROM user WHERE ..." results in opening the table C. First step of the table open process is completing the name. Let's imagine you're having a L handle with following settings: $dbh->{sql_identifier_case} = SQL_IC_LOWER; $dbh->{f_ext} = '.lst'; $dbh->{f_dir} = '/data/web/adrmgr'; Those settings will result in looking for files matching C<[Uu][Ss][Ee][Rr](\.lst)?$> in C. The scanning of the directory C and the pattern match check will be done in C by the C method. If you intend to provide other sources of data streams than files, in addition to provide an appropriate C method, a method to open the resource is required: package DBI::DBD::SqlEngine::DataSource; sub open_data ($) { my ( $self, $meta, $attrs, $flags ) = @_; ... } After the method C has been run successfully, the table's meta information are in a state which allows the table's data accessor methods will be able to fetch/store row information. Implementation details heavily depends on the table implementation, whereby the most famous is surely L. =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. You should consult the documentation of C<< SQL::Eval::Table >> (see L) 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. =over 4 =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<< $dbh->{ReadOnly} >> into C<< $meta->{readonly} >>, C and C 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 after bootstrapping a new I and L a mapping can be established between an existing I and the new bootstrapped one, the already existing is used and a mapping shortcut between the recent used table name and the already known table name is hold in C<< $dbh->{sql_meta_map} >>. 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 flag is removed, too. The decision is made based on C<%register_reset_on_modify>. =item register_reset_on_modify Allows C to reset meta attributes when special attributes are modified. For DBD::File, modifying one of C, C, C or C will reset C. DBD::DBM extends the list for C and C to reset the value of C. If your DBD has calculated values in the meta data area, then call C: my %reset_on_modify = ( "xxx_foo" => "xxx_bar" ); __PACKAGE__->register_reset_on_modify( \%reset_on_modify ); =item register_compat_map Allows C and C 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_data Called to open the table's data storage. This is silently forwarded to C<< $meta->{sql_data_source}->open_data() >>. 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. =back =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 DBI-1.634/lib/DBI/DBD/SqlEngine/HowTo.pod000644 000766 000024 00000025103 12531107446 017575 0ustar00timbostaff000000 000000 =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 based DBD. It expects that you carefully read the L documentation and that you're familiar with L and had read and understood L. 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. =head1 CREATING DRIVER CLASSES Do you have an entry in DBI's DBD registry? DBI::DBD::SqlEngine expect having a unique prefix for every driver class in inheritance chain. It's easy to get a prefix - just drop the DBI team a note (L). If you want for some reason hide your work, take a look at L how to wrap a private prefix method around existing C. For this guide, a prefix of C 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. In L 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 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 documentation. C and C taking care for you - all they need to know is which attribute names are valid and mutable or immutable. Tell them by adding C 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 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. 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 User comfort C since C<0.05> consolidates all persistent meta data of a table into a single structure stored in C<< $dbh->{sql_meta} >>. While DBI::DBD::SqlEngine provides only readonly access to this structure, modifications are still allowed. Primarily DBI::DBD::SqlEngine provides access via the setters C, C, C, C, C and C. 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_sql_engine_meta"); DBI::DBD::SqlEngine 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 (re-capture L): 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 these are the attributes C, C, C and C), inform DBI::DBD::SqlEngine 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 DBI::DBD::SqlEngine to re-do the entire meta initialization process. Any further action which needs to be taken can handled in C: 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 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 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. Second look should go to L to get a picture over the driver part of the table API. Usually there isn't much to do for an easy driver. =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 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 DBI-1.634/lib/DBI/Const/GetInfo/000750 000766 000024 00000000000 12557677761 016212 5ustar00timbostaff000000 000000 DBI-1.634/lib/DBI/Const/GetInfoReturn.pm000644 000766 000024 00000004653 12162132031 017725 0ustar00timbostaff000000 000000 # $Id: GetInfoReturn.pm 8696 2007-01-24 23:12:38Z Tim $ # # 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 = "2.008697"; =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; DBI-1.634/lib/DBI/Const/GetInfoType.pm000644 000766 000024 00000002253 12162132031 017361 0ustar00timbostaff000000 000000 # $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z Tim $ # # 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 = "2.008697"; =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; DBI-1.634/lib/DBI/Const/GetInfo/ANSI.pm000644 000766 000024 00000022600 12531110275 017255 0ustar00timbostaff000000 000000 # $Id: ANSI.pm 8696 2007-01-24 23:12:38Z Tim $ # # 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. use strict; package DBI::Const::GetInfo::ANSI; our (%InfoTypes,%ReturnTypes,%ReturnValues,); =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 = "2.008697"; %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 DBI-1.634/lib/DBI/Const/GetInfo/ODBC.pm000644 000766 000024 00000201111 12531110275 017226 0ustar00timbostaff000000 000000 # $Id: ODBC.pm 11373 2008-06-02 19:01:33Z Tim $ # # 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. use strict; package DBI::Const::GetInfo::ODBC; our (%InfoTypes,%ReturnTypes,%ReturnValues,); =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 = "2.011374"; %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 DBI-1.634/lib/DBD/DBM.pm000644 000766 000024 00000145600 12213146757 014520 0ustar00timbostaff000000 000000 ####################################################################### # # DBD::DBM - a DBI driver for DBM files # # Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > # Copyright (c) 2010-2013 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.08'; $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); use Carp qw/carp/; 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, everything 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; my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" ) or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() ); return $tbl_meta->{$tname}->{f_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'; 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 ) = @_; $meta->{f_dontopen} = 1; 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_data { my ( $className, $meta, $attrs, $flags ) = @_; $className->SUPER::open_data( $meta, $attrs, $flags ); unless ( $flags->{dropMode} ) { # TIEING # # XXX allow users to pass in a pre-created tied object # my @tie_args; if ( $meta->{dbm_type} eq 'BerkeleyDB' ) { my $DB_CREATE = BerkeleyDB::DB_CREATE(); my $DB_RDONLY = BerkeleyDB::DB_RDONLY(); my %tie_flags; if ( my $f = $meta->{dbm_berkeley_flags} ) { defined( $f->{DB_CREATE} ) and $DB_CREATE = delete $f->{DB_CREATE}; defined( $f->{DB_RDONLY} ) and $DB_RDONLY = delete $f->{DB_RDONLY}; %tie_flags = %$f; } my $open_mode = $flags->{lockMode} || $flags->{createMode} ? $DB_CREATE : $DB_RDONLY; @tie_args = ( -Filename => $meta->{f_fqbn}, -Flags => $open_mode, %tie_flags ); } else { my $open_mode = O_RDONLY; $flags->{lockMode} and $open_mode = O_RDWR; $flags->{createMode} and $open_mode = O_RDWR | O_CREAT | O_TRUNC; @tie_args = ( $meta->{f_fqbn}, $open_mode, 0666 ); } if ( $meta->{dbm_mldbm} ) { $MLDBM::UseDB = $meta->{dbm_usedb}; $MLDBM::Serializer = $meta->{dbm_mldbm}; } $meta->{hash} = {}; my $tie_class = $meta->{dbm_tietype}; eval { tie %{ $meta->{hash} }, $tie_class, @tie_args }; $@ and croak "Cannot tie(\%h $tie_class @tie_args): $@"; -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" ); } unless ( $flags->{createMode} ) { my ( $meta_data, $schema, $col_names ); if ( $meta->{dbm_store_metadata} ) { $meta_data = $col_names = $meta->{hash}->{"_metadata \0"}; if ( $meta_data and $meta_data =~ m~(.+)~is ) { $schema = $col_names = $1; $schema =~ s~.*(.+).*~$1~is; $col_names =~ s~.*(.+).*~$1~is; } } $col_names ||= $meta->{col_names} || [ 'k', 'v' ]; $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' ); if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} ) { $schema or $schema = ''; $meta->{hash}->{"_metadata \0"} = "" . "$schema" . "" . join( ",", @{$col_names} ) . "" . ""; } $meta->{schema} = $schema; $meta->{col_names} = $col_names; } } # you must define drop # it is called from execute of a SQL DROP statement # sub drop ($$) { my ( $self, $data ) = @_; my $meta = $self->{meta}; $meta->{hash} and untie %{ $meta->{hash} }; $self->SUPER::drop($data); # XXX extra_files -f $meta->{f_fqbn} . $dirfext and $meta->{f_ext} eq '.pag/r' and unlink( $meta->{f_fqbn} . $dirfext ); return 1; } # you must define fetch_row, it is called on all fetches; # it MUST return undef when no rows are left to fetch; # checking for $ary[0] is specific to hashes so you'll # probably need some other kind of check for nothing-left. # as Janis might say: "undef's just another word for # nothing left to fetch" :-) # sub fetch_row ($$) { my ( $self, $data ) = @_; my $meta = $self->{meta}; # fetch with %each # my @ary = each %{ $meta->{hash} }; $meta->{dbm_store_metadata} and $ary[0] and $ary[0] eq "_metadata \0" and @ary = each %{ $meta->{hash} }; my ( $key, $val ) = @ary; unless ($key) { delete $self->{row}; return; } my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val ); $self->{row} = @row ? \@row : undef; return wantarray ? @row : \@row; } # you must define push_row except insert_new_row and update_specific_row is defined # it is called on inserts and updates as primitive # sub insert_new_row ($$$) { my ( $self, $data, $row_aryref ) = @_; my $meta = $self->{meta}; my $ncols = scalar( @{ $meta->{col_names} } ); my $nitems = scalar( @{$row_aryref} ); $ncols == $nitems or croak "You tried to insert $nitems, but table is created with $ncols columns"; my $key = shift @$row_aryref; my $exists; eval { $exists = exists( $meta->{hash}->{$key} ); }; $exists and croak "Row with PK '$key' already exists"; $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row_aryref : $row_aryref->[0]; return 1; } # this is where you grab the column names from a CREATE statement # if you don't need to do that, it must be defined but can be empty # sub push_names ($$$) { my ( $self, $data, $row_aryref ) = @_; my $meta = $self->{meta}; # some sanity checks ... my $ncols = scalar(@$row_aryref); $ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ..."; !$meta->{dbm_mldbm} and $ncols > 2 and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols"; $meta->{col_names} = $row_aryref; return unless $meta->{dbm_store_metadata}; my $stmt = $data->{sql_stmt}; my $col_names = join( ',', @{$row_aryref} ); my $schema = $data->{Database}->{Statement}; $schema =~ s/^[^\(]+\((.+)\)$/$1/s; $schema = $stmt->schema_str() if ( $stmt->can('schema_str') ); $meta->{hash}->{"_metadata \0"} = "" . "$schema" . "$col_names" . ""; } # fetch_one_row, delete_one_row, update_one_row # are optimized for hash-style lookup without looping; # if you don't need them, omit them, they're optional # but, in that case you may need to define # truncate() and seek(), see below # sub fetch_one_row ($$;$) { my ( $self, $key_only, $key ) = @_; my $meta = $self->{meta}; $key_only and return $meta->{col_names}->[0]; exists $meta->{hash}->{$key} or return; my $val = $meta->{hash}->{$key}; $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val]; my $row = [ $key, @$val ]; return wantarray ? @{$row} : $row; } sub delete_one_row ($$$) { my ( $self, $data, $aryref ) = @_; my $meta = $self->{meta}; delete $meta->{hash}->{ $aryref->[0] }; } sub update_one_row ($$$) { my ( $self, $data, $aryref ) = @_; my $meta = $self->{meta}; my $key = shift @$aryref; defined $key or return; my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0]; } sub update_specific_row ($$$$) { my ( $self, $data, $aryref, $origary ) = @_; my $meta = $self->{meta}; my $key = shift @$origary; my $newkey = shift @$aryref; return unless ( defined $key ); $key eq $newkey or delete $meta->{hash}->{$key}; my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0]; } # you may not need to explicitly DESTROY the ::Table # put cleanup code to run when the execute is done # sub DESTROY ($) { my $self = shift; my $meta = $self->{meta}; $meta->{hash} and untie %{ $meta->{hash} }; $self->SUPER::DESTROY(); } # truncate() and seek() must be defined to satisfy DBI::SQL::Nano # *IF* you define the *_one_row methods above, truncate() and # seek() can be empty or you can use them without actually # truncating or seeking anything but if you don't define the # *_one_row methods, you may need to define these # if you need to do something after a series of # deletes or updates, you can put it in truncate() # which is called at the end of executing # sub truncate ($$) { # my ( $self, $data ) = @_; return 1; } # seek() is only needed if you use IO::File # though it could be used for other non-file operations # that you need to do before "writes" or truncate() # sub seek ($$$$) { # my ( $self, $data, $pos, $whence ) = @_; return 1; } # Th, th, th, that's all folks! See DBD::File and DBD::CSV for other # examples of creating pure perl DBDs. I hope this helped. # Now it's time to go forth and create your own DBD! # Remember to check in with dbi-dev@perl.org before you get too far. # We may be able to make suggestions or point you to other related # projects. 1; __END__ =pod =head1 NAME DBD::DBM - a DBI driver for DBM & MLDBM files =head1 SYNOPSIS use DBI; $dbh = DBI->connect('dbi:DBM:'); # defaults to SDBM_File $dbh = DBI->connect('DBI:DBM(RaiseError=1):'); # defaults to SDBM_File $dbh = DBI->connect('dbi:DBM:dbm_type=DB_File'); # defaults to DB_File $dbh = DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # MLDBM with SDBM_File # or $dbh = DBI->connect('dbi:DBM:', undef, undef); $dbh = DBI->connect('dbi:DBM:', undef, undef, { f_ext => '.db/r', f_dir => '/path/to/dbfiles/', f_lockfile => '.lck', dbm_type => 'BerkeleyDB', dbm_mldbm => 'FreezeThaw', dbm_store_metadata => 1, dbm_berkeley_flags => { '-Cachesize' => 1000, # set a ::Hash flag }, }); and other variations on connect() as shown in the L docs, L and L shown below. Use standard DBI prepare, execute, fetch, placeholders, etc., see L for an example. =head1 DESCRIPTION DBD::DBM is a database management system that works right out of the box. If you have a standard installation of Perl and DBI you can begin creating, accessing, and modifying simple database tables without any further modules. You can add other modules (e.g., SQL::Statement, DB_File etc) for improved functionality. The module uses a DBM file storage layer. DBM file storage is common on many platforms and files can be created with it in many programming languages using different APIs. That means, in addition to creating files with DBI/SQL, you can also use DBI/SQL to access and modify files created by other DBM modules and programs and vice versa. B that in those cases it might be necessary to use a common subset of the provided features. DBM files are stored in binary format optimized for quick retrieval when using a key field. That optimization can be used advantageously to make DBD::DBM SQL operations that use key fields very fast. There are several different "flavors" of DBM which use different storage formats supported by perl modules such as SDBM_File and MLDBM. This module supports all of the flavors that perl supports and, when used with MLDBM, supports tables with any number of columns and insertion of Perl objects into tables. DBD::DBM has been tested with the following DBM types: SDBM_File, NDBM_File, ODBM_File, GDBM_File, DB_File, BerkeleyDB. Each type was tested both with and without MLDBM and with the Data::Dumper, Storable, FreezeThaw, YAML and JSON serializers using the DBI::SQL::Nano or the SQL::Statement engines. =head1 QUICK START DBD::DBM operates like all other DBD drivers - it's basic syntax and operation is specified by DBI. If you're not familiar with DBI, you should start by reading L and the documents it points to and then come back and read this file. If you are familiar with DBI, you already know most of what you need to know to operate this module. Just jump in and create a test script something like the one shown below. You should be aware that there are several options for the SQL engine underlying DBD::DBM, see L. There are also many options for DBM support, see especially the section on L. But here's a sample to get you started. use DBI; my $dbh = DBI->connect('dbi:DBM:'); $dbh->{RaiseError} = 1; for my $sql( split /;\n+/," CREATE TABLE user ( user_name TEXT, phone TEXT ); INSERT INTO user VALUES ('Fred Bloggs','233-7777'); INSERT INTO user VALUES ('Sanjay Patel','777-3333'); INSERT INTO user VALUES ('Junk','xxx-xxxx'); DELETE FROM user WHERE user_name = 'Junk'; UPDATE user SET phone = '999-4444' WHERE user_name = 'Sanjay Patel'; SELECT * FROM user "){ my $sth = $dbh->prepare($sql); $sth->execute; $sth->dump_results if $sth->{NUM_OF_FIELDS}; } $dbh->disconnect; =head1 USAGE This section will explain some usage cases in more detail. To get an overview about the available attributes, see L. =head2 Specifying Files and Directories DBD::DBM will automatically supply an appropriate file extension for the type of DBM you are using. For example, if you use SDBM_File, a table called "fruit" will be stored in two files called "fruit.pag" and "fruit.dir". You should B specify the file extensions in your SQL statements. DBD::DBM recognizes following default extensions for following types: =over 4 =item .pag/r Chosen for dbm_type C<< SDBM_File >>, C<< ODBM_File >> and C<< NDBM_File >> when an implementation is detected which wraps C<< -ldbm >> for C<< NDBM_File >> (e.g. Solaris, AIX, ...). For those types, the C<< .dir >> extension is recognized, too (for being deleted when dropping a table). =item .db/r Chosen for dbm_type C<< NDBM_File >> when an implementation is detected which wraps BerkeleyDB 1.x for C<< NDBM_File >> (typically BSD's, Darwin). =back C<< GDBM_File >>, C<< DB_File >> and C<< BerkeleyDB >> don't usually use a file extension. If your DBM type uses an extension other than one of the recognized types of extensions, you should set the I attribute to the extension B file a bug report as described in DBI with the name of the implementation and extension so we can add it to DBD::DBM. Thanks in advance for that :-). $dbh = DBI->connect('dbi:DBM:f_ext=.db'); # .db extension is used $dbh = DBI->connect('dbi:DBM:f_ext='); # no extension is used # or $dbh->{f_ext}='.db'; # global setting $dbh->{f_meta}->{'qux'}->{f_ext}='.db'; # setting for table 'qux' By default files are assumed to be in the current working directory. To use other directories specify the I attribute in either the connect string or by setting the database handle attribute. For example, this will look for the file /foo/bar/fruit (or /foo/bar/fruit.pag for DBM types that use that extension) my $dbh = DBI->connect('dbi:DBM:f_dir=/foo/bar'); # and this will too: my $dbh = DBI->connect('dbi:DBM:'); $dbh->{f_dir} = '/foo/bar'; # but this is recommended my $dbh = DBI->connect('dbi:DBM:', undef, undef, { f_dir => '/foo/bar' } ); # now you can do my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM fruit }); You can also use delimited identifiers to specify paths directly in SQL statements. This looks in the same place as the two examples above but without setting I: my $dbh = DBI->connect('dbi:DBM:'); my $ary = $dbh->selectall_arrayref(q{ SELECT x FROM "/foo/bar/fruit" }); You can also tell DBD::DBM to use a specified path for a specific table: $dbh->{dbm_tables}->{f}->{file} = q(/foo/bar/fruit); Please be aware that you cannot specify this during connection. If you have SQL::Statement installed, you can use table aliases: my $dbh = DBI->connect('dbi:DBM:'); my $ary = $dbh->selectall_arrayref(q{ SELECT f.x FROM "/foo/bar/fruit" AS f }); See the L for using DROP on tables. =head2 Table locking and flock() Table locking is accomplished using a lockfile which has the same basename as the table's file but with the file extension '.lck' (or a lockfile extension that you supply, see below). This lock file is created with the table during a CREATE and removed during a DROP. Every time the table itself is opened, the lockfile is flocked(). For SELECT, this is a shared lock. For all other operations, it is an exclusive lock (except when you specify something different using the I attribute). Since the locking depends on flock(), it only works on operating systems that support flock(). In cases where flock() is not implemented, DBD::DBM will simply behave as if the flock() had occurred although no actual locking will happen. Read the documentation for flock() for more information. Even on those systems that do support flock(), locking is only advisory - as is always the case with flock(). This means that if another program tries to access the table file while DBD::DBM has the table locked, that other program will *succeed* at opening unless it is also using flock on the '.lck' file. As a result DBD::DBM's locking only really applies to other programs using DBD::DBM or other program written to cooperate with DBD::DBM locking. =head2 Specifying the DBM type Each "flavor" of DBM stores its files in a different format and has different capabilities and limitations. See L for a comparison of DBM types. By default, DBD::DBM uses the C<< SDBM_File >> type of storage since C<< SDBM_File >> comes with Perl itself. If you have other types of DBM storage available, you can use any of them with DBD::DBM. It is strongly recommended to use at least C<< DB_File >>, because C<< SDBM_File >> has quirks and limitations and C<< ODBM_file >>, C<< NDBM_File >> and C<< GDBM_File >> are not always available. You can specify the DBM type using the I attribute which can be set in the connection string or with C<< $dbh->{dbm_type} >> and C<< $dbh->{f_meta}->{$table_name}->{type} >> for per-table settings in cases where a single script is accessing more than one kind of DBM file. In the connection string, just set C<< dbm_type=TYPENAME >> where C<< TYPENAME >> is any DBM type such as GDBM_File, DB_File, etc. Do I use MLDBM as your I as that is set differently, see below. my $dbh=DBI->connect('dbi:DBM:'); # uses the default SDBM_File my $dbh=DBI->connect('dbi:DBM:dbm_type=GDBM_File'); # uses the GDBM_File # You can also use $dbh->{dbm_type} to set the DBM type for the connection: $dbh->{dbm_type} = 'DB_File'; # set the global DBM type print $dbh->{dbm_type}; # display the global DBM type If you have several tables in your script that use different DBM types, you can use the $dbh->{dbm_tables} hash to store different settings for the various tables. You can even use this to perform joins on files that have completely different storage mechanisms. # sets global default of GDBM_File my $dbh->('dbi:DBM:type=GDBM_File'); # overrides the global setting, but only for the tables called # I and I my $dbh->{f_meta}->{foo}->{dbm_type} = 'DB_File'; my $dbh->{f_meta}->{bar}->{dbm_type} = 'BerkeleyDB'; # prints the dbm_type for the table "foo" print $dbh->{f_meta}->{foo}->{dbm_type}; B that you must change the I of a table before you access it for first time. =head2 Adding multi-column support with MLDBM Most of the DBM types only support two columns and even if it would support more, DBD::DBM would only use two. However a CPAN module called MLDBM overcomes this limitation by allowing more than two columns. MLDBM does this by serializing the data - basically it puts a reference to an array into the second column. It can also put almost any kind of Perl object or even B into columns. If you want more than two columns, you B install MLDBM. It's available for many platforms and is easy to install. MLDBM is by default distributed with three serializers - Data::Dumper, Storable, and FreezeThaw. Data::Dumper is the default and Storable is the fastest. MLDBM can also make use of user-defined serialization methods or other serialization modules (e.g. L or L. You select the serializer using the I attribute. Some examples: $dbh=DBI->connect('dbi:DBM:dbm_mldbm=Storable'); # use MLDBM with Storable $dbh=DBI->connect( 'dbi:DBM:dbm_mldbm=MySerializer' # use MLDBM with a user defined module ); $dbh=DBI->connect('dbi::dbm:', undef, undef, { dbm_mldbm => 'YAML' }); # use 3rd party serializer $dbh->{dbm_mldbm} = 'YAML'; # same as above print $dbh->{dbm_mldbm} # show the MLDBM serializer $dbh->{f_meta}->{foo}->{dbm_mldbm}='Data::Dumper'; # set Data::Dumper for table "foo" print $dbh->{f_meta}->{foo}->{mldbm}; # show serializer for table "foo" MLDBM works on top of other DBM modules so you can also set a DBM type along with setting dbm_mldbm. The examples above would default to using SDBM_File with MLDBM. If you wanted GDBM_File instead, here's how: # uses DB_File with MLDBM and Storable $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_type => 'DB_File', dbm_mldbm => 'Storable', }); SDBM_File, the default I is quite limited, so if you are going to use MLDBM, you should probably use a different type, see L. See below for some L about MLDBM. =head2 Support for Berkeley DB The Berkeley DB storage type is supported through two different Perl modules - DB_File (which supports only features in old versions of Berkeley DB) and BerkeleyDB (which supports all versions). DBD::DBM supports specifying either "DB_File" or "BerkeleyDB" as a I, with or without MLDBM support. The "BerkeleyDB" dbm_type is experimental and it's interface is likely to change. It currently defaults to BerkeleyDB::Hash and does not currently support ::Btree or ::Recno. With BerkeleyDB, you can specify initialization flags by setting them in your script like this: use BerkeleyDB; my $env = new BerkeleyDB::Env -Home => $dir; # and/or other Env flags $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_type => 'BerkeleyDB', dbm_mldbm => 'Storable', dbm_berkeley_flags => { 'DB_CREATE' => DB_CREATE, # pass in constants 'DB_RDONLY' => DB_RDONLY, # pass in constants '-Cachesize' => 1000, # set a ::Hash flag '-Env' => $env, # pass in an environment }, }); Do I set the -Flags or -Filename flags as those are determined and overwritten by the SQL (e.g. -Flags => DB_RDONLY is set automatically when you issue a SELECT statement). Time has not permitted us to provide support in this release of DBD::DBM for further Berkeley DB features such as transactions, concurrency, locking, etc. We will be working on these in the future and would value suggestions, patches, etc. See L and L for further details. =head2 Optimizing the use of key fields Most "flavors" of DBM have only two physical columns (but can contain multiple logical columns as explained above in L). They work similarly to a Perl hash with the first column serving as the key. Like a Perl hash, DBM files permit you to do quick lookups by specifying the key and thus avoid looping through all records (supported by DBI::SQL::Nano only). Also like a Perl hash, the keys must be unique. It is impossible to create two records with the same key. To put this more simply and in SQL terms, the key column functions as the I or UNIQUE INDEX. In DBD::DBM, you can take advantage of the speed of keyed lookups by using DBI::SQL::Nano and a WHERE clause with a single equal comparison on the key field. For example, the following SQL statements are optimized for keyed lookup: CREATE TABLE user ( user_name TEXT, phone TEXT); INSERT INTO user VALUES ('Fred Bloggs','233-7777'); # ... many more inserts SELECT phone FROM user WHERE user_name='Fred Bloggs'; The "user_name" column is the key column since it is the first column. The SELECT statement uses the key column in a single equal comparison - "user_name='Fred Bloggs'" - so the search will find it very quickly without having to loop through all the names which were inserted into the table. In contrast, these searches on the same table are not optimized: 1. SELECT phone FROM user WHERE user_name < 'Fred'; 2. SELECT user_name FROM user WHERE phone = '233-7777'; In #1, the operation uses a less-than (<) comparison rather than an equals comparison, so it will not be optimized for key searching. In #2, the key field "user_name" is not specified in the WHERE clause, and therefore the search will need to loop through all rows to find the requested row(s). B that the underlying DBM storage needs to loop over all I pairs when the optimized fetch is used. SQL::Statement has a massively improved where clause evaluation which costs around 15% of the evaluation in DBI::SQL::Nano - combined with the loop in the DBM storage the speed improvement isn't so impressive. Even if lookups are faster by around 50%, DBI::SQL::Nano and SQL::Statement can benefit from the key field optimizations on updating and deleting rows - and here the improved where clause evaluation of SQL::Statement might beat DBI::SQL::Nano every time the where clause contains not only the key field (or more than one). =head2 Supported SQL syntax DBD::DBM uses a subset of SQL. The robustness of that subset depends on what other modules you have installed. Both options support basic SQL operations including CREATE TABLE, DROP TABLE, INSERT, DELETE, UPDATE, and SELECT. B