Rose-DB-0.777/000750 000765 000024 00000000000 12502143063 013021 5ustar00johnstaff000000 000000 Rose-DB-0.777/Changes000755 000765 000024 00000050752 12502142500 014330 0ustar00johnstaff000000 000000 0.777 (03.17.2015) - John Siracusa * Updated more project URLs. 0.776 (03.17.2015) - John Siracusa * Updated project URLs. 0.775 (01.18.2013) - John Siracusa * Improved automated installation detection (RT 92254) 0.774 (11.01.2013) - John Siracusa * Fixed typos. 0.773 (10.28.2013) - John Siracusa * Fixed bad skip count on test file. 0.772 (10.28.2013) - John Siracusa * Fixed a bug that caused nested arrays to be incorrectly formatted by Rose::DB::Pg's format_array() method. (Patch by Brian Duggan.) * Updated contributors list. 0.771 (08.04.2013) - John Siracusa * Documented the behavior of the dsn attribute when it has an explicit value and attributes that contribute to the dsn are also set (RT 87487) 0.770 (11.24.2012) - John Siracusa * Fixed "DBD::Informix::st execute failed: SQL: -255: Not in transaction" errors in the test suite. (Patch by Sergey Leschenko.) 0.769 (05.25.2012) - John Siracusa * Fixed (more) test failures due to DBD::SQLite not being installed. 0.768 (05.12.2012) - John Siracusa * Fixed test failures due to DBD::SQLite not being installed. 0.767 (05.01.2012) - John Siracusa * Fixed some bugs that could cause connect_options not to be honored. * Fixed some incorrectly failing handle_error tests. * Updated Rose::DB::Oracle to honor NLS_*_FORMAT environment variables for dates. 0.766 (01.05.2012) - John Siracusa * Fixed tests that might try to load DBD::* modules that aren't installed. 0.765 (01.04.2012) - John Siracusa * Added handle_error attribute (RT 63377) * Added mysql_bind_type_guessing attribute. * Added sqlite_unicode attribute. 0.764 (10.18.2011) - John Siracusa * Use ENGINE=InnoDB instead of TYPE=InnoDB in MySQL table creation statements to avoid an incompatibility with MySQL 5.5 (RT 71757) 0.763 (12.30.2010) - John Siracusa * Support for Rose::DB::Object 0.794 * Return from rollback() early if AutoCommit is set. 0.762 (06.23.2010) - John Siracusa * Support for Rose::DB::Object 0.789. 0.761 (05.22.2010) - John Siracusa * Support for Rose::DB::Object 0.788. * Detect and report problems caused by DBD::mysql versions that fail to set the Active database handle attribute back to a true value when mysql_auto_reconnect is set. (Reported by Matt S. Trout and Kostas Chatzikokolakis) 0.760 (04.28.2010) - John Siracusa * Moved version number back to three places after the decimal in order to placate Unix package management systems. (Suggested by Matt S. Trout) 0.7591 (04.27.2010) - John Siracusa * Corrected skip counts in MySQL tests. 0.759 (04.27.2010) - John Siracusa * Fixed some inheritance dead ends (Reported by Matt S. Trout) * Corrected parse_array()'s value unescaping (RT 56112) * Added timestamp with time zone parsing/formating methods. * Improved Oracle date/time parsing and formatting. * DateTime::Format::Oracle is now a prerequisite (see above). 0.758 (01.26.2010) - John Siracusa * Added workaround for DateTime::Duration bug (RT 53985) 0.757 (01.23.2010) - John Siracusa * Support for Rose::DB::Object 0.786. 0.756 (12.31.2009) - John Siracusa * Support for Rose::DB::Object 0.785. * Made fork- and thread-safe (though some databases, notably Oracle, don't support passing a database connection across a fork at all). * Updated mysql_enable_utf8() to run "SET NAMES utf8" id a database handle already exists. * Updated the various validate_*_keywords() methods to no longer accept anything that "looks like a function call." This was done to avoid possible SQL injection attacks, and because the now-pervasive support for scalar-reference literals in Rose::DB::Object obviates the need for such permissive SQL inlining. To restore the old behavior, use the default_keyword_function_calls() class method or the keyword_function_calls() object method. 0.755 (10.16.2009) - John Siracusa * Fixed a bug in Rose::DB::Oracle that caused the port to be omitted from the DSN. (Reported by llama) * Updated eval blocks to avoid stomping on $@ from an outer scope. 0.754 (09.14.2009) - John Siracusa * Removed outdated warning about Oracle support. * Clarified the return value and error handling for do_transaction(). 0.753 (07.09.2009) - John Siracusa * Detect enum-like columns in PostgreSQL. (RT 46214) * Added support for the "sslmode" DSN option for PostgreSQL. (Reported by foudfou) 0.752 (05.08.2009) - John Siracusa * Added workaround for the lack of getpwuid() on Windows. * SQLite column and table names are now properly unquoted when necessary. (RT 45836) * Indicate that MySQL 5.0.45 and later supports selecting from a subselect. 0.751 (04.19.2009) - John Siracusa * Worked around a mod_perl 2 issue related to PerlOptions +Parent http://bit.ly/160jLN (Reported by Anton) * Updated test suite to consider DBD::SQLite 1.19+ non-broken. 0.750 (02.26.2009) - Peter Karman * Added pg_enable_utf8 attribute. 0.749 (12.12.2008) - John Siracusa * Added support for many more registry entry attributes. * More mod_perl 2.x fixes for Rose::DB::Cache. (Reported by Kostas Chatzikokolakis) * Added apache_has_started attribute to Rose::DB::Cache to support mod_perl 2.x users who do not have the ability to run code on server startup. (Suggested by Kostas Chatzikokolakis) 0.748 (12.09.2008) - John Siracusa * Fixed mod_perl 2.x support in Rose::DB::Cache. (Reported by Kostas Chatzikokolakis) * Resolved ambiguous driver_class link in POD. 0.747 (10.22.2008) - Justin Ellison * Changed to require YAML instead of YAML::Syck, though YAML::Syck will be used in preference to YAML if it's present. (RT 31535) 0.746 (09.16.2008) - Justin Ellison * Fixed support for TIMESTAMP WITH TIME ZONE column in Oracle. 0.745 (09.12.2008) - John Siracusa * Added support for Oracle date/time column keywords. * Added methods to list cached db entries and keys. 0.744 (05.28.2008) - John Siracusa * Added fixup() class method call to auto_load_fixups(). (Suggested by Justin Ellison) * Skip the interactive part of the test suite when the AUTOMATED_TESTING environment variable is set. 0.743 (04.02.2008) - John Siracusa * Fixed some warnings and made nice with the CPAN version extractor. 0.742 (04.01.2008) - John Siracusa * Added warning for ancient DBD::mysql versions. * Support for Rose::DB::Object 0.769. 0.741 (02.25.2008) - John Siracusa * Changed mailing list URLs. 0.740 (02.15.2008) - John Siracusa * Added support for Rose::DB::Object 0.767's new hints features. 0.739 (02.08.2008) - John Siracusa * Caching of db objects during mod_perl server start-up is now turned off by default, with new API to turn it back on and do the necessary pre-fork clean-up that this entails. This change solved a segmentation fault problem triggered in DBD::Informix when database handles created in the parent were not properly disconnected prior to the first fork of the apache process. 0.738 (02.06.2008) - John Siracusa * The Informix INT8 column type is now detected and mapped to "bigint" on behalf of Rose::DB::Object. * Fixed a bug that prevented format_array() and parse_array() from correctly handling arrays containing undef or NULL, respectively. (Reported by Derek Watson) 0.737 (12.13.2007) - John Siracusa * Altered the behavior of connect() and disconnect() to account for the possibility that dbi_connect() may return a DBI $dbh that is already connected and has already been initialized. * Added optional (on by default) coercion of column type metadata from (big)int auto-increment to (big)serial for MySQL and SQLite. * Added support for the current_timestamp keyword to SQLite. * Added a dozen or so new MySQL connection attributes that must be inlined into the DSN rather than passed as connect() options. 0.736 (11.13.2007) - John Siracusa * Added new_or_cached() method and associated caching framework. * Added dbi_connect() method. (Patch by Peter Karman) * Removed mistakenly checked in breakpoint. 0.735 (07.21.2007) - John Siracusa * Improved parsing of SET values. * Fixed the test suite's detection of the broken DBD::SQLite 1.13. 0.734 (05.04.2007) - John Siracusa * Added the in_transaction() object method. * Added support for YAML and Perl-based fix-up files. * Fixed a dbh reference counting bug that was triggered when a Rose::DB object was given a $dbh that was generated elsewhere. * Improved detection of SKIP ... FIRST ... support in Informix. * Fixed a bug that prevented certain reserved words from being detected as primary key columns in PostgreSQL. (Reported by Fred Cox) 0.733 (02.23.2007) - John Siracusa * Schema support enabled for MySQL. * Added support for Informix's "datetime year to month" column type. * Tweaked handling of doubled quotes in PostgreSQL default column values. 0.732 (01.15.2007) - John Siracusa * Oracle support improved significantly. * Added MySQL $dbh attributes: mysql_auto_reconnect, mysql_enable_utf8, and mysql_use_result. * Rose::DB objects can now be constructed by specifying only a driver, even if no data sources are registered. * Documented new() behavior when parameters beyond just type and domain are passed. (Suggested by Christopher H. Laco) * Fixed a bug that prevented foreign keys with columns that use reserved words from being auto-initialized correctly. (Reported by Clayton Scott) * Improved DSN parsing. 0.731 (11.22.2006) - John Siracusa * Added support for MySQL's SET data type. (Patch by Ask Bjørn Hansen) * Fixed an Informix DSN construction bug. * Corrected the skip-counts for Informix tests. 0.730 (11.07.2006) - John Siracusa * Documented the ability to set the dbh(). 0.729 (10.29.2006) - John Siracusa * Added a description attribute and a clone() method to Rose::DB::Registry::Entry. 0.728 (10.20.2006) - John Siracusa * Added the registered_domains(), registered_types(), and dump() methods to Rose::DB::Registry. * Added a dump() method to Rose::DB::Registry::Entry. * Clone::PP is now a prerequisite. 0.727 (10.06.2006) - John Siracusa * Added the has_dbh() method. * Changes to support Rose::DB::Object 0.754. * Fixed some Informix date/time parsing bugs. * The test suite now refuses to run SQLite tests if the buggy DBD::SQLite version 1.13 is installed. 0.726 (09.17.2006) - John Siracusa * Fixed a bug that caused primary_key_column_names() and list_tables() to fail in Oracle. * Changes to support Rose::DB::Object 0.753. 0.725 (09.06.2006) - John Siracusa * Added time column support for Informix. 0.724 (08.29.2006) - John Siracusa * Corrected the number of tests in oracle.t and subclass-oracle.t. (Reported by Michael Lackhoff) * Failure to load a driver class is now a fatal error. * Fixed parsing of empty string default values in PostgreSQL. 0.723 (08.10.2006) - John Siracusa * Delegate to SQL::ReservedWords to determine which words are reserved. * Correctly indicate that Oracle supports schemas. 0.722 (07.21.2006) - John Siracusa * Support for Rose::DB::Object 0.742. 0.721 (07.14.2006) - John Siracusa * Added end-of-month mode parameter to parse_interval() * Added to the list of reserved words for PostgreSQL and MySQL. 0.72 (06.30.2006) - John Siracusa * Added support for the time data type. 0.71 (06.12.2006) - John Siracusa * Fixed broken Storable support and documented serialization caveats. (Reported by Drew Taylor) 0.70 (06.07.2006) - John Siracusa * Added primary_key_column_names() and has_primary_key() methods. * Added Storable hooks. * Driver classes no longer inherit from Rose::DB. * Improved Oracle DSN generation and quoting. (Suggested by Todd Lorenz) * Improved parsing of default column values in PostgreSQL databases. 0.673 (05.12.2006) - John Siracusa * Added partial support for Oracle databases. (Code by Ron Savage) * Fixed a bug that could cause list_tables() to fail when using the "generic" fall-back database driver. 0.672 (04.14.2006) - John Siracusa * Translate PostgreSQL's "real" type to the standard "float" type. (Patch from Lucian Dragus) 0.671 (04.04.2006) - John Siracusa * The war against stray "._*" files continues! 0.67 (04.04.2006) - John Siracusa * Added support for the interval data type. (Patch provided by Lucian Dragus.) * Prevent post_connect_sql from running more than once per DBI database handle when using Apache::DBI. * Added work-around for interval formatting bug in DateTime::Format::Pg version 0.10 and earlier. 0.66 (03.28.2006) - John Siracusa * Date parsing now passes DateTime objects through immediately instead of trying to parse them as strings and then failing over to Rose::DateTime::Util's parse_date() function. * Updated the test suite to avoid buggy behavior in DBD::Pg 1.43+. * The database password attribute is now stored in a closure to prevent it from appearing in Data::Dumper output. 0.65 (02.07.2006) - John Siracusa * Actually release the changes that were supposed to be in 0.64. 0.64 (02.07.2006) - John Siracusa * Small revisions to the tutorial. 0.63 (02.02.2006) - John Siracusa * Support for Rose::DB::Object 0.66. 0.62 (01.27.2006) - John Siracusa * More MySQL 5 BIT column tweaks. 0.61 (01.19.2006) - John Siracusa * Changes to support MySQL 5's brain-dead new BIT column type. * Changed SQLite's bitfield representation to use strings instead of integers to avoid numification that strips leading zeros. 0.60 (01.08.2006) - John Siracusa * Fixed a serious bug in parse_datetime() and parse_timestamp(). (Reported by Sean Davis) 0.59 (01.06.2006) - John Siracusa * The type and domain parameters to register_db() now default to the default_type() and default_domain(). 0.58 (01.05.2006) - John Siracusa * Improved parsing of default column values in PostgreSQL. 0.57 (12.31.2005) - John Siracusa * Changes to support Rose::DB::Object 0.60 0.56 (12.19.2005) - John Siracusa * Added support for prepended PostgreSQL arrays (e.g., "[0:3]={3,4,5,6}") 0.55 (12.15.2005) - John Siracusa * Changes to support Rose::DB::Object 0.58 0.54 (12.03.2005) - John Siracusa * Changes to support Rose::DB::Object 0.55 0.53 (11.30.2005) - John Siracusa * Added SQLite support. * Driver classes are now loaded on demand. * Changes to support Rose::DB::Object 0.54 0.52 (11.22.2005) - John Siracusa * Fixed a few identifier quoting issues. * Changes to support Rose::DB::Object 0.53 0.51 (11.21.2005) - John Siracusa * Fixed a limit-with-offset bug when connected to Informix 10+. * Changes to support Rose::DB::Object 0.52 0.50 (11.20.2005) - John Siracusa * Added list_tables() method. 0.032 (11.09.2005) - John Siracusa * Driver names are now case-insensitive. * Added generic fallback class for unsupported databases. * Added the use_private_registry() convenience method. * Added some tweaks to support PostgreSQL 8.1. 0.031 (10.25.2005) - John Siracusa * Support for Rose::DB::Object 0.079. 0.03 (10.05.2005) - John Siracusa * Rejiggered magic re-blessing to make private registries to work. * Added support for MySQL's weird "all-zeros" date/time keywords. * Added tutorial. 0.0264 (09.15.2005) - John Siracusa * Changes to support Rose::DB::Object 0.074. 0.0263 (09.07.2005) - John Siracusa * The war against stray "._*" files rages on :-/ 0.0262 (09.07.2005) - John Siracusa * Corrected Informix limit-with-offset support version detection. 0.0261 (08.20.2005) - John Siracusa * POD fixes. 0.026 (08.19.2005) - John Siracusa * Added quote_column_name() method. 0.025 (08.14.2005) - John Siracusa * Fixed support for "all zeros" timestamp defaults in MySQL auto-init. 0.024 (08.12.2005) - John Siracusa * Case-sensitivity fixes for PostgreSQL. * Added tentative support for Informix 10's "limit with offset" feature. 0.023 (08.09.2005) - John Siracusa * Deleted stray ._ files. Blah. 0.022 (08.09.2005) - John Siracusa * Fixed PostgreSQL column default value parsing. 0.021 (08.05.2005) - John Siracusa * Sigh. Forgot to add the catalog attribute to registry entries. 0.02 (08.05.2005) - John Siracusa * Added more granular column types for Pg and Informix datetimes. * Substantial update to support auto-initialization. 0.0154 (06.22.2005) - John Siracusa * Abstracted limit-with-offset syntax. 0.0153 (06.17.2005) - John Siracusa * Added Bit::Vector::Overload to the prerequisites. * Added links to the POD. 0.0152 (05.31.2005) - John Siracusa * Corrected number of tests to skip in trx.t. 0.0151 (05.29.2005) - John Siracusa * Fixed a PostgreSQL transactions test in trx.t. 0.015 (05.12.2005) - John Siracusa * Added proper data source registry and registry entry objects. * Changed behavior of dsn() method to reflect the fact that DBI's parse_dsn() method rarely extracts the information I need. * Added warning to documentation about DSN/attribute sync. 0.0143 (05.04.2005) - John Siracusa * Avoid trying to truncate undefined dates. 0.0142 (04.07.2005) - John Siracusa * Documented connect_options() method. * Added db_exists() method. 0.0141 (03.15.2005) - John Siracusa * Fixed tests to account for versions of DBI without the parse_dsn() method. 0.014 (03.15.2005) - John Siracusa * Added alias_db() class method. 0.013 (03.13.2005) - John Siracusa * Changes dsn() method to clear possibly changed DSN components, and also try to parse the DSN. 0.012 (03.11.2005) - John Siracusa * Fixed incorrect skip amount in pg.t. Sigh. 0.011 (03.11.2005) - John Siracusa * Correct misplaced _ in number. * Fixed bad return value from empty { } method. Perl 5.8.x treats it as I expect, but perl 5.6.1 requires a bare return; 0.01 (03.09.2005) - John Siracusa * Initial release. Rose-DB-0.777/lib/000750 000765 000024 00000000000 12502143063 013567 5ustar00johnstaff000000 000000 Rose-DB-0.777/Makefile.PL000755 000765 000024 00000003454 12502137062 015013 0ustar00johnstaff000000 000000 require 5.006; use ExtUtils::MakeMaker; my $MM_Version = $ExtUtils::MakeMaker::VERSION; if($MM_Version =~ /_/) # dev version { $MM_Version = eval $MM_Version; die $@ if($@); } WriteMakefile(NAME => 'Rose::DB', VERSION_FROM => 'lib/Rose/DB.pm', ($^O =~ /darwin/i ? (dist => { DIST_CP => 'cp' }) : ()), # Avoid Mac OS X ._* files PREREQ_PM => { 'DBI' => 0, 'Clone::PP' => 0, 'Bit::Vector::Overload' => '6.4', 'DateTime::Format::Pg' => '0.11', 'DateTime::Format::MySQL' => 0, 'DateTime::Format::Oracle' => 0, 'DateTime::Duration' => 0, 'Test::More' => 0, 'Rose::Object' => '0.854', 'Rose::DateTime::Util' => '0.532', 'Time::Clock' => 0, 'SQL::ReservedWords' => 0, 'Scalar::Util' => 0, }, clean => { FILES => "t/*.db" }, ($MM_Version >= 6.48 ? (MIN_PERL_VERSION => '5.6.0') : ()), ($MM_Version >= 6.31 ? (LICENSE => 'perl') : ()), ($MM_Version <= 6.44 ? () : (META_MERGE => { resources => { license => 'http://dev.perl.org/licenses/', homepage => 'http://rosecode.org', bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-DB', repository => 'https://github.com/siracusa/rose/tree/master/modules/Rose-DB', MailingList => 'http://groups.google.com/group/rose-db-object', }, }))); Rose-DB-0.777/MANIFEST000644 000765 000024 00000001730 12502143063 014160 0ustar00johnstaff000000 000000 Changes lib/Rose/DB.pm lib/Rose/DB/Cache.pm lib/Rose/DB/Cache/Entry.pm lib/Rose/DB/Constants.pm lib/Rose/DB/Generic.pm lib/Rose/DB/Informix.pm lib/Rose/DB/MySQL.pm lib/Rose/DB/Oracle.pm lib/Rose/DB/Pg.pm lib/Rose/DB/Registry.pm lib/Rose/DB/Registry/Entry.pm lib/Rose/DB/SQLite.pm lib/Rose/DB/Tutorial.pod Makefile.PL MANIFEST t/00-warning.t t/basic.t t/db_cache.t t/fork-informix.t t/fork-mysql.t t/fork-pg.t t/informix.t t/lib/My/DB.pm t/lib/My/FixUp.pm t/list-tables.t t/make-subclass-tests.pl t/mysql.t t/no-registry.t t/oracle.t t/pg.t t/pk-columns.t t/pod.t t/rosedbrc t/setup.t t/sqlite.t t/storable.ext t/storable.t t/subclass-basic.t t/subclass-informix.t t/subclass-list-tables.t t/subclass-mysql.t t/subclass-oracle.t t/subclass-pg.t t/subclass-sqlite.t t/subclass-trx.t t/subclass.t t/test-lib.pl t/trx.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Rose-DB-0.777/META.json000660 000765 000024 00000003324 12502143063 014447 0ustar00johnstaff000000 000000 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Rose-DB", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Bit::Vector::Overload" : "6.4", "Clone::PP" : "0", "DBI" : "0", "DateTime::Duration" : "0", "DateTime::Format::MySQL" : "0", "DateTime::Format::Oracle" : "0", "DateTime::Format::Pg" : "0.11", "Rose::DateTime::Util" : "0.532", "Rose::Object" : "0.854", "SQL::ReservedWords" : "0", "Scalar::Util" : "0", "Test::More" : "0", "Time::Clock" : "0", "perl" : "5.006000" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-DB" }, "homepage" : "http://rosecode.org", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/siracusa/rose/tree/master/modules/Rose-DB" }, "x_MailingList" : "http://groups.google.com/group/rose-db-object" }, "version" : "0.777" } Rose-DB-0.777/META.yml000660 000765 000024 00000002026 12502143063 014275 0ustar00johnstaff000000 000000 --- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Rose-DB no_index: directory: - t - inc requires: Bit::Vector::Overload: '6.4' Clone::PP: '0' DBI: '0' DateTime::Duration: '0' DateTime::Format::MySQL: '0' DateTime::Format::Oracle: '0' DateTime::Format::Pg: '0.11' Rose::DateTime::Util: '0.532' Rose::Object: '0.854' SQL::ReservedWords: '0' Scalar::Util: '0' Test::More: '0' Time::Clock: '0' perl: '5.006000' resources: MailingList: http://groups.google.com/group/rose-db-object bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-DB homepage: http://rosecode.org license: http://dev.perl.org/licenses/ repository: https://github.com/siracusa/rose/tree/master/modules/Rose-DB version: '0.777' Rose-DB-0.777/t/000750 000765 000024 00000000000 12502143063 013264 5ustar00johnstaff000000 000000 Rose-DB-0.777/t/00-warning.t000755 000765 000024 00000005745 12502134373 015362 0ustar00johnstaff000000 000000 #!/usr/bin/perl use strict; sub nvl { defined $ENV{$_[0]} ? $ENV{$_[0]} : $_[1] } print STDERR<<"EOF"; ## ## WARNING: Almost all the tests in this module distribution need to connect ## to a database in order to run. The tests need full privileges on this ## database: the ability to create and drop tables, insert, update, and delete ## rows, create schemas, sequences, functions, triggers, the works. ## ## By default, the tests will try to connect to the database named "test" ## running on "localhost" using the default superuser username for each ## database type and an empty password. ## ## If you have setup your database in a secure manner, these connection ## attempts will fail, and the tests will be skipped. If you want to override ## these values, set the following environment variables before running tests. ## (The current values are shown in parentheses.) ## ## PostgreSQL: ## ## RDBO_PG_DSN (@{[ nvl('RDBO_PG_DSN', 'dbi:Pg:dbname=test;host=localhost') ]}) ## RDBO_PG_USER (@{[ nvl('RDBO_PG_USER', 'postgres') ]}) ## RDBO_PG_PASS (@{[ nvl('RDBO_PG_PASS', '') ]}) ## ## MySQL: ## ## RDBO_MYSQL_DSN (@{[ nvl('RDBO_MYSQL_DSN', 'dbi:mysql:database=test;host=localhost') ]}) ## RDBO_MYSQL_USER (@{[ nvl('RDBO_MYSQL_USER', 'root') ]}) ## RDBO_MYSQL_PASS (@{[ nvl('RDBO_MYSQL_PASS', '') ]}) ## ## Oracle: ## ## RDBO_ORACLE_DSN (@{[ nvl('RDBO_ORACLE_DSN', 'dbi:Oracle:dbname=test') ]}) ## RDBO_ORACLE_USER (@{[ nvl('RDBO_ORACLE_USER', '') ]}) ## RDBO_ORACLE_PASS (@{[ nvl('RDBO_ORACLE_PASS', '') ]}) ## ## Informix: ## ## RDBO_INFORMIX_DSN (@{[ nvl('RDBO_INFORMIX_DSN', 'dbi:Informix:test@test') ]}) ## RDBO_INFORMIX_USER (@{[ nvl('RDBO_INFORMIX_USER', '') ]}) ## RDBO_INFORMIX_PASS (@{[ nvl('RDBO_INFORMIX_PASS', '') ]}) ## ## SQLite: To disable the SQLite tests, set this environment varible ## ## RDBO_NO_SQLITE (@{[ nvl('RDBO_NO_SQLITE', '') ]}) ## ## Press return to continue (or wait 60 seconds) EOF eval { require DBD::SQLite }; (my $version = $DBD::SQLite::VERSION || 0) =~ s/_//g; if(!$@ && ($version < 1.11 || ($version >= 1.13 && $version < 1.1902))) { print STDERR<<"EOF"; *** *** WARNING: DBD::SQLite version 1.13 detected. This version has some *** serious bugs that prevent the test suite from working correctly. *** In particular: *** *** http://rt.cpan.org/Public/Bug/Display.html?id=21472 *** *** The SQLite tests will be skipped. Please install DBD::SQLite 1.12 *** or a version that fixes the bugs in 1.13. *** *** Press return to continue (or wait 60 seconds) EOF } unless($ENV{'AUTOMATED_TESTING'} || $ENV{'PERL_MM_USE_DEFAULT'}) { my %old; $old{'ALRM'} = $SIG{'ALRM'} || 'DEFAULT'; eval { # Localize so I only have to restore in my catch block local $SIG{'ALRM'} = sub { die 'alarm' }; alarm(60); my $res = ; alarm(0); }; if($@ =~ /alarm/) { $SIG{'ALRM'} = $old{'ALRM'}; } } print "1..1\n", "ok 1\n"; 1; Rose-DB-0.777/t/basic.t000755 000765 000024 00000042136 12502134373 014554 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); use Test::More tests => 208; BEGIN { use_ok('Rose::DB'); use_ok('Rose::DB::Registry'); use_ok('Rose::DB::Registry::Entry'); use_ok('Rose::DB::Constants'); require 't/test-lib.pl'; is(Rose::DB::Constants::IN_TRANSACTION(), -1, 'Rose::DB::Constants::IN_TRANSACTION'); Rose::DB::Constants->import('IN_TRANSACTION'); # Default Rose::DB->register_db( domain => 'default', type => 'default', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Main Rose::DB->register_db( domain => 'test', type => 'default', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Aux Rose::DB->register_db( domain => 'test', type => 'aux', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Generic Rose::DB->register_db( domain => 'test', type => 'generic', driver => 'NoneSuch', database => 'test', host => 'localhost', username => 'someuser', password => '', ); # Alias Rose::DB->alias_db(source => { domain => 'test', type => 'aux' }, alias => { domain => 'atest', type => 'aaux' }); package MyPgClass; @MyPgClass::ISA = qw(Rose::DB::Pg); sub format_date { die "boo!" } } my $sqlite_ok = have_db('sqlite_admin'); is_deeply(scalar Rose::DB->registry->registered_domains, [ qw(atest catalog_test default test) ], 'registered_domains()'); is_deeply(scalar Rose::DB->registry->registered_types('test'), [ qw(aux default generic informix informix_admin mysql mysql_admin oracle oracle_admin pg pg_admin pg_with_schema), ($sqlite_ok ? qw(sqlite sqlite_admin) : ()) ], 'registered_types()'); # Lame arbitrary test of one dump attr my $dump = Rose::DB->registry->dump; is($dump->{'test'}{'aux'}{'username'}, 'postgres', 'dump() 1'); is(IN_TRANSACTION, -1, 'IN_TRANSACTION'); is(Rose::DB->default_keyword_function_calls, 0, 'default_keyword_function_calls 1'); Rose::DB->default_keyword_function_calls(1); is(Rose::DB->default_keyword_function_calls, 1, 'default_keyword_function_calls 2'); my $db = Rose::DB->new; is($db->keyword_function_calls, 1, 'keyword_function_calls 1'); $db = Rose::DB->new; is($db->keyword_function_calls, 1, 'keyword_function_calls 2'); is(Rose::DB->default_domain, 'test', 'default_domain() 1'); is(Rose::DB->default_type, 'default', 'default_type() 1'); ok(Rose::DB->db_exists('default'), 'db_exists() 1'); ok(!Rose::DB->db_exists('defaultx'), 'db_exists() 2'); ok(Rose::DB->db_exists(type => 'default'), 'db_exists() 3'); ok(!Rose::DB->db_exists(type => 'defaultx'), 'db_exists() 4'); ok(Rose::DB->db_exists(type => 'default', domain => 'test'), 'db_exists() 3'); ok(!Rose::DB->db_exists(type => 'defaultx', domain => 'testx'), 'db_exists() 4'); ok(!Rose::DB->db_exists(type => 'defaultx', domain => 'test'), 'db_exists() 3'); Rose::DB->error('foo'); is(Rose::DB->error, 'foo', 'error() 2'); $db->error('bar'); is(Rose::DB->error, 'bar', 'error() 3'); is($db->error, 'bar', 'error() 4'); eval { $db = Rose::DB->new }; ok(!$@, 'Valid type and domain'); Rose::DB->default_domain('foo'); is(Rose::DB->default_domain, 'foo', 'default_domain() 2'); eval { $db = Rose::DB->new }; ok($@, 'Invalid domain'); Rose::DB->default_domain('test'); Rose::DB->default_type('bar'); is(Rose::DB->default_type, 'bar', 'default_type() 2'); eval { $db = Rose::DB->new }; ok($@, 'Invalid type'); is(Rose::DB->driver_class('Pg'), 'Rose::DB::Pg', 'driver_class() 1'); is(Rose::DB->driver_class('xxx'), undef, 'driver_class() 2'); Rose::DB->driver_class(Pg => 'MyPgClass'); is(Rose::DB->driver_class('Pg'), 'MyPgClass', 'driver_class() 3'); $db = Rose::DB->new(type => 'aux', database => 'xyzzy'); is($db->database, 'xyzzy', 'override on new() 1'); $db = Rose::DB->new(type => 'aux', dsn => 'dbi:Pg:host=foo;database=bar'); is($db->dsn, 'dbi:Pg:host=foo;database=bar', 'override on new() 2'); $db = Rose::DB->new('aux'); ok($db->isa('MyPgClass'), 'new() single arg'); is($db->error('foo'), 'foo', 'subclass 1'); is($db->error, 'foo', 'subclass 2'); eval { $db->format_date('123') }; ok($@ =~ /^boo!/, 'driver_class() 4'); is(Rose::DB->default_connect_option('AutoCommit'), 1, "default_connect_option('AutoCommit')"); is(Rose::DB->default_connect_option('RaiseError'), 1, "default_connect_option('RaiseError')"); is(Rose::DB->default_connect_option('PrintError'), 1, "default_connect_option('PrintError')"); is(Rose::DB->default_connect_option('ChopBlanks'), 1, "default_connect_option('ChopBlanks')"); is(Rose::DB->default_connect_option('Warn'), 0, "default_connect_option('Warn')"); my $options = Rose::DB->default_connect_options; is(ref $options, 'HASH', 'default_connect_options() 1'); is(join(',', sort keys %$options), 'AutoCommit,ChopBlanks,PrintError,RaiseError,Warn', 'default_connect_options() 2'); Rose::DB->default_connect_options(a => 1, b => 2); is(Rose::DB->default_connect_option('a'), 1, "default_connect_option('a')"); is(Rose::DB->default_connect_option('b'), 2, "default_connect_option('b')"); Rose::DB->default_connect_options({ c => 3, d => 4 }); is(Rose::DB->default_connect_option('c'), 3, "default_connect_option('c') 1"); is(Rose::DB->default_connect_option('d'), 4, "default_connect_option('d') 1"); my $keys = join(',', sort keys %{$db->default_connect_options}); $db->default_connect_options(zzz => 'bar'); my $keys2 = join(',', sort keys %{$db->default_connect_options}); is($keys2, "$keys,zzz", 'default_connect_options() 1'); $db->default_connect_options({ zzz => 'bar' }); $keys2 = join(',', sort keys %{$db->default_connect_options}); is($keys2, 'zzz', 'default_connect_options() 2'); $keys = join(',', sort keys %{$db->connect_options}); $db->connect_options(zzzz => 'bar'); $keys2 = join(',', sort keys %{$db->connect_options}); is($keys2, "$keys,zzzz", 'connect_option() 1'); $db->connect_options({ zzzz => 'bar' }); $keys2 = join(',', sort keys %{$db->connect_options}); is($keys2, 'zzzz', 'connect_option() 2'); $db->dsn('dbi:Pg:dbname=dbfoo;host=hfoo;port=pfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:mysql:dbname=dbfoo;host=hfoo;port=pfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); $db = Rose::DB->new(domain => 'test', type => 'aux'); my $adb = Rose::DB->new(domain => 'atest', type => 'aaux'); is($db->class, 'Rose::DB', 'class() 1'); foreach my $attr (qw(domain type driver database username password connect_options post_connect_sql)) { is($db->username, $adb->username, "alias $attr()"); } Rose::DB->modify_db(domain => 'test', type => 'aux', username => 'blargh', connect_options => { Foo => 1 }); $db->init_db_info(refresh => 1); $adb->init_db_info(refresh => 1); is($db->username, $adb->username, "alias username() mod"); is($db->connect_options->{'Foo'}, $adb->connect_options->{'Foo'}, "alias connect_options() mod"); $db = Rose::DB->new('generic'); ok($db->isa('Rose::DB::Generic'), 'generic class'); is($db->dsn, 'dbi:NoneSuch:dbname=test;host=localhost', 'generic dsn'); ok(!$db->has_dbh, 'has_dbh() 1'); # # Registry tests # my $reg = Rose::DB->registry; ok($reg->isa('Rose::DB::Registry'), 'registry'); my $entry = $reg->entry(domain => 'test', type => 'aux'); ok($entry->isa('Rose::DB::Registry::Entry'), 'registry entry 1'); foreach my $param (qw(autocommit database domain driver dsn host password port print_error raise_error handle_error server_time_zone schema type username connect_options pre_disconnect_sql post_connect_sql)) { eval { $entry->$param() }; ok(!$@, "entry $param()"); } my $host = $entry->host; my $database = $entry->database; Rose::DB->modify_db(domain => 'test', type => 'aux', host => 'foo', database => 'bar'); is($entry->host, 'foo', 'entry modify_db() 1'); is($entry->database, 'bar', 'entry modify_db() 2'); is($entry->connect_option('RaiseError') || 0, 0, 'entry connect_option() 1'); $entry->connect_option('RaiseError' => 1); is($entry->connect_option('RaiseError'), 1, 'entry connect_option() 2'); $entry->pre_disconnect_sql(qw(sql1 sql2)); my $sql = $entry->pre_disconnect_sql; ok(@$sql == 2 && $sql->[0] eq 'sql1' && $sql->[1] eq 'sql2', 'entry pre_disconnect_sql() 1'); $entry->post_connect_sql(qw(sql3 sql4)); $sql = $entry->post_connect_sql; ok(@$sql == 2 && $sql->[0] eq 'sql3' && $sql->[1] eq 'sql4', 'entry post_connect_sql() 1'); $entry->raise_error(0); is($entry->connect_option('RaiseError'), 0, 'entry raise_error() 1'); $entry->print_error(1); is($entry->connect_option('PrintError'), 1, 'entry print_error() 1'); $entry->autocommit(1); is($entry->connect_option('AutoCommit'), 1, 'entry autocommit() 1'); my $handler = sub { 123 }; $entry->handle_error($handler); is($entry->connect_option('HandleError'), $handler, 'entry handle_error() 1'); { package MyTest::DB; our @ISA = qw(Rose::DB); MyTest::DB->use_private_registry; MyTest::DB->default_type('dt'); MyTest::DB->default_domain('dd'); MyTest::DB->register_db(driver => 'sqlite'); } $db = MyTest::DB->new; is($db->type, 'dt', 'default type 1'); is($db->domain, 'dd', 'default domain 1'); { package MyTest::DB2; our @ISA = qw(Rose::DB); MyTest::DB2->default_type('xdt'); MyTest::DB2->default_domain('xdd'); MyTest::DB2->register_db(driver => 'sqlite'); } $db = MyTest::DB2->new; is($db->type, 'xdt', 'default type 2'); is($db->domain, 'xdd', 'default domain 2'); my @Intervals = ( '+0::' => '', '-0:1:' => '-00:01:00', '2:' => '02:00:00', '1 D' => '1 day', '-1 d 2 s' => '-1 days +00:00:02', '-1 y 3 h -57 M 4 s' => '-1 years +02:03:04', '-1 y 2 mons 3 d' => '-10 mons +3 days', '-1 y 2 mons -3 d' => '-10 mons -3 days', '5 h -208 m -495 s' => '01:23:45', '-208 m -495 s' => '-03:36:15', '5 h 208 m 495 s' => '08:36:15', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '1234 years 5 mons 6 days 07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '-1234 years -5 mons -6 days -07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '1234 years 5 mons 6 days 07:08:09', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '1234 years 5 mons 6 days 07:08:09', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '1234 years 5 mons 6 days 07:08:09', '1 mil -1 d ago' => '-1000 years +1 day', '1 mil ago -1 d ago' => '-1000 years +1 day', ); my $i = 0; while($i < @Intervals) { my($val, $formatted) = ($Intervals[$i++], $Intervals[$i++]); is($db->format_interval($db->parse_interval($val)), $formatted, "parse_interval ($val)"); } MyTest::DB2->max_interval_characters(1); eval { $db->format_interval($db->parse_interval('1 day ago')) }; ok($@, 'max_interval_characters 1'); ok(Rose::DB->max_interval_characters != MyTest::DB2->max_interval_characters, 'max_interval_characters 2'); $db->keyword_function_calls(1); is($db->parse_interval('foo()'), 'foo()', 'parse_interval (foo())'); $db->keyword_function_calls(0); MyTest::DB2->max_interval_characters(255); my $d = $db->parse_interval('1 year 0.000003 seconds'); is($d->nanoseconds, 3000, 'nanoseconds 1'); is($db->format_interval($d), '1 year 00:00:00.000003000', 'nanoseconds 2'); # Time vaues my $tc; ok($tc = $db->parse_time('12:34:56.123456789'), 'parse time 12:34:56.123456789'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789'); ok($tc = $db->parse_time('12:34:56.123456789 pm'), 'parse time 12:34:56.123456789 pm'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789 pm'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789 pm'); ok($tc = $db->parse_time('12:34:56. A.m.'), 'parse time 12:34:56. A.m.'); is($tc->as_string, '00:34:56', 'check time 12:34:56 am'); is($db->format_time($tc), '00:34:56', 'format time 12:34:56 am'); ok($tc = $db->parse_time('12:34:56 pm'), 'parse time 12:34:56 pm'); is($tc->as_string, '12:34:56', 'check time 12:34:56 pm'); is($db->format_time($tc), '12:34:56', 'format time 12:34:56 pm'); ok($tc = $db->parse_time('2:34:56 pm'), 'parse time 2:34:56 pm'); is($tc->as_string, '14:34:56', 'check time 14:34:56 pm'); is($db->format_time($tc), '14:34:56', 'format time 14:34:56 pm'); ok($tc = $db->parse_time('2:34 pm'), 'parse time 2:34 pm'); is($tc->as_string, '14:34:00', 'check time 2:34 pm'); is($db->format_time($tc), '14:34:00', 'format time 2:34 pm'); ok($tc = $db->parse_time('2 pm'), 'parse time 2 pm'); is($tc->as_string, '14:00:00', 'check time 2 pm'); is($db->format_time($tc), '14:00:00', 'format time 2 pm'); ok($tc = $db->parse_time('3pm'), 'parse time 3pm'); is($tc->as_string, '15:00:00', 'check time 3pm'); is($db->format_time($tc), '15:00:00', 'format time 3pm'); ok($tc = $db->parse_time('4 p.M.'), 'parse time 4 p.M.'); is($tc->as_string, '16:00:00', 'check time 4 p.M.'); is($db->format_time($tc), '16:00:00', 'format time 4 p.M.'); ok($tc = $db->parse_time('24:00:00'), 'parse time 24:00:00'); is($tc->as_string, '24:00:00', 'check time 24:00:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00'); ok($tc = $db->parse_time('24:00:00 PM'), 'parse time 24:00:00 PM'); is($tc->as_string, '24:00:00', 'check time 24:00:00 PM'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00 PM'); ok($tc = $db->parse_time('24:00'), 'parse time 24:00'); is($tc->as_string, '24:00:00', 'check time 24:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00'); ok(!defined $db->parse_time('24:00:00.000000001'), 'parse time fail 24:00:00.000000001'); ok(!defined $db->parse_time('24:00:01'), 'parse time fail 24:00:01'); ok(!defined $db->parse_time('24:01'), 'parse time fail 24:01'); if(have_db('sqlite')) { Rose::DB->register_db ( domain => 'handel', type => 'default', driver => 'SQLite', ); $db = Rose::DB->new ( domain => 'handel', type => 'default', dsn => "dbi:SQLite:dbname=$Bin/sqlite.db", ); my $dbh = $db->dbh; is($db->dsn, "dbi:SQLite:dbname=$Bin/sqlite.db", 'dsn preservation 1'); $db = Rose::DB->new ( domain => 'handel', type => 'default', database => "$Bin/sqlitex.db", ); $dbh = $db->dbh; is($db->dsn, "dbi:SQLite:dbname=$Bin/sqlitex.db", 'dsn preservation 2'); unlink("$Bin/sqlite.db"); unlink("$Bin/sqlitex.db"); } else { ok(1, 'skipping - dsn preservation requires sqlite 1'); ok(1, 'skipping - dsn preservation requires sqlite 2'); } # # Registry entry tests # my @entry; $i = 1; foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'scalar'))) { push(@entry, $attr => ($attr eq 'driver' || $attr eq 'dbi_driver' ? 'sqlite' : $i++)); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'boolean'))) { push(@entry, $attr => $i++ % 2); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'hash'))) { push(@entry, $attr => { $i++ => $i++ }); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'array'))) { push(@entry, $attr => [ $i++ ]); } $entry = Rose::DB::Registry::Entry->new(@entry); $dump = $entry->dump; is_deeply($dump, { @entry }, 'dump entry'); if(have_db('mysql')) { my %mysql_entry = map { $_ => $dump->{$_} } grep { /^mysql_/ } keys %$dump; Rose::DB->register_db( domain => 'abc', type => 'def', driver => 'mysql', database => 'test', %mysql_entry); my $db = Rose::DB->new(domain => 'abc', type => 'def'); foreach my $attr (grep { /^mysql_/ } keys %$dump) { is($db->$attr(), $dump->{$attr}, "entry attr - $attr"); } } else { my $count = grep { /^mysql_/ } keys %$dump; SKIP: { skip('mysql entry tests', $count) } } if(have_db('sqlite')) { { package My::DBX; use base 'Rose::DB'; My::DBX->register_db( driver => 'SQLite', ); My::DBX->default_connect_options( { RaiseError => 0, } ); } my $db1 = My::DBX->new; ok(!$db1->dbh->{RaiseError}, 'RaiseError false'); my $db2 = My::DBX->new(raise_error => 1); ok($db2->dbh->{RaiseError}, 'RaiseError true'); my $db3 = My::DBX->new; ok(!$db3->dbh->{RaiseError}, 'RaiseError false'); } else { SKIP: { skip('connect option tests that require DBD::SQLite', 3) } } Rose-DB-0.777/t/db_cache.t000755 000765 000024 00000003433 12502134373 015200 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); use Test::More tests => 3 + (5 * 5) + (5 * 5); BEGIN { use_ok('Rose::DB'); use_ok('Rose::DB::Cache'); use_ok('Rose::DB::Cache::Entry'); require 't/test-lib.pl'; } foreach my $db_type (map { "${_}_admin" } qw(mysql pg informix sqlite oracle)) { SKIP: { unless(have_db($db_type)) { skip("$db_type tests", 5); } } next unless(have_db($db_type)); Rose::DB->default_type($db_type); my($db, $db2); ok($db = Rose::DB->new_or_cached(), "new_or_cached 1 - $db_type"); ok(ref $db && $db->isa('Rose::DB'), "new_or_cached 2 - $db_type"); ok($db2 = Rose::DB->new_or_cached(), "new_or_cached 3 - $db_type"); is($db->dbh, $db2->dbh, "new_or_cached dbh check - $db_type"); is_deeply([ sort Rose::DB->db_cache->db_cache_keys ], [ sort map { $_->key } Rose::DB->db_cache->db_cache_entries ], "db_cache_entries, db_cache_keys - $db_type"); } no warnings 'redefine'; *Rose::DB::dbi_connect = sub { shift; DBI->connect_cached(@_) }; foreach my $db_type (map { "${_}_admin" } qw(mysql pg informix sqlite oracle)) { SKIP: { unless(have_db($db_type)) { skip("$db_type tests", 5); } } next unless(have_db($db_type)); Rose::DB->default_type($db_type); my($db, $db2); ok($db = Rose::DB->new(), "dbi_connect override 1 - $db_type"); ok(ref $db && $db->isa('Rose::DB'), "dbi_connect override 2 - $db_type"); ok($db2 = Rose::DB->new(), "dbi_connect override 3 - $db_type"); is($db->dbh, $db2->dbh, "dbi_connect override dbh check - $db_type"); is_deeply([ sort Rose::DB->db_cache->db_cache_keys ], [ sort map { $_->key } Rose::DB->db_cache->db_cache_entries ], "dbi_connect override db_cache_entries, db_cache_keys - $db_type"); } Rose-DB-0.777/t/fork-informix.t000644 000765 000024 00000000241 12502134373 016251 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); no warnings 'once'; $Rose::DB::TEST::DB_TYPE = 'informix_admin'; do "$Bin/fork-mysql.t"; die $@ if($@); Rose-DB-0.777/t/fork-mysql.t000644 000765 000024 00000002230 12502134373 015563 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; require Test::More; if($^O =~ /MSWin/) { Test::More->import(skip_all => "Can't fork() on Win32"); } else { Test::More->import(tests => 1); } use POSIX ':sys_wait_h'; use Rose::DB; require 't/test-lib.pl'; no warnings 'once'; my $db_type = $Rose::DB::TEST::DB_TYPE || 'mysql_admin'; if(have_db($db_type)) { my $db = Rose::DB->new($db_type); eval { my $dbh = $db->dbh; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE fork_test'); }; $db->dbh->do('CREATE TABLE fork_test (i int)'); $db->dbh->do('INSERT INTO fork_test (i) VALUES (1)'); $db->dbh->do('INSERT INTO fork_test (i) VALUES (2)'); $SIG{'CHLD'} = \&Reaper; if(fork()) { # Parent sleep(3); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM fork_test WHERE i > 2'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 1, 'fork test'); } else { # Child $db->dbh->do('INSERT INTO fork_test (i) VALUES (3)'); $db = undef; exit(0); } } else { SKIP: { skip("$db_type not available", 1) } } sub Reaper { my $child; 1 while(waitpid(-1, WNOHANG) > 0); $SIG{'CHLD'} = \&Reaper; } Rose-DB-0.777/t/fork-pg.t000644 000765 000024 00000000233 12502134373 015025 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); no warnings 'once'; $Rose::DB::TEST::DB_TYPE = 'pg_admin'; do "$Bin/fork-mysql.t"; die $@ if($@); Rose-DB-0.777/t/informix.t000755 000765 000024 00000035654 12502134373 015335 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Informix }; if($@) { Test::More->import(skip_all => 'Missing DBD::Informix'); } else { Test::More->import(tests => 134); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } Rose::DB->default_domain('test'); Rose::DB->default_type('informix'); my $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 8) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = Rose::DB->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database username password)) { is($db2->$field(), $db->$field(), "$field()"); } ok(defined $db->supports_limit_with_offset, 'supports_limit_with_offset'); $db->disconnect; $db2->disconnect; } $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->validate_timestamp_keyword('today'), 'validate_timestamp_keyword (today)'); ok($db->validate_timestamp_keyword('current'), 'validate_timestamp_keyword (current)'); ok($db->validate_timestamp_keyword('current year to second'), 'validate_timestamp_keyword (current year to second)'); ok($db->validate_timestamp_keyword('current year to minute'), 'validate_timestamp_keyword (current year to minute)'); ok($db->validate_timestamp_keyword('current year to hour'), 'validate_timestamp_keyword (current year to hour)'); ok($db->validate_timestamp_keyword('current year to day'), 'validate_timestamp_keyword (current year to day)'); ok($db->validate_timestamp_keyword('current year to month'), 'validate_timestamp_keyword (current year to month)'); ok($db->validate_timestamp_keyword('current year to fraction(1)'), 'validate_timestamp_keyword (current year to fraction(1))'); ok($db->validate_timestamp_keyword('current year to fraction(5)'), 'validate_timestamp_keyword (current year to fraction(5))'); ok(!$db->validate_timestamp_keyword('current year to fraction(6)'), 'validate_timestamp_keyword (current year to fraction(6))'); ok(!$db->validate_timestamp_keyword('now'), 'validate_timestamp_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_timestamp_keyword('Foo(Bar)'), 'validate_timestamp_keyword (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_timestamp('current'), 'current', 'format_timestamp (current)'); is($db->format_timestamp('current year to fraction(1)'), 'current year to fraction(1)', 'format_timestamp (current year to fraction(1))'); is($db->format_timestamp('current year to fraction(5)'), 'current year to fraction(5)', 'format_timestamp (current year to fraction(5))'); $db->keyword_function_calls(1); is($db->format_timestamp('Foo(Bar)'), 'Foo(Bar)', 'format_timestamp (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_keyword('today'), 'validate_datetime_keyword (today)'); ok($db->validate_datetime_keyword('current year to second'), 'validate_datetime_keyword (current year to second)'); ok($db->validate_datetime_keyword('current year to minute'), 'validate_datetime_keyword (current year to minute)'); ok($db->validate_datetime_keyword('current year to hour'), 'validate_datetime_keyword (current year to hour)'); ok($db->validate_datetime_keyword('current year to day'), 'validate_datetime_keyword (current year to day)'); ok($db->validate_datetime_keyword('current year to month'), 'validate_datetime_keyword (current year to month)'); ok($db->validate_datetime_keyword('current'), 'validate_datetime_keyword current'); ok(!$db->validate_datetime_keyword('now'), 'validate_datetime_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_datetime_keyword('Foo(Bar)'), 'validate_datetime_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_fraction_keyword('today'), 'validate_datetime_year_to_fraction_keyword (today)'); ok($db->validate_datetime_year_to_fraction_keyword('current'), 'validate_timestamp_keyword (current)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to second'), 'validate_timestamp_keyword (current year to second)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to minute'), 'validate_timestamp_keyword (current year to minute)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to hour'), 'validate_timestamp_keyword (current year to hour)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to day'), 'validate_timestamp_keyword (current year to day)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to month'), 'validate_timestamp_keyword (current year to month)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to fraction(1)'), 'validate_timestamp_keyword (current year to fraction(1))'); ok($db->validate_datetime_year_to_fraction_keyword('current year to fraction(5)'), 'validate_timestamp_keyword (current year to fraction(5))'); ok(!$db->validate_datetime_year_to_fraction_keyword('current year to fraction(6)'), 'validate_timestamp_keyword (current year to fraction(6))'); ok(!$db->validate_datetime_year_to_fraction_keyword('now'), 'validate_timestamp_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_fraction_keyword('Foo(Bar)'), 'validate_timestamp_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_minute_keyword('today'), 'validate_datetime_year_to_minute_keyword (today)'); ok($db->validate_datetime_year_to_minute_keyword('current'), 'validate_datetime_year_to_minute_keyword current'); ok($db->validate_datetime_year_to_minute_keyword('current year to second'), 'validate_datetime_year_to_minute_keyword current year to second'); ok($db->validate_datetime_year_to_minute_keyword('current year to minute'), 'validate_datetime_year_to_minute_keyword current year to minute'); ok($db->validate_datetime_year_to_minute_keyword('current year to hour'), 'validate_datetime_year_to_minute_keyword (current year to hour)'); ok($db->validate_datetime_year_to_minute_keyword('current year to day'), 'validate_datetime_year_to_minute_keyword (current year to day)'); ok($db->validate_datetime_year_to_minute_keyword('current year to month'), 'validate_datetime_year_to_minute_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_minute_keyword('Foo(Bar)'), 'validate_datetime_year_to_minute_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_month_keyword('today'), 'validate_datetime_year_to_month_keyword (today)'); ok($db->validate_datetime_year_to_month_keyword('current'), 'validate_datetime_year_to_month_keyword current'); ok($db->validate_datetime_year_to_month_keyword('current year to second'), 'validate_datetime_year_to_month_keyword current year to second'); ok($db->validate_datetime_year_to_month_keyword('current year to minute'), 'validate_datetime_year_to_month_keyword current year to minute'); ok($db->validate_datetime_year_to_month_keyword('current year to hour'), 'validate_datetime_year_to_month_keyword (current year to hour)'); ok($db->validate_datetime_year_to_month_keyword('current year to day'), 'validate_datetime_year_to_month_keyword (current year to day)'); ok($db->validate_datetime_year_to_month_keyword('current year to month'), 'validate_datetime_year_to_month_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_month_keyword('Foo(Bar)'), 'validate_datetime_year_to_month_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_second_keyword('today'), 'validate_datetime_year_to_second_keyword (today)'); ok($db->validate_datetime_year_to_second_keyword('current'), 'validate_datetime_year_to_second_keyword current'); ok($db->validate_datetime_year_to_second_keyword('current year to second'), 'validate_datetime_year_to_second_keyword current year to second'); ok($db->validate_datetime_year_to_second_keyword('current year to minute'), 'validate_datetime_year_to_second_keyword current year to minute'); ok($db->validate_datetime_year_to_second_keyword('current year to hour'), 'validate_datetime_year_to_second_keyword (current year to hour)'); ok($db->validate_datetime_year_to_second_keyword('current year to day'), 'validate_datetime_year_to_second_keyword (current year to day)'); ok($db->validate_datetime_year_to_second_keyword('current year to month'), 'validate_datetime_year_to_second_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_second_keyword('Foo(Bar)'), 'validate_datetime_year_to_second_keyword (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_datetime('current'), 'current', 'format_datetime current'); ok($db->validate_datetime_year_to_second_keyword('current year to second'), 'validate_datetime_year_to_second_keyword current year to second'); ok($db->validate_datetime_year_to_second_keyword('current year to minute'), 'validate_datetime_year_to_second_keyword current year to minute'); ok($db->validate_datetime_year_to_second_keyword('current year to hour'), 'validate_datetime_year_to_second_keyword (current year to hour)'); ok($db->validate_datetime_year_to_second_keyword('current year to day'), 'validate_datetime_year_to_second_keyword (current year to day)'); ok($db->validate_datetime_year_to_second_keyword('current year to month'), 'validate_datetime_year_to_second_keyword (current year to month)'); $db->keyword_function_calls(1); is($db->format_datetime('Foo(Bar)'), 'Foo(Bar)', 'format_datetime (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_date_keyword('today'), 'validate_date_keyword (today)'); ok($db->validate_date_keyword('current'), 'validate_date_keyword current'); ok(!$db->validate_date_keyword('now'), 'validate_date_keyword (!now)'); is($db->format_date('current'), 'current', 'format_date (current)'); $db->keyword_function_calls(1); is($db->format_date('Foo(Bar)'), 'Foo(Bar)', 'format_date (Foo(Bar))'); $db->keyword_function_calls(0); #ok($db->validate_time_keyword('current'), 'validate_time_keyword current'); #is($db->format_time('current'), 'current', 'format_time (current)'); $db->keyword_function_calls(1); is($db->format_time('Foo(Bar)'), 'Foo(Bar)', 'format_time (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); eval { $db->format_array('a', undef) }; ok($@ =~ /undefined/i, 'format_array() 4'); eval { $db->format_array([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_array() 5'); my $a = $db->parse_array(q({"a","b"})); is($db->format_set([ 'a', 'b' ]), q(SET{'a','b'}), 'format_set() 1'); is($db->format_set('a', 'b'), q(SET{'a','b'}), 'format_set() 2'); eval { $db->format_set('a', undef) }; ok($@ =~ /undefined/i, 'format_set() 3'); eval { $db->format_set([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_set() 4'); my $s = $db->parse_set(q(SET{'a','b'})); ok(@$s == 2 && $s->[0] eq 'a' && $s->[1] eq 'b', 'parse_set() 1'); $s = $db->parse_set(q(SET{'4 '})); ok(@$s == 1 && $s->[0] eq '4 ', 'parse_set() 2'); $s = $db->parse_set(q(SET{'4 '}), { value_type => 'integer' }); ok(@$s == 1 && $s->[0] eq '4', 'parse_set() 3'); SKIP: { eval { $db->connect }; skip("Could not connect to db 'test', 'informix' - $@", 37) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'informix', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('2002-12-31', 'floating')), '12/31/2002', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); my $dt = $db->parse_datetime_year_to_second('12/31/2002 12:34:56.123456789'); is($dt->nanosecond, 0, 'parse_datetime_year_to_second()'); $dt = $db->parse_datetime_year_to_minute('12/31/2002 12:34:56'); is($dt->second, 0, 'parse_datetime_year_to_minute()'); is($db->format_datetime_year_to_second(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime_year_to_second() floating"); is($db->format_datetime_year_to_minute(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34', "format_datetime_year_to_minute() floating"); is($db->format_datetime_year_to_month(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12', "format_datetime_year_to_month() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.12345', 'floating')), '2002-12-31 12:34:56.12345', "format_timestamp() floating"); #is($db->format_time(parse_date('12/31/2002 12:34:56', 'floating')), '12:34:56', "format_datetime() floating"); is($db->format_bitfield($db->parse_bitfield('1010')), q(1010), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(1010), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(0010), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(1010), "format_bitfield() 4"); my $str = $db->format_array([ 'a' .. 'c' ]); is($str, '{"a","b","c"}', 'format_array() 1'); my $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && $ar->[1] eq 'b' && $ar->[2] eq 'c', 'parse_array() 1'); $str = $db->format_array($ar); is($str, '{"a","b","c"}', 'format_array() 2'); $str = $db->format_array([ 1, -2, 3.5 ]); is($str, '{1,-2,3.5}', 'format_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 2'); $str = $db->format_array($ar); is($str, '{1,-2,3.5}', 'format_array() 4'); $str = $db->format_array(1, -2, 3.5); is($str, '{1,-2,3.5}', 'format_array() 5'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 3'); is($db->format_boolean(1), 't', 'format_boolean (1)'); is($db->format_boolean(0), 'f', 'format_boolean (0)'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('T'), 1, 'parse_boolean (T)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('F'), 0, 'parse_boolean (F)'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } Rose-DB-0.777/t/lib/000750 000765 000024 00000000000 12502143063 014032 5ustar00johnstaff000000 000000 Rose-DB-0.777/t/list-tables.t000755 000765 000024 00000043345 12502134373 015721 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 1 + (6 * 2); BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } our @Tables = sort qw(rdbo_test_vendors rdbo_test_products rdbo_test_prices rdbo_test_colors rdbo_test_products_colors); my $Regex = '^(?:' . join('|', @Tables, 'rdbo_test_view', 'read') . ')'; our %Have; # # Tests # foreach my $db_type (qw(mysql pg pg_with_schema informix sqlite oracle)) { SKIP: { unless($Have{$db_type}) { skip("$db_type tests", 2); } } next unless($Have{$db_type}); Rose::DB->default_type($db_type); my $db = Rose::DB->new; # Oracle returns names in upper case. my @tables = sort grep { /$Regex/i } $db->list_tables; if($db_type eq 'mysql') { is_deeply(\@tables, [ sort(@Tables, 'read') ], "$db_type tables 1"); } elsif($db_type eq 'informix') { # Informix shows views every time is_deeply(\@tables, [ sort(@Tables, 'rdbo_test_view') ], "$db_type tables"); } elsif($db_type eq 'oracle') { is_deeply(\@tables, [ map { uc } @Tables ], "$db_type tables 1"); } else { is_deeply(\@tables, \@Tables, "$db_type tables 1"); } # Oracle returns names in upper case. @tables = sort grep { /$Regex/i } $db->list_tables(include_views => 1); if($db_type =~ /^(?:pg(?:_with_schema)?|sqlite|informix)$/) { is_deeply(\@tables, [ sort(@Tables, 'rdbo_test_view') ], "$db_type tables and views"); } else { if($db_type eq 'mysql') { is_deeply(\@tables, [ sort(@Tables, 'read') ], "$db_type tables and views"); } elsif($db_type eq 'oracle') { is_deeply(\@tables, [ map { uc } (@Tables, 'rdbo_test_view') ], "$db_type tables and views"); } else { is_deeply(\@tables, \@Tables, "$db_type tables and views"); } } } BEGIN { our %Have; # # PostgreSQL # my $dbh; eval { $dbh = Rose::DB->new('pg_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { $Have{'pg'} = 1; $Have{'pg_with_schema'} = 1; # Drop existing tables and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP VIEW Rose_db_object_private.rdbo_test_view'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_vendors CASCADE'); $dbh->do('DROP SCHEMA Rose_db_object_private CASCADE'); $dbh->do('CREATE SCHEMA Rose_db_object_private'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP NOT NULL DEFAULT NOW(), release_date TIMESTAMP, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP NOT NULL DEFAULT NOW(), release_date TIMESTAMP, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW Rose_db_object_private.rdbo_test_view AS SELECT * FROM Rose_db_object_private.rdbo_test_colors EOF $dbh->disconnect; } # # Oracle # eval { $dbh = Rose::DB->new('oracle_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { $Have{'oracle'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_products CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE CONSTRAINTS'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATE, release_date DATE, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INT NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->commit; $dbh->disconnect; } # # MySQL # eval { my $db = Rose::DB->new('mysql_admin'); $dbh = $db->retain_dbh or die Rose::DB->error; die "MySQL version too old" unless($db->database_version >= 4_000_000); # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP TABLE `read` CASCADE'); } # Foreign key stuff requires InnoDB support $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) ENGINE=InnoDB EOF # MySQL will silently ignore the "ENGINE=InnoDB" part and create # a MyISAM table instead. MySQL is evil! Now we have to manually # check to make sure an InnoDB table was really created. my $db_name = $db->database; my $sth = $dbh->prepare("SHOW TABLE STATUS FROM `$db_name` LIKE ?"); $sth->execute('rdbo_test_vendors'); my $info = $sth->fetchrow_hashref; no warnings 'uninitialized'; unless(lc $info->{'Type'} eq 'innodb' || lc $info->{'Engine'} eq 'innodb') { die "Missing InnoDB support"; } }; if(!$@ && $dbh) { $Have{'mysql'} = 1; $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT, status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP, release_date TIMESTAMP, UNIQUE(name), INDEX(vendor_id), FOREIGN KEY (vendor_id) REFERENCES rdbo_test_vendors (id) ON DELETE NO ACTION ON UPDATE SET NULL ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INT AUTO_INCREMENT PRIMARY KEY, product_id INT NOT NULL, region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region), INDEX(product_id), FOREIGN KEY (product_id) REFERENCES rdbo_test_products (id) ON UPDATE NO ACTION ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL, color_id INT NOT NULL, PRIMARY KEY(product_id, color_id), INDEX(color_id), INDEX(product_id), FOREIGN KEY (product_id) REFERENCES rdbo_test_products (id) ON DELETE RESTRICT, FOREIGN KEY (color_id) REFERENCES rdbo_test_colors (id) ON UPDATE NO ACTION ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE `read` ( id INT AUTO_INCREMENT PRIMARY KEY, `read` VARCHAR(255) NOT NULL ) ENGINE=InnoDB EOF $dbh->disconnect; } # # Informix # eval { $dbh = Rose::DB->new('informix_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { $Have{'informix'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATETIME YEAR TO SECOND, release_date DATETIME YEAR TO SECOND, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF #$dbh->commit; $dbh->disconnect; } # # SQLite # eval { $dbh = Rose::DB->new('sqlite_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { $Have{'sqlite'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors'); $dbh->do('DROP TABLE rdbo_test_colors'); $dbh->do('DROP TABLE rdbo_test_prices'); $dbh->do('DROP TABLE rdbo_test_products'); $dbh->do('DROP TABLE rdbo_test_vendors'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATETIME, release_date DATETIME, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INTEGER PRIMARY KEY AUTOINCREMENT, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->disconnect; } } END { # Delete test table if($Have{'pg'}) { # PostgreSQL my $dbh = Rose::DB->new('pg_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP VIEW Rose_db_object_private.rdbo_test_view'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_vendors CASCADE'); $dbh->do('DROP SCHEMA Rose_db_object_private CASCADE'); $dbh->disconnect; } if($Have{'oracle'}) { # Oracle my $dbh = Rose::DB->new('oracle_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_products CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE CONSTRAINTS'); $dbh->disconnect; } if($Have{'mysql'}) { # MySQL my $dbh = Rose::DB->new('mysql_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP TABLE `read` CASCADE'); $dbh->disconnect; } if($Have{'informix'}) { # Informix my $dbh = Rose::DB->new('informix_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->disconnect; } if($Have{'sqlite'}) { # Informix my $dbh = Rose::DB->new('sqlite_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors'); $dbh->do('DROP TABLE rdbo_test_colors'); $dbh->do('DROP TABLE rdbo_test_prices'); $dbh->do('DROP TABLE rdbo_test_products'); $dbh->do('DROP TABLE rdbo_test_vendors'); $dbh->disconnect; } } Rose-DB-0.777/t/make-subclass-tests.pl000755 000765 000024 00000001336 12502134373 017532 0ustar00johnstaff000000 000000 #!/usr/bin/perl use strict; use FindBin qw($Bin); chdir($Bin) or die "chdir($Bin) - $!"; opendir(my $dir, '.') or die "Could not opendir(.) - $!"; while(my $file = readdir($dir)) { next if($file !~ /\.t$/ || $file =~ /fork-|subclass|warning|pod|storable|pk-columns|no-registry|setup|db_cache/); my $new_file = "subclass-$file"; open(my $old, $file) or die "Could not open $file - $!"; open(my $new, ">$new_file") or die "Could not create $new_file - $!"; while(<$old>) { # I know, I know... unless(/^\s*use_ok|Rose::DB::(\w+)|->isa\(/) { s/\bRose::DB([^:A-Za-z0-9_])/My::DB2$1/g; } print $new $_; } close($old); close($new) or die "Could not write $new - $!"; } closedir($dir); Rose-DB-0.777/t/mysql.t000755 000765 000024 00000021343 12502134373 014635 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::mysql }; if($@) { Test::More->import(skip_all => 'Missing DBD::mysql'); } elsif($DBD::mysql::VERSION !~ /_/ && $DBD::mysql::VERSION < 4.017) { Test::More->import(skip_all => "Old DBD::mysql: $DBD::mysql::VERSION"); } else { Test::More->import(tests => 159); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } Rose::DB->default_domain('test'); Rose::DB->default_type('mysql'); my $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 9) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = Rose::DB->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } $db->disconnect; $db2->disconnect; } $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); my $rand; $rand .= $letters[int rand(@letters)] for(1 .. int(rand(20))); $rand = 'default' unless(defined $rand); # got under here once! ok(!$db->validate_timestamp_keyword($rand), "validate_timestamp_keyword ($rand)"); ok(!$db->validate_datetime_keyword($rand), "validate_datetime_keyword ($rand)"); ok(!$db->validate_date_keyword($rand), "validate_date_keyword ($rand)"); ok($db->validate_date_keyword('0000-00-00'), "validate_date_keyword (0000-00-00)"); ok($db->validate_datetime_keyword('0000-00-00 00:00:00'), "validate_datetime_keyword (0000-00-00 00:00:00)"); ok($db->validate_datetime_keyword('0000-00-00 00:00:00'), "validate_datetime_keyword (0000-00-00 00:00:00)"); ok($db->validate_timestamp_keyword('0000-00-00 00:00:00'), "validate_timestamp_keyword (0000-00-00 00:00:00)"); ok($db->validate_timestamp_keyword('00000000000000'), "validate_timestamp_keyword (00000000000000)"); ok(!$db->validate_time_keyword($rand), "validate_time_keyword ($rand)"); foreach my $name (qw(date datetime timestamp)) { my $method = "validate_${name}_keyword"; ok(!$db->$method('Foo(Bar)'), "$method (Foo(Bar)) 1"); $db->keyword_function_calls(1); ok($db->$method('Foo(Bar)'), "$method (Foo(Bar)) 2"); $db->keyword_function_calls(0); foreach my $value (qw(now() curtime() curdate() sysdate() current_time current_time() current_date current_date() current_timestamp current_timestamp())) { my $new_value = $value; my $i = int(rand(length($new_value) - 3)); # 3 = 1 + 2 (for possible parens) substr($new_value, $i, 1) = uc substr($new_value, $i, 1); ok($db->$method($new_value), "$method ($new_value)"); } } is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); my $a = $db->parse_array(q({"a","b","\\""})); ok(@$a == 3 && $a->[0] eq 'a' && $a->[1] eq 'b' && $a->[2] eq '"', 'parse_array() 1'); is($db->format_set([ 'a', 'b' ]), 'a,b', 'format_set() 1'); is($db->format_set('a', 'b'), 'a,b', 'format_set() 2'); eval { $db->format_set('a', undef) }; ok($@ =~ /undefined/i, 'format_set() 3'); eval { $db->format_set([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_set() 4'); my $s = $db->parse_set('a,b'); ok(@$s == 2 && $s->[0] eq 'a' && $s->[1] eq 'b', 'parse_set() 1'); SKIP: { unless(have_db('mysql')) { skip("MySQL connection tests", 80); } eval { $db->connect }; skip("Could not connect to db 'test', 'mysql' - $@", 27) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'mysql', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_timestamp() floating"); if($db->database_version >= 5_000_003) { is($db->format_bitfield($db->parse_bitfield('1010')), q(b'1010'), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(b'1010'), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(b'0010'), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(b'1010'), "format_bitfield() 4"); } else { is($db->format_bitfield($db->parse_bitfield('1010')), q(10), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(10), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(2), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(10), "format_bitfield() 4"); } #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; foreach my $attr (qw(mysql_auto_reconnect mysql_client_found_rows mysql_compression mysql_connect_timeout mysql_embedded_groups mysql_embedded_options mysql_enable_utf8 mysql_local_infile mysql_multi_statements mysql_read_default_file mysql_read_default_group mysql_socket mysql_ssl mysql_ssl_ca_file mysql_ssl_ca_path mysql_ssl_cipher mysql_ssl_client_cert mysql_ssl_client_key mysql_use_result mysql_bind_type_guessing)) { $db = Rose::DB->new($attr => 1); is($db->$attr(), 1, "$attr 1"); $db->connect; if($attr eq 'mysql_auto_reconnect') # can't read back the others? { is($db->$attr(), 1, "$attr 2"); is($db->dbh->{$attr}, 1, "$attr 3"); } else { SKIP: { skip("$attr dbh read-back", 2) } } } TEST: { my $dbh = Rose::DB->new->retain_dbh; $db = Rose::DB->new(dbh => $dbh); } $db->retain_dbh; $db->release_dbh; ok($db->{'dbh'}{'Active'}, 'retain stuffed dbh'); $db->connect; $db->mysql_enable_utf8(1); is($db->mysql_enable_utf8, 1, 'mysql_enable_utf8 2'); if($db->isa('My::DB2')) { $My::DB2::Called{'init_dbh'} = 0; $db = Rose::DB->new('mysql'); $db->dbh; is($My::DB2::Called{'init_dbh'}, 1, 'SUPER:: from driver'); } else { SKIP: { skip('SUPER:: from driver tests', 1) } } } $db->dsn('dbi:mysql:dbname=dbfoo;host=hfoo;port=pfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:Pg:dbname=dbfoo;host=hfoo;port=pfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); Rose::DB->register_db ( domain => 'stub', type => 'default', driver => 'MySQL', ); $db = Rose::DB->new ( domain => 'stub', type => 'default', dsn => "dbi:mysql:mydb", ); is($db->database, 'mydb', 'parse_dsn() 1'); sub lookup_ip { my($name) = shift; my $address = (gethostbyname($name))[4] or return 0; my @octets = unpack("CCCC", $address); return 0 unless($name && @octets); return join('.', @octets), "\n"; } (my $version = $DBI::VERSION) =~ s/_//g; if(have_db('mysql') && $version >= 1.24) { my $x = 0; my $handler = sub { $x++; die "Error: $x" }; Rose::DB->register_db( type => 'error_handler', driver => 'mysql', print_error => 0, raise_error => 1, handle_error => $handler, ); $db = Rose::DB->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); is($db->dbh->{'HandleError'}, $handler, 'HandleError 1'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; is($x, 2, 'handle_error 5'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 10) } } Rose-DB-0.777/t/no-registry.t000644 000765 000024 00000001310 12502134373 015737 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 5 * 4; BEGIN { require 't/test-lib.pl'; package My::DB; use base 'Rose::DB'; My::DB->use_private_registry; } foreach my $type (qw(pg mysql informix sqlite oracle)) { SKIP: { skip("$type tests", 4) unless(have_db($type)); ok(my $db = My::DB->new(driver => $type), "empty $type"); eval { $db = My::DB->new(driver => $type, type => 'nonesuch') }; ok($@, "$type - with type"); eval { $db = My::DB->new(driver => $type, domain => 'nonesuch') }; ok($@, "$type - with domain"); eval { $db = My::DB->new(driver => $type, type => 'nonesuch', domain => 'nonesuch') }; ok($@, "$type - with type and domain"); } } Rose-DB-0.777/t/oracle.t000644 000765 000024 00000014736 12502134373 014742 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Oracle }; if($@) { Test::More->import(skip_all => 'Missing DBD::Oracle'); } else { Test::More->import(tests => 80); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } Rose::DB->default_domain('test'); Rose::DB->default_type('oracle'); # Note: $db here is of type Rose::DB::Oracle. my $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('true'), 1, 'parse_boolean (true)'); is($db->parse_boolean('y'), 1, 'parse_boolean (y)'); is($db->parse_boolean('yes'), 1, 'parse_boolean (yes)'); is($db->parse_boolean('1'), 1, 'parse_boolean (1)'); is($db->parse_boolean('TRUE'), 'TRUE', 'parse_boolean (TRUE)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('false'), 0, 'parse_boolean (false)'); is($db->parse_boolean('n'), 0, 'parse_boolean (n)'); is($db->parse_boolean('no'), 0, 'parse_boolean (no)'); is($db->parse_boolean('0'), 0, 'parse_boolean (0)'); is($db->parse_boolean('FALSE'), 'FALSE', 'parse_boolean (FALSE)'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); foreach my $val (qw(t 1 true True T y Y yes Yes)) { is($db->format_boolean($db->parse_boolean($val)), 't', "format_boolean ($val)"); } foreach my $val (qw(f 0 false False F n N no No)) { is($db->format_boolean($db->parse_boolean($val)), 'f', "format_boolean ($val)"); } is($db->auto_quote_column_name('foo_bar_123'), 'foo_bar_123', 'auto_quote_column_name 1'); is($db->auto_quote_column_name('claim#'), '"CLAIM#"', 'auto_quote_column_name 2'); is($db->auto_quote_column_name('foo-bar'), '"FOO-BAR"', 'auto_quote_column_name 3'); is($db->parse_date('2002-12-31'), parse_date('12/31/2002'), "parse_date() 1"); is($db->parse_date('2002-12-31 12:34'), parse_date('12/31/2002 12:34'), "parse_date() 2"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56'), "parse_datetime() 1"); is($db->parse_datetime('2002-12-31 12:34:56.0'), parse_date('12/31/2002 12:34:56'), "parse_datetime() 2"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56'), "parse_timestamp() 1"); is($db->parse_timestamp('2002-12-31 12:34:56.0'), parse_date('12/31/2002 12:34:56'), "parse_timestamp() 2"); is($db->parse_timestamp('2002-12-31 12:34:56.123'), parse_date('12/31/2002 12:34:56.123'), "parse_timestamp() 3"); is($db->parse_timestamp('2002-12-31 12:34:56.123456789'), parse_date('12/31/2002 12:34:56.123456'), "parse_timestamp() 4"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 1"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.0 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 2"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.123 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 3"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.123456789 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 4"); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 16) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = Rose::DB->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } SEQUENCE_PREP: { my $dbh = $db->dbh; local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 0; $dbh->do('DROP SEQUENCE rose_db_sequence_test'); } $dbh->do('CREATE SEQUENCE rose_db_sequence_test MINVALUE 5'); ok($db->sequence_exists('rose_db_sequence_test'), 'sequence_exists 1'); ok(!$db->sequence_exists('rose_db_sequence_testx'), 'sequence_exists 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 1'); is($db->next_value_in_sequence('rose_db_sequence_test'), 6, 'next_value_in_sequence 1'); is($db->current_value_in_sequence('rose_db_sequence_test'), 6, 'current_value_in_sequence 2'); is($db->next_value_in_sequence('rose_db_sequence_test'), 7, 'next_value_in_sequence 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 7, 'current_value_in_sequence 3'); $dbh->do('DROP SEQUENCE rose_db_sequence_test'); $db->disconnect; $db2->disconnect; } $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; Rose::DB->register_db ( domain => 'stub', type => 'default', driver => 'oracle', ); $db = Rose::DB->new ( domain => 'stub', type => 'default', dsn => "dbi:Oracle:mydb", ); is($db->database, 'mydb', 'parse_dsn() 1'); SKIP: { $db = Rose::DB->new; eval { $db->connect }; skip("Could not connect to db 'test', 'oracle' - $@", 10) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'oracle', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } Rose::DB->register_db ( type => 'dsn1', driver => 'oracle', database => 'somedb', ); is(Rose::DB->new('dsn1')->dsn, 'dbi:Oracle:somedb', 'dsn 1'); Rose::DB->register_db ( type => 'dsn2', driver => 'oracle', database => 'somedb', host => 'somehost', ); is(Rose::DB->new('dsn2')->dsn, 'dbi:Oracle:sid=somedb;host=somehost', 'dsn 2'); Rose::DB->register_db ( type => 'dsn3', driver => 'oracle', database => 'somedb', port => 'someport', ); is(Rose::DB->new('dsn3')->dsn, 'dbi:Oracle:sid=somedb;port=someport', 'dsn 3'); Rose::DB->register_db ( type => 'dsn4', driver => 'oracle', database => 'somedb', host => 'somehost', port => 'someport', ); is(Rose::DB->new('dsn4')->dsn, 'dbi:Oracle:sid=somedb;host=somehost;port=someport', 'dsn 4'); Rose-DB-0.777/t/pg.t000755 000765 000024 00000050442 12502134373 014100 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Pg }; if($@) { Test::More->import(skip_all => 'Missing DBD::Pg'); } else { Test::More->import(tests => 325); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } Rose::DB->default_domain('test'); Rose::DB->default_type('pg'); my $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); SKIP: { skip("Could not connect to db - $@", 15) unless(have_db('pg')); my $dbh = $db->dbh; ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = Rose::DB->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } ok(!$db->pg_enable_utf8, 'pg_enable_utf8 false'); $db->pg_enable_utf8(1); ok($db->pg_enable_utf8 && $db->dbh->{'pg_enable_utf8'}, 'pg_enable_utf8 true'); SEQUENCE_PREP: { my $dbh = $db->dbh; local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 0; $dbh->do('DROP SEQUENCE rose_db_sequence_test'); } $dbh->do('CREATE SEQUENCE rose_db_sequence_test MINVALUE 5'); ok($db->sequence_exists('rose_db_sequence_test'), 'sequence_exists 1'); ok(!$db->sequence_exists('rose_db_sequence_testx'), 'sequence_exists 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 1'); is($db->next_value_in_sequence('rose_db_sequence_test'), 5, 'next_value_in_sequence 1'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 2'); is($db->next_value_in_sequence('rose_db_sequence_test'), 6, 'next_value_in_sequence 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 6, 'current_value_in_sequence 3'); $dbh->do('DROP SEQUENCE rose_db_sequence_test'); $db->disconnect; $db2->disconnect; } $db = Rose::DB->new(); $db->sslmode('allow'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;sslmode=allow', 'sslmode()'); $db->options('opts'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;options=opts;sslmode=allow', 'options()'); $db->service('srv'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;options=opts;service=srv;sslmode=allow', 'service()'); $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); ok($db->validate_timestamp_keyword('now'), 'validate_timestamp_keyword (now)'); ok($db->validate_timestamp_keyword('infinity'), 'validate_timestamp_keyword (infinity)'); ok($db->validate_timestamp_keyword('-infinity'), 'validate_timestamp_keyword (-infinity)'); ok($db->validate_timestamp_keyword('epoch'), 'validate_timestamp_keyword (epoch)'); ok($db->validate_timestamp_keyword('today'), 'validate_timestamp_keyword (today)'); ok($db->validate_timestamp_keyword('tomorrow'), 'validate_timestamp_keyword (tomorrow)'); ok($db->validate_timestamp_keyword('yesterday'), 'validate_timestamp_keyword (yesterday)'); ok($db->validate_timestamp_keyword('allballs'), 'validate_timestamp_keyword (allballs)'); is($db->format_timestamp('now'), 'now', 'format_timestamp (now)'); is($db->format_timestamp('infinity'), 'infinity', 'format_timestamp (infinity)'); is($db->format_timestamp('-infinity'), '-infinity', 'format_timestamp (-infinity)'); is($db->format_timestamp('epoch'), 'epoch', 'format_timestamp (epoch)'); is($db->format_timestamp('today'), 'today', 'format_timestamp (today)'); is($db->format_timestamp('tomorrow'), 'tomorrow', 'format_timestamp (tomorrow)'); is($db->format_timestamp('yesterday'), 'yesterday', 'format_timestamp (yesterday)'); is($db->format_timestamp('allballs'), 'allballs', 'format_timestamp (allballs)'); ok($db->validate_datetime_keyword('now'), 'validate_datetime_keyword (now)'); ok($db->validate_datetime_keyword('infinity'), 'validate_datetime_keyword (infinity)'); ok($db->validate_datetime_keyword('-infinity'), 'validate_datetime_keyword (-infinity)'); ok($db->validate_datetime_keyword('epoch'), 'validate_datetime_keyword (epoch)'); ok($db->validate_datetime_keyword('today'), 'validate_datetime_keyword (today)'); ok($db->validate_datetime_keyword('tomorrow'), 'validate_datetime_keyword (tomorrow)'); ok($db->validate_datetime_keyword('yesterday'), 'validate_datetime_keyword (yesterday)'); ok($db->validate_datetime_keyword('allballs'), 'validate_datetime_keyword (allballs)'); is($db->format_datetime('now'), 'now', 'format_datetime (now)'); is($db->format_datetime('infinity'), 'infinity', 'format_datetime (infinity)'); is($db->format_datetime('-infinity'), '-infinity', 'format_datetime (-infinity)'); is($db->format_datetime('epoch'), 'epoch', 'format_datetime (epoch)'); is($db->format_datetime('today'), 'today', 'format_datetime (today)'); is($db->format_datetime('tomorrow'), 'tomorrow', 'format_datetime (tomorrow)'); is($db->format_datetime('yesterday'), 'yesterday', 'format_datetime (yesterday)'); is($db->format_datetime('allballs'), 'allballs', 'format_datetime (allballs)'); ok($db->validate_date_keyword('now'), 'validate_date_keyword (now)'); ok($db->validate_date_keyword('epoch'), 'validate_date_keyword (epoch)'); ok($db->validate_date_keyword('today'), 'validate_date_keyword (today)'); ok($db->validate_date_keyword('tomorrow'), 'validate_date_keyword (tomorrow)'); ok($db->validate_date_keyword('yesterday'), 'validate_date_keyword (yesterday)'); is($db->format_date('now'), 'now', 'format_date (now)'); is($db->format_date('epoch'), 'epoch', 'format_date (epoch)'); is($db->format_date('today'), 'today', 'format_date (today)'); is($db->format_date('tomorrow'), 'tomorrow', 'format_date (tomorrow)'); is($db->format_date('yesterday'), 'yesterday', 'format_date (yesterday)'); ok($db->validate_time_keyword('now'), 'validate_time_keyword (now)'); ok($db->validate_time_keyword('allballs'), 'validate_time_keyword (allballs)'); is($db->format_time('now'), 'now', 'format_time (now)'); is($db->format_time('allballs'), 'allballs', 'format_time (allballs)'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('true'), 1, 'parse_boolean (true)'); is($db->parse_boolean('y'), 1, 'parse_boolean (y)'); is($db->parse_boolean('yes'), 1, 'parse_boolean (yes)'); is($db->parse_boolean('1'), 1, 'parse_boolean (1)'); is($db->parse_boolean('TRUE'), 'TRUE', 'parse_boolean (TRUE)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('false'), 0, 'parse_boolean (false)'); is($db->parse_boolean('n'), 0, 'parse_boolean (n)'); is($db->parse_boolean('no'), 0, 'parse_boolean (no)'); is($db->parse_boolean('0'), 0, 'parse_boolean (0)'); is($db->parse_boolean('FALSE'), 'FALSE', 'parse_boolean (FALSE)'); ok(!$db->validate_boolean_keyword('Foo(Bar)'), 'validate_boolean_keyword (Foo(Bar))'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); foreach my $name (qw(date datetime time timestamp)) { my $method = "validate_${name}_keyword"; ok(!$db->$method('Foo(Bar)'), "$method (Foo(Bar)) 1"); $db->keyword_function_calls(1); ok($db->$method('Foo(Bar)'), "$method (Foo(Bar)) 2"); $db->keyword_function_calls(0); foreach my $value (qw(current_date current_time current_time() current_time(1) current_timestamp current_timestamp() current_timestamp(2) localtime localtime() localtime(3) localtimestamp localtimestamp() localtimestamp(4) now now() timeofday())) { my $new_value = $value; my $i = int(rand(length($new_value) - 3)); # 3 = 1 + 2 (for possible parens) substr($new_value, $i, 1) = uc substr($new_value, $i, 1); ok($db->$method($new_value), "$method ($new_value)"); } } # Interval values isa_ok($db->parse_interval('00:00:00'), 'DateTime::Duration'); my @Intervals = ( '+0::' => '@ 0', '-0:1:' => '@ -1 minutes', '2:' => '@ 120 minutes', '1 D' => '@ 1 days', '-1 d 2 s' => '@ -1 days 2 seconds', '-1 y 3 h -57 M 4 s' => '@ -12 months 123 minutes 4 seconds', '-1 y 2 mons 3 d' => '@ -10 months 3 days', '-1 y 2 mons -3 d' => '@ -10 months -3 days', '5 h -208 m -495 s' => '@ 83 minutes 45 seconds', '-208 m -495 s' => '@ -216 minutes -15 seconds', '5 h 208 m 495 s' => '@ 516 minutes 15 seconds', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '@ 14813 months 6 days 428 minutes 9 seconds', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '@ -14813 months -6 days -428 minutes -9 seconds', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 mil -1 d ago' => '@ -12000 months 1 days', '1 mil ago -1 d ago' => '@ -12000 months 1 days', ); my %Alt_Intervals = ( '+0::' => '', '-0:1:' => '-00:01:00', '2:' => '02:00:00', '1 D' => '1 day', '-1 d 2 s' => '-1 days +00:00:02', '-1 y 3 h -57 M 4 s' => '-1 years +02:03:04', '-1 y 2 mons 3 d' => '-10 mons +3 days', '-1 y 2 mons -3 d' => '-10 mons -3 days', '5 h -208 m -495 s' => '01:23:45', '-208 m -495 s' => '-03:36:15', '5 h 208 m 495 s' => '08:36:15', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '1234 years 5 mons 6 days 07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '-1234 years -5 mons -6 days -07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '1234 years 5 mons 6 days 07:08:09', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '1234 years 5 mons 6 days 07:08:09', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '1234 years 5 mons 6 days 07:08:09', '1 mil -1 d ago' => '-1000 years +1 day', '1 mil ago -1 d ago' => '-1000 years +1 day', ); my $i = 0; while($i < @Intervals) { my($val, $formatted) = ($Intervals[$i], $Intervals[$i + 1]); $i += 2; my $d = $db->parse_interval($val, 'preserve'); is($db->format_interval($d), $formatted, "parse_interval ($val)"); my $alt_d = $db->parse_interval($Alt_Intervals{$val}, 'preserve'); ok((!defined $d && !defined $alt_d) || DateTime::Duration->compare($d, $alt_d) == 0, "parse_interval alt check $i"); } $db->keyword_function_calls(1); is($db->parse_interval('foo()'), 'foo()', 'parse_interval (foo())'); $db->keyword_function_calls(0); my $d = $db->parse_interval('1 year 0.000003 seconds'); is($d->nanoseconds, 3000, 'nanoseconds 1'); is($db->format_interval($d), '@ 12 months 0.000003 seconds', 'nanoseconds 2'); # Time vaues my $tc; ok($tc = $db->parse_time('12:34:56.123456789'), 'parse time 12:34:56.123456789'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789'); ok($tc = $db->parse_time('12:34:56.123456789 pm'), 'parse time 12:34:56.123456789 pm'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789 pm'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789 pm'); ok($tc = $db->parse_time('12:34:56. A.m.'), 'parse time 12:34:56. A.m.'); is($tc->as_string, '00:34:56', 'check time 12:34:56 am'); is($db->format_time($tc), '00:34:56', 'format time 12:34:56 am'); ok($tc = $db->parse_time('12:34:56 pm'), 'parse time 12:34:56 pm'); is($tc->as_string, '12:34:56', 'check time 12:34:56 pm'); is($db->format_time($tc), '12:34:56', 'format time 12:34:56 pm'); ok($tc = $db->parse_time('2:34:56 pm'), 'parse time 2:34:56 pm'); is($tc->as_string, '14:34:56', 'check time 14:34:56 pm'); is($db->format_time($tc), '14:34:56', 'format time 14:34:56 pm'); ok($tc = $db->parse_time('2:34 pm'), 'parse time 2:34 pm'); is($tc->as_string, '14:34:00', 'check time 2:34 pm'); is($db->format_time($tc), '14:34:00', 'format time 2:34 pm'); ok($tc = $db->parse_time('2 pm'), 'parse time 2 pm'); is($tc->as_string, '14:00:00', 'check time 2 pm'); is($db->format_time($tc), '14:00:00', 'format time 2 pm'); ok($tc = $db->parse_time('3pm'), 'parse time 3pm'); is($tc->as_string, '15:00:00', 'check time 3pm'); is($db->format_time($tc), '15:00:00', 'format time 3pm'); ok($tc = $db->parse_time('4 p.M.'), 'parse time 4 p.M.'); is($tc->as_string, '16:00:00', 'check time 4 p.M.'); is($db->format_time($tc), '16:00:00', 'format time 4 p.M.'); ok($tc = $db->parse_time('24:00:00'), 'parse time 24:00:00'); is($tc->as_string, '24:00:00', 'check time 24:00:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00'); ok($tc = $db->parse_time('24:00:00 PM'), 'parse time 24:00:00 PM'); is($tc->as_string, '24:00:00', 'check time 24:00:00 PM'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00 PM'); ok($tc = $db->parse_time('24:00'), 'parse time 24:00'); is($tc->as_string, '24:00:00', 'check time 24:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00'); ok(!defined $db->parse_time('24:00:00.000000001'), 'parse time fail 24:00:00.000000001'); ok(!defined $db->parse_time('24:00:01'), 'parse time fail 24:00:01'); ok(!defined $db->parse_time('24:01'), 'parse time fail 24:01'); SKIP: { unless(have_db('pg')) { skip('pg tests', 48); } eval { $db->connect }; skip("Could not connect to db 'test', 'pg' - $@", 43) if($@); my $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'pg', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56.123456789', 'floating')), '2002-12-31 12:34:56.123456789', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.12345', 'floating')), '2002-12-31 12:34:56.123450000', "format_timestamp() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); $db->server_time_zone('UTC'); is($db->format_date(parse_date('12/31/2002', 'UTC')), '2002-12-31', "format_date()"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'UTC')), '2002-12-31 12:34:56+0000', "format_datetime()"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56')), '2002-12-31 12:34:56', "format_timestamp()"); is($db->format_datetime(parse_date('12/31/2002 12:34:56')), '2002-12-31 12:34:56', "format_datetime()"); is($db->parse_date('12-31-2002'), parse_date('12/31/2002', 'UTC'), "parse_date()"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_datetime()"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_timestamp()"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56-05')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone()"); #is($db->parse_time('12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC')->strftime('%H:%M:%S'), "parse_time()"); $db->european_dates(1); is($db->parse_date('31-12-2002'), parse_date('12/31/2002', 'UTC'), "parse_date() european"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_datetime() european"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_timestamp() european"); is($db->format_bitfield($db->parse_bitfield('1010')), q(1010), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(1010), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(0010), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(1010), "format_bitfield() 4"); my $str = $db->format_array([ undef, 'a' .. 'c' ]); is($str, '{NULL,"a","b","c"}', 'format_array() 1.0'); $str = $db->format_array([ 'a' .. 'c' ]); is($str, '{"a","b","c"}', 'format_array() 2'); my $str2 = $db->format_array([ [ 'a' .. 'c' ], [ 'd', 'e' ] ]); is($str2, '{{"a","b","c"},{"d","e"}}', 'format_array() 3'); my $ar = $db->parse_array('[-3:3]={1,2,3}'); ok(ref $ar eq 'ARRAY' && @$ar == 3 && $ar->[0] eq '1' && $ar->[1] eq '2' && $ar->[2] eq '3', 'parse_array() 1'); $ar = $db->parse_array('{NULL,"a","b"}'); ok(ref $ar eq 'ARRAY' && !defined $ar->[0] && $ar->[1] eq 'a' && $ar->[2] eq 'b', 'parse_array() 2'); $ar = $db->parse_array('{"a",NULL}'); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && !defined $ar->[1], 'parse_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && $ar->[1] eq 'b' && $ar->[2] eq 'c', 'parse_array() 4'); $str = $db->format_array($ar); is($str, '{"a","b","c"}', 'format_array() 2'); $str = $db->format_array([ 1, -2, 3.5 ]); is($str, '{1,-2,3.5}', 'format_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 2'); $str = $db->format_array($ar); is($str, '{1,-2,3.5}', 'format_array() 4'); $str = $db->format_array(1, -2, 3.5); is($str, '{1,-2,3.5}', 'format_array() 5'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 3'); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); eval { $db->sequence_name(table => 'foo') }; ok($@, 'auto_sequence_name() 1'); eval { $db->sequence_name(column => 'bar') }; ok($@, 'auto_sequence_name() 2'); is($db->auto_sequence_name(table => 'foo.goo', column => 'bar'), 'foo.goo_bar_seq', 'auto_sequence_name() 3'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } (my $version = $DBI::VERSION) =~ s/_//g; if(have_db('pg') && $version >= 1.24) { my $x = 0; my $handler = sub { $x++ }; Rose::DB->register_db( type => 'error_handler', driver => 'pg', database => 'test', host => 'localhost', print_error => 0, raise_error => 1, handle_error => $handler, ); $db = Rose::DB->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); is($db->dbh->{'HandleError'}, $handler, 'HandleError 1'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; is($x, 2, 'handle_error 5'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 10) } } Rose-DB-0.777/t/pk-columns.t000755 000765 000024 00000023221 12502134373 015555 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 1 + (5 * 15); BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } foreach my $db_type (qw(mysql pg informix sqlite oracle)) { SKIP: { unless(have_db($db_type)) { skip("$db_type tests", 15); } } next unless(have_db($db_type)); Rose::DB->default_type($db_type); my $db = Rose::DB->new; my $pk_columns = $db->primary_key_column_names('Rdb_test_pk0'); ok(ref $pk_columns eq 'ARRAY' && @$pk_columns == 0, "$db_type no pk columns 1"); my @pk_columns = $db->primary_key_column_names('Rdb_test_pk0'); ok(@pk_columns == 0, "$db_type no pk columns 2"); if($db_type eq 'pg') { @pk_columns = $db->primary_key_column_names(schema => 'Rose_db_private', table => 'Rdb_test_pk0'); ok(@pk_columns == 0, "$db_type no pk columns 3"); $pk_columns = $db->primary_key_column_names(schema => 'Rose_db_private', table => 'Rdb_test_pk0'); ok(@$pk_columns == 0, "$db_type no pk columns 4"); } else { ok(1, "$db_type no pk columns 3"); ok(1, "$db_type no pk columns 4"); } $pk_columns = $db->primary_key_column_names('Rdb_test_pk1'); @pk_columns = sort @$pk_columns; if($db_type eq 'oracle') { # Oracle returns names in upper case. is_deeply(\@pk_columns, [ 'ID' ], "$db_type pk columns 1"); } else { is_deeply(\@pk_columns, [ 'id' ], "$db_type pk columns 1"); } @pk_columns = $db->primary_key_column_names('Rdb_test_pk1'); @pk_columns = sort @pk_columns; if($db_type eq 'oracle') { is_deeply(\@pk_columns, [ 'ID' ], "$db_type pk columns 2"); } else { is_deeply(\@pk_columns, [ 'id' ], "$db_type pk columns 2"); } ok($db->has_primary_key(table => 'Rdb_test_pk1'), "$db_type pk check 1"); ok($db_type ne 'pg' || $db->has_primary_key('rdb_test_Pk1'), "$db_type pk check 2"); $pk_columns = $db->primary_key_column_names('Rdb_test_pk2'); @pk_columns = sort @$pk_columns; if($db_type eq 'oracle') { # Oracle returns names in upper case. is_deeply(\@pk_columns, [ 'ID1', 'ID2' ], "$db_type pk columns 3"); } else { is_deeply(\@pk_columns, [ 'id1', 'id2' ], "$db_type pk columns 3"); } @pk_columns = $db->primary_key_column_names('Rdb_test_pk2'); @pk_columns = sort @pk_columns; if($db_type eq 'oracle') { # Oracle returns names in upper case. is_deeply(\@pk_columns, [ 'ID1', 'ID2' ], "$db_type pk columns 4"); } else { is_deeply(\@pk_columns, [ 'id1', 'id2' ], "$db_type pk columns 4"); } ok($db->has_primary_key(table => 'Rdb_test_pk2'), "$db_type pk check 3"); ok($db_type ne 'pg' || $db->has_primary_key('rdb_test_Pk2'), "$db_type pk check 4"); if($db_type eq 'pg') { @pk_columns = $db->primary_key_column_names(schema => 'Rose_db_private', table => 'Rdb_test_pk2'); @pk_columns = sort @pk_columns; is_deeply(\@pk_columns, [ 'id1', 'id2' ], "$db_type pk columns 5"); ok($db->has_primary_key(schema => 'Rose_db_private', table => 'Rdb_test_pk2'), "$db_type pk check 5"); ok($db->has_primary_key(schema => 'rose_db_Private', table => 'rdb_test_Pk2'), "$db_type pk check 6"); } else { ok(1, "$db_type pk columns 5"); ok(1, "$db_type pk check 5"); ok(1, "$db_type pk check 6"); } } BEGIN { # # PostgreSQL # if(my $dbh = get_dbh('pg_admin')) { # Drop existing tables and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk2 CASCADE'); $dbh->do('DROP SCHEMA Rose_db_private CASCADE'); $dbh->do('CREATE SCHEMA Rose_db_private'); } $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk1 ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_private.Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_private.Rdb_test_pk1 ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_private.Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF # $dbh->do(<<"EOF"); # CREATE VIEW Rose_db_private.Rdb_test_view AS # SELECT * FROM Rose_db_private.Rdb_test_pk1 # EOF $dbh->disconnect; } # # Oracle # if(my $dbh = get_dbh('oracle_admin')) { # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE CONSTRAINTS'); } $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk1 ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF $dbh->disconnect; } # # MySQL # if(my $dbh = get_dbh('mysql_admin')) { # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); } $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk1 ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF $dbh->disconnect; } # # Informix # if(my $dbh = get_dbh('informix_admin')) { # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); } $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk1 ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF $dbh->disconnect; } # # SQLite # if(my $dbh = get_dbh('sqlite_admin')) { # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE Rdb_test_pk0'); $dbh->do('DROP TABLE Rdb_test_pk1'); $dbh->do('DROP TABLE Rdb_test_pk2'); } $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk0 ( name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk1 ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rdb_test_pk2 ( id1 INT NOT NULL, id2 INT NOT NULL, name VARCHAR(255) NOT NULL, PRIMARY KEY(id1, id2), UNIQUE(name) ) EOF $dbh->disconnect; } } END { # Delete test tables if(have_db('pg_admin') && (my $dbh = get_dbh('pg_admin'))) { $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rose_db_private.Rdb_test_pk2 CASCADE'); $dbh->do('DROP SCHEMA Rose_db_private CASCADE'); $dbh->disconnect; } if(have_db('oracle_admin') && (my $dbh = get_dbh('oracle_admin'))) { $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE CONSTRAINTS'); $dbh->disconnect; } if(have_db('mysql_admin') && (my $dbh = get_dbh('mysql_admin'))) { $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); $dbh->disconnect; } if(have_db('informix_admin') && (my $dbh = get_dbh('informix_admin'))) { $dbh->do('DROP TABLE Rdb_test_pk0 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk1 CASCADE'); $dbh->do('DROP TABLE Rdb_test_pk2 CASCADE'); $dbh->disconnect; } if(have_db('sqlite_admin') && (my $dbh = get_dbh('sqlite_admin'))) { $dbh->do('DROP TABLE Rdb_test_pk0'); $dbh->do('DROP TABLE Rdb_test_pk1'); $dbh->do('DROP TABLE Rdb_test_pk2'); $dbh->disconnect; } } Rose-DB-0.777/t/pod.t000755 000765 000024 00000000253 12502134373 014247 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; 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(); Rose-DB-0.777/t/rosedbrc000644 000765 000024 00000000206 12502134373 015021 0ustar00johnstaff000000 000000 --- somedomain: sometype: database: somevalue --- otherdomain: othertype: host: othervalue port: 1234 Rose-DB-0.777/t/setup.t000755 000765 000024 00000001462 12502134373 014630 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); use lib "$Bin/lib"; use Test::More; eval { require YAML::Syck }; if($@) { eval { require YAML }; plan(skip_all => 'YAML or YAML::Syck required for setup tests') if($@); } Test::More->import(tests => 4); $ENV{'ROSEDBRC'} = "$Bin/rosedbrc"; $ENV{'ROSEDB_DEVINIT'} = rand > 0.5 ? 'My::FixUp' : "$Bin/lib/My/FixUp.pm"; use_ok('My::DB'); my $entry = My::DB->registry->entry(domain => 'somedomain', type => 'sometype'); is($entry->database, 'somevalue', 'ROSEDBRC 1'); $entry = My::DB->registry->entry(domain => 'otherdomain', type => 'othertype'); is($entry->host, 'othervalue', 'ROSEDBRC 2'); if($ENV{'ROSEDB_DEVINIT'} eq 'My::FixUp') { is($entry->port, '456', 'ROSEDB_DEVINIT 1'); } else { is($entry->port, '789', 'ROSEDB_DEVINIT 1'); } Rose-DB-0.777/t/sqlite.t000755 000765 000024 00000014764 12502134373 015002 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; BEGIN { $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} = 1 } use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; require 't/test-lib.pl'; if(have_db('sqlite_admin')) { Test::More->import(tests => 60); } else { Test::More->import(skip_all => 'DBD::SQLite unavailable or broken'); } } use_ok('Rose::DB'); Rose::DB->default_domain('test'); Rose::DB->default_type('sqlite_admin'); is(Rose::DB->default_keyword_function_calls, 1, 'default_keyword_function_calls 2'); my $db = Rose::DB->new(); is($db->keyword_function_calls, 1, 'keyword_function_calls 1'); Rose::DB->default_keyword_function_calls(0); $db->keyword_function_calls(0); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 9) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = Rose::DB->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field() || '', $db->$field() || '', "$field()"); } $db->disconnect; $db2->disconnect; } $db = Rose::DB->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); my $rand; $rand .= $letters[int rand(@letters)] for(1 .. int(rand(20))); $rand = 'default' unless(defined $rand); # got under here once! ok(!$db->validate_timestamp_keyword($rand), "validate_timestamp_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_timestamp('Foo(Bar)'), 'Foo(Bar)', 'format_timestamp (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_datetime_keyword($rand), "validate_datetime_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_datetime('Foo(Bar)'), 'Foo(Bar)', 'format_datetime (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_date_keyword($rand), "validate_date_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_date('Foo(Bar)'), 'Foo(Bar)', 'format_date (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_time_keyword($rand), "validate_time_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_time('Foo(Bar)'), 'Foo(Bar)', 'format_time (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); my $a = $db->parse_array(q({"a","b","\\""})); ok(@$a == 3 && $a->[0] eq 'a' && $a->[1] eq 'b' && $a->[2] eq '"', 'parse_array() 1'); SKIP: { eval { $db->connect }; skip("Could not connect to db 'test', 'sqlite' - $@", 18) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'sqlite_admin', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.123456789', 'floating')), '2002-12-31 12:34:56.123456789', "format_timestamp() floating"); #is($db->format_time(parse_date('12/31/2002 12:34:56', 'floating')), '12:34:56', "format_time() floating"); is($db->format_bitfield($db->parse_bitfield('1010')), q(b'1010'), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(b'1010'), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(b'0010'), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(b'1010'), "format_bitfield() 4"); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; if($db->isa('My::DB2')) { $My::DB2::Called{'init_dbh'} = 0; $db = Rose::DB->new('sqlite'); $db->dbh; is($My::DB2::Called{'init_dbh'}, 1, 'SUPER:: from driver'); } else { SKIP: { skip('SUPER:: from driver tests', 1) } } } $db->dsn('dbi:SQLite:dbname=dbfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:Pg:dbname=dbfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); Rose::DB->register_db( domain => Rose::DB->default_domain, type => 'nonesuch', driver => 'SQLITE', database => '/tmp/rdbo_does_not_exist.db', auto_create => 0, ); if((! -e '/tmp/rdbo_does_not_exist.db') || unlink('/tmp/rdbo_does_not_exist.db')) { $db = Rose::DB->new('nonesuch'); eval { $db->connect }; ok($@ =~ /^Refus/, 'nonesuch database'); } else { ok(1, "could not unlink /tmp/rdbo_does_not_exist.db - $!"); } (my $version = $DBI::VERSION) =~ s/_//g; if($version >= 1.24) { my $x = 0; my $handler = sub { $x++ }; Rose::DB->register_db( type => 'error_handler', driver => 'sqlite', print_error => 0, raise_error => 1, handle_error => $handler, sqlite_unicode => 1, ); $db = Rose::DB->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); eval { $db->dbh->prepare('select nonesuch from ?') }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { $db->dbh->prepare('select nonesuch from ?') }; is($x, 2, 'handle_error 5'); ok($db->sqlite_unicode, 'sqlite_unicode 1'); ok($db->dbh->{'sqlite_unicode'}, 'sqlite_unicode 2'); $db->sqlite_unicode(0); ok(!$db->sqlite_unicode, 'sqlite_unicode 3'); ok(!$db->dbh->{'sqlite_unicode'}, 'sqlite_unicode 4'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 13) } } Rose-DB-0.777/t/storable.ext000644 000765 000024 00000000444 12502134373 015634 0ustar00johnstaff000000 000000 #!/usr/bin/perl use lib 'lib'; use FindBin qw($Bin); require 't/test-lib.pl'; use Storable; my $frozen_file = "$Bin/frozen"; my $thawed = Storable::retrieve($frozen_file); $thawed->dbh->do('DROP TABLE rose_db_storable_test'); print "dropped\n"; unlink($frozen_file); # ignore errors Rose-DB-0.777/t/storable.t000644 000765 000024 00000005177 12502134373 015307 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; require Test::More; eval { require Storable }; if($@) { Test::More->import(skip_all => 'Could not load Storable'); } else { Test::More->import(tests => 1 + (4 * 5)); } use Config; use FindBin qw($Bin); require 't/test-lib.pl'; use_ok('Rose::DB'); my $frozen_file = "$Bin/frozen"; my $Perl = $^X; if($^O ne 'VMS') { $Perl .= $Config{'_exe'} unless($Perl =~ /$Config{'_exe'}$/i); } my($db, @Cleanup); foreach my $db_type (qw(pg mysql informix sqlite oracle)) { $db = get_db($db_type); unless($db) { SKIP: { skip("Could not connect to $db_type", 4) } next; } CLEAR: { my $dbh = $db->dbh; local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_storable_test'); } $db->dbh->do('CREATE TABLE rose_db_storable_test (i INT)'); CLEANUP: { my $dbh = $db->dbh; push(@Cleanup, sub { $dbh->do('DROP TABLE rose_db_storable_test') }); } my $frozen = Storable::freeze($db); Storable::nstore($db, $frozen_file); my $thawed = Storable::thaw($frozen); ok(!defined $thawed->{'dbh'}, "check dbh - $db_type"); if(!defined $db->password) { ok(!defined $thawed->{'password'}, "check password - $db_type"); ok(!defined $thawed->{'password_closure'}, "check password closure - $db_type"); } else { ok(!defined $thawed->{'password'}, "check password - $db_type"); ok(ref $thawed->{'password_closure'}, "check password closure - $db_type"); } $thawed->dbh->do('DROP TABLE rose_db_storable_test'); pop(@Cleanup); # Disconnect to flush SQLite memory buffers if($db_type eq 'sqlite') { $thawed->disconnect; $db->disconnect; } $db->dbh->do('CREATE TABLE rose_db_storable_test (i INT)'); CLEANUP: { my $dbh = $db->dbh; push(@Cleanup, sub { $dbh->{'RaiseError'} = 0; $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_storable_test'); }); } my($ok, $script_fh); # Perl 5.8.x and later support the FILEHANDLE,MODE,EXPR,LIST form of # open, but not (apparently) on Windows if($Config{'version'} =~ /^5\.([89]|10)\./ && $^O !~ /Win32/i) { $ok = open($script_fh, '-|', $Perl, 't/storable.ext', $db_type); } else { $ok = open($script_fh, "$Perl t/storable.ext $db_type |"); } if($ok) { chomp(my $line = <$script_fh>); close($script_fh); is($line, 'dropped', "external test - $db_type"); pop(@Cleanup) if($line eq 'dropped'); } else { ok(0, "Failed to open external script for $db_type - $!"); } } END { unlink($frozen_file); # ignore errors foreach my $code (@Cleanup) { $code->(); } } Rose-DB-0.777/t/subclass-basic.t000755 000765 000024 00000042033 12502134373 016365 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use FindBin qw($Bin); use Test::More tests => 208; BEGIN { use_ok('Rose::DB'); use_ok('Rose::DB::Registry'); use_ok('Rose::DB::Registry::Entry'); use_ok('Rose::DB::Constants'); require 't/test-lib.pl'; is(Rose::DB::Constants::IN_TRANSACTION(), -1, 'Rose::DB::Constants::IN_TRANSACTION'); Rose::DB::Constants->import('IN_TRANSACTION'); # Default My::DB2->register_db( domain => 'default', type => 'default', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Main My::DB2->register_db( domain => 'test', type => 'default', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Aux My::DB2->register_db( domain => 'test', type => 'aux', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); # Generic My::DB2->register_db( domain => 'test', type => 'generic', driver => 'NoneSuch', database => 'test', host => 'localhost', username => 'someuser', password => '', ); # Alias My::DB2->alias_db(source => { domain => 'test', type => 'aux' }, alias => { domain => 'atest', type => 'aaux' }); package MyPgClass; @MyPgClass::ISA = qw(Rose::DB::Pg); sub format_date { die "boo!" } } my $sqlite_ok = have_db('sqlite_admin'); is_deeply(scalar My::DB2->registry->registered_domains, [ qw(atest catalog_test default test) ], 'registered_domains()'); is_deeply(scalar My::DB2->registry->registered_types('test'), [ qw(aux default generic informix informix_admin mysql mysql_admin oracle oracle_admin pg pg_admin pg_with_schema), ($sqlite_ok ? qw(sqlite sqlite_admin) : ()) ], 'registered_types()'); # Lame arbitrary test of one dump attr my $dump = My::DB2->registry->dump; is($dump->{'test'}{'aux'}{'username'}, 'postgres', 'dump() 1'); is(IN_TRANSACTION, -1, 'IN_TRANSACTION'); is(My::DB2->default_keyword_function_calls, 0, 'default_keyword_function_calls 1'); My::DB2->default_keyword_function_calls(1); is(My::DB2->default_keyword_function_calls, 1, 'default_keyword_function_calls 2'); my $db = My::DB2->new; is($db->keyword_function_calls, 1, 'keyword_function_calls 1'); $db = My::DB2->new; is($db->keyword_function_calls, 1, 'keyword_function_calls 2'); is(My::DB2->default_domain, 'test', 'default_domain() 1'); is(My::DB2->default_type, 'default', 'default_type() 1'); ok(My::DB2->db_exists('default'), 'db_exists() 1'); ok(!My::DB2->db_exists('defaultx'), 'db_exists() 2'); ok(My::DB2->db_exists(type => 'default'), 'db_exists() 3'); ok(!My::DB2->db_exists(type => 'defaultx'), 'db_exists() 4'); ok(My::DB2->db_exists(type => 'default', domain => 'test'), 'db_exists() 3'); ok(!My::DB2->db_exists(type => 'defaultx', domain => 'testx'), 'db_exists() 4'); ok(!My::DB2->db_exists(type => 'defaultx', domain => 'test'), 'db_exists() 3'); My::DB2->error('foo'); is(My::DB2->error, 'foo', 'error() 2'); $db->error('bar'); is(My::DB2->error, 'bar', 'error() 3'); is($db->error, 'bar', 'error() 4'); eval { $db = My::DB2->new }; ok(!$@, 'Valid type and domain'); My::DB2->default_domain('foo'); is(My::DB2->default_domain, 'foo', 'default_domain() 2'); eval { $db = My::DB2->new }; ok($@, 'Invalid domain'); My::DB2->default_domain('test'); My::DB2->default_type('bar'); is(My::DB2->default_type, 'bar', 'default_type() 2'); eval { $db = My::DB2->new }; ok($@, 'Invalid type'); is(Rose::DB->driver_class('Pg'), 'Rose::DB::Pg', 'driver_class() 1'); is(My::DB2->driver_class('xxx'), undef, 'driver_class() 2'); My::DB2->driver_class(Pg => 'MyPgClass'); is(My::DB2->driver_class('Pg'), 'MyPgClass', 'driver_class() 3'); $db = My::DB2->new(type => 'aux', database => 'xyzzy'); is($db->database, 'xyzzy', 'override on new() 1'); $db = My::DB2->new(type => 'aux', dsn => 'dbi:Pg:host=foo;database=bar'); is($db->dsn, 'dbi:Pg:host=foo;database=bar', 'override on new() 2'); $db = My::DB2->new('aux'); ok($db->isa('MyPgClass'), 'new() single arg'); is($db->error('foo'), 'foo', 'subclass 1'); is($db->error, 'foo', 'subclass 2'); eval { $db->format_date('123') }; ok($@ =~ /^boo!/, 'driver_class() 4'); is(My::DB2->default_connect_option('AutoCommit'), 1, "default_connect_option('AutoCommit')"); is(My::DB2->default_connect_option('RaiseError'), 1, "default_connect_option('RaiseError')"); is(My::DB2->default_connect_option('PrintError'), 1, "default_connect_option('PrintError')"); is(My::DB2->default_connect_option('ChopBlanks'), 1, "default_connect_option('ChopBlanks')"); is(My::DB2->default_connect_option('Warn'), 0, "default_connect_option('Warn')"); my $options = My::DB2->default_connect_options; is(ref $options, 'HASH', 'default_connect_options() 1'); is(join(',', sort keys %$options), 'AutoCommit,ChopBlanks,PrintError,RaiseError,Warn', 'default_connect_options() 2'); My::DB2->default_connect_options(a => 1, b => 2); is(My::DB2->default_connect_option('a'), 1, "default_connect_option('a')"); is(My::DB2->default_connect_option('b'), 2, "default_connect_option('b')"); My::DB2->default_connect_options({ c => 3, d => 4 }); is(My::DB2->default_connect_option('c'), 3, "default_connect_option('c') 1"); is(My::DB2->default_connect_option('d'), 4, "default_connect_option('d') 1"); my $keys = join(',', sort keys %{$db->default_connect_options}); $db->default_connect_options(zzz => 'bar'); my $keys2 = join(',', sort keys %{$db->default_connect_options}); is($keys2, "$keys,zzz", 'default_connect_options() 1'); $db->default_connect_options({ zzz => 'bar' }); $keys2 = join(',', sort keys %{$db->default_connect_options}); is($keys2, 'zzz', 'default_connect_options() 2'); $keys = join(',', sort keys %{$db->connect_options}); $db->connect_options(zzzz => 'bar'); $keys2 = join(',', sort keys %{$db->connect_options}); is($keys2, "$keys,zzzz", 'connect_option() 1'); $db->connect_options({ zzzz => 'bar' }); $keys2 = join(',', sort keys %{$db->connect_options}); is($keys2, 'zzzz', 'connect_option() 2'); $db->dsn('dbi:Pg:dbname=dbfoo;host=hfoo;port=pfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:mysql:dbname=dbfoo;host=hfoo;port=pfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); $db = My::DB2->new(domain => 'test', type => 'aux'); my $adb = My::DB2->new(domain => 'atest', type => 'aaux'); is($db->class, 'My::DB2', 'class() 1'); foreach my $attr (qw(domain type driver database username password connect_options post_connect_sql)) { is($db->username, $adb->username, "alias $attr()"); } My::DB2->modify_db(domain => 'test', type => 'aux', username => 'blargh', connect_options => { Foo => 1 }); $db->init_db_info(refresh => 1); $adb->init_db_info(refresh => 1); is($db->username, $adb->username, "alias username() mod"); is($db->connect_options->{'Foo'}, $adb->connect_options->{'Foo'}, "alias connect_options() mod"); $db = My::DB2->new('generic'); ok($db->isa('Rose::DB::Generic'), 'generic class'); is($db->dsn, 'dbi:NoneSuch:dbname=test;host=localhost', 'generic dsn'); ok(!$db->has_dbh, 'has_dbh() 1'); # # Registry tests # my $reg = My::DB2->registry; ok($reg->isa('Rose::DB::Registry'), 'registry'); my $entry = $reg->entry(domain => 'test', type => 'aux'); ok($entry->isa('Rose::DB::Registry::Entry'), 'registry entry 1'); foreach my $param (qw(autocommit database domain driver dsn host password port print_error raise_error handle_error server_time_zone schema type username connect_options pre_disconnect_sql post_connect_sql)) { eval { $entry->$param() }; ok(!$@, "entry $param()"); } my $host = $entry->host; my $database = $entry->database; My::DB2->modify_db(domain => 'test', type => 'aux', host => 'foo', database => 'bar'); is($entry->host, 'foo', 'entry modify_db() 1'); is($entry->database, 'bar', 'entry modify_db() 2'); is($entry->connect_option('RaiseError') || 0, 0, 'entry connect_option() 1'); $entry->connect_option('RaiseError' => 1); is($entry->connect_option('RaiseError'), 1, 'entry connect_option() 2'); $entry->pre_disconnect_sql(qw(sql1 sql2)); my $sql = $entry->pre_disconnect_sql; ok(@$sql == 2 && $sql->[0] eq 'sql1' && $sql->[1] eq 'sql2', 'entry pre_disconnect_sql() 1'); $entry->post_connect_sql(qw(sql3 sql4)); $sql = $entry->post_connect_sql; ok(@$sql == 2 && $sql->[0] eq 'sql3' && $sql->[1] eq 'sql4', 'entry post_connect_sql() 1'); $entry->raise_error(0); is($entry->connect_option('RaiseError'), 0, 'entry raise_error() 1'); $entry->print_error(1); is($entry->connect_option('PrintError'), 1, 'entry print_error() 1'); $entry->autocommit(1); is($entry->connect_option('AutoCommit'), 1, 'entry autocommit() 1'); my $handler = sub { 123 }; $entry->handle_error($handler); is($entry->connect_option('HandleError'), $handler, 'entry handle_error() 1'); { package MyTest::DB; our @ISA = qw(My::DB2); MyTest::DB->use_private_registry; MyTest::DB->default_type('dt'); MyTest::DB->default_domain('dd'); MyTest::DB->register_db(driver => 'sqlite'); } $db = MyTest::DB->new; is($db->type, 'dt', 'default type 1'); is($db->domain, 'dd', 'default domain 1'); { package MyTest::DB2; our @ISA = qw(My::DB2); MyTest::DB2->default_type('xdt'); MyTest::DB2->default_domain('xdd'); MyTest::DB2->register_db(driver => 'sqlite'); } $db = MyTest::DB2->new; is($db->type, 'xdt', 'default type 2'); is($db->domain, 'xdd', 'default domain 2'); my @Intervals = ( '+0::' => '', '-0:1:' => '-00:01:00', '2:' => '02:00:00', '1 D' => '1 day', '-1 d 2 s' => '-1 days +00:00:02', '-1 y 3 h -57 M 4 s' => '-1 years +02:03:04', '-1 y 2 mons 3 d' => '-10 mons +3 days', '-1 y 2 mons -3 d' => '-10 mons -3 days', '5 h -208 m -495 s' => '01:23:45', '-208 m -495 s' => '-03:36:15', '5 h 208 m 495 s' => '08:36:15', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '1234 years 5 mons 6 days 07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '-1234 years -5 mons -6 days -07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '1234 years 5 mons 6 days 07:08:09', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '1234 years 5 mons 6 days 07:08:09', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '1234 years 5 mons 6 days 07:08:09', '1 mil -1 d ago' => '-1000 years +1 day', '1 mil ago -1 d ago' => '-1000 years +1 day', ); my $i = 0; while($i < @Intervals) { my($val, $formatted) = ($Intervals[$i++], $Intervals[$i++]); is($db->format_interval($db->parse_interval($val)), $formatted, "parse_interval ($val)"); } MyTest::DB2->max_interval_characters(1); eval { $db->format_interval($db->parse_interval('1 day ago')) }; ok($@, 'max_interval_characters 1'); ok(My::DB2->max_interval_characters != MyTest::DB2->max_interval_characters, 'max_interval_characters 2'); $db->keyword_function_calls(1); is($db->parse_interval('foo()'), 'foo()', 'parse_interval (foo())'); $db->keyword_function_calls(0); MyTest::DB2->max_interval_characters(255); my $d = $db->parse_interval('1 year 0.000003 seconds'); is($d->nanoseconds, 3000, 'nanoseconds 1'); is($db->format_interval($d), '1 year 00:00:00.000003000', 'nanoseconds 2'); # Time vaues my $tc; ok($tc = $db->parse_time('12:34:56.123456789'), 'parse time 12:34:56.123456789'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789'); ok($tc = $db->parse_time('12:34:56.123456789 pm'), 'parse time 12:34:56.123456789 pm'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789 pm'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789 pm'); ok($tc = $db->parse_time('12:34:56. A.m.'), 'parse time 12:34:56. A.m.'); is($tc->as_string, '00:34:56', 'check time 12:34:56 am'); is($db->format_time($tc), '00:34:56', 'format time 12:34:56 am'); ok($tc = $db->parse_time('12:34:56 pm'), 'parse time 12:34:56 pm'); is($tc->as_string, '12:34:56', 'check time 12:34:56 pm'); is($db->format_time($tc), '12:34:56', 'format time 12:34:56 pm'); ok($tc = $db->parse_time('2:34:56 pm'), 'parse time 2:34:56 pm'); is($tc->as_string, '14:34:56', 'check time 14:34:56 pm'); is($db->format_time($tc), '14:34:56', 'format time 14:34:56 pm'); ok($tc = $db->parse_time('2:34 pm'), 'parse time 2:34 pm'); is($tc->as_string, '14:34:00', 'check time 2:34 pm'); is($db->format_time($tc), '14:34:00', 'format time 2:34 pm'); ok($tc = $db->parse_time('2 pm'), 'parse time 2 pm'); is($tc->as_string, '14:00:00', 'check time 2 pm'); is($db->format_time($tc), '14:00:00', 'format time 2 pm'); ok($tc = $db->parse_time('3pm'), 'parse time 3pm'); is($tc->as_string, '15:00:00', 'check time 3pm'); is($db->format_time($tc), '15:00:00', 'format time 3pm'); ok($tc = $db->parse_time('4 p.M.'), 'parse time 4 p.M.'); is($tc->as_string, '16:00:00', 'check time 4 p.M.'); is($db->format_time($tc), '16:00:00', 'format time 4 p.M.'); ok($tc = $db->parse_time('24:00:00'), 'parse time 24:00:00'); is($tc->as_string, '24:00:00', 'check time 24:00:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00'); ok($tc = $db->parse_time('24:00:00 PM'), 'parse time 24:00:00 PM'); is($tc->as_string, '24:00:00', 'check time 24:00:00 PM'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00 PM'); ok($tc = $db->parse_time('24:00'), 'parse time 24:00'); is($tc->as_string, '24:00:00', 'check time 24:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00'); ok(!defined $db->parse_time('24:00:00.000000001'), 'parse time fail 24:00:00.000000001'); ok(!defined $db->parse_time('24:00:01'), 'parse time fail 24:00:01'); ok(!defined $db->parse_time('24:01'), 'parse time fail 24:01'); if(have_db('sqlite')) { My::DB2->register_db ( domain => 'handel', type => 'default', driver => 'SQLite', ); $db = My::DB2->new ( domain => 'handel', type => 'default', dsn => "dbi:SQLite:dbname=$Bin/sqlite.db", ); my $dbh = $db->dbh; is($db->dsn, "dbi:SQLite:dbname=$Bin/sqlite.db", 'dsn preservation 1'); $db = My::DB2->new ( domain => 'handel', type => 'default', database => "$Bin/sqlitex.db", ); $dbh = $db->dbh; is($db->dsn, "dbi:SQLite:dbname=$Bin/sqlitex.db", 'dsn preservation 2'); unlink("$Bin/sqlite.db"); unlink("$Bin/sqlitex.db"); } else { ok(1, 'skipping - dsn preservation requires sqlite 1'); ok(1, 'skipping - dsn preservation requires sqlite 2'); } # # Registry entry tests # my @entry; $i = 1; foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'scalar'))) { push(@entry, $attr => ($attr eq 'driver' || $attr eq 'dbi_driver' ? 'sqlite' : $i++)); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'boolean'))) { push(@entry, $attr => $i++ % 2); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'hash'))) { push(@entry, $attr => { $i++ => $i++ }); } foreach my $attr (sort(Rose::DB::Registry::Entry::_attrs(type => 'array'))) { push(@entry, $attr => [ $i++ ]); } $entry = Rose::DB::Registry::Entry->new(@entry); $dump = $entry->dump; is_deeply($dump, { @entry }, 'dump entry'); if(have_db('mysql')) { my %mysql_entry = map { $_ => $dump->{$_} } grep { /^mysql_/ } keys %$dump; My::DB2->register_db( domain => 'abc', type => 'def', driver => 'mysql', database => 'test', %mysql_entry); my $db = My::DB2->new(domain => 'abc', type => 'def'); foreach my $attr (grep { /^mysql_/ } keys %$dump) { is($db->$attr(), $dump->{$attr}, "entry attr - $attr"); } } else { my $count = grep { /^mysql_/ } keys %$dump; SKIP: { skip('mysql entry tests', $count) } } if(have_db('sqlite')) { { package My::DBX; use base 'My::DB2'; My::DBX->register_db( driver => 'SQLite', ); My::DBX->default_connect_options( { RaiseError => 0, } ); } my $db1 = My::DBX->new; ok(!$db1->dbh->{RaiseError}, 'RaiseError false'); my $db2 = My::DBX->new(raise_error => 1); ok($db2->dbh->{RaiseError}, 'RaiseError true'); my $db3 = My::DBX->new; ok(!$db3->dbh->{RaiseError}, 'RaiseError false'); } else { SKIP: { skip('connect option tests that require DBD::SQLite', 3) } } Rose-DB-0.777/t/subclass-informix.t000755 000765 000024 00000035647 12502134373 017154 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Informix }; if($@) { Test::More->import(skip_all => 'Missing DBD::Informix'); } else { Test::More->import(tests => 134); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } My::DB2->default_domain('test'); My::DB2->default_type('informix'); my $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 8) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = My::DB2->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database username password)) { is($db2->$field(), $db->$field(), "$field()"); } ok(defined $db->supports_limit_with_offset, 'supports_limit_with_offset'); $db->disconnect; $db2->disconnect; } $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->validate_timestamp_keyword('today'), 'validate_timestamp_keyword (today)'); ok($db->validate_timestamp_keyword('current'), 'validate_timestamp_keyword (current)'); ok($db->validate_timestamp_keyword('current year to second'), 'validate_timestamp_keyword (current year to second)'); ok($db->validate_timestamp_keyword('current year to minute'), 'validate_timestamp_keyword (current year to minute)'); ok($db->validate_timestamp_keyword('current year to hour'), 'validate_timestamp_keyword (current year to hour)'); ok($db->validate_timestamp_keyword('current year to day'), 'validate_timestamp_keyword (current year to day)'); ok($db->validate_timestamp_keyword('current year to month'), 'validate_timestamp_keyword (current year to month)'); ok($db->validate_timestamp_keyword('current year to fraction(1)'), 'validate_timestamp_keyword (current year to fraction(1))'); ok($db->validate_timestamp_keyword('current year to fraction(5)'), 'validate_timestamp_keyword (current year to fraction(5))'); ok(!$db->validate_timestamp_keyword('current year to fraction(6)'), 'validate_timestamp_keyword (current year to fraction(6))'); ok(!$db->validate_timestamp_keyword('now'), 'validate_timestamp_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_timestamp_keyword('Foo(Bar)'), 'validate_timestamp_keyword (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_timestamp('current'), 'current', 'format_timestamp (current)'); is($db->format_timestamp('current year to fraction(1)'), 'current year to fraction(1)', 'format_timestamp (current year to fraction(1))'); is($db->format_timestamp('current year to fraction(5)'), 'current year to fraction(5)', 'format_timestamp (current year to fraction(5))'); $db->keyword_function_calls(1); is($db->format_timestamp('Foo(Bar)'), 'Foo(Bar)', 'format_timestamp (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_keyword('today'), 'validate_datetime_keyword (today)'); ok($db->validate_datetime_keyword('current year to second'), 'validate_datetime_keyword (current year to second)'); ok($db->validate_datetime_keyword('current year to minute'), 'validate_datetime_keyword (current year to minute)'); ok($db->validate_datetime_keyword('current year to hour'), 'validate_datetime_keyword (current year to hour)'); ok($db->validate_datetime_keyword('current year to day'), 'validate_datetime_keyword (current year to day)'); ok($db->validate_datetime_keyword('current year to month'), 'validate_datetime_keyword (current year to month)'); ok($db->validate_datetime_keyword('current'), 'validate_datetime_keyword current'); ok(!$db->validate_datetime_keyword('now'), 'validate_datetime_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_datetime_keyword('Foo(Bar)'), 'validate_datetime_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_fraction_keyword('today'), 'validate_datetime_year_to_fraction_keyword (today)'); ok($db->validate_datetime_year_to_fraction_keyword('current'), 'validate_timestamp_keyword (current)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to second'), 'validate_timestamp_keyword (current year to second)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to minute'), 'validate_timestamp_keyword (current year to minute)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to hour'), 'validate_timestamp_keyword (current year to hour)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to day'), 'validate_timestamp_keyword (current year to day)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to month'), 'validate_timestamp_keyword (current year to month)'); ok($db->validate_datetime_year_to_fraction_keyword('current year to fraction(1)'), 'validate_timestamp_keyword (current year to fraction(1))'); ok($db->validate_datetime_year_to_fraction_keyword('current year to fraction(5)'), 'validate_timestamp_keyword (current year to fraction(5))'); ok(!$db->validate_datetime_year_to_fraction_keyword('current year to fraction(6)'), 'validate_timestamp_keyword (current year to fraction(6))'); ok(!$db->validate_datetime_year_to_fraction_keyword('now'), 'validate_timestamp_keyword (!now)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_fraction_keyword('Foo(Bar)'), 'validate_timestamp_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_minute_keyword('today'), 'validate_datetime_year_to_minute_keyword (today)'); ok($db->validate_datetime_year_to_minute_keyword('current'), 'validate_datetime_year_to_minute_keyword current'); ok($db->validate_datetime_year_to_minute_keyword('current year to second'), 'validate_datetime_year_to_minute_keyword current year to second'); ok($db->validate_datetime_year_to_minute_keyword('current year to minute'), 'validate_datetime_year_to_minute_keyword current year to minute'); ok($db->validate_datetime_year_to_minute_keyword('current year to hour'), 'validate_datetime_year_to_minute_keyword (current year to hour)'); ok($db->validate_datetime_year_to_minute_keyword('current year to day'), 'validate_datetime_year_to_minute_keyword (current year to day)'); ok($db->validate_datetime_year_to_minute_keyword('current year to month'), 'validate_datetime_year_to_minute_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_minute_keyword('Foo(Bar)'), 'validate_datetime_year_to_minute_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_month_keyword('today'), 'validate_datetime_year_to_month_keyword (today)'); ok($db->validate_datetime_year_to_month_keyword('current'), 'validate_datetime_year_to_month_keyword current'); ok($db->validate_datetime_year_to_month_keyword('current year to second'), 'validate_datetime_year_to_month_keyword current year to second'); ok($db->validate_datetime_year_to_month_keyword('current year to minute'), 'validate_datetime_year_to_month_keyword current year to minute'); ok($db->validate_datetime_year_to_month_keyword('current year to hour'), 'validate_datetime_year_to_month_keyword (current year to hour)'); ok($db->validate_datetime_year_to_month_keyword('current year to day'), 'validate_datetime_year_to_month_keyword (current year to day)'); ok($db->validate_datetime_year_to_month_keyword('current year to month'), 'validate_datetime_year_to_month_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_month_keyword('Foo(Bar)'), 'validate_datetime_year_to_month_keyword (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_datetime_year_to_second_keyword('today'), 'validate_datetime_year_to_second_keyword (today)'); ok($db->validate_datetime_year_to_second_keyword('current'), 'validate_datetime_year_to_second_keyword current'); ok($db->validate_datetime_year_to_second_keyword('current year to second'), 'validate_datetime_year_to_second_keyword current year to second'); ok($db->validate_datetime_year_to_second_keyword('current year to minute'), 'validate_datetime_year_to_second_keyword current year to minute'); ok($db->validate_datetime_year_to_second_keyword('current year to hour'), 'validate_datetime_year_to_second_keyword (current year to hour)'); ok($db->validate_datetime_year_to_second_keyword('current year to day'), 'validate_datetime_year_to_second_keyword (current year to day)'); ok($db->validate_datetime_year_to_second_keyword('current year to month'), 'validate_datetime_year_to_second_keyword (current year to month)'); $db->keyword_function_calls(1); ok($db->validate_datetime_year_to_second_keyword('Foo(Bar)'), 'validate_datetime_year_to_second_keyword (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_datetime('current'), 'current', 'format_datetime current'); ok($db->validate_datetime_year_to_second_keyword('current year to second'), 'validate_datetime_year_to_second_keyword current year to second'); ok($db->validate_datetime_year_to_second_keyword('current year to minute'), 'validate_datetime_year_to_second_keyword current year to minute'); ok($db->validate_datetime_year_to_second_keyword('current year to hour'), 'validate_datetime_year_to_second_keyword (current year to hour)'); ok($db->validate_datetime_year_to_second_keyword('current year to day'), 'validate_datetime_year_to_second_keyword (current year to day)'); ok($db->validate_datetime_year_to_second_keyword('current year to month'), 'validate_datetime_year_to_second_keyword (current year to month)'); $db->keyword_function_calls(1); is($db->format_datetime('Foo(Bar)'), 'Foo(Bar)', 'format_datetime (Foo(Bar))'); $db->keyword_function_calls(0); ok($db->validate_date_keyword('today'), 'validate_date_keyword (today)'); ok($db->validate_date_keyword('current'), 'validate_date_keyword current'); ok(!$db->validate_date_keyword('now'), 'validate_date_keyword (!now)'); is($db->format_date('current'), 'current', 'format_date (current)'); $db->keyword_function_calls(1); is($db->format_date('Foo(Bar)'), 'Foo(Bar)', 'format_date (Foo(Bar))'); $db->keyword_function_calls(0); #ok($db->validate_time_keyword('current'), 'validate_time_keyword current'); #is($db->format_time('current'), 'current', 'format_time (current)'); $db->keyword_function_calls(1); is($db->format_time('Foo(Bar)'), 'Foo(Bar)', 'format_time (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); eval { $db->format_array('a', undef) }; ok($@ =~ /undefined/i, 'format_array() 4'); eval { $db->format_array([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_array() 5'); my $a = $db->parse_array(q({"a","b"})); is($db->format_set([ 'a', 'b' ]), q(SET{'a','b'}), 'format_set() 1'); is($db->format_set('a', 'b'), q(SET{'a','b'}), 'format_set() 2'); eval { $db->format_set('a', undef) }; ok($@ =~ /undefined/i, 'format_set() 3'); eval { $db->format_set([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_set() 4'); my $s = $db->parse_set(q(SET{'a','b'})); ok(@$s == 2 && $s->[0] eq 'a' && $s->[1] eq 'b', 'parse_set() 1'); $s = $db->parse_set(q(SET{'4 '})); ok(@$s == 1 && $s->[0] eq '4 ', 'parse_set() 2'); $s = $db->parse_set(q(SET{'4 '}), { value_type => 'integer' }); ok(@$s == 1 && $s->[0] eq '4', 'parse_set() 3'); SKIP: { eval { $db->connect }; skip("Could not connect to db 'test', 'informix' - $@", 37) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'informix', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('2002-12-31', 'floating')), '12/31/2002', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); my $dt = $db->parse_datetime_year_to_second('12/31/2002 12:34:56.123456789'); is($dt->nanosecond, 0, 'parse_datetime_year_to_second()'); $dt = $db->parse_datetime_year_to_minute('12/31/2002 12:34:56'); is($dt->second, 0, 'parse_datetime_year_to_minute()'); is($db->format_datetime_year_to_second(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime_year_to_second() floating"); is($db->format_datetime_year_to_minute(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34', "format_datetime_year_to_minute() floating"); is($db->format_datetime_year_to_month(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12', "format_datetime_year_to_month() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.12345', 'floating')), '2002-12-31 12:34:56.12345', "format_timestamp() floating"); #is($db->format_time(parse_date('12/31/2002 12:34:56', 'floating')), '12:34:56', "format_datetime() floating"); is($db->format_bitfield($db->parse_bitfield('1010')), q(1010), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(1010), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(0010), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(1010), "format_bitfield() 4"); my $str = $db->format_array([ 'a' .. 'c' ]); is($str, '{"a","b","c"}', 'format_array() 1'); my $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && $ar->[1] eq 'b' && $ar->[2] eq 'c', 'parse_array() 1'); $str = $db->format_array($ar); is($str, '{"a","b","c"}', 'format_array() 2'); $str = $db->format_array([ 1, -2, 3.5 ]); is($str, '{1,-2,3.5}', 'format_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 2'); $str = $db->format_array($ar); is($str, '{1,-2,3.5}', 'format_array() 4'); $str = $db->format_array(1, -2, 3.5); is($str, '{1,-2,3.5}', 'format_array() 5'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 3'); is($db->format_boolean(1), 't', 'format_boolean (1)'); is($db->format_boolean(0), 'f', 'format_boolean (0)'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('T'), 1, 'parse_boolean (T)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('F'), 0, 'parse_boolean (F)'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } Rose-DB-0.777/t/subclass-list-tables.t000644 000765 000024 00000043317 12502134373 017532 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 1 + (6 * 2); BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } our @Tables = sort qw(rdbo_test_vendors rdbo_test_products rdbo_test_prices rdbo_test_colors rdbo_test_products_colors); my $Regex = '^(?:' . join('|', @Tables, 'rdbo_test_view', 'read') . ')'; our %Have; # # Tests # foreach my $db_type (qw(mysql pg pg_with_schema informix sqlite oracle)) { SKIP: { unless($Have{$db_type}) { skip("$db_type tests", 2); } } next unless($Have{$db_type}); My::DB2->default_type($db_type); my $db = My::DB2->new; # Oracle returns names in upper case. my @tables = sort grep { /$Regex/i } $db->list_tables; if($db_type eq 'mysql') { is_deeply(\@tables, [ sort(@Tables, 'read') ], "$db_type tables 1"); } elsif($db_type eq 'informix') { # Informix shows views every time is_deeply(\@tables, [ sort(@Tables, 'rdbo_test_view') ], "$db_type tables"); } elsif($db_type eq 'oracle') { is_deeply(\@tables, [ map { uc } @Tables ], "$db_type tables 1"); } else { is_deeply(\@tables, \@Tables, "$db_type tables 1"); } # Oracle returns names in upper case. @tables = sort grep { /$Regex/i } $db->list_tables(include_views => 1); if($db_type =~ /^(?:pg(?:_with_schema)?|sqlite|informix)$/) { is_deeply(\@tables, [ sort(@Tables, 'rdbo_test_view') ], "$db_type tables and views"); } else { if($db_type eq 'mysql') { is_deeply(\@tables, [ sort(@Tables, 'read') ], "$db_type tables and views"); } elsif($db_type eq 'oracle') { is_deeply(\@tables, [ map { uc } (@Tables, 'rdbo_test_view') ], "$db_type tables and views"); } else { is_deeply(\@tables, \@Tables, "$db_type tables and views"); } } } BEGIN { our %Have; # # PostgreSQL # my $dbh; eval { $dbh = My::DB2->new('pg_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { $Have{'pg'} = 1; $Have{'pg_with_schema'} = 1; # Drop existing tables and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP VIEW Rose_db_object_private.rdbo_test_view'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_vendors CASCADE'); $dbh->do('DROP SCHEMA Rose_db_object_private CASCADE'); $dbh->do('CREATE SCHEMA Rose_db_object_private'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP NOT NULL DEFAULT NOW(), release_date TIMESTAMP, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP NOT NULL DEFAULT NOW(), release_date TIMESTAMP, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE Rose_db_object_private.rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW Rose_db_object_private.rdbo_test_view AS SELECT * FROM Rose_db_object_private.rdbo_test_colors EOF $dbh->disconnect; } # # Oracle # eval { $dbh = My::DB2->new('oracle_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { $Have{'oracle'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_products CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE CONSTRAINTS'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATE, release_date DATE, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INT NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INT NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->commit; $dbh->disconnect; } # # MySQL # eval { my $db = My::DB2->new('mysql_admin'); $dbh = $db->retain_dbh or die My::DB2->error; die "MySQL version too old" unless($db->database_version >= 4_000_000); # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP TABLE `read` CASCADE'); } # Foreign key stuff requires InnoDB support $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) ENGINE=InnoDB EOF # MySQL will silently ignore the "ENGINE=InnoDB" part and create # a MyISAM table instead. MySQL is evil! Now we have to manually # check to make sure an InnoDB table was really created. my $db_name = $db->database; my $sth = $dbh->prepare("SHOW TABLE STATUS FROM `$db_name` LIKE ?"); $sth->execute('rdbo_test_vendors'); my $info = $sth->fetchrow_hashref; no warnings 'uninitialized'; unless(lc $info->{'Type'} eq 'innodb' || lc $info->{'Engine'} eq 'innodb') { die "Missing InnoDB support"; } }; if(!$@ && $dbh) { $Have{'mysql'} = 1; $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) NOT NULL DEFAULT 0.00, vendor_id INT, status VARCHAR(128) NOT NULL DEFAULT 'inactive' CHECK(status IN ('inactive', 'active', 'defunct')), date_created TIMESTAMP, release_date TIMESTAMP, UNIQUE(name), INDEX(vendor_id), FOREIGN KEY (vendor_id) REFERENCES rdbo_test_vendors (id) ON DELETE NO ACTION ON UPDATE SET NULL ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INT AUTO_INCREMENT PRIMARY KEY, product_id INT NOT NULL, region CHAR(2) NOT NULL DEFAULT 'US', price DECIMAL(10,2) NOT NULL DEFAULT 0.00, UNIQUE(product_id, region), INDEX(product_id), FOREIGN KEY (product_id) REFERENCES rdbo_test_products (id) ON UPDATE NO ACTION ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INT AUTO_INCREMENT PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL, color_id INT NOT NULL, PRIMARY KEY(product_id, color_id), INDEX(color_id), INDEX(product_id), FOREIGN KEY (product_id) REFERENCES rdbo_test_products (id) ON DELETE RESTRICT, FOREIGN KEY (color_id) REFERENCES rdbo_test_colors (id) ON UPDATE NO ACTION ) ENGINE=InnoDB EOF $dbh->do(<<"EOF"); CREATE TABLE `read` ( id INT AUTO_INCREMENT PRIMARY KEY, `read` VARCHAR(255) NOT NULL ) ENGINE=InnoDB EOF $dbh->disconnect; } # # Informix # eval { $dbh = My::DB2->new('informix_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { $Have{'informix'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATETIME YEAR TO SECOND, release_date DATETIME YEAR TO SECOND, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id SERIAL NOT NULL PRIMARY KEY, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id SERIAL NOT NULL PRIMARY KEY, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF #$dbh->commit; $dbh->disconnect; } # # SQLite # eval { $dbh = My::DB2->new('sqlite_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { $Have{'sqlite'} = 1; # Drop existing tables, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors'); $dbh->do('DROP TABLE rdbo_test_colors'); $dbh->do('DROP TABLE rdbo_test_prices'); $dbh->do('DROP TABLE rdbo_test_products'); $dbh->do('DROP TABLE rdbo_test_vendors'); } $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_vendors ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, vendor_id INT REFERENCES rdbo_test_vendors (id), status VARCHAR(128) DEFAULT 'inactive' NOT NULL CHECK(status IN ('inactive', 'active', 'defunct')), date_created DATETIME, release_date DATETIME, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_prices ( id INTEGER PRIMARY KEY AUTOINCREMENT, product_id INT NOT NULL REFERENCES rdbo_test_products (id), region CHAR(2) DEFAULT 'US' NOT NULL, price DECIMAL(10,2) DEFAULT 0.00 NOT NULL, UNIQUE(product_id, region) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_colors ( id INTEGER PRIMARY KEY AUTOINCREMENT, name VARCHAR(255) NOT NULL, UNIQUE(name) ) EOF $dbh->do(<<"EOF"); CREATE TABLE rdbo_test_products_colors ( product_id INT NOT NULL REFERENCES rdbo_test_products (id), color_id INT NOT NULL REFERENCES rdbo_test_colors (id), PRIMARY KEY(product_id, color_id) ) EOF $dbh->do(<<"EOF"); CREATE VIEW rdbo_test_view AS SELECT * FROM rdbo_test_colors EOF $dbh->disconnect; } } END { # Delete test table if($Have{'pg'}) { # PostgreSQL my $dbh = My::DB2->new('pg_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP VIEW Rose_db_object_private.rdbo_test_view'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_products CASCADE'); $dbh->do('DROP TABLE Rose_db_object_private.rdbo_test_vendors CASCADE'); $dbh->do('DROP SCHEMA Rose_db_object_private CASCADE'); $dbh->disconnect; } if($Have{'oracle'}) { # Oracle my $dbh = My::DB2->new('oracle_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_products CASCADE CONSTRAINTS'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE CONSTRAINTS'); $dbh->disconnect; } if($Have{'mysql'}) { # MySQL my $dbh = My::DB2->new('mysql_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->do('DROP TABLE `read` CASCADE'); $dbh->disconnect; } if($Have{'informix'}) { # Informix my $dbh = My::DB2->new('informix_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_colors CASCADE'); $dbh->do('DROP TABLE rdbo_test_prices CASCADE'); $dbh->do('DROP TABLE rdbo_test_products CASCADE'); $dbh->do('DROP TABLE rdbo_test_vendors CASCADE'); $dbh->disconnect; } if($Have{'sqlite'}) { # Informix my $dbh = My::DB2->new('sqlite_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP VIEW rdbo_test_view'); $dbh->do('DROP TABLE rdbo_test_products_colors'); $dbh->do('DROP TABLE rdbo_test_colors'); $dbh->do('DROP TABLE rdbo_test_prices'); $dbh->do('DROP TABLE rdbo_test_products'); $dbh->do('DROP TABLE rdbo_test_vendors'); $dbh->disconnect; } } Rose-DB-0.777/t/subclass-mysql.t000755 000765 000024 00000021326 12502134373 016453 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::mysql }; if($@) { Test::More->import(skip_all => 'Missing DBD::mysql'); } elsif($DBD::mysql::VERSION !~ /_/ && $DBD::mysql::VERSION < 4.017) { Test::More->import(skip_all => "Old DBD::mysql: $DBD::mysql::VERSION"); } else { Test::More->import(tests => 159); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } My::DB2->default_domain('test'); My::DB2->default_type('mysql'); my $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 9) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = My::DB2->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } $db->disconnect; $db2->disconnect; } $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); my $rand; $rand .= $letters[int rand(@letters)] for(1 .. int(rand(20))); $rand = 'default' unless(defined $rand); # got under here once! ok(!$db->validate_timestamp_keyword($rand), "validate_timestamp_keyword ($rand)"); ok(!$db->validate_datetime_keyword($rand), "validate_datetime_keyword ($rand)"); ok(!$db->validate_date_keyword($rand), "validate_date_keyword ($rand)"); ok($db->validate_date_keyword('0000-00-00'), "validate_date_keyword (0000-00-00)"); ok($db->validate_datetime_keyword('0000-00-00 00:00:00'), "validate_datetime_keyword (0000-00-00 00:00:00)"); ok($db->validate_datetime_keyword('0000-00-00 00:00:00'), "validate_datetime_keyword (0000-00-00 00:00:00)"); ok($db->validate_timestamp_keyword('0000-00-00 00:00:00'), "validate_timestamp_keyword (0000-00-00 00:00:00)"); ok($db->validate_timestamp_keyword('00000000000000'), "validate_timestamp_keyword (00000000000000)"); ok(!$db->validate_time_keyword($rand), "validate_time_keyword ($rand)"); foreach my $name (qw(date datetime timestamp)) { my $method = "validate_${name}_keyword"; ok(!$db->$method('Foo(Bar)'), "$method (Foo(Bar)) 1"); $db->keyword_function_calls(1); ok($db->$method('Foo(Bar)'), "$method (Foo(Bar)) 2"); $db->keyword_function_calls(0); foreach my $value (qw(now() curtime() curdate() sysdate() current_time current_time() current_date current_date() current_timestamp current_timestamp())) { my $new_value = $value; my $i = int(rand(length($new_value) - 3)); # 3 = 1 + 2 (for possible parens) substr($new_value, $i, 1) = uc substr($new_value, $i, 1); ok($db->$method($new_value), "$method ($new_value)"); } } is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); my $a = $db->parse_array(q({"a","b","\\""})); ok(@$a == 3 && $a->[0] eq 'a' && $a->[1] eq 'b' && $a->[2] eq '"', 'parse_array() 1'); is($db->format_set([ 'a', 'b' ]), 'a,b', 'format_set() 1'); is($db->format_set('a', 'b'), 'a,b', 'format_set() 2'); eval { $db->format_set('a', undef) }; ok($@ =~ /undefined/i, 'format_set() 3'); eval { $db->format_set([ 'a', undef ]) }; ok($@ =~ /undefined/i, 'format_set() 4'); my $s = $db->parse_set('a,b'); ok(@$s == 2 && $s->[0] eq 'a' && $s->[1] eq 'b', 'parse_set() 1'); SKIP: { unless(have_db('mysql')) { skip("MySQL connection tests", 80); } eval { $db->connect }; skip("Could not connect to db 'test', 'mysql' - $@", 27) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'mysql', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_timestamp() floating"); if($db->database_version >= 5_000_003) { is($db->format_bitfield($db->parse_bitfield('1010')), q(b'1010'), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(b'1010'), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(b'0010'), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(b'1010'), "format_bitfield() 4"); } else { is($db->format_bitfield($db->parse_bitfield('1010')), q(10), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(10), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(2), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(10), "format_bitfield() 4"); } #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; foreach my $attr (qw(mysql_auto_reconnect mysql_client_found_rows mysql_compression mysql_connect_timeout mysql_embedded_groups mysql_embedded_options mysql_enable_utf8 mysql_local_infile mysql_multi_statements mysql_read_default_file mysql_read_default_group mysql_socket mysql_ssl mysql_ssl_ca_file mysql_ssl_ca_path mysql_ssl_cipher mysql_ssl_client_cert mysql_ssl_client_key mysql_use_result mysql_bind_type_guessing)) { $db = My::DB2->new($attr => 1); is($db->$attr(), 1, "$attr 1"); $db->connect; if($attr eq 'mysql_auto_reconnect') # can't read back the others? { is($db->$attr(), 1, "$attr 2"); is($db->dbh->{$attr}, 1, "$attr 3"); } else { SKIP: { skip("$attr dbh read-back", 2) } } } TEST: { my $dbh = My::DB2->new->retain_dbh; $db = My::DB2->new(dbh => $dbh); } $db->retain_dbh; $db->release_dbh; ok($db->{'dbh'}{'Active'}, 'retain stuffed dbh'); $db->connect; $db->mysql_enable_utf8(1); is($db->mysql_enable_utf8, 1, 'mysql_enable_utf8 2'); if($db->isa('My::DB2')) { $My::DB2::Called{'init_dbh'} = 0; $db = My::DB2->new('mysql'); $db->dbh; is($My::DB2::Called{'init_dbh'}, 1, 'SUPER:: from driver'); } else { SKIP: { skip('SUPER:: from driver tests', 1) } } } $db->dsn('dbi:mysql:dbname=dbfoo;host=hfoo;port=pfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:Pg:dbname=dbfoo;host=hfoo;port=pfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); My::DB2->register_db ( domain => 'stub', type => 'default', driver => 'MySQL', ); $db = My::DB2->new ( domain => 'stub', type => 'default', dsn => "dbi:mysql:mydb", ); is($db->database, 'mydb', 'parse_dsn() 1'); sub lookup_ip { my($name) = shift; my $address = (gethostbyname($name))[4] or return 0; my @octets = unpack("CCCC", $address); return 0 unless($name && @octets); return join('.', @octets), "\n"; } (my $version = $DBI::VERSION) =~ s/_//g; if(have_db('mysql') && $version >= 1.24) { my $x = 0; my $handler = sub { $x++; die "Error: $x" }; My::DB2->register_db( type => 'error_handler', driver => 'mysql', print_error => 0, raise_error => 1, handle_error => $handler, ); $db = My::DB2->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); is($db->dbh->{'HandleError'}, $handler, 'HandleError 1'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; is($x, 2, 'handle_error 5'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 10) } } Rose-DB-0.777/t/subclass-oracle.t000644 000765 000024 00000014716 12502134373 016555 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Oracle }; if($@) { Test::More->import(skip_all => 'Missing DBD::Oracle'); } else { Test::More->import(tests => 80); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } My::DB2->default_domain('test'); My::DB2->default_type('oracle'); # Note: $db here is of type Rose::DB::Oracle. my $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('true'), 1, 'parse_boolean (true)'); is($db->parse_boolean('y'), 1, 'parse_boolean (y)'); is($db->parse_boolean('yes'), 1, 'parse_boolean (yes)'); is($db->parse_boolean('1'), 1, 'parse_boolean (1)'); is($db->parse_boolean('TRUE'), 'TRUE', 'parse_boolean (TRUE)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('false'), 0, 'parse_boolean (false)'); is($db->parse_boolean('n'), 0, 'parse_boolean (n)'); is($db->parse_boolean('no'), 0, 'parse_boolean (no)'); is($db->parse_boolean('0'), 0, 'parse_boolean (0)'); is($db->parse_boolean('FALSE'), 'FALSE', 'parse_boolean (FALSE)'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); foreach my $val (qw(t 1 true True T y Y yes Yes)) { is($db->format_boolean($db->parse_boolean($val)), 't', "format_boolean ($val)"); } foreach my $val (qw(f 0 false False F n N no No)) { is($db->format_boolean($db->parse_boolean($val)), 'f', "format_boolean ($val)"); } is($db->auto_quote_column_name('foo_bar_123'), 'foo_bar_123', 'auto_quote_column_name 1'); is($db->auto_quote_column_name('claim#'), '"CLAIM#"', 'auto_quote_column_name 2'); is($db->auto_quote_column_name('foo-bar'), '"FOO-BAR"', 'auto_quote_column_name 3'); is($db->parse_date('2002-12-31'), parse_date('12/31/2002'), "parse_date() 1"); is($db->parse_date('2002-12-31 12:34'), parse_date('12/31/2002 12:34'), "parse_date() 2"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56'), "parse_datetime() 1"); is($db->parse_datetime('2002-12-31 12:34:56.0'), parse_date('12/31/2002 12:34:56'), "parse_datetime() 2"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56'), "parse_timestamp() 1"); is($db->parse_timestamp('2002-12-31 12:34:56.0'), parse_date('12/31/2002 12:34:56'), "parse_timestamp() 2"); is($db->parse_timestamp('2002-12-31 12:34:56.123'), parse_date('12/31/2002 12:34:56.123'), "parse_timestamp() 3"); is($db->parse_timestamp('2002-12-31 12:34:56.123456789'), parse_date('12/31/2002 12:34:56.123456'), "parse_timestamp() 4"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 1"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.0 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 2"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.123 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 3"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56.123456789 -0500')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone() 4"); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 16) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = My::DB2->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } SEQUENCE_PREP: { my $dbh = $db->dbh; local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 0; $dbh->do('DROP SEQUENCE rose_db_sequence_test'); } $dbh->do('CREATE SEQUENCE rose_db_sequence_test MINVALUE 5'); ok($db->sequence_exists('rose_db_sequence_test'), 'sequence_exists 1'); ok(!$db->sequence_exists('rose_db_sequence_testx'), 'sequence_exists 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 1'); is($db->next_value_in_sequence('rose_db_sequence_test'), 6, 'next_value_in_sequence 1'); is($db->current_value_in_sequence('rose_db_sequence_test'), 6, 'current_value_in_sequence 2'); is($db->next_value_in_sequence('rose_db_sequence_test'), 7, 'next_value_in_sequence 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 7, 'current_value_in_sequence 3'); $dbh->do('DROP SEQUENCE rose_db_sequence_test'); $db->disconnect; $db2->disconnect; } $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; My::DB2->register_db ( domain => 'stub', type => 'default', driver => 'oracle', ); $db = My::DB2->new ( domain => 'stub', type => 'default', dsn => "dbi:Oracle:mydb", ); is($db->database, 'mydb', 'parse_dsn() 1'); SKIP: { $db = My::DB2->new; eval { $db->connect }; skip("Could not connect to db 'test', 'oracle' - $@", 10) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'oracle', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } My::DB2->register_db ( type => 'dsn1', driver => 'oracle', database => 'somedb', ); is(My::DB2->new('dsn1')->dsn, 'dbi:Oracle:somedb', 'dsn 1'); My::DB2->register_db ( type => 'dsn2', driver => 'oracle', database => 'somedb', host => 'somehost', ); is(My::DB2->new('dsn2')->dsn, 'dbi:Oracle:sid=somedb;host=somehost', 'dsn 2'); My::DB2->register_db ( type => 'dsn3', driver => 'oracle', database => 'somedb', port => 'someport', ); is(My::DB2->new('dsn3')->dsn, 'dbi:Oracle:sid=somedb;port=someport', 'dsn 3'); My::DB2->register_db ( type => 'dsn4', driver => 'oracle', database => 'somedb', host => 'somehost', port => 'someport', ); is(My::DB2->new('dsn4')->dsn, 'dbi:Oracle:sid=somedb;host=somehost;port=someport', 'dsn 4'); Rose-DB-0.777/t/subclass-pg.t000755 000765 000024 00000050231 12502134373 015711 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; eval { require DBD::Pg }; if($@) { Test::More->import(skip_all => 'Missing DBD::Pg'); } else { Test::More->import(tests => 324); } } BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } My::DB2->default_domain('test'); My::DB2->default_type('pg'); my $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), 'new()'); SKIP: { skip("Could not connect to db - $@", 15) unless(have_db('pg')); my $dbh = $db->dbh; ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = My::DB2->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field(), $db->$field(), "$field()"); } ok(!$db->pg_enable_utf8, 'pg_enable_utf8 false'); $db->pg_enable_utf8(1); ok($db->pg_enable_utf8 && $db->dbh->{'pg_enable_utf8'}, 'pg_enable_utf8 true'); SEQUENCE_PREP: { my $dbh = $db->dbh; local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 0; $dbh->do('DROP SEQUENCE rose_db_sequence_test'); } $dbh->do('CREATE SEQUENCE rose_db_sequence_test MINVALUE 5'); ok($db->sequence_exists('rose_db_sequence_test'), 'sequence_exists 1'); ok(!$db->sequence_exists('rose_db_sequence_testx'), 'sequence_exists 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 1'); is($db->next_value_in_sequence('rose_db_sequence_test'), 5, 'next_value_in_sequence 1'); is($db->current_value_in_sequence('rose_db_sequence_test'), 5, 'current_value_in_sequence 2'); is($db->next_value_in_sequence('rose_db_sequence_test'), 6, 'next_value_in_sequence 2'); is($db->current_value_in_sequence('rose_db_sequence_test'), 6, 'current_value_in_sequence 3'); $dbh->do('DROP SEQUENCE rose_db_sequence_test'); $db->disconnect; $db2->disconnect; } $db = My::DB2->new(); $db->sslmode('allow'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;sslmode=allow', 'sslmode()'); $db->options('opts'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;options=opts;sslmode=allow', 'options()'); $db->service('srv'); is($db->dsn, 'dbi:Pg:dbname=test;host=localhost;options=opts;service=srv;sslmode=allow', 'service()'); $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); ok($db->validate_timestamp_keyword('now'), 'validate_timestamp_keyword (now)'); ok($db->validate_timestamp_keyword('infinity'), 'validate_timestamp_keyword (infinity)'); ok($db->validate_timestamp_keyword('-infinity'), 'validate_timestamp_keyword (-infinity)'); ok($db->validate_timestamp_keyword('epoch'), 'validate_timestamp_keyword (epoch)'); ok($db->validate_timestamp_keyword('today'), 'validate_timestamp_keyword (today)'); ok($db->validate_timestamp_keyword('tomorrow'), 'validate_timestamp_keyword (tomorrow)'); ok($db->validate_timestamp_keyword('yesterday'), 'validate_timestamp_keyword (yesterday)'); ok($db->validate_timestamp_keyword('allballs'), 'validate_timestamp_keyword (allballs)'); is($db->format_timestamp('now'), 'now', 'format_timestamp (now)'); is($db->format_timestamp('infinity'), 'infinity', 'format_timestamp (infinity)'); is($db->format_timestamp('-infinity'), '-infinity', 'format_timestamp (-infinity)'); is($db->format_timestamp('epoch'), 'epoch', 'format_timestamp (epoch)'); is($db->format_timestamp('today'), 'today', 'format_timestamp (today)'); is($db->format_timestamp('tomorrow'), 'tomorrow', 'format_timestamp (tomorrow)'); is($db->format_timestamp('yesterday'), 'yesterday', 'format_timestamp (yesterday)'); is($db->format_timestamp('allballs'), 'allballs', 'format_timestamp (allballs)'); ok($db->validate_datetime_keyword('now'), 'validate_datetime_keyword (now)'); ok($db->validate_datetime_keyword('infinity'), 'validate_datetime_keyword (infinity)'); ok($db->validate_datetime_keyword('-infinity'), 'validate_datetime_keyword (-infinity)'); ok($db->validate_datetime_keyword('epoch'), 'validate_datetime_keyword (epoch)'); ok($db->validate_datetime_keyword('today'), 'validate_datetime_keyword (today)'); ok($db->validate_datetime_keyword('tomorrow'), 'validate_datetime_keyword (tomorrow)'); ok($db->validate_datetime_keyword('yesterday'), 'validate_datetime_keyword (yesterday)'); ok($db->validate_datetime_keyword('allballs'), 'validate_datetime_keyword (allballs)'); is($db->format_datetime('now'), 'now', 'format_datetime (now)'); is($db->format_datetime('infinity'), 'infinity', 'format_datetime (infinity)'); is($db->format_datetime('-infinity'), '-infinity', 'format_datetime (-infinity)'); is($db->format_datetime('epoch'), 'epoch', 'format_datetime (epoch)'); is($db->format_datetime('today'), 'today', 'format_datetime (today)'); is($db->format_datetime('tomorrow'), 'tomorrow', 'format_datetime (tomorrow)'); is($db->format_datetime('yesterday'), 'yesterday', 'format_datetime (yesterday)'); is($db->format_datetime('allballs'), 'allballs', 'format_datetime (allballs)'); ok($db->validate_date_keyword('now'), 'validate_date_keyword (now)'); ok($db->validate_date_keyword('epoch'), 'validate_date_keyword (epoch)'); ok($db->validate_date_keyword('today'), 'validate_date_keyword (today)'); ok($db->validate_date_keyword('tomorrow'), 'validate_date_keyword (tomorrow)'); ok($db->validate_date_keyword('yesterday'), 'validate_date_keyword (yesterday)'); is($db->format_date('now'), 'now', 'format_date (now)'); is($db->format_date('epoch'), 'epoch', 'format_date (epoch)'); is($db->format_date('today'), 'today', 'format_date (today)'); is($db->format_date('tomorrow'), 'tomorrow', 'format_date (tomorrow)'); is($db->format_date('yesterday'), 'yesterday', 'format_date (yesterday)'); ok($db->validate_time_keyword('now'), 'validate_time_keyword (now)'); ok($db->validate_time_keyword('allballs'), 'validate_time_keyword (allballs)'); is($db->format_time('now'), 'now', 'format_time (now)'); is($db->format_time('allballs'), 'allballs', 'format_time (allballs)'); is($db->parse_boolean('t'), 1, 'parse_boolean (t)'); is($db->parse_boolean('true'), 1, 'parse_boolean (true)'); is($db->parse_boolean('y'), 1, 'parse_boolean (y)'); is($db->parse_boolean('yes'), 1, 'parse_boolean (yes)'); is($db->parse_boolean('1'), 1, 'parse_boolean (1)'); is($db->parse_boolean('TRUE'), 'TRUE', 'parse_boolean (TRUE)'); is($db->parse_boolean('f'), 0, 'parse_boolean (f)'); is($db->parse_boolean('false'), 0, 'parse_boolean (false)'); is($db->parse_boolean('n'), 0, 'parse_boolean (n)'); is($db->parse_boolean('no'), 0, 'parse_boolean (no)'); is($db->parse_boolean('0'), 0, 'parse_boolean (0)'); is($db->parse_boolean('FALSE'), 'FALSE', 'parse_boolean (FALSE)'); ok(!$db->validate_boolean_keyword('Foo(Bar)'), 'validate_boolean_keyword (Foo(Bar))'); $db->keyword_function_calls(1); is($db->parse_boolean('Foo(Bar)'), 'Foo(Bar)', 'parse_boolean (Foo(Bar))'); $db->keyword_function_calls(0); foreach my $name (qw(date datetime time timestamp)) { my $method = "validate_${name}_keyword"; ok(!$db->$method('Foo(Bar)'), "$method (Foo(Bar)) 1"); $db->keyword_function_calls(1); ok($db->$method('Foo(Bar)'), "$method (Foo(Bar)) 2"); $db->keyword_function_calls(0); foreach my $value (qw(current_date current_time current_time() current_time(1) current_timestamp current_timestamp() current_timestamp(2) localtime localtime() localtime(3) localtimestamp localtimestamp() localtimestamp(4) now now() timeofday())) { my $new_value = $value; my $i = int(rand(length($new_value) - 3)); # 3 = 1 + 2 (for possible parens) substr($new_value, $i, 1) = uc substr($new_value, $i, 1); ok($db->$method($new_value), "$method ($new_value)"); } } # Interval values isa_ok($db->parse_interval('00:00:00'), 'DateTime::Duration'); my @Intervals = ( '+0::' => '@ 0', '-0:1:' => '@ -1 minutes', '2:' => '@ 120 minutes', '1 D' => '@ 1 days', '-1 d 2 s' => '@ -1 days 2 seconds', '-1 y 3 h -57 M 4 s' => '@ -12 months 123 minutes 4 seconds', '-1 y 2 mons 3 d' => '@ -10 months 3 days', '-1 y 2 mons -3 d' => '@ -10 months -3 days', '5 h -208 m -495 s' => '@ 83 minutes 45 seconds', '-208 m -495 s' => '@ -216 minutes -15 seconds', '5 h 208 m 495 s' => '@ 516 minutes 15 seconds', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '@ 14813 months 6 days 428 minutes 9 seconds', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '@ -14813 months -6 days -428 minutes -9 seconds', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '@ 14813 months 6 days 428 minutes 9 seconds', '1 mil -1 d ago' => '@ -12000 months 1 days', '1 mil ago -1 d ago' => '@ -12000 months 1 days', ); my %Alt_Intervals = ( '+0::' => '', '-0:1:' => '-00:01:00', '2:' => '02:00:00', '1 D' => '1 day', '-1 d 2 s' => '-1 days +00:00:02', '-1 y 3 h -57 M 4 s' => '-1 years +02:03:04', '-1 y 2 mons 3 d' => '-10 mons +3 days', '-1 y 2 mons -3 d' => '-10 mons -3 days', '5 h -208 m -495 s' => '01:23:45', '-208 m -495 s' => '-03:36:15', '5 h 208 m 495 s' => '08:36:15', ':' => undef, '::' => undef, '123:456:' => undef, '1:-2:3' => undef, '1:2:-3' => undef, '1 h 1:1:1' => undef, '1 d 2 d' => undef, '1: 2:' => undef, '1 s 2:' => undef, '1 ys 2 h 3 m 4 s' => undef, '1 y s 2 h 3 m 4 s' => undef, '1 ago' => undef, '1s ago' => undef, '1 s agos' => undef, '1 m ago ago 1 s' => undef, '1 m ago1 s' => undef, '1 m1 s' => undef, '1 mil 2 c 3 dec 4 y 5 mon 1 w -1 d 7 h 8 m 9 s' => '1234 years 5 mons 6 days 07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s' => '-1234 years -5 mons -6 days -07:08:09', '-1 mil -2 c -3 dec -4 y -5 mon -1 w 1 d -7 h -8 m -9 s ago' => '1234 years 5 mons 6 days 07:08:09', '1 mils 2 cents 3 decs 4 years 5 mons 1 weeks -1 days 7 hours 8 mins 9 secs' => '1234 years 5 mons 6 days 07:08:09', '1 millenniums 2 centuries 3 decades 4 years 5 months 1 weeks -1 days 7 hours 8 minutes 9 seconds' => '1234 years 5 mons 6 days 07:08:09', '1 mil -1 d ago' => '-1000 years +1 day', '1 mil ago -1 d ago' => '-1000 years +1 day', ); my $i = 0; while($i < @Intervals) { my($val, $formatted) = ($Intervals[$i], $Intervals[$i + 1]); $i += 2; my $d = $db->parse_interval($val, 'preserve'); is($db->format_interval($d), $formatted, "parse_interval ($val)"); my $alt_d = $db->parse_interval($Alt_Intervals{$val}, 'preserve'); ok((!defined $d && !defined $alt_d) || DateTime::Duration->compare($d, $alt_d) == 0, "parse_interval alt check $i"); } $db->keyword_function_calls(1); is($db->parse_interval('foo()'), 'foo()', 'parse_interval (foo())'); $db->keyword_function_calls(0); my $d = $db->parse_interval('1 year 0.000003 seconds'); is($d->nanoseconds, 3000, 'nanoseconds 1'); is($db->format_interval($d), '@ 12 months 0.000003 seconds', 'nanoseconds 2'); # Time vaues my $tc; ok($tc = $db->parse_time('12:34:56.123456789'), 'parse time 12:34:56.123456789'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789'); ok($tc = $db->parse_time('12:34:56.123456789 pm'), 'parse time 12:34:56.123456789 pm'); is($tc->as_string, '12:34:56.123456789', 'check time 12:34:56.123456789 pm'); is($db->format_time($tc), '12:34:56.123456789', 'format time 12:34:56.123456789 pm'); ok($tc = $db->parse_time('12:34:56. A.m.'), 'parse time 12:34:56. A.m.'); is($tc->as_string, '00:34:56', 'check time 12:34:56 am'); is($db->format_time($tc), '00:34:56', 'format time 12:34:56 am'); ok($tc = $db->parse_time('12:34:56 pm'), 'parse time 12:34:56 pm'); is($tc->as_string, '12:34:56', 'check time 12:34:56 pm'); is($db->format_time($tc), '12:34:56', 'format time 12:34:56 pm'); ok($tc = $db->parse_time('2:34:56 pm'), 'parse time 2:34:56 pm'); is($tc->as_string, '14:34:56', 'check time 14:34:56 pm'); is($db->format_time($tc), '14:34:56', 'format time 14:34:56 pm'); ok($tc = $db->parse_time('2:34 pm'), 'parse time 2:34 pm'); is($tc->as_string, '14:34:00', 'check time 2:34 pm'); is($db->format_time($tc), '14:34:00', 'format time 2:34 pm'); ok($tc = $db->parse_time('2 pm'), 'parse time 2 pm'); is($tc->as_string, '14:00:00', 'check time 2 pm'); is($db->format_time($tc), '14:00:00', 'format time 2 pm'); ok($tc = $db->parse_time('3pm'), 'parse time 3pm'); is($tc->as_string, '15:00:00', 'check time 3pm'); is($db->format_time($tc), '15:00:00', 'format time 3pm'); ok($tc = $db->parse_time('4 p.M.'), 'parse time 4 p.M.'); is($tc->as_string, '16:00:00', 'check time 4 p.M.'); is($db->format_time($tc), '16:00:00', 'format time 4 p.M.'); ok($tc = $db->parse_time('24:00:00'), 'parse time 24:00:00'); is($tc->as_string, '24:00:00', 'check time 24:00:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00'); ok($tc = $db->parse_time('24:00:00 PM'), 'parse time 24:00:00 PM'); is($tc->as_string, '24:00:00', 'check time 24:00:00 PM'); is($db->format_time($tc), '24:00:00', 'format time 24:00:00 PM'); ok($tc = $db->parse_time('24:00'), 'parse time 24:00'); is($tc->as_string, '24:00:00', 'check time 24:00'); is($db->format_time($tc), '24:00:00', 'format time 24:00'); ok(!defined $db->parse_time('24:00:00.000000001'), 'parse time fail 24:00:00.000000001'); ok(!defined $db->parse_time('24:00:01'), 'parse time fail 24:00:01'); ok(!defined $db->parse_time('24:01'), 'parse time fail 24:01'); SKIP: { unless(have_db('pg')) { skip('pg tests', 47); } eval { $db->connect }; skip("Could not connect to db 'test', 'pg' - $@", 43) if($@); my $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'pg', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56.123456789', 'floating')), '2002-12-31 12:34:56.123456789', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.12345', 'floating')), '2002-12-31 12:34:56.123450000', "format_timestamp() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); $db->server_time_zone('UTC'); is($db->format_date(parse_date('12/31/2002', 'UTC')), '2002-12-31', "format_date()"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'UTC')), '2002-12-31 12:34:56+0000', "format_datetime()"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56')), '2002-12-31 12:34:56', "format_timestamp()"); is($db->format_datetime(parse_date('12/31/2002 12:34:56')), '2002-12-31 12:34:56', "format_datetime()"); is($db->parse_date('12-31-2002'), parse_date('12/31/2002', 'UTC'), "parse_date()"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_datetime()"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_timestamp()"); like($db->parse_timestamp_with_time_zone('2002-12-31 12:34:56-05')->time_zone->name, qr/^-0*50*$/, "parse_timestamp_with_time_zone()"); #is($db->parse_time('12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC')->strftime('%H:%M:%S'), "parse_time()"); $db->european_dates(1); is($db->parse_date('31-12-2002'), parse_date('12/31/2002', 'UTC'), "parse_date() european"); is($db->parse_datetime('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_datetime() european"); is($db->parse_timestamp('2002-12-31 12:34:56'), parse_date('12/31/2002 12:34:56', 'UTC'), "parse_timestamp() european"); is($db->format_bitfield($db->parse_bitfield('1010')), q(1010), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(1010), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(0010), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(1010), "format_bitfield() 4"); my $str = $db->format_array([ undef, 'a' .. 'c' ]); is($str, '{NULL,"a","b","c"}', 'format_array() 1.0'); $str = $db->format_array([ 'a' .. 'c' ]); is($str, '{"a","b","c"}', 'format_array() 2'); my $ar = $db->parse_array('[-3:3]={1,2,3}'); ok(ref $ar eq 'ARRAY' && @$ar == 3 && $ar->[0] eq '1' && $ar->[1] eq '2' && $ar->[2] eq '3', 'parse_array() 1'); $ar = $db->parse_array('{NULL,"a","b"}'); ok(ref $ar eq 'ARRAY' && !defined $ar->[0] && $ar->[1] eq 'a' && $ar->[2] eq 'b', 'parse_array() 2'); $ar = $db->parse_array('{"a",NULL}'); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && !defined $ar->[1], 'parse_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] eq 'a' && $ar->[1] eq 'b' && $ar->[2] eq 'c', 'parse_array() 4'); $str = $db->format_array($ar); is($str, '{"a","b","c"}', 'format_array() 2'); $str = $db->format_array([ 1, -2, 3.5 ]); is($str, '{1,-2,3.5}', 'format_array() 3'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 2'); $str = $db->format_array($ar); is($str, '{1,-2,3.5}', 'format_array() 4'); $str = $db->format_array(1, -2, 3.5); is($str, '{1,-2,3.5}', 'format_array() 5'); $ar = $db->parse_array($str); ok(ref $ar eq 'ARRAY' && $ar->[0] == 1 && $ar->[1] == -2 && $ar->[2] == 3.5, 'parse_array() 3'); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); eval { $db->sequence_name(table => 'foo') }; ok($@, 'auto_sequence_name() 1'); eval { $db->sequence_name(column => 'bar') }; ok($@, 'auto_sequence_name() 2'); is($db->auto_sequence_name(table => 'foo.goo', column => 'bar'), 'foo.goo_bar_seq', 'auto_sequence_name() 3'); my $dbh_copy = $db->retain_dbh; $db->disconnect; } (my $version = $DBI::VERSION) =~ s/_//g; if(have_db('pg') && $version >= 1.24) { my $x = 0; my $handler = sub { $x++ }; My::DB2->register_db( type => 'error_handler', driver => 'pg', database => 'test', host => 'localhost', print_error => 0, raise_error => 1, handle_error => $handler, ); $db = My::DB2->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); is($db->dbh->{'HandleError'}, $handler, 'HandleError 1'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { my $sth = $db->dbh->prepare('select nonesuch from ?'); $sth->execute; }; is($x, 2, 'handle_error 5'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 10) } } Rose-DB-0.777/t/subclass-sqlite.t000644 000765 000024 00000014747 12502134373 016615 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; BEGIN { $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} = 1 } use Rose::DateTime::Util qw(parse_date); BEGIN { require Test::More; require 't/test-lib.pl'; if(have_db('sqlite_admin')) { Test::More->import(tests => 60); } else { Test::More->import(skip_all => 'DBD::SQLite unavailable or broken'); } } use_ok('Rose::DB'); My::DB2->default_domain('test'); My::DB2->default_type('sqlite_admin'); is(My::DB2->default_keyword_function_calls, 1, 'default_keyword_function_calls 2'); my $db = My::DB2->new(); is($db->keyword_function_calls, 1, 'keyword_function_calls 1'); My::DB2->default_keyword_function_calls(0); $db->keyword_function_calls(0); ok(ref $db && $db->isa('Rose::DB'), 'new()'); my $dbh; eval { $dbh = $db->dbh }; SKIP: { skip("Could not connect to db - $@", 9) if($@); ok($dbh, 'dbh() 1'); ok($db->has_dbh, 'has_dbh() 1'); my $db2 = My::DB2->new(); $db2->dbh($dbh); foreach my $field (qw(dsn driver database host port username password)) { is($db2->$field() || '', $db->$field() || '', "$field()"); } $db->disconnect; $db2->disconnect; } $db = My::DB2->new(); ok(ref $db && $db->isa('Rose::DB'), "new()"); $db->init_db_info; ok($db->supports_limit_with_offset, 'supports_limit_with_offset'); my @letters = ('a' .. 'z', 'A' .. 'Z', 0 .. 9); my $rand; $rand .= $letters[int rand(@letters)] for(1 .. int(rand(20))); $rand = 'default' unless(defined $rand); # got under here once! ok(!$db->validate_timestamp_keyword($rand), "validate_timestamp_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_timestamp('Foo(Bar)'), 'Foo(Bar)', 'format_timestamp (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_datetime_keyword($rand), "validate_datetime_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_datetime('Foo(Bar)'), 'Foo(Bar)', 'format_datetime (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_date_keyword($rand), "validate_date_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_date('Foo(Bar)'), 'Foo(Bar)', 'format_date (Foo(Bar))'); $db->keyword_function_calls(0); ok(!$db->validate_time_keyword($rand), "validate_time_keyword ($rand)"); $db->keyword_function_calls(1); is($db->format_time('Foo(Bar)'), 'Foo(Bar)', 'format_time (Foo(Bar))'); $db->keyword_function_calls(0); is($db->format_array([ 'a', 'b' ]), q({"a","b"}), 'format_array() 1'); is($db->format_array('a', 'b'), q({"a","b"}), 'format_array() 2'); eval { $db->format_array('x' x 300) }; ok($@, 'format_array() 3'); my $a = $db->parse_array(q({"a","b","\\""})); ok(@$a == 3 && $a->[0] eq 'a' && $a->[1] eq 'b' && $a->[2] eq '"', 'parse_array() 1'); SKIP: { eval { $db->connect }; skip("Could not connect to db 'test', 'sqlite' - $@", 18) if($@); $dbh = $db->dbh; is($db->domain, 'test', "domain()"); is($db->type, 'sqlite_admin', "type()"); is($db->print_error, $dbh->{'PrintError'}, 'print_error() 2'); is($db->print_error, $db->connect_option('PrintError'), 'print_error() 3'); is($db->null_date, '0000-00-00', "null_date()"); is($db->null_datetime, '0000-00-00 00:00:00', "null_datetime()"); is($db->format_date(parse_date('12/31/2002', 'floating')), '2002-12-31', "format_date() floating"); is($db->format_datetime(parse_date('12/31/2002 12:34:56', 'floating')), '2002-12-31 12:34:56', "format_datetime() floating"); is($db->format_timestamp(parse_date('12/31/2002 12:34:56.123456789', 'floating')), '2002-12-31 12:34:56.123456789', "format_timestamp() floating"); #is($db->format_time(parse_date('12/31/2002 12:34:56', 'floating')), '12:34:56', "format_time() floating"); is($db->format_bitfield($db->parse_bitfield('1010')), q(b'1010'), "format_bitfield() 1"); is($db->format_bitfield($db->parse_bitfield(q(B'1010'))), q(b'1010'), "format_bitfield() 2"); is($db->format_bitfield($db->parse_bitfield(2), 4), q(b'0010'), "format_bitfield() 3"); is($db->format_bitfield($db->parse_bitfield('0xA'), 4), q(b'1010'), "format_bitfield() 4"); #is($db->autocommit + 0, $dbh->{'AutoCommit'} + 0, 'autocommit() 1'); $db->autocommit(1); is($db->autocommit + 0, 1, 'autocommit() 2'); is($dbh->{'AutoCommit'} + 0, 1, 'autocommit() 3'); $db->autocommit(0); is($db->autocommit + 0, 0, 'autocommit() 4'); is($dbh->{'AutoCommit'} + 0, 0, 'autocommit() 5'); my $dbh_copy = $db->retain_dbh; $db->disconnect; if($db->isa('My::DB2')) { $My::DB2::Called{'init_dbh'} = 0; $db = My::DB2->new('sqlite'); $db->dbh; is($My::DB2::Called{'init_dbh'}, 1, 'SUPER:: from driver'); } else { SKIP: { skip('SUPER:: from driver tests', 1) } } } $db->dsn('dbi:SQLite:dbname=dbfoo'); #ok(!defined($db->database) || $db->database eq 'dbfoo', 'dsn() 1'); #ok(!defined($db->host) || $db->host eq 'hfoo', 'dsn() 2'); #ok(!defined($db->port) || $db->port eq 'port', 'dsn() 3'); eval { $db->dsn('dbi:Pg:dbname=dbfoo') }; ok($@ || $DBI::VERSION < 1.43, 'dsn() driver change'); My::DB2->register_db( domain => My::DB2->default_domain, type => 'nonesuch', driver => 'SQLITE', database => '/tmp/rdbo_does_not_exist.db', auto_create => 0, ); if((! -e '/tmp/rdbo_does_not_exist.db') || unlink('/tmp/rdbo_does_not_exist.db')) { $db = My::DB2->new('nonesuch'); eval { $db->connect }; ok($@ =~ /^Refus/, 'nonesuch database'); } else { ok(1, "could not unlink /tmp/rdbo_does_not_exist.db - $!"); } (my $version = $DBI::VERSION) =~ s/_//g; if($version >= 1.24) { my $x = 0; my $handler = sub { $x++ }; My::DB2->register_db( type => 'error_handler', driver => 'sqlite', print_error => 0, raise_error => 1, handle_error => $handler, sqlite_unicode => 1, ); $db = My::DB2->new('error_handler'); ok($db->raise_error, 'raise_error 1'); ok(!$db->print_error, 'print_error 1'); is($db->handle_error, $handler, 'handle_error 1'); $db->connect; ok($db->raise_error, 'raise_error 2'); ok(!$db->print_error, 'print_error 2'); is($db->handle_error, $handler, 'handle_error 2'); eval { $db->dbh->prepare('select nonesuch from ?') }; ok($@, 'handle_error 3'); is($x, 1, 'handle_error 4'); eval { $db->dbh->prepare('select nonesuch from ?') }; is($x, 2, 'handle_error 5'); ok($db->sqlite_unicode, 'sqlite_unicode 1'); ok($db->dbh->{'sqlite_unicode'}, 'sqlite_unicode 2'); $db->sqlite_unicode(0); ok(!$db->sqlite_unicode, 'sqlite_unicode 3'); ok(!$db->dbh->{'sqlite_unicode'}, 'sqlite_unicode 4'); } else { SKIP: { skip("HandleError tests (DBI $DBI::VERSION)", 13) } } Rose-DB-0.777/t/subclass-trx.t000755 000765 000024 00000031577 12502134373 016134 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 78; BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } our($HAVE_PG, $HAVE_ORACLE, $HAVE_MYSQL, $HAVE_INFORMIX); My::DB2->default_domain('test'); # # PostgreSQL # SKIP: foreach my $db_type ('pg') { skip("PostgreSQL tests", 24) unless($HAVE_PG); My::DB2->default_type($db_type); my $db = My::DB2->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (2, 'b'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (1, 'a', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (2, 'b', 2))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); FAIL_COMMIT: { local $db->dbh->{'PrintError'} = 0; ok($db->begin_work, "begin_work() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 3))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 4))); ok(!defined $db->commit && $db->error, "commit() 2 - $db_type"); } ok($db->rollback, "rollback() 1 - $db_type"); SKIP: { my $version = $DBD::Pg::VERSION; $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("$1.%03d%03d", $2, $3)/e; # lame conversion of three-part version number # This broke in DBD::Pg 1.47, and 1.44-6 are broken in other ways # so only run these tests with 1.43 or earlier, or 1.48 or later. skip('DBD::Pg 1.43-7 bug?', 7) if($version > 1.43 && $version < 1.48); ok($db->begin_work, "begin_work() 3 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); ok($db->rollback, "rollback() 2 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); is($db->do_transaction(sub { die bless { msg => 'Test' }, 'My::Exception'; }), undef, "do_transaction() exception 1 - $db_type"); is(ref $db->error, 'My::Exception', "do_transaction() exception 1 - $db_type"); } $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # Oracle # SKIP: foreach my $db_type ('oracle') { skip("Oracle tests", 22) unless($HAVE_ORACLE); My::DB2->default_type($db_type); my $db = My::DB2->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (2, 'b'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (1, 'a', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (2, 'b', 2))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); FAIL_COMMIT: { local $db->dbh->{'PrintError'} = 0; ok($db->begin_work, "begin_work() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 3))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 4))); ok(!defined $db->commit && $db->error, "commit() 2 - $db_type"); } ok($db->rollback, "rollback() 1 - $db_type"); SKIP: { ok($db->begin_work, "begin_work() 3 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); ok($db->rollback, "rollback() 2 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); } $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # MySQL # SKIP: foreach my $db_type ('mysql') { skip("MySQL tests", 14) unless($HAVE_MYSQL); My::DB2->default_type($db_type); my $db = My::DB2->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (2, 'b'))); ok($db->commit, "commit() 1 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # Informix # SKIP: foreach my $db_type ('informix') { skip("Informix tests", 17) unless($HAVE_INFORMIX); My::DB2->default_type($db_type); my $db = My::DB2->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (2, 'b'))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } BEGIN { # # PostgreSQL # my $dbh; eval { $dbh = My::DB2->new('pg_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { our $HAVE_PG = 1; # Drop existing table and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test_other ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL, fid INT NOT NULL REFERENCES rose_db_test_other (id) INITIALLY DEFERRED ) EOF $dbh->disconnect; } # # Oracle # eval { $dbh = My::DB2->new('oracle_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { our $HAVE_ORACLE = 1; # Drop existing table and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test_other ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL, fid INT NOT NULL REFERENCES rose_db_test_other (id) INITIALLY DEFERRED ) EOF $dbh->disconnect; } # # MySQL # eval { $dbh = My::DB2->new('mysql_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { our $HAVE_MYSQL = 1; # Drop existing table, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->disconnect; } # # Informix # eval { $dbh = My::DB2->new('informix_admin')->retain_dbh() or die My::DB2->error; }; if(!$@ && $dbh) { our $HAVE_INFORMIX = 1; # Drop existing table, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->disconnect; } } END { # Delete test table if($HAVE_PG) { # PostgreSQL my $dbh = My::DB2->new('pg_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); $dbh->disconnect; } if($HAVE_ORACLE) { # Oracle my $dbh = My::DB2->new('oracle_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); $dbh->disconnect; } if($HAVE_MYSQL) { # MySQL my $dbh = My::DB2->new('mysql_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->disconnect; } if($HAVE_INFORMIX) { # Informix my $dbh = My::DB2->new('informix_admin')->retain_dbh() or die My::DB2->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->disconnect; } } Rose-DB-0.777/t/subclass.t000755 000765 000024 00000003534 12502134373 015311 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 13; BEGIN { use_ok('Rose::DB'); require 't/test-lib.pl'; # Pg My::DB2->register_db( domain => 'default', type => 'pg', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', ); # Oracle My::DB2->register_db( domain => 'default', type => 'oracle', driver => 'oracle', database => 'test', host => 'localhost', username => '', password => '', ); # MySQL My::DB2->register_db( domain => 'default', type => 'mysql', driver => 'mysql', database => 'test', host => 'localhost', username => 'root', ); # Informix My::DB2->register_db( domain => 'test', type => 'informix', driver => 'Informix', database => 'test@test', ); } my $db = My::DB2->new(domain => 'test', type => 'pg'); ok($db->isa('My::DB2::Pg'), 'My::DB2::Pg 1'); is($db->subclass_special_pg, 'PG', 'My::DB2::Pg 2'); $db = My::DB2->new(domain => 'test', type => 'oracle'); ok($db->isa('My::DB2::Oracle'), 'My::DB2::Oracle 1'); is($db->subclass_special_oracle, 'ORACLE', 'My::DB2::Oracle 2'); $db = My::DB2->new(domain => 'test', type => 'mysql'); ok($db->isa('My::DB2::MySQL'), 'My::DB2::MySQL 1'); is($db->subclass_special_mysql, 'MYSQL', 'My::DB2::MySQL 2'); $db = My::DB2->new(domain => 'test', type => 'informix'); ok($db->isa('My::DB2::Informix'), 'My::DB2::Informix 1'); is($db->subclass_special_informix, 'INFORMIX', 'My::DB2::Informix 2'); eval { $db = My::DBReg->new(domain => 'test', type => 'mysql') }; ok($@, 'My::DBReg no such db'); $db = My::DBReg->new(domain => 'test', type => 'pg_sub'); ok($db->isa('My::DBReg'), 'My::DBReg isa My::DBReg'); ok($db->isa('Rose::DB'), 'My::DBReg isa Rose::DB'); ok($db->isa('Rose::DB::Pg'), 'My::DBReg isa Rose::DB::Pg'); Rose-DB-0.777/t/test-lib.pl000755 000765 000024 00000016521 12502134373 015365 0ustar00johnstaff000000 000000 #!/usr/bin/perl use strict; use FindBin qw($Bin); use Rose::DB; BEGIN { Rose::DB->default_domain('test'); # # PostgreSQL # # Main Rose::DB->register_db( domain => 'test', type => 'pg', driver => 'pg', database => 'test', host => 'localhost', username => 'postgres', password => '', post_connect_sql => [ 'SET default_transaction_isolation TO "read committed"', ], ); # Private schema Rose::DB->register_db( domain => 'test', type => 'pg_with_schema', schema => 'rose_db_object_private', driver => 'pg', database => 'test', host => 'localhost', username => 'postgres', password => '', post_connect_sql => [ 'SET default_transaction_isolation TO "read committed"', ], ); # Admin Rose::DB->register_db( domain => 'test', type => 'pg_admin', driver => 'pg', database => 'test', host => 'localhost', username => 'postgres', password => '', post_connect_sql => [ 'SET default_transaction_isolation TO "read committed"', ], ); # # Oracle # # Main Rose::DB->register_db( domain => 'test', type => 'oracle', driver => 'oracle', database => 'test', host => 'localhost', username => '', password => '', post_connect_sql => [ "alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SS'", ], ); # Admin Rose::DB->register_db( domain => 'test', type => 'oracle_admin', driver => 'oracle', database => 'test', host => 'localhost', username => '', password => '', post_connect_sql => [ "alter session set nls_timestamp_format = 'YYYY-MM-DD HH24:MI:SS'", ], ); # # MySQL # # Main Rose::DB->register_db( domain => 'test', type => 'mysql', driver => 'mysql', database => 'test', host => 'localhost', username => 'root', password => '' ); # Admin Rose::DB->register_db( domain => 'test', type => 'mysql_admin', driver => 'mysql', database => 'test', host => 'localhost', username => 'root', password => '' ); # # Informix # # Main Rose::DB->register_db( domain => 'test', type => 'informix', driver => 'Informix', database => 'test@test', connect_options => { AutoCommit => 1, ((rand() < 0.5) ? (FetchHashKeyName => 'NAME_lc') : ()), }, post_connect_sql => [ 'SET LOCK MODE TO WAIT 60', 'SET ISOLATION TO DIRTY READ', ], ); # Admin Rose::DB->register_db( domain => 'test', type => 'informix_admin', driver => 'Informix', database => 'test@test', connect_options => { AutoCommit => 1, ((rand() < 0.5) ? (FetchHashKeyName => 'NAME_lc') : ()), }, post_connect_sql => [ 'SET LOCK MODE TO WAIT 60', 'SET ISOLATION TO DIRTY READ', ], ); # Just test that the catalog attribute works. No supported DBs use it. Rose::DB->register_db( domain => 'catalog_test', type => 'catalog_test', driver => 'pg', database => 'test', catalog => 'somecatalog', schema => 'someschema', host => 'localhost', username => 'postgres', password => '', ); # # SQLite # eval { local $^W = 0; require DBD::SQLite; }; (my $version = $DBD::SQLite::VERSION || 0) =~ s/_//g; unless($ENV{'RDBO_NO_SQLITE'} || $version < 1.11 || ($version >= 1.13 && $version < 1.1902)) { # Main Rose::DB->register_db( domain => 'test', type => 'sqlite', driver => 'sqlite', database => "$Bin/sqlite.db", auto_create => 0, connect_options => { AutoCommit => 1, ((rand() < 0.5) ? (FetchHashKeyName => 'NAME_lc') : ()), }, post_connect_sql => [ 'PRAGMA synchronous = OFF', 'PRAGMA temp_store = MEMORY', ], ); # Admin Rose::DB->register_db( domain => 'test', type => 'sqlite_admin', driver => 'sqlite', database => "$Bin/sqlite.db", connect_options => { AutoCommit => 1, ((rand() < 0.5) ? (FetchHashKeyName => 'NAME_lc') : ()), }, post_connect_sql => [ 'PRAGMA synchronous = OFF', 'PRAGMA temp_store = MEMORY', ], ); } my @types = qw(oracle oracle_admin pg pg_with_schema pg_admin mysql mysql_admin informix informix_admin sqlite sqlite_admin); unless($Rose::DB::Object::Test::NoDefaults) { foreach my $db_type (qw(ORACLE PG MYSQL INFORMIX)) { if(my $dsn = $ENV{"RDBO_${db_type}_DSN"}) { foreach my $type (grep { /^$db_type(?:_|$)/i } @types) { Rose::DB->modify_db(domain => 'test', type => $type, dsn => $dsn); } } if(my $user = $ENV{"RDBO_${db_type}_USER"}) { foreach my $type (grep { /^$db_type(?:_|$)/i } @types) { Rose::DB->modify_db(domain => 'test', type => $type, username => $user); } } if(my $user = $ENV{"RDBO_${db_type}_PASS"}) { foreach my $type (grep { /^$db_type(?:_|$)/i } @types) { Rose::DB->modify_db(domain => 'test', type => $type, password => $user); } } } } } Rose::DB->load_driver_classes(qw(ORAcle pg MySQL informix SQLItE)); # Subclass testing package My::DB; @My::DB::ISA = qw(Rose::DB); package My::DB2; @My::DB2::ISA = qw(My::DB); sub init_dbh { my($self) = shift; $My::DB2::Called{'init_dbh'}++; $self->SUPER::init_dbh(@_); } package My::DB2::Oracle; @My::DB2::Oracle::ISA = qw(Rose::DB::Oracle); sub subclass_special_oracle { 'ORACLE' } package My::DB2::Pg; @My::DB2::Pg::ISA = qw(Rose::DB::Pg); sub subclass_special_pg { 'PG' } package My::DB2::MySQL; @My::DB2::MySQL::ISA = qw(Rose::DB::MySQL); sub subclass_special_mysql { 'MYSQL' } package My::DB2::Informix; @My::DB2::Informix::ISA = qw(Rose::DB::Informix); sub subclass_special_informix { 'INFORMIX' } My::DB2->driver_class(Oracle => 'My::DB2::Oracle'); My::DB2->driver_class(Pg => 'My::DB2::Pg'); My::DB2->driver_class(mysql => 'My::DB2::MySQL'); My::DB2->driver_class(Informix => 'My::DB2::Informix'); package My::DB3; @My::DB3::ISA = qw(My::DB2); My::DB3->use_private_registry; package My::DBReg; @My::DBReg::ISA = qw(Rose::DB); My::DBReg->registry(Rose::DB::Registry->new); My::DBReg->register_db( domain => 'test', type => 'pg_sub', driver => 'Pg', database => 'test_sub', host => 'subhost', username => 'subuser'); package main; my %Have_DB; sub get_db { my($type) = shift; if((defined $Have_DB{$type} && !$Have_DB{$type}) || !get_dbh($type)) { return undef; } return Rose::DB->new($type); } sub get_dbh { my($type) = shift; my $dbh; eval { my $db = Rose::DB->new($type); $db->print_error(0); $dbh = $db->retain_dbh or die Rose::DB->error; $db->print_error(1); }; if(!$@ && $dbh) { $Have_DB{$type} = 1; return $dbh; } return $Have_DB{$type} = 0; } sub have_db { my($type) = shift; if($type =~ /^sqlite(?:_admin)$/ && $ENV{'RDBO_NO_SQLITE'}) { return $Have_DB{$type} = 0; } return $Have_DB{$type} = shift if(@_); return $Have_DB{$type} if(exists $Have_DB{$type}); return get_dbh($type) ? 1 : 0; } 1; Rose-DB-0.777/t/trx.t000755 000765 000024 00000031630 12502134373 014305 0ustar00johnstaff000000 000000 #!/usr/bin/perl -w use strict; use Test::More tests => 78; BEGIN { require 't/test-lib.pl'; use_ok('Rose::DB'); } our($HAVE_PG, $HAVE_ORACLE, $HAVE_MYSQL, $HAVE_INFORMIX); Rose::DB->default_domain('test'); # # PostgreSQL # SKIP: foreach my $db_type ('pg') { skip("PostgreSQL tests", 24) unless($HAVE_PG); Rose::DB->default_type($db_type); my $db = Rose::DB->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (2, 'b'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (1, 'a', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (2, 'b', 2))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); FAIL_COMMIT: { local $db->dbh->{'PrintError'} = 0; ok($db->begin_work, "begin_work() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 3))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 4))); ok(!defined $db->commit && $db->error, "commit() 2 - $db_type"); } ok($db->rollback, "rollback() 1 - $db_type"); SKIP: { my $version = $DBD::Pg::VERSION; $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("$1.%03d%03d", $2, $3)/e; # lame conversion of three-part version number # This broke in DBD::Pg 1.47, and 1.44-6 are broken in other ways # so only run these tests with 1.43 or earlier, or 1.48 or later. skip('DBD::Pg 1.43-7 bug?', 7) if($version > 1.43 && $version < 1.48); ok($db->begin_work, "begin_work() 3 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); ok($db->rollback, "rollback() 2 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); is($db->do_transaction(sub { die bless { msg => 'Test' }, 'My::Exception'; }), undef, "do_transaction() exception 1 - $db_type"); is(ref $db->error, 'My::Exception', "do_transaction() exception 1 - $db_type"); } $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # Oracle # SKIP: foreach my $db_type ('oracle') { skip("Oracle tests", 22) unless($HAVE_ORACLE); Rose::DB->default_type($db_type); my $db = Rose::DB->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test_other (id, name) VALUES (2, 'b'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (1, 'a', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (2, 'b', 2))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); FAIL_COMMIT: { local $db->dbh->{'PrintError'} = 0; ok($db->begin_work, "begin_work() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 3))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 4))); ok(!defined $db->commit && $db->error, "commit() 2 - $db_type"); } ok($db->rollback, "rollback() 1 - $db_type"); SKIP: { ok($db->begin_work, "begin_work() 3 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); ok($db->rollback, "rollback() 2 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (3, 'c', 1))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name, fid) VALUES (4, 'd', 2))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); } $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # MySQL # SKIP: foreach my $db_type ('mysql') { skip("MySQL tests", 14) unless($HAVE_MYSQL); Rose::DB->default_type($db_type); my $db = Rose::DB->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (2, 'b'))); ok($db->commit, "commit() 1 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } # # Informix # SKIP: foreach my $db_type ('informix') { skip("Informix tests", 17) unless($HAVE_INFORMIX); Rose::DB->default_type($db_type); my $db = Rose::DB->new; is($db->commit, 0, "commit() no-op - $db_type"); is($db->rollback, 0, "commit() no-op - $db_type"); is($db->autocommit, 1, "autocommit() 1 - $db_type"); is($db->raise_error, 1, "raise_error() 1 - $db_type"); is($db->print_error, 1, "print_error() 1 - $db_type"); is($db->in_transaction, undef, "in_transaction() 1 - $db_type"); ok($db->begin_work, "begin_work() 1 - $db_type"); is($db->in_transaction, 1, "in_transaction() 2 - $db_type"); ok(!$db->autocommit, "autocommit() 2 - $db_type"); is($db->raise_error, 1, "raise_error() 2 - $db_type"); is($db->print_error, 1, "print_error() 2 - $db_type"); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (1, 'a'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (2, 'b'))); ok($db->commit, "commit() 1 - $db_type"); is($db->in_transaction, 0, "in_transaction() 3 - $db_type"); ok($db->do_transaction(sub { $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 1 - $db_type"); ok(!defined $db->do_transaction(sub { local $db->dbh->{'PrintError'} = 0; $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (3, 'c'))); $db->dbh->do(q(INSERT INTO rose_db_test (id, name) VALUES (4, 'd'))); }), "do_transaction() 2 - $db_type"); my $sth = $db->dbh->prepare('SELECT COUNT(*) FROM rose_db_test'); $sth->execute; my $count = $sth->fetchrow_array; is($count, 4, "do_transaction() 3 - $db_type"); $db->dbh->{'AutoCommit'} = 1; is($db->rollback, 1, "rollback with AutoCommit set - $db_type"); } BEGIN { # # PostgreSQL # my $dbh; eval { $dbh = Rose::DB->new('pg_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { our $HAVE_PG = 1; # Drop existing table and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test_other ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL, fid INT NOT NULL REFERENCES rose_db_test_other (id) INITIALLY DEFERRED ) EOF $dbh->disconnect; } # # Oracle # eval { $dbh = Rose::DB->new('oracle_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { our $HAVE_ORACLE = 1; # Drop existing table and create schema, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test_other ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT NOT NULL PRIMARY KEY, name VARCHAR(32) NOT NULL, fid INT NOT NULL REFERENCES rose_db_test_other (id) INITIALLY DEFERRED ) EOF $dbh->disconnect; } # # MySQL # eval { $dbh = Rose::DB->new('mysql_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { our $HAVE_MYSQL = 1; # Drop existing table, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT UNSIGNED AUTO_INCREMENT PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->disconnect; } # # Informix # eval { $dbh = Rose::DB->new('informix_admin')->retain_dbh() or die Rose::DB->error; }; if(!$@ && $dbh) { our $HAVE_INFORMIX = 1; # Drop existing table, ignoring errors { local $dbh->{'RaiseError'} = 0; local $dbh->{'PrintError'} = 0; $dbh->do('DROP TABLE rose_db_test'); } $dbh->do(<<"EOF"); CREATE TABLE rose_db_test ( id INT PRIMARY KEY, name VARCHAR(32) NOT NULL ) EOF $dbh->disconnect; } } END { # Delete test table if($HAVE_PG) { # PostgreSQL my $dbh = Rose::DB->new('pg_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); $dbh->disconnect; } if($HAVE_ORACLE) { # Oracle my $dbh = Rose::DB->new('oracle_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->do('DROP TABLE rose_db_test_other'); $dbh->disconnect; } if($HAVE_MYSQL) { # MySQL my $dbh = Rose::DB->new('mysql_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->disconnect; } if($HAVE_INFORMIX) { # Informix my $dbh = Rose::DB->new('informix_admin')->retain_dbh() or die Rose::DB->error; $dbh->do('DROP TABLE rose_db_test'); $dbh->disconnect; } } Rose-DB-0.777/t/lib/My/000750 000765 000024 00000000000 12502143063 014417 5ustar00johnstaff000000 000000 Rose-DB-0.777/t/lib/My/DB.pm000644 000765 000024 00000000751 12502134373 015256 0ustar00johnstaff000000 000000 package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); __PACKAGE__->register_db( domain => 'somedomain', type => 'sometype', driver => 'Pg', database => 'test', host => 'localhost', username => 'postgres', password => '', ); __PACKAGE__->register_db( domain => 'otherdomain', type => 'othertype', driver => 'Pg', database => 'test2', host => 'localhost', username => 'postgres', password => '', ); __PACKAGE__->auto_load_fixups; 1; Rose-DB-0.777/t/lib/My/FixUp.pm000644 000765 000024 00000000431 12502134373 016017 0ustar00johnstaff000000 000000 package My::FixUp; sub fixup { My::DB->modify_db(domain => 'otherdomain', type => 'othertype', port => 456); } My::DB->modify_db(domain => 'otherdomain', type => 'othertype', port => 789); 1; Rose-DB-0.777/lib/Rose/000750 000765 000024 00000000000 12502143063 014477 5ustar00johnstaff000000 000000 Rose-DB-0.777/lib/Rose/DB/000750 000765 000024 00000000000 12502143063 014764 5ustar00johnstaff000000 000000 Rose-DB-0.777/lib/Rose/DB.pm000755 000765 000024 00000365134 12502142630 015345 0ustar00johnstaff000000 000000 package Rose::DB; use strict; use DBI; use Carp(); use Clone::PP(); use Bit::Vector::Overload; use SQL::ReservedWords(); use Time::Clock; use Rose::DateTime::Util(); use Rose::DB::Cache; use Rose::DB::Registry; use Rose::DB::Registry::Entry; use Rose::DB::Constants qw(IN_TRANSACTION); use Rose::Object; our @ISA = qw(Rose::Object); our $Error; our $VERSION = '0.777'; our $Debug = 0; # # Class data # use Rose::Class::MakeMethods::Generic ( inheritable_scalar => [ 'default_domain', 'default_type', 'registry', 'max_array_characters', 'max_interval_characters', '_db_cache', 'db_cache_class', 'parent_class', ], inheritable_boolean => [ 'default_keyword_function_calls', ] ); use Rose::Class::MakeMethods::Generic ( inheritable_hash => [ driver_classes => { interface => 'get_set_all' }, _driver_class => { interface => 'get_set', hash_key => 'driver_classes' }, delete_driver_class => { interface => 'delete', hash_key => 'driver_classes' }, default_connect_options => { interface => 'get_set_all', }, default_connect_option => { interface => 'get_set', hash_key => 'default_connect_options' }, delete_connect_option => { interface => 'delete', hash_key => 'default_connect_options' }, ], ); __PACKAGE__->db_cache_class('Rose::DB::Cache'); __PACKAGE__->default_domain('default'); __PACKAGE__->default_type('default'); __PACKAGE__->max_array_characters(255); # Used for array type emulation __PACKAGE__->max_interval_characters(255); # Used for interval type emulation __PACKAGE__->default_keyword_function_calls( defined $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} ? $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} : 0); __PACKAGE__->driver_classes ( mysql => 'Rose::DB::MySQL', pg => 'Rose::DB::Pg', informix => 'Rose::DB::Informix', oracle => 'Rose::DB::Oracle', sqlite => 'Rose::DB::SQLite', generic => 'Rose::DB::Generic', ); __PACKAGE__->default_connect_options ( AutoCommit => 1, RaiseError => 1, PrintError => 1, ChopBlanks => 1, Warn => 0, ); BEGIN { __PACKAGE__->registry(Rose::DB::Registry->new(parent => __PACKAGE__)) } my %Class_Loaded; # Load on demand instead # LOAD_SUBCLASSES: # { # my %seen; # # my $map = __PACKAGE__->driver_classes; # # foreach my $class (values %$map) # { # eval qq(require $class) unless($seen{$class}++); # die "Could not load $class - $@" if($@); # } # } # # Object data # use Rose::Object::MakeMethods::Generic ( 'scalar' => [ qw(dbi_driver username _dbh_refcount id) ], 'boolean' => [ 'auto_create' => { default => 1 }, 'european_dates' => { default => 0 }, ], 'scalar --get_set_init' => [ 'domain', 'type', 'date_handler', 'server_time_zone', 'keyword_function_calls', ], 'array' => [ 'post_connect_sql', 'pre_disconnect_sql', ], 'hash' => [ connect_options => { interface => 'get_set_init' }, ] ); # # Class methods # sub register_db { my $class = shift; # Smuggle parent/caller in with an otherwise nonsensical arrayref arg my $entry = $class->registry->add_entry([ $class ], @_); if($entry) { my $driver = $entry->driver; Carp::confess "No driver found for registry entry $entry" unless(defined $driver); $class->setup_dynamic_class_for_driver($driver); } return $entry; } our %Rebless; sub setup_dynamic_class_for_driver { my($class, $driver) = @_; my $driver_class = $class->driver_class($driver) || $class->driver_class('generic') || Carp::croak "No driver class found for drivers '$driver' or 'generic'"; unless($Rebless{$class,$driver_class}) { no strict 'refs'; unless($Class_Loaded{$driver_class} || @{"${driver_class}::ISA"}) { my $error; TRY: { local $@; eval "require $driver_class"; $error = $@; } Carp::croak "Could not load driver class '$driver_class' - $error" if($error); } $Class_Loaded{$driver_class}++; # Make a new driver class based on the current class my $new_class = $class . '::__RoseDBPrivate__::' . $driver_class; no strict 'refs'; @{"${new_class}::ISA"} = ($driver_class, $class); *{"${new_class}::STORABLE_thaw"} = \&STORABLE_thaw; *{"${new_class}::STORABLE_freeze"} = \&STORABLE_freeze; $new_class->parent_class($class); # Cache result $Rebless{$class,$driver_class} = $new_class; } return $Rebless{$class,$driver_class}; } sub unregister_db { shift->registry->delete_entry(@_) } sub default_implicit_schema { undef } sub registration_schema { undef } sub use_private_registry { $_[0]->registry(Rose::DB::Registry->new(parent => $_[0])) } sub modify_db { my($class, %args) = @_; my $domain = delete $args{'domain'} || $class->default_domain || Carp::croak "Missing domain"; my $type = delete $args{'type'} || $class->default_type || Carp::croak "Missing type"; my $entry = $class->registry->entry(domain => $domain, type => $type) or Carp::croak "No db defined for domain '$domain' and type '$type'"; while(my($key, $val) = each(%args)) { $entry->$key($val); } return $entry; } sub db_exists { my($class) = shift; my %args = (@_ == 1) ? (type => $_[0]) : @_; my $domain = $args{'domain'} || $class->default_domain || Carp::croak "Missing domain"; my $type = $args{'type'} || $class->default_type || Carp::croak "Missing type"; return $class->registry->entry_exists(domain => $domain, type => $type); } sub alias_db { my($class, %args) = @_; my $source = $args{'source'} or Carp::croak "Missing source"; my $src_domain = $source->{'domain'} or Carp::croak "Missing source domain"; my $src_type = $source->{'type'} or Carp::croak "Missing source type"; my $alias = $args{'alias'} or Carp::croak "Missing alias"; my $alias_domain = $alias->{'domain'} or Carp::croak "Missing source domain"; my $alias_type = $alias->{'type'} or Carp::croak "Missing source type"; my $registry = $class->registry; my $entry = $registry->entry(domain => $src_domain, type => $src_type) or Carp::croak "No db defined for domain '$src_domain' and type '$src_type'"; $registry->add_entry(domain => $alias_domain, type => $alias_type, entry => $entry); } sub unregister_domain { shift->registry->delete_domain(@_) } sub driver_class { my($class, $driver) = (shift, lc shift); if(@_) { $class->_driver_class($driver, @_); $class->setup_dynamic_class_for_driver($driver); } return $class->_driver_class($driver); } sub db_cache { my($class) = shift; if(@_) { return $class->_db_cache(@_); } if(my $cache = $class->_db_cache) { return $cache; } my $cache_class = $class->db_cache_class; my $error; TRY: { local $@; eval "use $cache_class"; $error = $@; } die "Could not load db cache class '$cache_class' - $error" if($error); return $class->_db_cache($cache_class->new); } sub use_cache_during_apache_startup { shift->db_cache->use_cache_during_apache_startup(@_); } sub prepare_cache_for_apache_fork { shift->db_cache->prepare_for_apache_fork(@_); } sub new_or_cached { my($class) = shift; @_ = (type => $_[0]) if(@_ == 1); my %args = @_; $args{'domain'} = $class->default_domain unless(exists $args{'domain'}); $args{'type'} = $class->default_type unless(exists $args{'type'}); #$Debug && warn "New or cached db type: $args{'type'}, domain: $args{'domain'}\n"; my $cache = $class->db_cache; if(my $db = $cache->get_db(%args)) { $Debug && warn "$$ $class Returning cached db (", $db->domain, ', ', $db->type, ") $db from ", $cache, "\n"; return $db; } if($Debug) { my $db = $class->new(@_); $Debug && warn "$$ $class Setting cached db $db (", join(', ', map { $args{$_} } qw(domain type)), ") in ", $cache, "\n"; # The set_db() call may refuse to set, so call get_db() to properly # register clean-up handlers, etc., but fall back to the db returned # by set_db() in the case where the db was never cached. $db = $cache->set_db($class->new(@_)); return $cache->get_db(%args) || $db; } else { # The set_db() call may refuse to set, so call get_db() to properly # register clean-up handlers, etc., but fall back to the db returned # by set_db() in the case where the db was never cached. my $db = $cache->set_db($class->new(@_)); return $cache->get_db(%args) || $db; } } sub clear_db_cache { shift->db_cache->clear(@_) } # # Object methods # sub new { my($class) = shift; @_ = (type => $_[0]) if(@_ == 1); my %args = @_; my $allow_empty = $args{'driver'} && !($args{'type'} || $args{'domain'}); my $domain = exists $args{'domain'} ? delete $args{'domain'} : $class->default_domain; my $type = exists $args{'type'} ? delete $args{'type'} : $class->default_type; my $db_info; # I'm being bad here for speed purposes, digging into private hashes instead # of using object methods. I'll fix it when the first person emails me to # complain that I'm breaking their Rose::DB or Rose::DB::Registry[::Entry] # subclass by doing this. Call it "demand-paged programming" :) my $registry = $class->registry->hash; if(exists $registry->{$domain} && exists $registry->{$domain}{$type}) { $db_info = $registry->{$domain}{$type} } elsif(!$allow_empty) { Carp::croak "No database information found for domain '$domain' and ", "type '$type' and no driver type specified in call to ", "$class->new(...)"; } my $driver = $db_info->{'driver'} || $args{'driver'}; Carp::croak "No driver found for domain '$domain' and type '$type'" unless(defined $driver); my $driver_class = $class->driver_class($driver) || $class->driver_class('generic') || Carp::croak "No driver class found for drivers '$driver' or 'generic'"; unless($Class_Loaded{$driver_class}) { $class->load_driver_class($driver_class); } my $self; REBLESS: # Do slightly evil re-blessing magic { # Check cache if(my $new_class = $Rebless{$class,$driver_class}) { $self = bless {}, $new_class; } else { # Make a new driver class based on the current class my $new_class = $class . '::__RoseDBPrivate__::' . $driver_class; no strict 'refs'; @{"${new_class}::ISA"} = ($driver_class, $class); $self = bless {}, $new_class; $new_class->parent_class($class); # Cache result $Rebless{$class,$driver_class} = ref $self; } } $self->class($class); $self->{'id'} = "$domain\0$type"; $self->{'type'} = $type; $self->{'domain'} = $domain; $self->init(@_); $self->init_db_info; return $self; } sub class { my($self) = shift; return $self->{'_origin_class'} = shift if(@_); return $self->{'_origin_class'} || ref $self; } sub init_keyword_function_calls { ref($_[0])->default_keyword_function_calls } # sub init # { # my($self) = shift; # $self->SUPER::init(@_); # $self->init_db_info; # } sub load_driver_class { my($class, $arg) = @_; my $driver_class = $class->driver_class($arg) || $arg; no strict 'refs'; unless(defined ${"${driver_class}::VERSION"}) { my $error; TRY: { local $@; eval "require $driver_class"; $error = $@; } Carp::croak "Could not load driver class '$driver_class' - $error" if($error); } $Class_Loaded{$driver_class}++; } sub driver_class_is_loaded { $Class_Loaded{$_[1]} } sub load_driver_classes { my($class) = shift; my $map = $class->driver_classes; foreach my $arg (@_ ? @_ : keys %$map) { $class->load_driver_class($arg); } return; } sub database { my($self) = shift; if(@_) { $self->{'dsn'} = undef if($self->{'dsn'}); return $self->{'database'} = shift; } return $self->{'database'}; } sub schema { my($self) = shift; if(@_) { $self->{'dsn'} = undef if($self->{'dsn'}); return $self->{'schema'} = shift; } return $self->{'schema'}; } sub catalog { my($self) = shift; if(@_) { $self->{'dsn'} = undef if($self->{'dsn'}); return $self->{'catalog'} = shift; } return $self->{'catalog'}; } sub host { my($self) = shift; if(@_) { $self->{'dsn'} = undef if($self->{'dsn'}); return $self->{'host'} = shift; } return $self->{'host'}; } sub port { my($self) = shift; if(@_) { $self->{'dsn'} = undef if($self->{'dsn'}); return $self->{'port'} = shift; } return $self->{'port'}; } sub database_version { my($self) = shift; return $self->{'database_version'} if(defined $self->{'database_version'}); return $self->{'database_version'} = $self->dbh->get_info(18); # SQL_DBMS_VER } # Use a closure to keep the password from appearing when the # object is dumped using Data::Dumper sub password { my($self) = shift; if(@_) { my $password = shift; $self->{'password_closure'} = sub { $password }; return $password; } return $self->{'password_closure'} ? $self->{'password_closure'}->() : undef; } # These have to "cheat" to get the right values by going through # the real origin class because they may be called after the # re-blessing magic takes place. sub init_domain { shift->{'_origin_class'}->default_domain } sub init_type { shift->{'_origin_class'}->default_type } sub init_date_handler { Rose::DateTime::Format::Generic->new } sub init_server_time_zone { 'floating' } sub init_db_info { my($self, %args) = @_; return 1 if($self->{'dsn'}); my $class = ref $self; my $domain = $self->domain; my $type = $self->type; my $db_info; # I'm being bad here for speed purposes, digging into private hashes instead # of using object methods. I'll fix it when the first person emails me to # complain that I'm breaking their Rose::DB or Rose::DB::Registry[::Entry] # subclass by doing this. Call it "demand-paged programming" :) my $registry = $self->class->registry->hash; if(exists $registry->{$domain} && exists $registry->{$domain}{$type}) { $db_info = $registry->{$domain}{$type} } else { return 1 if($self->{'driver'}); Carp::croak "No database information found for domain '$domain' and type '$type'"; } unless($args{'refresh'} || ($self->{'connect_options_for'}{$domain} && $self->{'connect_options_for'}{$domain}{$type})) { if(my $custom_options = $db_info->{'connect_options'}) { my $options = $self->connect_options; @$options{keys %$custom_options} = values %$custom_options; } $self->{'connect_options_for'} = { $domain => { $type => 1 } }; } $self->driver($db_info->{'driver'}); while(my($field, $value) = each(%$db_info)) { if($field ne 'connect_options' && defined $value && !defined $self->{$field}) { $self->$field($value); } } return 1; } sub init_connect_options { my($class) = ref $_[0]; return Clone::PP::clone(scalar $class->default_connect_options); } sub connect_option { my($self, $param) = (shift, shift); my $options = $self->connect_options; return $options->{$param} = shift if(@_); return $options->{$param}; } sub dsn { my($self) = shift; unless(@_) { return $self->{'dsn'} || $self->build_dsn(%$self); } if(my $dsn = shift) { foreach my $method (qw(database host port)) { $self->$method(undef); } $self->init($self->parse_dsn($dsn)); return $self->{'dsn'} = $dsn; } else { $self->{'dsn'} = undef; return $self->build_dsn(%$self); } } my %DSN_Attr_Method = ( db => 'database', dbname => 'database', user => 'username', hostname => 'host', hostaddr => 'host', sid => 'database', ); sub dsn_attribute_to_db_method { $DSN_Attr_Method{$_[1]} } sub parse_dsn { my($self, $dsn) = @_; my($scheme, $driver, $attr_string, $attr_hash, $driver_dsn); # x DBI->parse_dsn('dbi:mysql:database=test;host=localhost') # 0 'dbi' # 1 'mysql' # 2 undef # 3 undef # 4 'database=test;host=localhost' if(DBI->can('parse_dsn')) { ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn($dsn); } else { ($scheme, $driver, $attr_string, $driver_dsn) = ($dsn =~ /^((?i)dbi) : (\w+) : (?: \( ([^)]+) \) : )? (.*)/x); } my %init = ( dbi_driver => $driver, driver => $driver, ); while($driver_dsn =~ /\G(\w+)=([^;]+)(?:;|$)?/g) { my($name, $value) = ($1, $2); if(my $method = $self->dsn_attribute_to_db_method($name)) { $init{$method} = $value; } elsif($self->can($name)) { $init{$name} = $value; } } unless($init{'database'}) { $init{'database'} = $driver_dsn; } return %init; } sub database_from_dsn { my($self_or_class, $dsn) = @_; my %attrs = $self_or_class->parse_dsn($dsn); return $attrs{'database'}; } sub dbh { my($self) = shift; unless(@_) { if(my $dbh = $self->{'dbh'}) { # If this db connection wasn't created in another process or thread, return it if((!$INC{'threads.pm'} || $dbh->{'private_tid'} == threads->tid) && $dbh->{'private_pid'} == $$) { return $dbh; } # This $dbh wasn't created here, so disable destroy actions, # undef it, and create a new one by falling through to the # init_dbh() call below. $dbh->{'InactiveDestroy'} = 1; $self->{'dbh'} = undef; } return $self->init_dbh; } unless(defined($_[0])) { return $self->{'dbh'} = undef; } $self->driver($_[0]->{'Driver'}{'Name'}); $self->{'_dbh_refcount'}++; return $self->{'dbh'} = $_[0]; } sub driver { if(@_ > 1) { my $driver = lc $_[1]; if(defined $driver && defined $_[0]->{'driver'} && $_[0]->{'driver'} ne $driver) { Carp::croak "Attempt to change driver from '$_[0]->{'driver'}' to ", "'$driver' detected. The driver cannot be changed after ", "object creation."; } return $_[0]->{'driver'} = $driver; } return $_[0]->{'driver'}; } sub retain_dbh { my($self) = shift; my $dbh = $self->dbh or return undef; #$Debug && warn "$self->{'_dbh_refcount'} -> ", ($self->{'_dbh_refcount'} + 1), " $dbh\n"; $self->{'_dbh_refcount'}++; return $dbh; } sub release_dbh { my($self, %args) = @_; my $dbh = $self->{'dbh'} or return 0; if($args{'force'}) { $self->{'_dbh_refcount'} = 0; # Account for possible Apache::DBI magic if(UNIVERSAL::isa($dbh, 'Apache::DBI::db')) { return $dbh->DBI::db::disconnect; # bypass Apache::DBI } else { return $dbh->disconnect; } } #$Debug && warn "$self->{'_dbh_refcount'} -> ", ($self->{'_dbh_refcount'} - 1), " $dbh\n"; $self->{'_dbh_refcount'}--; unless($self->{'_dbh_refcount'} || $self->{'_dbh_has_foreign_owner'}) { if(my $sqls = $self->pre_disconnect_sql) { my $error; TRY: { local $@; eval { foreach my $sql (@$sqls) { $dbh->do($sql) or die "$sql - " . $dbh->errstr; return undef; } }; $error = $@; } if($error) { $self->error("Could not do pre-disconnect SQL: $error"); return undef; } } #$Debug && warn "DISCONNECT $dbh ", join(':', (caller(3))[0,2]), "\n"; return $dbh->disconnect; } #else { $Debug && warn "DISCONNECT NOOP $dbh ", join(':', (caller(2))[0,2]), "\n"; } return 1; } sub dbh_attribute { my($self, $name) = (shift, shift); if(@_) { if(my $dbh = $self->{'dbh'}) { return $self->{'dbh'}{$name} = $self->{'__dbh_attributes'}{$name} = shift; } else { return $self->{'__dbh_attributes'}{$name} = shift; } } if(my $dbh = $self->{'dbh'}) { return $self->{'dbh'}{$name}; } else { return $self->{'__dbh_attributes'}{$name}; } } sub dbh_attribute_boolean { my($self, $name) = (shift, shift); return $self->dbh_attribute($name, (@_ ? ($_[0] ? 1 : 0) : ())); } sub has_dbh { defined shift->{'dbh'} } sub dbi_connect { shift; $Debug && warn "DBI->connect('$_[1]', '$_[2]', ...)\n"; DBI->connect(@_); } use constant DID_PCSQL_KEY => 'private_rose_db_did_post_connect_sql'; sub init_dbh { my($self) = shift; my $options = $self->connect_options; $options->{'private_pid'} = $$; $options->{'private_tid'} = threads->tid if($INC{'threads.pm'}); my $dsn = $self->dsn; $self->{'error'} = undef; $self->{'database_version'} = undef; $self->{'_dbh_refcount'} = 0; $self->{'_dbh_has_foreign_owner'} = undef; my $dbh = $self->dbi_connect($dsn, $self->username, $self->password, $options); unless($dbh) { $self->error("Could not connect to database: $DBI::errstr"); return undef; } if($dbh->{'private_rose_db_inited'}) { # Someone else owns this dbh $self->{'_dbh_has_foreign_owner'} = 1; } else # Only initialize if this is really a new connection { $dbh->{'private_rose_db_inited'} = 1; if($self->{'__dbh_attributes'}) { foreach my $attr (keys %{$self->{'__dbh_attributes'}}) { my $val = $self->dbh_attribute($attr); next unless(defined $val); $dbh->{$attr} = $val; } } if((my $sqls = $self->post_connect_sql) && !$dbh->{DID_PCSQL_KEY()}) { my $error; TRY: { local $@; eval { foreach my $sql (@$sqls) { #$Debug && warn "$dbh DO: $sql\n"; $dbh->do($sql) or die "$sql - " . $dbh->errstr; } }; $error = $@; } if($error) { $self->error("Could not do post-connect SQL: $error"); $dbh->disconnect; return undef; } $dbh->{DID_PCSQL_KEY()} = 1; } } $self->{'_dbh_refcount'} = 1; return $self->{'dbh'} = $dbh; } sub print_error { shift->_dbh_and_connect_option('PrintError', @_) } sub raise_error { shift->_dbh_and_connect_option('RaiseError', @_) } sub autocommit { shift->_dbh_and_connect_option('AutoCommit', @_) } sub handle_error { shift->_dbh_and_connect_option('HandleError', @_) } sub _dbh_and_connect_option { my($self, $param) = (shift, shift); if(@_) { my $val = $_[0] ? 1 : 0; $self->connect_option($param => $val); $self->{'dbh'}{$param} = $val if($self->{'dbh'}); } return $self->{'dbh'} ? $self->{'dbh'}{$param} : $self->connect_option($param); } sub connect { my($self) = shift; $self->dbh or return 0; return 1; } sub disconnect { my($self) = shift; $self->release_dbh(@_) or return undef; $self->{'dbh'} = undef; } sub begin_work { my($self) = shift; my $dbh = $self->dbh or return undef; if($dbh->{'AutoCommit'}) { my $ret; #$Debug && warn "BEGIN TRX\n"; my $error; TRY: { local $@; eval { local $dbh->{'RaiseError'} = 1; # XXX: Detect DBD::mysql bug (in some versions before 4.012) that # XXX: fails to set Active back to 1 when mysql_auto_reconnect # XXX: is in use. unless($dbh->{'Active'}) { if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012) { die 'Database handle does not have Active set to a true value. DBD::mysql ', 'versions before 4.012 may fail to set Active back to 1 when the ', 'mysql_auto_reconnect is set. Try upgrading to DBD::mysql 4.012 or later'; } else { die "Cannot start transaction on inactive database handle ($dbh)"; } } $ret = $dbh->begin_work }; $error = $@; } if($error) { no warnings 'uninitialized'; $self->error("begin_work() - $error " . $dbh->errstr); return undef; } unless($ret) { $self->error('begin_work() failed - ' . $dbh->errstr); return undef; } return 1; } return IN_TRANSACTION; } sub in_transaction { my $dbh = shift->{'dbh'} or return undef; return ($dbh->{'AutoCommit'}) ? 0 : 1; } sub commit { my($self) = shift; my $is_active = (defined $self->{'dbh'} && $self->{'dbh'}{'Active'}) ? 1 : 0; unless(defined $self->{'dbh'}) { $self->error("Could not commit transaction: database handle is undefined"); return 0; } my $dbh = $self->dbh or return undef; unless($dbh->{'AutoCommit'}) { my $ret; #$Debug && warn "COMMIT TRX\n"; my $error; TRY: { local $@; eval { local $dbh->{'RaiseError'} = 1; $ret = $dbh->commit; }; $error = $@; } if($error) { no warnings 'uninitialized'; $self->error("commit() $error - " . $dbh->errstr); unless($is_active) { if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012) { $self->error($self->error . '; Also, the database handle did not ' . 'have Active set to a true value. DBD::mysql versions before 4.012 ' . 'may fail to set Active back to 1 when the mysql_auto_reconnect is ' . 'set. Try upgrading to DBD::mysql 4.012 or later'); } return 0; } return undef; } unless($ret) { $self->error('Could not commit transaction: ' . ($dbh->errstr || $DBI::errstr || 'Possibly a referential integrity violation. ' . 'Check the database error log for more information.')); return undef; } return 1; } return -1; } sub rollback { my($self) = shift; my $is_active = (defined $self->{'dbh'} && $self->{'dbh'}{'Active'}) ? 1 : 0; unless(defined $self->{'dbh'}) { $self->error("Could not roll back transaction: database handle is undefined"); return 0; } my $dbh = $self->dbh or return undef; my $ac = $dbh->{'AutoCommit'}; return 1 if($ac); my $ret; #$Debug && warn "ROLLBACK TRX\n"; my $error; TRY: { local $@; eval { local $dbh->{'RaiseError'} = 1; $ret = $dbh->rollback; }; $error = $@; } if($error) { no warnings 'uninitialized'; $self->error("rollback() - $error " . $dbh->errstr); unless($is_active) { if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012) { $self->error($self->error . '; Also, the database handle did not ' . 'have Active set to a true value. DBD::mysql versions before 4.012 ' . 'may fail to set Active back to 1 when the mysql_auto_reconnect is ' . 'set. Try upgrading to DBD::mysql 4.012 or later'); } return 0; } return undef; } unless($ret || $ac) { $self->error('rollback() failed - ' . $dbh->errstr); return undef; } # DBI does this for me... #$dbh->{'AutoCommit'} = 1; return 1; } sub do_transaction { my($self, $code) = (shift, shift); my $dbh = $self->dbh or return undef; my $error; TRY: { local $@; eval { $self->begin_work or die $self->error; $code->(@_); $self->commit or die $self->error; }; $error = $@; } if($error) { $error = ref $error ? $error : "do_transaction() failed - $error"; if($self->rollback) { $self->error($error); } else { $self->error("$error. rollback() also failed - " . $self->error) } return undef; } return 1; } sub auto_quote_table_name { my($self, $name) = @_; if($name =~ /\W/ || $self->is_reserved_word($name)) { return $self->quote_table_name($name, @_); } return $name; } sub auto_quote_column_name { my($self, $name) = @_; if($name =~ /\W/ || $self->is_reserved_word($name)) { return $self->quote_column_name($name, @_); } return $name; } sub quote_column_name { my $name = $_[1]; $name =~ s/"/""/g; return qq("$name"); } sub quote_table_name { my $name = $_[1]; $name =~ s/"/""/g; return qq("$name"); } sub unquote_column_name { my($self_or_class, $name) = @_; no warnings 'uninitialized'; # handle quoted strings with quotes doubled inside them if($name =~ /^(['"`])(.+)\1$/) { my $q = $1; $name = $2; $name =~ s/$q$q/$q/g; } return $name; } *unquote_table_name = \&unquote_column_name; #sub is_reserved_word { 0 } *is_reserved_word = \&SQL::ReservedWords::is_reserved; BEGIN { sub quote_identifier_dbi { my($self) = shift; my $dbh = $self->dbh or die $self->error; return $dbh->quote_identifier(@_); } sub quote_identifier_fallback { my($self, $catalog, $schema, $table) = @_; return join('.', map { qq("$_") } grep { defined } ($schema, $table)); } if($DBI::VERSION >= 1.21) { *quote_identifier = \"e_identifier_dbi; } else { *quote_identifier = \"e_identifier_fallback; } } *quote_identifier_for_sequence = \"e_identifier; sub quote_column_with_table { my($self, $column, $table) = @_; return $table ? $self->quote_table_name($table) . '.' . $self->quote_column_name($column) : $self->quote_column_name($column); } sub auto_quote_column_with_table { my($self, $column, $table) = @_; return $table ? $self->auto_quote_table_name($table) . '.' . $self->auto_quote_column_name($column) : $self->auto_quote_column_name($column); } sub has_primary_key { my($self) = shift; my $columns = $self->primary_key_column_names(@_); return (ref $columns && @$columns) ? 1 : 0; } sub primary_key_column_names { my($self) = shift; my %args = @_ == 1 ? (table => @_) : @_; my $table = $args{'table'} or Carp::croak "Missing table name parameter"; my $catalog = $args{'catalog'} || $self->catalog; my $schema = $args{'schema'} || $self->schema; $schema = $self->default_implicit_schema unless(defined $schema); $table = lc $table if($self->likes_lowercase_table_names); $schema = lc $schema if(defined $schema && $self->likes_lowercase_schema_names); $catalog = lc $catalog if(defined $catalog && $self->likes_lowercase_catalog_names); my $table_unquoted = $self->unquote_table_name($table); my $columns; my $error; TRY: { local $@; eval { $columns = $self->_get_primary_key_column_names($catalog, $schema, $table_unquoted); }; $error = $@; } if($error || !$columns) { no warnings 'uninitialized'; # undef strings okay $error = 'no primary key columns found' unless(defined $error); Carp::croak "Could not get primary key columns for catalog '" . $catalog . "' schema '" . $schema . "' table '" . $table_unquoted . "' - " . $error; } return wantarray ? @$columns : $columns; } sub _get_primary_key_column_names { my($self, $catalog, $schema, $table) = @_; my $dbh = $self->dbh or die $self->error; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $sth = $dbh->primary_key_info($catalog, $schema, $table); unless(defined $sth) { no warnings 'uninitialized'; # undef strings okay $self->error("No primary key information found for catalog '", $catalog, "' schema '", $schema, "' table '", $table, "'"); return []; } my @columns; PK: while(my $pk_info = $sth->fetchrow_hashref) { CHECK_TABLE: # Make sure this column is from the right table { no warnings; # Allow undef coercion to empty string $pk_info->{'TABLE_NAME'} = $self->unquote_table_name($pk_info->{'TABLE_NAME'}); next PK unless($pk_info->{'TABLE_CAT'} eq $catalog && $pk_info->{'TABLE_SCHEM'} eq $schema && $pk_info->{'TABLE_NAME'} eq $table); } unless(defined $pk_info->{'COLUMN_NAME'}) { Carp::croak "Could not extract column name from DBI primary_key_info()"; } push(@columns, $self->unquote_column_name($pk_info->{'COLUMN_NAME'})); } return \@columns; } # # These methods could/should be overridden in driver-specific subclasses # sub insertid_param { undef } sub null_date { '0000-00-00' } sub null_datetime { '0000-00-00 00:00:00' } sub null_timestamp { '00000000000000' } sub min_timestamp { '00000000000000' } sub max_timestamp { '00000000000000' } sub last_insertid_from_sth { $_[1]->{$_[0]->insertid_param} } sub generate_primary_key_values { (undef) x ($_[1] || 1) } sub generate_primary_key_placeholders { (undef) x ($_[1] || 1) } sub max_column_name_length { 255 } sub max_column_alias_length { 255 } # Boolean formatting and parsing sub format_boolean { $_[1] ? 1 : 0 } sub parse_boolean { my($self, $value) = @_; return $value if($self->validate_boolean_keyword($_[1]) || ($self->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); return 1 if($value =~ /^(?:t(?:rue)?|y(?:es)?|1)$/i); return 0 if($value =~ /^(?:f(?:alse)?|no?|0)$/i); $self->error("Invalid boolean value: '$value'"); return undef; } # Date formatting sub format_date { my($self, $date) = @_; return $date if($self->validate_date_keyword($date) || ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/)); return $self->date_handler->format_date($date); } sub format_datetime { my($self, $date) = @_; return $date if($self->validate_datetime_keyword($date) || ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/)); return $self->date_handler->format_datetime($date); } use constant HHMMSS_PRECISION => 6; use constant HHMM_PRECISION => 4; sub format_time { my($self, $time, $precision) = @_; return $time if($self->validate_time_keyword($time) || ($self->keyword_function_calls && $time =~ /^\w+\(.*\)$/)); if(defined $precision) { if($precision > HHMMSS_PRECISION) { my $scale = $precision - HHMMSS_PRECISION; return $time->format("%H:%M:%S%${scale}n"); } elsif($precision == HHMMSS_PRECISION) { return $time->format("%H:%M:%S"); } elsif($precision == HHMM_PRECISION) { return $time->format("%H:%M"); } } # Punt return $time->as_string; } sub format_timestamp { my($self, $date) = @_; return $date if($self->validate_timestamp_keyword($date) || ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/)); return $self->date_handler->format_timestamp($date); } sub format_timestamp_with_time_zone { my($self, $date) = @_; return $date if($self->validate_timestamp_keyword($date) || ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/)); return $self->date_handler->format_timestamp_with_time_zone($date); } # Date parsing sub parse_date { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_date_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = $self->date_handler->parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse date '$value' - $error"); return undef; } return $dt; } sub parse_datetime { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = $self->date_handler->parse_datetime($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime '$value' - $error"); return undef; } return $dt; } sub parse_timestamp { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_timestamp_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = $self->date_handler->parse_timestamp($value) }; $error = $@; } if($error) { $self->error("Could not parse timestamp '$value' - $error"); return undef; } return $dt; } sub parse_timestamp_with_time_zone { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_timestamp_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = $self->date_handler->parse_timestamp_with_time_zone($value) }; $error = $@; } if($error) { $self->error("Could not parse timestamp with time zone '$value' - $error"); return undef; } return $dt; } sub parse_time { my($self, $value) = @_; if(!defined $value || UNIVERSAL::isa($value, 'Time::Clock') || $self->validate_time_keyword($value) || ($self->keyword_function_calls && $value =~ /^\w+\(.*\)$/)) { return $value; } my($time, $error); TRY: { local $@; eval { $time = Time::Clock->new->parse($value) }; $error = $@; } if($error) { my $second_error; TRY: { local $@; eval { my $dt = $self->date_handler->parse_time($value); # Using parse()/strftime() is faster than using the # Time::Clock constructor and the DateTime accessors. $time = Time::Clock->new->parse($dt->strftime('%H:%M:%S.%N')); }; $second_error = $@; } if($second_error) { $self->error("Could not parse time '$value' - Time::Clock::parse() failed " . "($error) and $second_error"); return undef; } } return $time; } sub parse_bitfield { my($self, $val, $size) = @_; return undef unless(defined $val); if(ref $val) { if($size && $val->Size != $size) { return Bit::Vector->new_Bin($size, $val->to_Bin); } return $val; } if($val =~ /^[10]+$/) { return Bit::Vector->new_Bin($size || length $val, $val); } elsif($val =~ /^\d*[2-9]\d*$/) { return Bit::Vector->new_Dec($size || (length($val) * 4), $val); } elsif($val =~ s/^0x// || $val =~ s/^X'(.*)'$/$1/ || $val =~ /^[0-9a-f]+$/i) { return Bit::Vector->new_Hex($size || (length($val) * 4), $val); } elsif($val =~ s/^B'([10]+)'$/$1/i) { return Bit::Vector->new_Bin($size || length $val, $val); } else { $self->error("Could not parse bitfield value '$val'"); return undef; #return Bit::Vector->new_Bin($size || length($val), $val); } } sub format_bitfield { my($self, $vec, $size) = @_; if($size) { $vec = Bit::Vector->new_Bin($size, $vec->to_Bin); return sprintf('%0*b', $size, hex($vec->to_Hex)); } return sprintf('%b', hex($vec->to_Hex)); } sub select_bitfield_column_sql { shift->auto_quote_column_with_table(@_) } sub parse_array { my($self) = shift; return $_[0] if(ref $_[0]); return [ @_ ] if(@_ > 1); my $val = $_[0]; return undef unless(defined $val); $val =~ s/^ (?:\[.+\]=)? \{ (.*) \} $/$1/sx; my @array; while($val =~ s/(?:"((?:[^"\\]+|\\.)*)"|([^",]+))(?:,|$)//) { my($item) = map { $_ eq 'NULL' ? undef : $_ } (defined $1 ? $1 : $2); $item =~ s{\\(.)}{$1}g if(defined $item); push(@array, $item); } return \@array; } sub format_array { my($self) = shift; return undef unless(ref $_[0] || defined $_[0]); my @array = (ref $_[0]) ? @{$_[0]} : @_; my $str = '{' . join(',', map { if(!defined $_) { 'NULL' } elsif(/^[-+]?\d+(?:\.\d*)?$/) { $_ } else { s/\\/\\\\/g; s/"/\\"/g; qq("$_") } } @array) . '}'; if(length($str) > $self->max_array_characters) { Carp::croak "Array string is longer than ", ref($self), "->max_array_characters (", $self->max_array_characters, ") characters long: $str"; } return $str; } my $Interval_Regex = qr{ (?:\@\s*)? (?: (?: (?: \s* ([+-]?) (\d+) : ([0-5]?\d)? (?:: ([0-5]?\d (?:\.\d+)? )? )?)) # (sign)hhh:mm:ss | (?: \s* ( [+-]? \d+ (?:\.\d+(?=\s+s))? ) \s+ # quantity (?: # unit (?:\b(dec) (?:ades?\b | s?\b)?\b) # decades | (?:\b(d) (?:ays?\b)?\b) # days | (?:\b(y) (?:ears?\b)?\b) # years | (?:\b(h) (?:ours?\b)?\b) # hours | (?:\b(mon) (?:s\b | ths?\b)?\b) # months | (?:\b(mil) (?:s\b | lenniums?\b)?\b) # millenniums | (?:\b(m) (?:inutes?\b | ins?\b)?\b) # minutes | (?:\b(s) (?:ec(?:s | onds?)?)?\b) # seconds | (?:\b(w) (?:eeks?\b)?\b) # weeks | (?:\b(c) (?:ent(?:s | ury | uries)?\b)?\b) # centuries ) ) ) (?: \s+ (ago) \b)? # direction | (.+) }ix; sub parse_interval { my($self, $value, $end_of_month_mode) = @_; if(!defined $value || UNIVERSAL::isa($value, 'DateTime::Duration') || $self->validate_interval_keyword($value) || ($self->keyword_function_calls && $value =~ /^\w+\(.*\)$/)) { return $value; } for($value) { s/\A //; s/ \z//; s/\s+/ /g; } my(%units, $is_ago, $sign, $error, $dt_duration); my $value_pos; while(!$error && $value =~ /$Interval_Regex/go) { $value_pos = pos($value); $is_ago = 1 if($16); if($2 || $3 || $4) { if($sign || defined $units{'hours'} || defined $units{'minutes'} || defined $units{'seconds'}) { $error = 1; last; } $sign = ($1 && $1 eq '-') ? -1 : 1; my $secs = $4; if(defined $secs && $secs != int($secs)) { my $fsecs = substr($secs, index($secs, '.') + 1); $secs = int($secs); my $len = length $fsecs; if($len < 9) { $fsecs .= ('0' x (9 - length $fsecs)); } elsif($len > 9) { $fsecs = substr($fsecs, 0, 9); } $units{'nanoseconds'} = $sign * $fsecs; } $units{'hours'} = $sign * ($2 || 0); $units{'minutes'} = $sign * ($3 || 0); $units{'seconds'} = $sign * ($secs || 0); } elsif($6) { if($units{'decades'}) { $error = 1; last } $units{'decades'} = $5; } elsif(defined $7) { if($units{'days'}) { $error = 1; last } $units{'days'} = $5; } elsif(defined $8) { if($units{'years'}) { $error = 1; last } $units{'years'} = $5; } elsif(defined $9) { if($units{'hours'}) { $error = 1; last } $units{'hours'} = $5; } elsif(defined $10) { if($units{'months'}) { $error = 1; last } $units{'months'} = $5; } elsif(defined $11) { if($units{'millenniums'}) { $error = 1; last } $units{'millenniums'} = $5; } elsif(defined $12) { if($units{'minutes'}) { $error = 1; last } $units{'minutes'} = $5; } elsif(defined $13) { if($units{'seconds'}) { $error = 1; last } my $secs = $5; $units{'seconds'} = int($secs); if($units{'seconds'} != $secs) { my $fsecs = substr($secs, index($secs, '.') + 1); my $len = length $fsecs; if($len < 9) { $fsecs .= ('0' x (9 - length $fsecs)); } elsif($len > 9) { $fsecs = substr($fsecs, 0, 9); } $units{'nanoseconds'} = $fsecs; } } elsif(defined $14) { if($units{'weeks'}) { $error = 1; last } $units{'weeks'} = $5; } elsif(defined $15) { if($units{'centuries'}) { $error = 1; last } $units{'centuries'} = $5; } elsif(defined $17) { $error = 1; last; } } if($error) { $self->error("Could not parse interval '$value' - found overlaping time units"); return undef; } if($value_pos != length($value)) { $self->error("Could not parse interval '$value' - could not interpret all tokens"); return undef; } if(defined $units{'millenniums'}) { $units{'years'} += 1000 * $units{'millenniums'}; delete $units{'millenniums'}; } if(defined $units{'centuries'}) { $units{'years'} += 100 * $units{'centuries'}; delete $units{'centuries'}; } if(defined $units{'decades'}) { $units{'years'} += 10 * $units{'decades'}; delete $units{'decades'}; } if($units{'hours'} || $units{'minutes'} || $units{'seconds'}) { my $seconds = ($units{'hours'} || 0) * 60 * 60 + ($units{'minutes'} || 0) * 60 + ($units{'seconds'} || 0); $units{'hours'} = int($seconds / 3600); $seconds -= $units{'hours'} * 3600; $units{'minutes'} = int($seconds / 60); $units{'seconds'} = $seconds - $units{'minutes'} * 60; } $units{'end_of_month'} = $end_of_month_mode if(defined $end_of_month_mode); $dt_duration = $is_ago ? DateTime::Duration->new(%units)->inverse : DateTime::Duration->new(%units); # XXX: Ugly hack workaround for DateTime::Duration bug (RT 53985) if($is_ago && defined $end_of_month_mode && $dt_duration->end_of_month_mode ne $end_of_month_mode) { $dt_duration->{'end_of_month'} = $end_of_month_mode; } return $dt_duration; } sub format_interval { my($self, $dur) = @_; if(!defined $dur || $self->validate_interval_keyword($dur) || ($self->keyword_function_calls && $dur =~ /^\w+\(.*\)$/)) { return $dur; } my $output = ''; my(%deltas, %unit, $neg); @deltas{qw/years mons days h m s/} = $dur->in_units(qw/years months days hours minutes seconds/); foreach (qw/years mons days/) { $unit{$_} = $_; $unit{$_} =~ s/s\z// if $deltas{$_} == 1; } $output .= "$deltas{'years'} $unit{'years'} " if($deltas{'years'}); $neg = 1 if($deltas{'years'} < 0); $output .= '+' if ($neg && $deltas{'mons'} > 0); $output .= "$deltas{'mons'} $unit{'mons'} " if($deltas{'mons'}); $neg = $deltas{'mons'} < 0 ? 1 : $deltas{'mons'} ? 0 : $neg; $output .= '+' if($neg && $deltas{'days'} > 0); $output .= "$deltas{'days'} $unit{'days'} " if($deltas{'days'}); if($deltas{'h'} || $deltas{'m'} || $deltas{'s'} || $dur->nanoseconds) { $neg = $deltas{'days'} < 0 ? 1 : $deltas{'days'} ? 0 : $neg; if($neg && (($deltas{'h'} > 0) || (!$deltas{'h'} && $deltas{'m'} > 0) || (!$deltas{'h'} && !$deltas{'m'} && $deltas{'s'} > 0))) { $output .= '+'; } my $nsec = $dur->nanoseconds; $output .= '-' if(!$deltas{'h'} && ($deltas{'m'} < 0 || $deltas{'s'} < 0)); @deltas{qw/m s/} = (abs($deltas{'m'}), abs($deltas{'s'})); $deltas{'hms'} = join(':', map { sprintf('%.2d', $deltas{$_}) } (qw/h m/)) . ($nsec ? sprintf(':%02d.%09d', $deltas{'s'}, $nsec) : sprintf(':%02d', $deltas{'s'})); $output .= "$deltas{'hms'}" if($deltas{'hms'}); } $output =~ s/ \z//; if(length($output) > $self->max_interval_characters) { Carp::croak "Interval string is longer than ", ref($self), "->max_interval_characters (", $self->max_interval_characters, ") characters long: $output"; } return $output; } sub build_dsn { 'override in subclass' } sub validate_integer_keyword { 0 } sub validate_float_keyword { 0 } sub validate_numeric_keyword { 0 } sub validate_decimal_keyword { 0 } sub validate_double_precision_keyword { 0 } sub validate_bigint_keyword { 0 } sub validate_date_keyword { 0 } sub validate_datetime_keyword { 0 } sub validate_time_keyword { 0 } sub validate_timestamp_keyword { 0 } sub validate_interval_keyword { 0 } sub validate_set_keyword { 0 } sub validate_array_keyword { 0 } sub validate_bitfield_keyword { 0 } sub validate_boolean_keyword { no warnings 'uninitialized'; $_[1] =~ /^(?:TRUE|FALSE)$/; } sub should_inline_keyword { no warnings 'uninitialized'; ($_[1] =~ /^\w+\(.*\)$/) ? 1 : 0; } BEGIN { *should_inline_integer_keyword = \&should_inline_keyword; *should_inline_float_keyword = \&should_inline_keyword; *should_inline_decimal_keyword = \&should_inline_keyword; *should_inline_numeric_keyword = \&should_inline_keyword; *should_inline_double_precision_keyword = \&should_inline_keyword; *should_inline_bigint_keyword = \&should_inline_keyword; *should_inline_date_keyword = \&should_inline_keyword; *should_inline_datetime_keyword = \&should_inline_keyword; *should_inline_time_keyword = \&should_inline_keyword; *should_inline_timestamp_keyword = \&should_inline_keyword; *should_inline_interval_keyword = \&should_inline_keyword; *should_inline_set_keyword = \&should_inline_keyword; *should_inline_array_keyword = \&should_inline_keyword; *should_inline_boolean_keyword = \&should_inline_keyword; *should_inline_bitfield_value = \&should_inline_keyword; } sub next_value_in_sequence { my($self, $seq) = @_; $self->error("Don't know how to select next value in sequence '$seq' " . "for database driver " . $self->driver); return undef; } sub current_value_in_sequence { my($self, $seq) = @_; $self->error("Don't know how to select current value in sequence '$seq' " . "for database driver " . $self->driver); return undef; } sub sequence_exists { my($self, $seq) = @_; $self->error("Don't know how to tell if sequence '$seq' exists " . "for database driver " . $self->driver); return undef; } sub auto_sequence_name { undef } sub supports_multi_column_count_distinct { 1 } sub supports_nested_joins { 1 } sub supports_limit_with_offset { 1 } sub supports_arbitrary_defaults_on_insert { 0 } sub supports_select_from_subselect { 0 } sub format_select_from_subselect { "(\n$_[1]\n )" } sub likes_redundant_join_conditions { 0 } sub likes_lowercase_table_names { 0 } sub likes_uppercase_table_names { 0 } sub likes_lowercase_schema_names { 0 } sub likes_uppercase_schema_names { 0 } sub likes_lowercase_catalog_names { 0 } sub likes_uppercase_catalog_names { 0 } sub likes_lowercase_sequence_names { 0 } sub likes_uppercase_sequence_names { 0 } sub likes_implicit_joins { 0 } sub supports_schema { 0 } sub supports_catalog { 0 } sub use_auto_sequence_name { 0 } sub format_limit_with_offset { my($self, $limit, $offset, $args) = @_; delete $args->{'limit'}; delete $args->{'offset'}; if(defined $offset) { $args->{'limit_suffix'} = "LIMIT $limit OFFSET $offset"; } else { $args->{'limit_suffix'} = "LIMIT $limit"; } } sub format_table_with_alias { #my($self, $table, $alias, $hints) = @_; return "$_[1] $_[2]"; } sub format_select_start_sql { my($self, $hints) = @_; return 'SELECT' unless($hints); return 'SELECT ' . ($hints->{'comment'} ? "/* $hints->{'comment'} */" : ''); } sub format_select_lock { '' } sub column_sql_from_lock_on_value { my($self, $object_or_class, $name, $tables) = @_; my %map; if($tables) { my $tn = 1; foreach my $table (@$tables) { (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//; $map{$table_key} = 't' . $tn++; } } my $table; my $chase_meta = $object_or_class->meta; # Chase down multi-level keys: e.g., products.vendor.name while($name =~ /\G([^.]+)(\.|$)/g) { my($sub_name, $more) = ($1, $2); my $key = $chase_meta->foreign_key($sub_name) || $chase_meta->relationship($sub_name); if($key) { $chase_meta = $key->can('foreign_class') ? $key->foreign_class->meta : $key->class->meta; $table = $chase_meta->table; } else { if($more) { Carp::confess 'Invalid lock => { on => ... } argument: ', "no foreign key or relationship named '$sub_name' ", 'found in ', $chase_meta->class; } else { my $column = $sub_name; if($table) { $table = $map{$table} if(defined $map{$table}); return $self->auto_quote_column_with_table($column, $table); } else { return $self->auto_quote_column_name($column); } } } } Carp::confess "Invalid lock => { on => ... } argument: $name"; } sub table_sql_from_lock_on_value { my($self, $object_or_class, $name, $tables) = @_; my %map; if($tables) { my $tn = 1; foreach my $table (@$tables) { (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//; $map{$table_key} = 't' . $tn++; } } my $table; my $chase_meta = $object_or_class->meta; # Chase down multi-level keys: e.g., products.vendor.location while($name =~ /\G([^.]+)(\.|$)/g) { my($sub_name, $more) = ($1, $2); my $key = $chase_meta->foreign_key($sub_name) || $chase_meta->relationship($sub_name); if($key || !$more) { if($key) { $chase_meta = $key->can('foreign_class') ? $key->foreign_class->meta : $key->class->meta; $table = $chase_meta->table; } else { $table = $sub_name; } next if($more); $table = $map{$table} if(defined $map{$table}); return $self->auto_quote_table_name($table); } else { Carp::confess 'Invalid lock => { on => ... } argument: ', "no foreign key or relationship named '$sub_name' ", 'found in ', $chase_meta->class; } } Carp::confess "Invalid lock => { on => ... } argument: $name"; } sub supports_on_duplicate_key_update { 0 } # # DBI introspection # sub refine_dbi_column_info { my($self, $col_info) = @_; # Parse odd default value syntaxes $col_info->{'COLUMN_DEF'} = $self->parse_dbi_column_info_default($col_info->{'COLUMN_DEF'}, $col_info); # Make sure the data type name is lowercase $col_info->{'TYPE_NAME'} = lc $col_info->{'TYPE_NAME'}; # Unquote column name $col_info->{'COLUMN_NAME'} = $self->unquote_column_name($col_info->{'COLUMN_NAME'}); return; } sub refine_dbi_foreign_key_info { my($self, $fk_info) = @_; # Unquote names foreach my $name (qw(NAME COLUMN_NAME DATA_TYPE TABLE_NAME TABLE_CAT TABLE_SCHEM)) { foreach my $prefix (qw(FK_ UK_)) { my $param = $prefix . $name; $fk_info->{$param} = $self->unquote_column_name($fk_info->{$param}) if(exists $fk_info->{$param}); } } return; } sub parse_dbi_column_info_default { $_[1] } sub list_tables { my($self, %args) = @_; my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE'; my(@tables, $error); TRY: { local $@; eval { my $dbh = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $sth = $dbh->table_info($self->catalog, $self->schema, '%', $types); $sth->execute; while(my $table_info = $sth->fetchrow_hashref) { push(@tables, $table_info->{'TABLE_NAME'}) } }; $error = $@; } if($error) { Carp::croak "Could not list tables from ", $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } # # Setup overrides # # - Rose::DB development init file - Perl code # - Rose::DB fixup rc file - YAML format sub auto_load_fixups { my($class) = shift; # Load a file full of fix-ups for the data sources (usually just passwords) # from a "well-known" (or at least "well-specified") location. my $fixup_file = $ENV{'ROSEDBRC'}; $fixup_file = '/etc/rosedbrc' unless(defined $fixup_file && -e $fixup_file); if(-e $fixup_file) { if(-r $fixup_file) { $class->load_yaml_fixup_file($fixup_file); } else { warn "Cannot read Rose::DB fixup file '$fixup_file'"; } } # Load a file or package full of arbitrary Perl used to alter the data # source registry. This is intended for use in development only. my $rosedb_devinit = $ENV{'ROSEDB_DEVINIT'}; my $error; if(defined $rosedb_devinit) { if(-e $rosedb_devinit) { TRY: { local $@; do $rosedb_devinit; $error = $@; } } else { TRY: { local $@; eval qq(require $rosedb_devinit); $error = $@; } if($rosedb_devinit->can('fixup')) { $rosedb_devinit->fixup($class); } } } if($error || !defined $rosedb_devinit) { my $username; # The getpwuid() function is often(?) unimplemented in perl on Windows TRY: { local $@; eval { $username = lc getpwuid($<) }; $error = $@; } unless($error) { $rosedb_devinit = "Rose::DB::Devel::Init::$username"; TRY: { local $@; eval qq(require $rosedb_devinit); $error = $@; } if($error) { TRY: { local $@; eval { do $rosedb_devinit }; $error = $@; } } else { if($rosedb_devinit->can('fixup')) { $rosedb_devinit->fixup($class); } } } } } # YAML syntax example: # # --- # production: # g3db: # password: mysecret # --- # mqa: # g3db: # password: myothersecret our $YAML_Class; sub load_yaml_fixup_file { my($class, $file) = @_; my $registry = $class->registry; unless($YAML_Class) { my $error; TRY: { local $@; eval { require YAML::Syck }; $error = $@; } if($error) { require YAML; #warn "# Using YAML\n"; $YAML_Class = 'YAML'; } else { #warn "# Using YAML::Syck\n"; $YAML_Class = 'YAML::Syck'; } } $Debug && warn "$class - Loading fixups from $file...\n"; no strict 'refs'; my @data = &{"${YAML_Class}::LoadFile"}($file); foreach my $data (@data) { foreach my $domain (sort keys %$data) { foreach my $type (sort keys %{$data->{$domain}}) { my $entry = $registry->entry(domain => $domain, type => $type); unless($entry) { warn "No $class data source found for domain '$domain' ", "and type '$type'"; next; } while(my($method, $value) = each(%{$data->{$domain}{$type}})) { #$Debug && warn "$class - $domain:$type - $method = $value\n"; $entry->$method($value); } } } } } # # Storable hooks # sub STORABLE_freeze { my($self, $cloning) = @_; return if($cloning); # Ditch the DBI $dbh and pull the password out of its closure my $db = { %$self }; $db->{'dbh'} = undef; $db->{'password'} = $self->password; $db->{'password_closure'} = undef; require Storable; return Storable::freeze($db); } sub STORABLE_thaw { my($self, $cloning, $serialized) = @_; %$self = %{ Storable::thaw($serialized) }; # Put the password back in a closure my $password = delete $self->{'password'}; $self->{'password_closure'} = sub { $password } if(defined $password); } # # This is both a class and an object method # sub error { my($self_or_class) = shift; if(ref $self_or_class) # Object method { if(@_) { return $self_or_class->{'error'} = $Error = shift; } return $self_or_class->{'error'}; } # Class method return $Error = shift if(@_); return $Error; } sub DESTROY { $_[0]->disconnect; } BEGIN { package Rose::DateTime::Format::Generic; use Rose::Object; our @ISA = qw(Rose::Object); use Rose::Object::MakeMethods::Generic ( scalar => 'server_tz', boolean => 'european', ); sub format_date { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d') } sub format_datetime { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d %T') } sub format_timestamp { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d %H:%M:%S.%N') } sub format_timestamp_with_time_zone { shift->format_timestamp(@_) } sub parse_date { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) } sub parse_datetime { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) } sub parse_timestamp { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) } sub parse_timestamp_with_time_zone { shift->parse_timestamp(@_) } } 1; __END__ =encoding utf8 =head1 NAME Rose::DB - A DBI wrapper and abstraction layer. =head1 SYNOPSIS package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); My::DB->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', server_time_zone => 'UTC', ); My::DB->register_db( domain => 'production', type => 'main', driver => 'Pg', database => 'big_db', host => 'dbserver.acme.com', username => 'dbadmin', password => 'prodsecret', server_time_zone => 'UTC', ); My::DB->default_domain('development'); My::DB->default_type('main'); ... $db = My::DB->new; my $dbh = $db->dbh or die $db->error; $db->begin_work or die $db->error; $dbh->do(...) or die $db->error; $db->commit or die $db->error; $db->do_transaction(sub { $dbh->do(...); $sth = $dbh->prepare(...); $sth->execute(...); while($sth->fetch) { ... } $dbh->do(...); }) or die $db->error; $dt = $db->parse_timestamp('2001-03-05 12:34:56.123'); $val = $db->format_timestamp($dt); $dt = $db->parse_datetime('2001-03-05 12:34:56'); $val = $db->format_datetime($dt); $dt = $db->parse_date('2001-03-05'); $val = $db->format_date($dt); $bit = $db->parse_bitfield('0x0AF', 32); $val = $db->format_bitfield($bit); ... =head1 DESCRIPTION L is a wrapper and abstraction layer for L-related functionality. A L object "has a" L object; it is not a subclass of L. Please see the L (perldoc Rose::DB::Tutorial) for an example usage scenario that reflects "best practices" for this module. B Are you looking for an object-relational mapper (ORM)? If so, please see the L module. L is an ORM that uses this module to manage its database connections. L alone is simply a data source abstraction layer; it is not an ORM. =head1 DATABASE SUPPORT L currently supports the following L database drivers: DBD::Pg (PostgreSQL) DBD::mysql (MySQL) DBD::SQLite (SQLite) DBD::Informix (Informix) DBD::Oracle (Oracle) L will attempt to service an unsupported database using a L implementation that may or may not work. Support for more drivers may be added in the future. Patches are welcome. All database-specific behavior is contained and documented in the subclasses of L. L's constructor method (L) returns a database-specific subclass of L, chosen based on the L value of the selected L. The default mapping of databases to L subclasses is: DBD::Pg -> Rose::DB::Pg DBD::mysql -> Rose::DB::MySQL DBD::SQLite -> Rose::DB::SQLite DBD::Informix -> Rose::DB::Informix DBD::Oracle -> Rose::DB::Oracle This mapping can be changed using the L class method. The L object method documentation found here defines the purpose of each method, as well as the default behavior of the method if it is not overridden by a subclass. You must read the subclass documentation to learn about behaviors that are specific to each type of database. Subclasses may also add methods that do not exist in the parent class, of course. This is yet another reason to read the documentation for the subclass that corresponds to your data source's database software. =head1 FEATURES The basic features of L are as follows. =head2 Data Source Abstraction Instead of dealing with "databases" that exist on "hosts" or are located via some vendor-specific addressing scheme, L deals with "logical" data sources. Each logical data source is currently backed by a single "physical" database (basically a single L connection). Multiplexing, fail-over, and other more complex relationships between logical data sources and physical databases are not part of L. Some basic types of fail-over may be added to L in the future, but right now the mapping is strictly one-to-one. (I'm also currently inclined to encourage multiplexing functionality to exist in a layer above L, rather than within it or in a subclass of it.) The driver type of the data source determines the functionality of all methods that do vendor-specific things (e.g., L). L identifies data sources using a two-level namespace made of a "domain" and a "type". Both are arbitrary strings. If left unspecified, the default domain and default type (accessible via L's L and L class methods) are assumed. There are many ways to use the two-level namespace, but the most common is to use the domain to represent the current environment (e.g., "development", "staging", "production") and then use the type to identify the logical data source within that environment (e.g., "report", "main", "archive") A typical deployment scenario will set the default domain using the L class method as part of the configure/install process. Within application code, L objects can be constructed by specifying type alone: $main_db = Rose::DB->new(type => 'main'); $archive_db = Rose::DB->new(type => 'archive'); If there is only one database type, then all L objects can be instantiated with a bare constructor call like this: $db = Rose::DB->new; Again, remember that this is just one of many possible uses of domain and type. Arbitrarily complex scenarios can be created by nesting namespaces within one or both parameters (much like how Perl uses "::" to create a multi-level namespace from single strings). The important point is the abstraction of data sources so they can be identified and referred to using a vocabulary that is entirely independent of the actual DSN (data source names) used by L behind the scenes. =head2 Database Handle Life-Cycle Management When a L object is destroyed while it contains an active L database handle, the handle is explicitly disconnected before destruction. L supports a simple retain/release reference-counting system which allows a database handle to out-live its parent L object. In the simplest case, L could be used for its data source abstractions features alone. For example, transiently creating a L and then retaining its L database handle before it is destroyed: $main_dbh = Rose::DB->new(type => 'main')->retain_dbh or die Rose::DB->error; $aux_dbh = Rose::DB->new(type => 'aux')->retain_dbh or die Rose::DB->error; If the database handle was simply extracted via the L method instead of retained with L, it would be disconnected by the time the statement completed. # WRONG: $dbh will be disconnected immediately after the assignment! $dbh = Rose::DB->new(type => 'main')->dbh or die Rose::DB->error; =head2 Vendor-Specific Column Value Parsing and Formatting Certain semantically identical column types are handled differently in different databases. Date and time columns are good examples. Although many databases store month, day, year, hours, minutes, and seconds using a "datetime" column type, there will likely be significant differences in how each of those databases expects to receive such values, and how they're returned. L is responsible for converting the wide range of vendor-specific column values for a particular column type into a single form that is convenient for use within Perl code. L also handles the opposite task, taking input from the Perl side and converting it into the appropriate format for a specific database. Not all column types that exist in the supported databases are handled by L, but support will expand in the future. Many column types are specific to a single database and do not exist elsewhere. When it is reasonable to do so, vendor-specific column types may be "emulated" by L for the benefit of other databases. For example, an ARRAY value may be stored as a specially formatted string in a VARCHAR field in a database that does not have a native ARRAY column type. L does B attempt to present a unified column type system, however. If a column type does not exist in a particular kind of database, there should be no expectation that L will be able to parse and format that value type on behalf of that database. =head2 High-Level Transaction Support Transactions may be started, committed, and rolled back in a variety of ways using the L database handle directly. L provides wrappers to do the same things, but with different error handling and return values. There's also a method (L) that will execute arbitrary code within a single transaction, automatically handling rollback on failure and commit on success. =head1 SUBCLASSING Subclassing is B and generally works as expected. (See the L for a complete example.) There is, however, the question of how class data is shared with subclasses. Here's how it works for the various pieces of class data. =over =item B, B, B, B, B By default, all subclasses share the same data source "registry" with L. To provide a private registry for your subclass (the recommended approach), see the example in the documentation for the L method below. =item B, B If called with no arguments, and if the attribute was never set for this class, then a left-most, breadth-first search of the parent classes is initiated. The value returned is taken from first parent class encountered that has ever had this attribute set. (These attributes use the L method type as defined in L.) =item B These hashes of attributes are inherited by subclasses using a one-time, shallow copy from a superclass. Any subclass that accesses or manipulates the hash in any way will immediately get its own private copy of the hash I. The superclass from which the hash is copied is the closest ("least super") class that has ever accessed or manipulated this hash. The copy is a "shallow" copy, duplicating only the keys and values. Reference values are not recursively copied. Setting to hash to undef (using the 'reset' interface) will cause it to be re-copied from a superclass the next time it is accessed. (These attributes use the L method type as defined in L.) =back =head1 SERIALIZATION A L object may contain a L database handle, and L database handles usually don't survive the serialize process intact. L objects also hide database passwords inside closures, which also don't serialize well. In order for a L object to survive serialization, custom hooks are required. L has hooks for the L serialization module, but there is an important caveat. Since L objects are blessed into a dynamically generated class (derived from the L), you must load your L-derived class with all its registered data sources before you can successfully L a L L-derived object. Here's an example. Imagine that this is your L-derived class: package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); My::DB->register_db( domain => 'dev', type => 'main', driver => 'Pg', ... ); My::DB->register_db( domain => 'prod', type => 'main', driver => 'Pg', ... ); My::DB->default_domain('dev'); My::DB->default_type('main'); In one program, a C object is L using L: # my_freeze_script.pl use My::DB; use Storable qw(nstore); # Create My::DB object $db = My::DB->new(domain => 'dev', type => 'main'); # Do work... $db->dbh->db('CREATE TABLE some_table (...)'); ... # Serialize $db and store it in frozen_data_file nstore($db, 'frozen_data_file'); Now another program wants to L out that C object and use it. To do so, it must be sure to load the L module (which registers all its data sources when loaded) I attempting to deserialize the C object serialized by C. # my_thaw_script.pl # IMPORTANT: load db modules with all data sources registered before # attempting to deserialize objects of this class. use My::DB; use Storable qw(retrieve); # Retrieve frozen My::DB object from frozen_data_file $db = retrieve('frozen_data_file'); # Do work... $db->dbh->db('DROP TABLE some_table'); ... Note that this rule about loading a L-derived class with all its data sources registered prior to deserializing such an object only applies if the serialization was done in a different process. If you L and L within the same process, you don't have to worry about it. =head1 ENVIRONMENT There are two ways to alter the initial L data source registry. =over 4 =item * The ROSEDB_DEVINIT file or module, which can add, modify, or remove data sources and alter the default L and L. =item * The ROSEDBRC file, which can modify existing data sources. =back =head2 ROSEDB_DEVINIT The C file or module is used during development, usually to set up data sources for a particular developer's database or project. If the C environment variable is set, it should be the name of a Perl module or file. If it is a Perl module and that module has a C subroutine, it will be called as a class method after the module is loaded. If the C environment variable is not set, or if the specified file does not exist or has errors, then it defaults to the package name C, where "username" is the account name of the current user. B if the L function is unavailable (as is often the case on Windows versions of perl) then this default does not apply and the loading of the module named C is not attempted. The C file or module may contain arbitrary Perl code which will be loaded and evaluated in the context of L. Example: Rose::DB->default_domain('development'); Rose::DB->modify_db(domain => 'development', type => 'main_db', database => 'main', username => 'jdoe', password => 'mysecret'); 1; Remember to end the file with a true value. The C file or module must be read explicitly by calling the L class method. =head2 ROSEDBRC The C file contains configuration "fix-up" information. This file is most often used to dynamically set passwords that are too sensitive to be included directly in the source code of a L-derived class. The path to the fix-up file is determined by the C environment variable. If this variable is not set, or if the file it points to does not exist, then it defaults to C. This file should be in YAML format. To read this file, you must have either L or some reasonably modern version of L installed (0.66 or later recommended). L will be preferred if both are installed. The C file's contents have the following structure: --- somedomain: sometype: somemethod: somevalue --- otherdomain: othertype: othermethod: othervalue Each entry modifies an existing registered data source. Any valid L object method can be used (in place of "somemethod" and "othermethod" in the YAML example above). This file must be read explicitly by calling the L class method I setting up all your data sources. Example: package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); __PACKAGE__->use_private_registry; # Register all data sources __PACKAGE__->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); ... # Load fix-up files, if any __PACKAGE__->auto_load_fixups; =head1 CLASS METHODS =over 4 =item B Make one data source an alias for another by pointing them both to the same registry entry. PARAMS are name/value pairs that must include domain and type values for both the source and alias parameters. Example: Rose::DB->alias_db(source => { domain => 'dev', type => 'main' }, alias => { domain => 'dev', type => 'aux' }); This makes the "dev/aux" data source point to the same registry entry as the "dev/main" data source. Modifications to either registry entry (via L) will be reflected in both. =item B Attempt to load both the YAML-based L and Perl-based L fix-up files, if any exist, in that order. The L file will modify the data source L of the calling class. See the L section above for more information. =item B Get or set the L-derived object used to cache L objects on behalf of this class. If no such object exists, a new cache object of L class will be created, stored, and returned. =item B Get or set the name of the L-derived class used to cache L objects on behalf of this class. The default value is L. =item B Returns true of the data source specified by PARAMS is registered, false otherwise. PARAMS are name/value pairs for C and C. If they are omitted, they default to L and L, respectively. If default values do not exist, a fatal error will occur. If a single value is passed instead of name/value pairs, it is taken as the value of the C parameter. =item B Get or set the default L connect options hash. If a reference to a hash is passed, it replaces the default connect options hash. If a series of name/value pairs are passed, they are added to the default connect options hash. The default set of default connect options is: AutoCommit => 1, RaiseError => 1, PrintError => 1, ChopBlanks => 1, Warn => 0, See the L object method for more information on how the default connect options are used. =item B Get or set the default data source domain. See the L<"Data Source Abstraction"> section for more information on data source domains. =item B Get or set the default data source type. See the L<"Data Source Abstraction"> section for more information on data source types. =item B Get or set the subclass used for DRIVER. The DRIVER argument is automatically converted to lowercase. (Driver names are effectively case-insensitive.) $class = Rose::DB->driver_class('Pg'); # get Rose::DB->driver_class('pg' => 'MyDB::Pg'); # set The default mapping of driver names to class names is as follows: mysql -> Rose::DB::MySQL pg -> Rose::DB::Pg informix -> Rose::DB::Informix sqlite -> Rose::DB::SQLite oracle -> Rose::DB::Oracle generic -> Rose::DB::Generic The class mapped to the special driver name "generic" will be used for any driver name that does not have an entry in the map. See the documentation for the L method for more information on how the driver influences the class of objects returned by the constructor. =item B Get or set a boolean default value for the L object attribute. Defaults to the value of the C environment variable, it set to a defined value, or false otherwise. =item B Modify a data source, setting the attributes specified in PARAMS, where PARAMS are name/value pairs. Any L object method that sets a L is a valid parameter name. # Set new username for data source identified by domain and type Rose::DB->modify_db(domain => 'test', type => 'main', username => 'tester'); PARAMS should include values for both the C and C parameters since these two attributes are used to identify the data source. If they are omitted, they default to L and L, respectively. If default values do not exist, a fatal error will occur. If there is no data source defined for the specified C and C, a fatal error will occur. =item B This is a convenience method that is equivalent to the following call: Rose::DB->db_cache->prepare_for_apache_fork() Any arguments passed to this method are passed on to the call to the L's L method. Please read the L documentation, particularly the documentation for the L method for more information. =item B Registers a new data source with the attributes specified in PARAMS, where PARAMS are name/value pairs. Any L object method that sets a L is a valid parameter name. PARAMS B include a value for the C parameter. If the C or C parameters are omitted or undefined, they default to the return values of the L and L class methods, respectively. The C and C are used to identify the data source. If either one is missing, a fatal error will occur. See the L<"Data Source Abstraction"> section for more information on data source types and domains. The C is used to determine which class objects will be blessed into by the L constructor, L. The driver name is automatically converted to lowercase. If it is missing, a fatal error will occur. In most deployment scenarios, L is called early in the compilation process to ensure that the registered data sources are available when the "real" code runs. Database registration can be included directly in your L subclass. This is the recommended approach. Example: package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); # Use a private registry for this class __PACKAGE__->use_private_registry; # Register data sources My::DB->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); My::DB->register_db( domain => 'production', type => 'main', driver => 'Pg', database => 'big_db', host => 'dbserver.acme.com', username => 'dbadmin', password => 'prodsecret', ); ... Another possible approach is to consolidate data source registration in a single module which is then Ced early on in the code path. For example, imagine a mod_perl web server environment: # File: MyCorp/DataSources.pm package MyCorp::DataSources; My::DB->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); My::DB->register_db( domain => 'production', type => 'main', driver => 'Pg', database => 'big_db', host => 'dbserver.acme.com', username => 'dbadmin', password => 'prodsecret', ); ... # File: /usr/local/apache/conf/startup.pl use My::DB; # your Rose::DB subclass use MyCorp::DataSources; # register all data sources ... Data source registration can happen at any time, of course, but it is most useful when all application code can simply assume that all the data sources are already registered. Doing the registration as early as possible (e.g., directly in your L subclass, or in a C file that is loaded from an apache/mod_perl web server's C file) is the best way to create such an environment. Note that the data source registry serves as an I source of information for L objects. Once an object is instantiated, it is independent of the registry. Changes to an object are not reflected in the registry, and changes to the registry are not reflected in existing objects. =item B Get or set the L-derived object that manages and stores the data source registry. It defaults to an "empty" L object. Remember that setting a new registry will replace the existing registry and all the data sources registered in it. Note that L subclasses will inherit the base class's L object and will therefore inherit all existing registry entries and share the same registry namespace as the base class. This may or may not be what you want. In most cases, it's wise to give your subclass its own private registry if it inherits directly from L. To do that, just set a new registry object in your subclass. Example: package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); # Create a private registry for this class: # # either explicitly: # use Rose::DB::Registry; # __PACKAGE__->registry(Rose::DB::Registry->new); # # or use the convenience method: __PACKAGE__->use_private_registry; ... Further subclasses of C may then inherit its registry object, if desired, or may create their own private registries in the manner shown above. =item B Unregisters the data source having the C and C specified in PARAMS, where PARAMS are name/value pairs. Returns true if the data source was unregistered successfully, false if it did not exist in the first place. Example: Rose::DB->unregister_db(type => 'main', domain => 'test'); PARAMS B include values for both the C and C parameters since these two attributes are used to identify the data source. If either one is missing, a fatal error will occur. Unregistering a data source removes all knowledge of it. This may be harmful to any existing L objects that are associated with that data source. =item B Unregisters an entire domain. Returns true if the domain was unregistered successfully, false if it did not exist in the first place. Example: Rose::DB->unregister_domain('test'); Unregistering a domain removes all knowledge of all of the data sources that existed under it. This may be harmful to any existing L objects that are associated with any of those data sources. =item B This is a convenience method that is equivalent to the following call: Rose::DB->db_cache->use_cache_during_apache_startup(...) The boolean argument passed to this method is passed on to the call to the L's L method. Please read the L's L documentation for more information. =item B This method is used to give a class its own private L. In other words, this: __PACKAGE__->use_private_registry; is roughly equivalent to this: use Rose::DB::Registry; __PACKAGE__->registry(Rose::DB::Registry->new); =back =head1 CONSTRUCTORS =over 4 =item B Constructs a new object based on PARAMS, where PARAMS are name/value pairs. Any object method is a valid parameter name. Example: $db = Rose::DB->new(type => 'main', domain => 'qa'); If a single argument is passed to L, it is used as the C value: $db = Rose::DB->new(type => 'aux'); $db = Rose::DB->new('aux'); # same thing Each L object is associated with a particular data source, defined by the L and L values. If these are not part of PARAMS, then the default values are used. If you do not want to use the default values for the L and L attributes, you should specify them in the constructor PARAMS. The default L and L can be set using the L and L class methods. See the L<"Data Source Abstraction"> section for more information on data sources. Object attributes are set based on the L entry specified by the C and C parameters. This registry entry must exist or a fatal error will occur (with one exception; see below). Any additional PARAMS will override the values taken from the registry entry. If C and C parameters are not passed, but a C parameter is passed, then a new "empty" object will be returned. Examples: # This is ok, even if no registered data sources exist $db = Rose::DB->new(driver => 'sqlite'); The object returned by L will be derived from a database-specific driver class, chosen based on the L value of the selected data source. If there is no registered data source for the specified L and L, a fatal error will occur. The default driver-to-class mapping is as follows: pg -> Rose::DB::Pg mysql -> Rose::DB::MySQL informix -> Rose::DB::Informix oracle -> Rose::DB::Oracle sqlite -> Rose::DB::SQLite You can change this mapping with the L class method. =item B Constructs or returns a L object based on PARAMS, where PARAMS are any name/value pairs that can be passed to the L method. If the L's L method returns an existing L object that matches PARAMS, then it is returned. Otherwise, a L L object is created, L in the L, then returned. See the L documentation to learn about the cache API and the default implementation. =back =head1 OBJECT METHODS =over 4 =item B Attempt to start a transaction by calling the L method on the L database handle. If necessary, the database handle will be constructed and connected to the current data source. If this fails, undef is returned. If there is no registered data source for the current C and C, a fatal error will occur. If the "AutoCommit" database handle attribute is false, the handle is assumed to already be in a transaction and L (-1) is returned. If the call to L's L method succeeds, 1 is returned. If it fails, undef is returned. =item B Attempt to commit the current transaction by calling the L method on the L database handle. If the L database handle does not exist or is not connected, 0 is returned. If the "AutoCommit" database handle attribute is true, the handle is assumed to not be in a transaction and L (-1) is returned. If the call to L's L method succeeds, 1 is returned. If it fails, undef is returned. =item B Constructs and connects the L database handle for the current data source, calling L to create a new L database handle if none exists. If there is no registered data source for the current L and L, a fatal error will occur. If any L statement failed to execute, the database handle is disconnected and then discarded. If the database handle returned by L was originally connected by another L-derived object (e.g., if a subclass's custom implementation of L calls L's L method) then the L statements will not be run, nor will any custom L attributes be applied (e.g., L's L attribute). Returns true if the database handle was connected successfully and all L statements (if any) were run successfully, false otherwise. =item B Get or set a single connection option. Example: $val = $db->connect_option('RaiseError'); # get $db->connect_option(AutoCommit => 1); # set Connection options are name/value pairs that are passed in a hash reference as the fourth argument to the call to Lconnect()|DBI/connect>. See the L documentation for descriptions of the various options. =item B Get or set the L connect options hash. If a reference to a hash is passed, it replaces the connect options hash. If a series of name/value pairs are passed, they are added to the connect options hash. Returns a reference to the connect options has in scalar context, or a list of name/value pairs in list context. =item B Get or set the L database handle connected to the current data source. If the database handle does not exist or was created in another process or thread, this method will discard the old database handle (if any) and L will be called to create a new one. Returns undef if the database handle could not be constructed and connected. If there is no registered data source for the current C and C, a fatal error will occur. Note: when setting this attribute, you I pass in a L database handle that has the same L as the object. For example, if the L is C then the L database handle must be connected to a MySQL database. Passing in a mismatched database handle will cause a fatal error. =item B This method calls Lconnect(...)|DBI/connect>, passing all ARGS and returning all values. This method has no affect on the internal state of the object. Use the L method to create and store a new L in the object. Override this method in your L subclass if you want to use a different method (e.g. Lconnect_cached()|DBI/connect_cached>) to create database handles. =item B Decrements the reference count for the database handle and disconnects it if the reference count is zero and if the database handle was originally connected by this object. (This may not be the case if, say, a subclass's custom implementation of L calls L's L method.) Regardless of the reference count, it sets the L attribute to undef. Returns true if all L statements (if any) were run successfully and the database handle was disconnected successfully (or if it was simply set to undef), false otherwise. The database handle will not be disconnected if any L statement fails to execute, and the L is not run unless the handle is going to be disconnected. =item B Execute arbitrary code within a single transaction, rolling back if any of the code fails, committing if it succeeds. CODE should be a code reference. It will be called with any arguments passed to L after the code reference. Example: # Transfer $100 from account id 5 to account id 9 $db->do_transaction(sub { my($amt, $id1, $id2) = @_; my $dbh = $db->dbh or die $db->error; # Transfer $amt from account id $id1 to account id $id2 $dbh->do("UPDATE acct SET bal = bal - $amt WHERE id = $id1"); $dbh->do("UPDATE acct SET bal = bal + $amt WHERE id = $id2"); }, 100, 5, 9) or warn "Transfer failed: ", $db->error; If the CODE block threw an exception or the transaction could not be started and committed successfully, then undef is returned and the exception thrown is available in the L attribute. Otherwise, a true value is returned. =item B Get or set the error message associated with the last failure. If a method fails, check this attribute to get the reason for the failure in the form of a text message. =item B Returns true if the object has a L database handle (L), false if it does not. =item B Returns true if the specified table has a primary key (as determined by the L method), false otherwise. The arguments are the same as those for the L method: either a table name or name/value pairs specifying C, C, and C. The C and C parameters are optional and default to the return values of the L and L methods, respectively. See the documentation for the L for more information. =item B Return true if the L is currently in the middle of a transaction, false (but defined) if it is not. If no L exists, then undef is returned. =item B Initialize data source configuration information based on the current values of the L and L attributes by pulling data from the corresponding registry entry. If there is no registered data source for the current L and L, a fatal error will occur. L is called as part of the L and L methods. =item B Returns the name of the L statement handle attribute that contains the auto-generated unique key created during the last insert operation. Returns undef if the current data source does not support this attribute. =item B Get or set a boolean value that indicates whether or not any string that looks like a function call (matches C) will be treated as a "keyword" by the various L methods. Defaults to the value returned by the L class method. =item B Given a L statement handle, returns the value of the auto-generated unique key created during the last insert operation. This value may be undefined if this feature is not supported by the current data source. =item B Returns a list (in list context) or reference to an array (in scalar context) of tables in the database. The current L and L are honored. =item B Returns the column name NAME appropriately quoted for use in an SQL statement. (Note that "appropriate" quoting may mean no quoting at all.) =item B Decrements the reference count for the L database handle, if it exists. Returns 0 if the database handle does not exist. If the reference count drops to zero, the database handle is disconnected. Keep in mind that the L object itself will increment the reference count when the database handle is connected, and decrement it when L is called. Returns true if the reference count is not 0 or if all L statements (if any) were run successfully and the database handle was disconnected successfully, false otherwise. The database handle will not be disconnected if any L statement fails to execute, and the L is not run unless the handle is going to be disconnected. See the L<"Database Handle Life-Cycle Management"> section for more information on the retain/release system. =item B Returns the connected L database handle after incrementing the reference count. If the database handle does not exist or is not already connected, this method will do everything necessary to do so. Returns undef if the database handle could not be constructed and connected. If there is no registered data source for the current L and L, a fatal error will occur. See the L<"Database Handle Life-Cycle Management"> section for more information on the retain/release system. =item B Roll back the current transaction by calling the L method on the L database handle. If the L database handle does not exist or is not connected, 0 is returned. If the call to L's L method succeeds or if auto-commit is enabled, 1 is returned. If it fails, undef is returned. =back =head2 Data Source Configuration Not all databases will use all of these values. Values that are not supported are simply ignored. =over 4 =item B Get or set the value of the "AutoCommit" connect option and L handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "AutoCommit" attribute of the database handle if it exists, or the connect option otherwise. This method should not be mixed with the L method in calls to L or L since L will overwrite I the connect options with its argument, and neither L nor L guarantee the order that its parameters will be evaluated. =item B Get or set the database catalog name. This setting is only relevant to databases that support the concept of catalogs. =item B Get or set the options passed in a hash reference as the fourth argument to the call to Lconnect()|DBI/connect>. See the L documentation for descriptions of the various options. If a reference to a hash is passed, it replaces the connect options hash. If a series of name/value pairs are passed, they are added to the connect options hash. Returns a reference to the hash of options in scalar context, or a list of name/value pairs in list context. When L is called for the first time on an object (either in isolation or as part of the L process), the connect options are merged with the L. The defaults are overridden in the case of a conflict. Example: Rose::DB->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', connect_options => { RaiseError => 0, AutoCommit => 0, } ); # Rose::DB->default_connect_options are: # # AutoCommit => 1, # ChopBlanks => 1, # PrintError => 1, # RaiseError => 1, # Warn => 0, # The object's connect options are merged with default options # since new() will trigger the first call to init_db_info() # for this object $db = Rose::DB->new(domain => 'development', type => 'main'); # $db->connect_options are: # # AutoCommit => 0, # ChopBlanks => 1, # PrintError => 1, # RaiseError => 0, # Warn => 0, $db->connect_options(TraceLevel => 2); # Add an option # $db->connect_options are now: # # AutoCommit => 0, # ChopBlanks => 1, # PrintError => 1, # RaiseError => 0, # TraceLevel => 2, # Warn => 0, # The object's connect options are NOT re-merged with the default # connect options since this will trigger the second call to # init_db_info(), not the first $db->connect or die $db->error; # $db->connect_options are still: # # AutoCommit => 0, # ChopBlanks => 1, # PrintError => 1, # RaiseError => 0, # TraceLevel => 2, # Warn => 0, =item B Get or set the database name used in the construction of the DSN used in the L L call. =item B Get or set the data source domain. See the L<"Data Source Abstraction"> section for more information on data source domains. =item B Get or set the driver name. The driver name can only be set during object construction (i.e., as an argument to L) since it determines the object class. After the object is constructed, setting the driver to anything other than the same value it already has will cause a fatal error. Even in the call to L, setting the driver name explicitly is not recommended. Instead, specify the driver when calling L for each data source and allow the L to be set automatically based on the L and L. The driver names for the L are: pg mysql informix oracle sqlite Driver names should only use lowercase letters. =item B Get or set the L DSN (Data Source Name) passed to the call to L's L method. An attempt is made to parse the new DSN. Any parts successfully extracted are assigned to the corresponding L attributes (e.g., L, L, L). If no value could be extracted for an attribute, it is set to undef. If the DSN is never set explicitly, it is built automatically based on the relevant object attributes. If the DSN is set explicitly, but any of L, L, L, L, or L are also provided, either in an object constructor or when the data source is registered, the explicit DSN may be ignored as a new DSN is constructed based on these attributes. =item B Get or set the value of the "HandleError" connect option and L handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "HandleError" attribute of the database handle if it exists, or the connect option otherwise. This method should not be mixed with the L method in calls to L or L since L will overwrite I the connect options with its argument, and neither L nor L guarantee the order that its parameters will be evaluated. =item B Get or set the database server host name used in the construction of the DSN which is passed in the L L call. =item B Get or set the password that will be passed to the L L call. =item B Get or set the database server port number used in the construction of the DSN which is passed in the L L call. =item B Get or set the SQL statements that will be run immediately before disconnecting from the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. The SQL statements are run in the order that they are supplied in STATEMENTS. If any L statement fails when executed, the subsequent statements are ignored. =item B Get or set the SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. The SQL statements are run in the order that they are supplied in STATEMENTS. If any L statement fails when executed, the subsequent statements are ignored. =item B Returns a list (in list context) or reference to an array (in scalar context) of the names of the columns that make up the primary key for the specified table. If the table has no primary key, an empty list (in list context) or reference to an empty array (in scalar context) will be returned. The table may be specified in two ways. If one argument is passed, it is taken as the name of the table. Otherwise, name/value pairs are expected. Valid parameter names are: =over 4 =item C The name of the catalog that contains the table. This parameter is optional and defaults to the return value of the L method. =item C The name of the schema that contains the table. This parameter is optional and defaults to the return value of the L method. =item C
The name of the table. This parameter is required. =back Case-sensitivity of names is determined by the underlying database. If your database is case-sensitive, then you must pass names to this method with the expected case. =item B Get or set the value of the "PrintError" connect option and L handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "PrintError" attribute of the database handle if it exists, or the connect option otherwise. This method should not be mixed with the L method in calls to L or L since L will overwrite I the connect options with its argument, and neither L nor L guarantee the order that its parameters will be evaluated. =item B Get or set the value of the "RaiseError" connect option and L handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "RaiseError" attribute of the database handle if it exists, or the connect option otherwise. This method should not be mixed with the L method in calls to L or L since L will overwrite I the connect options with its argument, and neither L nor L guarantee the order that its parameters will be evaluated. =item B Get or set the database schema name. This setting is only useful to databases that support the concept of schemas (e.g., PostgreSQL). =item B Get or set the time zone used by the database server software. TZ should be a time zone name that is understood by L. The default value is "floating". See the L documentation for acceptable values of TZ. =item B Get or set the data source type. See the L<"Data Source Abstraction"> section for more information on data source types. =item B Get or set the username that will be passed to the L L call. =back =head2 Value Parsing and Formatting =over 4 =item B Converts the L object BITS into the appropriate format for the "bitfield" data type of the current data source. If a SIZE argument is provided, the bit field will be padded with the appropriate number of zeros until it is SIZE bits long. If the data source does not have a native "bit" or "bitfield" data type, a character data type may be used to store the string of 1s and 0s returned by the default implementation. =item B Converts VALUE into the appropriate format for the "boolean" data type of the current data source. VALUE is simply evaluated in Perl's scalar context to determine if it's true or false. =item B Converts the L object DATETIME into the appropriate format for the "date" (month, day, year) data type of the current data source. =item B Converts the L object DATETIME into the appropriate format for the "datetime" (month, day, year, hour, minute, second) data type of the current data source. =item B Converts the L object DURATION into the appropriate format for the interval (years, months, days, hours, minutes, seconds) data type of the current data source. If DURATION is undefined, a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. =item B Converts the L object TIMECLOCK into the appropriate format for the time (hour, minute, second, fractional seconds) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source. =item B Converts the L object DATETIME into the appropriate format for the timestamp (month, day, year, hour, minute, second, fractional seconds) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source. =item B Converts the L object DATETIME into the appropriate format for the timestamp with time zone (month, day, year, hour, minute, second, fractional seconds, time zone) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source. =item B Parse BITS and return a corresponding L object. If SIZE is not passed, then it defaults to the number of bits in the parsed bit string. If BITS is a string of "1"s and "0"s or matches C, then the "1"s and "0"s are parsed as a binary string. If BITS is a string of numbers, at least one of which is in the range 2-9, it is assumed to be a decimal (base 10) number and is converted to a bitfield as such. If BITS matches any of these regular expressions: /^0x/ /^X'.*'$/ /^[0-9a-f]+$/ it is assumed to be a hexadecimal number and is converted to a bitfield as such. Otherwise, undef is returned. =item B Parse STRING and return a boolean value of 1 or 0. STRING should be formatted according to the data source's native "boolean" data type. The default implementation accepts 't', 'true', 'y', 'yes', and '1' values for true, and 'f', 'false', 'n', 'no', and '0' values for false. If STRING is a valid boolean keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "boolean" value. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "date" (month, day, year) data type. If STRING is a valid date keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "date" value. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "datetime" (month, day, year, hour, minute, second) data type. If STRING is a valid datetime keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "datetime" value. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "interval" (years, months, days, hours, minutes, seconds) data type. If STRING is a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Otherwise, undef is returned if STRING could not be parsed as a valid "interval" value. This optional MODE argument determines how math is done on duration objects. If defined, the C setting for each L object created by this column will have its mode set to MODE. Otherwise, the C parameter will not be passed to the L constructor. Valid modes are C, C, and C. See the documentation for L for a full explanation. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "time" (hour, minute, second, fractional seconds) data type. If STRING is a valid time keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "time" value. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "timestamp" (month, day, year, hour, minute, second, fractional seconds) data type. Fractional seconds are optional, and the acceptable precision may vary depending on the data source. If STRING is a valid timestamp keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "timestamp" value. =item B Parse STRING and return a L object. STRING should be formatted according to the data source's native "timestamp with time zone" (month, day, year, hour, minute, second, fractional seconds, time zone) data type. Fractional seconds are optional, and the acceptable precision may vary depending on the data source. If STRING is a valid timestamp keyword (according to L) or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "timestamp with time zone" value. =item B Returns true if STRING is a valid keyword for the "boolean" data type of the current data source, false otherwise. The default implementation accepts the values "TRUE" and "FALSE". =item B Returns true if STRING is a valid keyword for the "date" (month, day, year) data type of the current data source, false otherwise. The default implementation always returns false. =item B Returns true if STRING is a valid keyword for the "datetime" (month, day, year, hour, minute, second) data type of the current data source, false otherwise. The default implementation always returns false. =item B Returns true if STRING is a valid keyword for the "interval" (years, months, days, hours, minutes, seconds) data type of the current data source, false otherwise. The default implementation always returns false. =item B Returns true if STRING is a valid keyword for the "time" (hour, minute, second, fractional seconds) data type of the current data source, false otherwise. The default implementation always returns false. =item B Returns true if STRING is a valid keyword for the "timestamp" (month, day, year, hour, minute, second, fractional seconds) data type of the current data source, false otherwise. The default implementation always returns false. =back =head1 DEVELOPMENT POLICY The L applies to this, and all C modules. Please install L from CPAN and then run "C" for more information. =head1 SUPPORT Any L questions or problems can be posted to the L mailing list. (If the volume ever gets high enough, I'll create a separate list for L, but it isn't an issue right now.) To subscribe to the list or view the archives, go here: L Although the mailing list is the preferred support mechanism, you can also email the author (see below) or file bugs using the CPAN bug tracking system: L There's also a wiki and other resources linked from the Rose project home page: L =head1 CONTRIBUTORS Kostas Chatzikokolakis, Peter Karman, Brian Duggan, Lucian Dragus, Ask Bjørn Hansen, Sergey Leschenko, Ron Savage =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Cache/000750 000765 000024 00000000000 12502143063 015767 5ustar00johnstaff000000 000000 Rose-DB-0.777/lib/Rose/DB/Cache.pm000644 000765 000024 00000042411 12502134373 016340 0ustar00johnstaff000000 000000 package Rose::DB::Cache; use strict; use base 'Rose::Object'; use Scalar::Util qw(refaddr); use Rose::DB::Cache::Entry; our $VERSION = '0.755'; our $Debug = 0; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => [ 'entry_class', '_default_use_cache_during_apache_startup', ], ); __PACKAGE__->entry_class('Rose::DB::Cache::Entry'); __PACKAGE__->default_use_cache_during_apache_startup(0); our($MP2_Is_Child, $Apache_Has_Started); sub default_use_cache_during_apache_startup { my($class) = shift; return $class->_default_use_cache_during_apache_startup($_[0] ? 1 : 0) if(@_); return $class->_default_use_cache_during_apache_startup; } sub use_cache_during_apache_startup { my($self) = shift; return $self->{'use_cache_during_apache_startup'} = $_[0] ? 1 : 0 if(@_); if(defined $self->{'use_cache_during_apache_startup'}) { return $self->{'use_cache_during_apache_startup'}; } else { return $self->{'use_cache_during_apache_startup'} = ref($self)->default_use_cache_during_apache_startup; } } sub prepare_for_apache_fork { my($self) = shift; foreach my $entry ($self->db_cache_entries) { if($entry->created_during_apache_startup) { my $db = $entry->db; $Debug && warn "$$ Disconnecting and undef-ing ", $db->dbh, " contained in $db"; $db->dbh->disconnect; $db->dbh(undef); $db = undef; $Debug && warn "$$ Deleting cache entry for $db"; delete $self->{'cache'}{$entry->key}; } } } sub build_cache_key { my($class, %args) = @_; return join("\0", $args{'domain'}, $args{'type'}); } QUIET: { no warnings 'uninitialized'; use constant MOD_PERL_1 => ($ENV{'MOD_PERL'} && !$ENV{'MOD_PERL_API_VERSION'}) ? 1 : 0; use constant MOD_PERL_2 => ($ENV{'MOD_PERL'} && $ENV{'MOD_PERL_API_VERSION'} == 2) ? 1 : 0; use constant APACHE_DBI => ($INC{'Apache/DBI.pm'} || $Apache::DBI::VERSION) ? 1 : 0; use constant APACHE_DBI_MP2 => (APACHE_DBI && MOD_PERL_2) ? 1 : 0; use constant APACHE_DBI_MP1 => (APACHE_DBI && MOD_PERL_1) ? 1 : 0; } sub db_cache_entries { my($self) = shift; return wantarray ? values %{$self->{'cache'} || {}} : [ values %{$self->{'cache'} || {}} ]; } sub db_cache_keys { my($self) = shift; return wantarray ? keys %{$self->{'cache'} || {}} : [ keys %{$self->{'cache'} || {}} ]; } sub get_db { my($self) = shift; my $key = $self->build_cache_key(@_); if(my $entry = $self->{'cache'}{$key}) { if(my $db = $entry->db) { $self->prepare_db($db, $entry); return $db; } } return undef; } sub set_db { my($self, $db) = @_; my $key = $self->build_cache_key(domain => $db->domain, type => $db->type, db => $db); my $entry = ref($self)->entry_class->new(db => $db, key => $key); # Don't cache anything during apache startup if use_cache_during_apache_startup # is false. Weird conditional structure is meant to encourage code elimination # thanks to the lone constants in the if/elsif conditions. if(MOD_PERL_1) { if($Apache::Server::Starting) { if($self->use_cache_during_apache_startup) { $entry->created_during_apache_startup(1); $entry->prepared(0); } else { $Debug && warn "Refusing to cache $db during apache server start-up ", "because use_cache_during_apache_startup is false"; return $db; } } } if(MOD_PERL_2) { if(!$MP2_Is_Child) { if($self->use_cache_during_apache_startup) { $entry->created_during_apache_startup(1); $entry->prepared(0); } else { $Debug && warn "Refusing to cache $db in pre-fork apache process ", "because use_cache_during_apache_startup is false"; return $db; } } } $self->{'cache'}{$key} = $entry; return $db; } sub clear { shift->{'cache'} = {} } if(MOD_PERL_2) { require Apache2::ServerUtil; require Apache2::RequestUtil; require Apache2::Const; Apache2::Const->import(-compile => qw(OK)); $MP2_Is_Child = 0; if(__PACKAGE__->apache_has_started) { $Debug && warn "$$ is already MP2 child (not registering child init handler)\n"; $MP2_Is_Child = 1; } elsif(!$ENV{'ROSE_DB_NO_CHILD_INIT_HANDLER'}) { Apache2::ServerUtil->server->push_handlers( PerlChildInitHandler => \&__mod_perl_2_rose_db_child_init_handler); } } # http://mail-archives.apache.org/mod_mbox/perl-dev/200504.mbox/%3C4256B5FF.5060401@stason.org%3E # To work around this issue, we'll use a named subroutine. sub __mod_perl_2_rose_db_child_init_handler { $Debug && warn "$$ is MP2 child\n"; $MP2_Is_Child = 1; return Apache2::Const::OK(); } sub apache_has_started { my($class) = shift; if(@_) { return $Apache_Has_Started = $_[0] ? 1 : 0; } return $Apache_Has_Started if(defined $Apache_Has_Started); if(MOD_PERL_2) { return $Apache_Has_Started = $MP2_Is_Child; } if(MOD_PERL_1) { return $Apache_Has_Started = $Apache::Server::Starting; } return undef; } sub prepare_db { my($self, $db, $entry) = @_; if(MOD_PERL_1) { if($Apache::Server::Starting) { $entry->created_during_apache_startup(1); $entry->prepared(0); } elsif(!$entry->is_prepared) { if($entry->created_during_apache_startup) { if($db->has_dbh) { $Debug && warn "$$ Disconnecting and undef-ing dbh ", $db->dbh, " created during apache startup from $db\n"; my $error; TRY: { local $@; eval { $db->dbh->disconnect }; # will probably fail! $error = $@; } warn "$$ Could not disconnect dbh created during apache startup: ", $db->dbh, " - $error" if($error); $db->dbh(undef); } $entry->created_during_apache_startup(0); } Apache->push_handlers(PerlCleanupHandler => sub { $Debug && warn "$$ Clear dbh and prepared flag for $db, $entry\n"; $db->dbh(undef) if($db); $entry->prepared(0) if($entry); }); $entry->prepared(1); } } # Not a chained elsif to help Perl eliminate the unused code (maybe unnecessary?) if(MOD_PERL_2) { if(!$MP2_Is_Child) { $entry->created_during_apache_startup(1); $entry->prepared(0); } elsif(!$entry->is_prepared) { if($entry->created_during_apache_startup) { if($db->has_dbh) { $Debug && warn "$$ Disconnecting and undef-ing dbh ", $db->dbh, " created during apache startup from $db\n"; my $error; TRY: { local $@; eval { $db->dbh->disconnect }; # will probably fail! $error = $@; } warn "$$ Could not disconnect dbh created during apache startup: ", $db->dbh, " - $error" if($error); $db->dbh(undef); } $entry->created_during_apache_startup(0); } my($r, $error); TRY: { local $@; eval { $r = Apache2::RequestUtil->request }; $error = $@; } if($error) { $Debug && warn "Couldn't get apache request (restart count is ", Apache2::ServerUtil::restart_count(), ") - $error\n"; $entry->created_during_apache_startup(1); # tag for cleanup $entry->prepared(0); return; } else { $r->push_handlers(PerlCleanupHandler => sub { $Debug && warn "$$ Clear dbh and prepared flag for $db, $entry\n"; $db->dbh(undef) if($db); $entry->prepared(0) if($entry); return Apache2::Const::OK(); }); } $entry->prepared(1); } } } 1; __END__ =head1 NAME Rose::DB::Cache - A mod_perl-aware cache for Rose::DB objects. =head1 SYNOPSIS # Usage package My::DB; use base 'Rose::DB'; ... $cache = My::DB->db_cache; $db = $cache->get_db(...); $cache->set_db($db); $cache->clear; # Subclassing package My::DB::Cache; use Rose::DB::Cache; our @ISA = qw(Rose::DB::Cache); # Override methods as desired sub get_db { ... } sub set_db { ... } sub prepare_db { ... } sub build_cache_key { ... } sub clear { ... } ... =head1 DESCRIPTION L provides both an API and a default implementation of a caching system for L objects. Each L-derived class L a L-derived object to which it delegates cache-related activities. See the L method for an example. The default implementation caches and returns L objects using the combination of their L and L as the cache key. There is no cache expiration or other cache cleaning. The only sophistication in the default implementation is that it is L- and L-aware. When running under mod_perl, with or without L, the L attribute of each cached L object is set to C at the end of each request. Additionally, any db connections made in a pre-fork parent apache process are not cached. When running under L, the behavior described above will ensure that L's "ping" and rollback features work as expected, keeping the L database handles L within each L object connected and alive. When running under mod_perl I L, the behavior described above will use a single L database connection per cached L object per request, but will discard these connections at the end of each request. Both mod_perl 1.x and 2.x are supported. Under mod_perl 2.x, you should load L on server startup (e.g., in your C file). If this is not possible, then you must explicitly tell L that apache has started up already by setting L to a true value. Subclasses can override any and all methods described below in order to implement their own caching strategy. =head1 CLASS METHODS =over 4 =item B Get or set a boolean value indicating whether or not apache has completed its startup process. If this value is not set explicitly, a best guess as to the answer will be returned. =item B Given the name/value pairs PARAMS, return a string representing the corresponding cache key. Calls to this method from within L will include at least C and C parameters, but you may pass any parameters if you override all methods that call this method in your subclass. =item B Get or set a boolean value that determines the default value of the L object attribute. The default value is false. See the L documentation for more information. =item B Get or set the name of the L-derived class used to store cached L objects on behalf of this class. The default value is L. =back =head1 CONSTRUCTORS =over 4 =item B Constructs a new L object based on PARAMS, where PARAMS are name/value pairs. Any object method is a valid parameter name. =back =head1 OBJECT METHODS =over 4 =item B Clear the cache entirely. =item B Returns a list (in list context) or reference to an array (in scalar context) of L for each cached db object. =item B Returns a list (in list context) or reference to an array (in scalar context) of L for each L . =item B Return the cached L-derived object corresponding to the name/value pairs passed in PARAMS. PARAMS are passed to the L method, and the key returned is used to look up the cached object. If a cached object is found, the L method is called, passing the cached db object and its corresponding L object as arguments. The cached db object is then returned. If no such object exists in the cache, undef is returned. =item B Prepares the cache for the initial fork of the apache parent process by L all database handles and deleting all cache entries that were L. This call is only necessary if running under L I L set set to true. See the L documentation for more information. =item B Prepare the cached L-derived object DB for usage. The cached's db object's L object, ENTRY, is also passed. When I running under L, this method does nothing. When running under L (version 1.x or 2.x), this method will do the following: =over 4 =item * Any L database handle created inside a L object during apache server startup will be L as such. Any attempt to use such an object after the apache startup process has completed (i.e., in a child apache process) will cause it to be discarded and replaced. Note that you usually don't want it to come to this. It's better to cleanly disconnect all such database handles before the first apache child forks off. See the documentation for the L and L methods for more information. =item * All L database handles contained in cached L objects will be cleared at the end of each request using a C. This will cause Lconnect|DBI/connect> to be called the next time a L is requested from a cached L object, which in turn will trigger L's ping mechanism to ensure that the database handle is fresh. =back Putting all the pieces together, the following implementation of the L method in your L-derived common base class will ensure that database connections are shared and fresh under L and (optionally) L, but I elsewhere: package My::DB::Object; use base 'Rose::DB::Object'; use My::DB; # isa Rose::DB ... BEGIN: { if($ENV{'MOD_PERL'}) { *init_db = sub { My::DB->new_or_cached }; } else # act "normally" when not under mod_perl { *init_db = sub { My::DB->new }; } } =item B Add the L-derived object DB to the cache. The DB's L, L, and the db object itself (under the parameter name C) are all are passed to the L method and the DB object is stored under the key returned. If running under L I the apache server is starting up I L is set to true, then the DB object is I added to the cache, but merely returned. =item B Get or set a boolean value that determines whether or not to cache database objects during the apache server startup process. The default value is determined by the L class method. L database handles created in the parent apache process cannot be used in child apache processes. Furthermore, in the case of at least L one L, you must I ensure that any database handles created in the apache parent process during server startup are properly L I you fork off the first apache child. Failure to do so may cause segmentation faults(!) in child apache processes. The upshot is that if L is set to true, you should call L at the very end of the apache startup process (i.e., once all other Perl modules have been loaded and all other Perl code has run). This is usually done by placing a call at the bottom of the traditional C file. Assuming C is your L-derived class: My::DB->db_cache->prepare_for_apache_fork(); A L exists in L as well, which simply translates into call shown above: My::DB->prepare_cache_for_apache_fork(); =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Constants.pm000755 000765 000024 00000002042 12502134373 017310 0ustar00johnstaff000000 000000 package Rose::DB::Constants; use strict; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(IN_TRANSACTION); use constant IN_TRANSACTION => -1; 1; __END__ =head1 NAME Rose::DB::Constants - Symbolic names for important Rose::DB constants. =head1 SYNOPSIS use Rose::DB::Constants qw(IN_TRANSACTION); ... $ret = $db->begin_work or die $db->error; ... unless($ret == IN_TRANSACTION) { $db->commit or die $db->error; } =head1 DESCRIPTION This module contains and optionally exports symbolic names for important L constants. The only constant defined so far is C. See the documentation for L's C object method for more information on this constant. This module inherits from C. No symbols are exported by default. =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Generic.pm000755 000765 000024 00000004242 12502134373 016714 0ustar00johnstaff000000 000000 package Rose::DB::Generic; use strict; use Rose::DB; our $VERSION = '0.11'; # # Object methods # sub build_dsn { my($self_or_class, %args) = @_; my %info; $info{'dbname'} = $args{'db'} || $args{'database'}; $info{'host'} = $args{'host'}; $info{'port'} = $args{'port'}; return "dbi:$args{'dbi_driver'}:" . join(';', map { "$_=$info{$_}" } grep { defined $info{$_} } qw(dbname host port)); } sub last_insertid_from_sth { } 1; __END__ =head1 NAME Rose::DB::Generic - Generic driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db( dsn => 'dbi:SomeDB:...', # unknown driver username => 'devuser', password => 'mysecret', ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... $db = Rose::DB->new; # $db is really a Rose::DB::Generic object ... =head1 DESCRIPTION This is the subclass that L blesses an object into (by default) when the L specified in the registry entry is has no class name registered in the L. To maximize the chance that this class will work with an unsupported database, do the following. =over 4 =item * Use a L name that exactly matches the L "DBD::..." driver name. Even though L Ls are case-insensitive, using the exact spelling and letter case will allow this generic L driver to connect successfully. =item * Specify the DSN explicitly rather than providing the pieces separately (host, database, port, etc.) and then relying upon this class to assemble them into L DSN. This class will assemble a DSN, but it may not be in the format that an unsupported driver expects. =back This class inherits from L. See the L documentation for information on the inherited methods. =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Informix.pm000755 000765 000024 00000077154 12502134373 017147 0ustar00johnstaff000000 000000 package Rose::DB::Informix; use strict; use Rose::DateTime::Util(); our $VERSION = '0.774'; our $Debug = 0; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => [ 'max_array_characters', 'default_supports_limit_with_offset', ], ); __PACKAGE__->max_array_characters(255); # # Object methods # sub build_dsn { my($self_or_class, %args) = @_; return "dbi:Informix:" . ($args{'db'} || $args{'database'}); } sub last_insertid_from_sth { $_[1]->{'ix_sqlerrd'}[1] || $_[1]->{'ix_serial8'} } sub likes_lowercase_table_names { 1 } sub generate_primary_key_values { return; } # old perls seem to like this... sub generate_primary_key_placeholders { (@_ == 1 || (@_ > 1 && $_[1] == 1)) ? 0 : ((undef) x $_[1]) } # Informix doesn't like anything to be quoted and appears to # accept everything without quotes. sub is_reserved_word { 0 } sub refine_dbi_column_info { my($self, $col_info, $meta) = @_; my $method = ref($self)->parent_class . '::refine_dbi_column_info'; no strict 'refs'; $self->$method($col_info); my $type_name = $col_info->{'TYPE_NAME'}; # Handle "INT8" big integers if($type_name eq 'int' && $col_info->{'informix_collength'} == 10) { $col_info->{'TYPE_NAME'} = 'bigint'; } return; } # Boolean formatting and parsing sub format_boolean { $_[1] ? 't' : 'f' } sub parse_boolean { my($self, $value) = @_; return $value if($self->validate_boolean_keyword($_[1]) || ($self->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); return 1 if($value =~ /^[t1]$/i); return 0 if($value =~ /^[f0]$/i); $self->error("Invalid boolean value: '$value'"); return undef; } # Date formatting sub format_date { return $_[1] if($_[0]->validate_date_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%m/%d/%Y'); } sub format_datetime { return $_[1] if($_[0]->validate_datetime_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%Y-%m-%d %H:%M:%S'); } sub format_datetime_year_to_second { return $_[1] if($_[0]->validate_datetime_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%Y-%m-%d %H:%M:%S'); } sub format_datetime_year_to_minute { return $_[1] if($_[0]->validate_datetime_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%Y-%m-%d %H:%M'); } sub format_datetime_year_to_month { return $_[1] if($_[0]->validate_datetime_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%Y-%m'); } # sub format_time # { # return $_[1] if($_[0]->validate_time_keyword($_[1])); # return Rose::DateTime::Util::format_date($_[1], '%H:%M:%S'); # } sub format_timestamp { return $_[1] if($_[0]->validate_timestamp_keyword($_[1])); return Rose::DateTime::Util::format_date($_[1], '%Y-%m-%d %H:%M:%S.%5N'); } sub format_datetime_year_to_fraction { my($self, $dt, $fraction) = @_; $fraction ||= 3; return $dt if($self->validate_datetime_year_to_fraction_keyword($dt)); return Rose::DateTime::Util::format_date($dt, "%Y-%m-%d %H:%M:%S.%${fraction}N"); } sub format_datetime_year_to_fraction_1 { format_datetime_year_to_fraction(@_, 1) } sub format_datetime_year_to_fraction_2 { format_datetime_year_to_fraction(@_, 2) } sub format_datetime_year_to_fraction_3 { format_datetime_year_to_fraction(@_, 3) } sub format_datetime_year_to_fraction_4 { format_datetime_year_to_fraction(@_, 4) } sub format_datetime_year_to_fraction_5 { format_datetime_year_to_fraction(@_, 5) } # Date parsing sub parse_date { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_date_keyword($value)) { return $value; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse date '$value' - $error"); return undef; } return $dt; } sub parse_datetime { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_keyword($value)) { return $value; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime '$value' - $error"); return undef; } return $dt; } sub parse_datetime_year_to_second { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_year_to_second_keyword($value)) { return $value; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime year to second '$value' - $error"); return undef; } $dt->truncate(to => 'second') if(ref $dt); return $dt; } sub parse_datetime_year_to_fraction { my($self, $arg, $fraction) = @_; return $arg if($self->validate_datetime_year_to_fraction_keyword($arg)); $fraction ||= 3; my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($arg) }; $error = $@; } if($error) { $self->error("Could not parse datetime year to fraction '$arg' - $error"); return undef; } if(ref $dt) { # Truncate nanosecs to correct fraction. (Yes, using strings. I am lame.) my $n = sprintf('%09d', $dt->nanosecond); $n = substr($n, 0, $fraction); if(length $n < 9) { $n .= ('0' x (9 - length $n)); } $dt->set_nanosecond($n); } return $dt; } *parse_datetime_year_to_fraction_1 = sub { parse_datetime_year_to_fraction(@_, 1) }; *parse_datetime_year_to_fraction_2 = sub { parse_datetime_year_to_fraction(@_, 2) }; *parse_datetime_year_to_fraction_3 = sub { parse_datetime_year_to_fraction(@_, 3) }; *parse_datetime_year_to_fraction_4 = sub { parse_datetime_year_to_fraction(@_, 4) }; *parse_datetime_year_to_fraction_5 = sub { parse_datetime_year_to_fraction(@_, 5) }; sub parse_datetime_year_to_minute { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_year_to_minute_keyword($value)) { return $value; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime year to minute '$value' - $error"); return undef; } $dt->truncate(to => 'minute') if(ref $dt); return $dt; } sub parse_datetime_year_to_month { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_year_to_month_keyword($value)) { return $value; } if($value =~ m{^(\d\d?)/(\d{4})$}) { # Add day to MM/YYYY $value = "$1/01/$2"; } elsif($value =~ /^\d{4}-\d\d$/) { # Append day to YYYY-MM $value .= '-01'; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime year to month '$value' - $error"); return undef; } $dt->truncate(to => 'month') if(ref $dt); return $dt; } sub parse_timestamp { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_timestamp_keyword($value)) { return $value; } my($error, $dt); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse timestamp '$value' - $error"); return undef; } return $dt; } sub validate_date_keyword { no warnings; $_[1] =~ /^(?:current|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_time_keyword { no warnings; lc $_[1] eq 'current' || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_timestamp_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:fraction(?:\([1-5]\))?|second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_datetime_year_to_fraction_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:fraction(?:\([1-5]\))?|second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_datetime_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_datetime_year_to_second_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_datetime_year_to_minute_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_datetime_year_to_month_keyword { no warnings; $_[1] =~ /^(?:current(?: +year +to +(?:second|minute|hour|day|month))?|today)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub should_inline_date_keyword { 1 } sub should_inline_datetime_keyword { 1 } sub should_inline_time_keyword { 1 } sub should_inline_timestamp_keyword { 1 } sub parse_set { my($self) = shift; return $_[0] if(ref $_[0] eq 'ARRAY'); if(@_ > 1 && !ref $_[1]) { pop(@_); return [ @_ ]; } my $val = $_[0]; return undef unless(defined $val); my $options = ref $_[-1] eq 'HASH' ? $_[-1] : {}; no warnings 'uninitialized'; my $numeric = ($options->{'value_type'} =~ /^(?:(?:big)?(?:float|int(?:eger)?|num(?:eric)?)|decimal)$/i) ? 1 : 0; return undef unless(defined $val); $val =~ s/^SET\{(.*)\}$/$1/; my @set; while($val =~ s/(?:'((?:[^'\\]+|\\.)*)'|([^',]+))(?:,|$)//) { push(@set, (defined $1) ? $1 : $2); if($numeric) { $set[-1] =~ s/\s+//g; } } return \@set; } sub format_set { my($self) = shift; my @set = (ref $_[0]) ? @{$_[0]} : @_; return undef unless(@set && defined $set[0]); return 'SET{' . join(',', map { if(!defined $_) { Carp::croak 'Undefined value found in array or list passed to ', __PACKAGE__, '::format_set()'; } elsif(/^[-+]?\d+(?:\.\d*)?$/) { $_ } else { s/\\/\\\\/g; s/'/\\'/g; qq('$_') } } @set) . '}'; } sub parse_array { my($self) = shift; return $_[0] if(ref $_[0]); return [ @_ ] if(@_ > 1); my $val = $_[0]; return undef unless(defined $val); $val =~ s/^\{(.*)\}$/$1/; my @array; while($val =~ s/(?:"((?:[^"\\]+|\\.)*)"|([^",]+))(?:,|$)//) { push(@array, (defined $1) ? $1 : $2); } return \@array; } sub format_array { my($self) = shift; my @array = (ref $_[0]) ? @{$_[0]} : @_; return undef unless(@array && defined $array[0]); my $str = '{' . join(',', map { if(!defined $_) { Carp::croak 'Undefined value found in array or list passed to ', __PACKAGE__, '::format_array()'; } elsif(/^[-+]?\d+(?:\.\d*)?$/) { $_ } else { s/\\/\\\\/g; s/"/\\"/g; qq("$_") } } @array) . '}'; if(length($str) > $self->max_array_characters) { Carp::croak "Array string is longer than ", ref($self), "->max_array_characters (", $self->max_array_characters, ") characters long: $str"; } return $str; } sub next_value_in_sequence { my($self, $seq) = @_; my $dbh = $self->dbh or return undef; my($error, $id); TRY: { local $@; eval { my $sth = $dbh->prepare(qq(SELECT nextval('$seq'))); $sth->execute; $id = ${$sth->fetchrow_arrayref}[0]; }; $error = $@; } if($error) { $self->error("Could not get the next value in the sequence '$seq' - $error"); return undef; } return $id; } use constant VERSION_SQL => q(SELECT FIRST 1 DBINFO('version', 'major') from 'informix'.systables); our %Major_Version_Cache; use constant MAX_TO_CACHE => 500; sub supports_limit_with_offset { my($self) = shift; my $ok = ref($self)->default_supports_limit_with_offset; return $ok if(defined $ok); my $dbh = $self->dbh or return 0; unless(defined $Major_Version_Cache{$dbh}) { my $version; TRY: { local $@; eval { $Debug && warn VERSION_SQL, "\n"; my $sth = $dbh->prepare(VERSION_SQL); $sth->execute; ($version) = $sth->fetchrow_array; }; # Intentionally ignore any errors } %Major_Version_Cache = () if(keys %Major_Version_Cache > MAX_TO_CACHE); $Major_Version_Cache{$dbh} = $version || 0; } return $Major_Version_Cache{$dbh} >= 10 ? 1 : 0; return 0; } sub format_limit_with_offset { my($self, $limit, $offset, $args) = @_; delete $args->{'limit'}; delete $args->{'offset'}; if(defined $offset) { $args->{'limit_prefix'} = "SKIP $offset FIRST $limit"; } else { $args->{'limit_prefix'} = "FIRST $limit"; } } sub supports_select_from_subselect { 0 } # can't handle serial columns in multiset sub format_select_from_subselect { "\nTABLE(MULTISET(($_[1])))\n " } sub format_select_start_sql { my($self, $hints) = @_; return 'SELECT' unless($hints); my $comment = join(' ', ($hints->{'comment'} ? $hints->{'comment'} : ()), (map { $hints->{$_} ? uc("+$_") : () } qw(first_rows all_rows))); return "SELECT {$comment}"; } # # Introspection # sub list_tables { my($self, %args) = @_; my(@tables, $error); TRY: { local $@; eval { my $dbh = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; my @table_info = $dbh->func('user', '_tables'); my $schema = $self->schema; #if($args{'include_views'}) #{ # my @view_info = $dbh->func('view', '_tables'); # push(@table_info, @view_info); #} my %seen; foreach my $item (@table_info) { # From DBD::Informix::Metadata: # # The owner name will be enclosed in double quotes; if it contains # double quotes, those will be doubled up as required by SQL. The # table name will only be enclosed in double quotes if it is not a # valid C identifier (meaning, it starts with an alphabetic # character or underscore, and continues with alphanumeric # characters or underscores). If it is enclosed in double quotes, # any embedded double quotes are doubled up. # # "jsiracusa ".test if($item =~ /^(?: "((?:""|[^"]+)+)" | ([^"]+) ) \. (?: "((?:""|[^"]+)+)" | ([^"]+) )$/x) { my $user = defined $1 ? $1 : $2; my $table = defined $3 ? $3 : $4; for($user, $table) { s/""/"/g; } next if($seen{$table}++); if(!defined $schema || $schema eq $user) { push(@tables, $table); } } else { Carp::carp "Could not parse table information: $item"; } } }; $error = $@; } if($error) { Carp::croak "Could not list tables from ", $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } sub _get_primary_key_column_names { my($self, $catalog, $schema, $table_arg) = @_; require DBD::Informix::Metadata; my $dbh = $self->dbh or die $self->error; local $dbh->{'FetchHashKeyName'} = 'NAME'; # We need the table owner. Asking for column information is the only # way I know of to reliably get this information. # # Informix does not support DBI's column_info() method so we have # to get all that into "the hard way." # # Each item in @col_list is a reference to an array of values: # # 0 owner name # 1 table name # 2 column number # 3 column name # 4 data type (encoded) # 5 data length (encoded) # my @col_list = DBD::Informix::Metadata::ix_columns($dbh, $table_arg); my $owner = $col_list[0][0]; my $table = $col_list[0][1]; # just in case... unless(defined $owner) { #die "Could not find owner for table ", $table; # Failure to find an owner is sometimes caused by # DBD::Informix::Metadata's annoying habit of returning # sequences along with the list of tables. So we'll just # say that it has no primary key columns. return []; } # Then comes this monster query to get the primary key column names. # I'd love to know a better/easier way to do this... my $pk_sth = $dbh->prepare(<<'EOF'); SELECT col.colname FROM informix.sysconstraints con, informix.systables tab, informix.sysindexes idx, informix.syscolumns col WHERE constrtype = 'P' AND con.tabid = tab.tabid AND con.tabid = idx.tabid AND con.tabid = col.tabid AND con.idxname = idx.idxname AND ( col.colno = idx.part1 OR col.colno = idx.part2 OR col.colno = idx.part3 OR col.colno = idx.part4 OR col.colno = idx.part5 OR col.colno = idx.part6 OR col.colno = idx.part7 OR col.colno = idx.part8 OR col.colno = idx.part9 OR col.colno = idx.part10 OR col.colno = idx.part11 OR col.colno = idx.part12 OR col.colno = idx.part13 OR col.colno = idx.part14 OR col.colno = idx.part15 OR col.colno = idx.part16 ) AND tab.tabname = ? AND tab.owner = ? EOF $pk_sth->execute($table, $owner); my(@columns, $column); $pk_sth->bind_columns(\$column); while($pk_sth->fetch) { push(@columns, $column); } return \@columns; } 1; __END__ =head1 NAME Rose::DB::Informix - Informix driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db( domain => 'development', type => 'main', driver => 'Informix', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', server_time_zone => 'UTC', ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... # Set max length of varchar columns used to emulate the array data type Rose::DB::Informix->max_array_characters(128); $db = Rose::DB->new; # $db is really a Rose::DB::Informix-derived object $dt = $db->parse_datetime_year_to_minute(...); $val = $db->format_datetime_year_to_minute($dt); $dt = $db->parse_datetime_year_to_second(...); $val = $db->format_datetime_year_to_second($dt); ... =head1 DESCRIPTION L blesses objects into a class derived from L when the L is "informix". This mapping of driver names to class names is configurable. See the documentation for L's L and L methods for more information. This class cannot be used directly. You must use L and let its L method return an object blessed into the appropriate class for you, according to its L mappings. Only the methods that are new or have different behaviors than those in L are documented here. See the L documentation for the full list of methods. =head1 CLASS METHODS =over 4 =item B Get or set a boolean value that indicates whether or not all Informix databases that you plan to connect to support the "SELECT SKIP N FIRST M ..." syntax. If undefined, this feature will be looked up on a per-connection basis as needed. The default is undefined. =item B Get or set the maximum length of varchar columns used to emulate the array data type. The default value is 255. Informix does not have a native "ARRAY" data type, but it can be emulated using a "VARCHAR" column and a specially formatted string. The formatting and parsing of this string is handled by the C and C object methods. The maximum length limit is honored by the C object method. Informix does have a native "SET" data type, serviced by the C and C object methods. This is a better choice than the emulated array data type if you don't care about the order of the stored values. =back =head1 OBJECT METHODS =head2 Value Parsing and Formatting =over 4 =item B Given a reference to an array or a list of values, return a specially formatted string. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. The array or list must not contain undefined values. If the resulting string is longer than C, a fatal error will occur. =item B Converts the L object DATETIME into the appropriate format for the "DATE" data type. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO SECOND" data type. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO FRACTION" data type. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO FRACTION(N)" data type, where N is an integer from 1 to 5. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO MINUTE" data type. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO MONTH" data type. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO SECOND" data type. =item B Given a reference to an array or a list of values, return a string formatted according to the rules of Informix's "SET" data type. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. If the array or list contains undefined values, a fatal error will occur. =item B Converts the L object DATETIME into the appropriate format for the "DATETIME YEAR TO FRACTION(5)" data type. =item B Parse STRING and return a reference to an array. STRING should be formatted according to the Informix array data type emulation format returned by C. Undef is returned if STRING is undefined. If a LIST of more than one item is passed, a reference to an array containing the values in LIST is returned. If a an ARRAYREF is passed, it is returned as-is. =item B Parse STRING and return a boolean value of 1 or 0. STRING should be formatted according to Informix's native "boolean" data type. Acceptable values are 't', 'T', or '1' for true, and 'f', 'F', or '0' for false. If STRING is a valid boolean keyword (according to L) or if it looks like a function call (matches /^\w+\(.*\)$/) and L is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "boolean" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATE" data type. If STRING is a valid date keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATE" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO SECOND" data type. If STRING is a valid "datetime year to second" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO SECOND" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO FRACTION" data type. If STRING is a valid "datetime year to fraction" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO FRACTION" value. =item B These five methods parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO FRACTION(N)" data type, where N is an integer from 1 to 5. If STRING is a valid "datetime year to fraction" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO FRACTION(N)" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO MINUTE" data type. If STRING is a valid "datetime year to minute" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO MINUTE" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO MINUTE" data type. If STRING is a valid "datetime year to month" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO MONTH" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO SECOND" data type. If STRING is a valid "datetime year to second" keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO SECOND" value. =item B Parse STRING and return a reference to an array. STRING should be formatted according to Informix's "SET" data type. Undef is returned if STRING is undefined. If a LIST of more than one item is passed, a reference to an array containing the values in LIST is returned. If a an ARRAYREF is passed, it is returned as-is. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME YEAR TO FRACTION(5)" data type. If STRING is a valid timestamp keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME YEAR TO FRACTION(5)" value. =item B Returns true if STRING is a valid keyword for the "boolean" data type of the current data source, false otherwise. Valid (case-insensitive) boolean keywords are: TRUE FALSE =item B Returns true if STRING is a valid keyword for the Informix "date", false otherwise. Valid (case-insensitive) date keywords are: current today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid date keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "datetime year to second" data type, false otherwise. Valid (case-insensitive) datetime keywords are: current current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid datetime keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "datetime year to fraction(n)" data type (where n is an integer from 1 to 5), false otherwise. Valid (case-insensitive) "datetime year to fraction" keywords are: current current year to fraction current year to fraction(1) current year to fraction(2) current year to fraction(3) current year to fraction(4) current year to fraction(5) current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid "datetime year to fraction" keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "datetime year to minute" data type, false otherwise. Valid (case-insensitive) "datetime year to minute" keywords are: current current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid "datetime year to minute" keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "datetime year to month" data type, false otherwise. Valid (case-insensitive) "datetime year to month" keywords are: current current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid "datetime year to month" keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "datetime year to second" data type, false otherwise. Valid (case-insensitive) datetime keywords are: current current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid "datetime year to second" keyword if L is true. =item B Returns true if STRING is a valid keyword for the Informix "timestamp" data type, false otherwise. Valid (case-insensitive) timestamp keywords are: current current year to fraction current year to fraction(1) current year to fraction(2) current year to fraction(3) current year to fraction(4) current year to fraction(5) current year to second current year to minute current year to hour current year to day current year to month today The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid timestamp keyword if L is true. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/MySQL.pm000755 000765 000024 00000104030 12502134373 016301 0ustar00johnstaff000000 000000 package Rose::DB::MySQL; use strict; use Carp(); use DateTime::Format::MySQL; use SQL::ReservedWords::MySQL(); TRY: { local $@; eval { require DBD::mysql }; # Ignore errors } use Rose::DB; our $VERSION = '0.774'; our $Debug = 0; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => [ 'supports_schema', 'coerce_autoincrement_to_serial', ] ); __PACKAGE__->supports_schema(1); __PACKAGE__->coerce_autoincrement_to_serial(1); # # Object methods # sub registration_schema { shift->database } sub build_dsn { my($self_or_class, %args) = @_; my %info; $info{'database'} = $args{'db'} || $args{'database'}; $info{'host'} = $args{'host'}; $info{'port'} = $args{'port'}; return "dbi:mysql:" . join(';', map { "$_=$info{$_}" } grep { defined $info{$_} } qw(database host port)); } sub dbi_driver { 'mysql' } sub mysql_auto_reconnect { shift->dbh_attribute_boolean('mysql_auto_reconnect', @_) } sub mysql_client_found_rows { shift->dbh_attribute_boolean('mysql_client_found_rows', @_) } sub mysql_compression { shift->dbh_attribute_boolean('mysql_compression', @_) } sub mysql_connect_timeout { shift->dbh_attribute_boolean('mysql_connect_timeout', @_) } sub mysql_embedded_groups { shift->dbh_attribute('mysql_embedded_groups', @_) } sub mysql_embedded_options { shift->dbh_attribute('mysql_embedded_options', @_) } sub mysql_local_infile { shift->dbh_attribute('mysql_local_infile', @_) } sub mysql_multi_statements { shift->dbh_attribute_boolean('mysql_multi_statements', @_) } sub mysql_read_default_file { shift->dbh_attribute('mysql_read_default_file', @_) } sub mysql_read_default_group { shift->dbh_attribute('mysql_read_default_group', @_) } sub mysql_socket { shift->dbh_attribute('mysql_socket', @_) } sub mysql_ssl { shift->dbh_attribute_boolean('mysql_ssl', @_) } sub mysql_ssl_ca_file { shift->dbh_attribute('mysql_ssl_ca_file', @_) } sub mysql_ssl_ca_path { shift->dbh_attribute('mysql_ssl_ca_path', @_) } sub mysql_ssl_cipher { shift->dbh_attribute('mysql_ssl_cipher', @_) } sub mysql_ssl_client_cert { shift->dbh_attribute('mysql_ssl_client_cert', @_) } sub mysql_ssl_client_key { shift->dbh_attribute('mysql_ssl_client_key', @_) } sub mysql_use_result { shift->dbh_attribute_boolean('mysql_use_result', @_) } sub mysql_bind_type_guessing { shift->dbh_attribute_boolean('mysql_bind_type_guessing', @_) } sub mysql_enable_utf8 { my($self) = shift; $self->dbh->do('SET NAMES utf8') if(@_ && $self->has_dbh); $self->dbh_attribute_boolean('mysql_enable_utf8', @_) } sub database_version { my($self) = shift; return $self->{'database_version'} if(defined $self->{'database_version'}); my $vers = $self->dbh->get_info(18); # SQL_DBMS_VER # Convert to an integer, e.g., 5.1.13 -> 5001013 if($vers =~ /^(\d+)\.(\d+)(?:\.(\d+))?/) { $vers = sprintf('%d%03d%03d', $1, $2, $3 || 0); } return $self->{'database_version'} = $vers; } sub init_dbh { my($self) = shift; $self->{'supports_on_duplicate_key_update'} = undef; my $method = ref($self)->parent_class . '::init_dbh'; no strict 'refs'; return $self->$method(@_); } sub max_column_name_length { 64 } sub max_column_alias_length { 255 } sub quote_column_name { my $name = $_[1]; $name =~ s/`/``/g; return qq(`$name`); } sub quote_table_name { my $name = $_[1]; $name =~ s/`/``/g; return qq(`$name`); } sub list_tables { my($self, %args) = @_; my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE'; my @tables; my $schema = $self->schema; $schema = $self->database unless(defined $schema); my $error; TRY: { local $@; eval { my $dbh = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $sth = $dbh->table_info($self->catalog, $schema, '%', $types); $sth->execute; while(my $table_info = $sth->fetchrow_hashref) { push(@tables, $self->unquote_table_name($table_info->{'TABLE_NAME'})); } }; $error = $@; } if($error) { Carp::croak "Could not list tables from ", $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } sub init_date_handler { DateTime::Format::MySQL->new } sub insertid_param { 'mysql_insertid' } sub last_insertid_from_sth { $_[1]->{'mysql_insertid'} } sub format_table_with_alias { my($self, $table, $alias, $hints) = @_; my $version = $self->database_version; if($hints && $version >= 3_023_012) { my $sql = "$table $alias "; # "ignore index()" and "use index()" were added in 3.23.12 (07 March 2000) # "force index()" was added in 4.0.9 (09 January 2003) my @types = (($version >= 4_000_009 ? 'force' : ()), qw(use ignore)); foreach my $index_hint_type (@types) { my $key = "${index_hint_type}_index"; if($hints->{$key}) { $sql .= uc($index_hint_type) . ' INDEX ('; if(ref $hints->{$key} eq 'ARRAY') { $sql .= join(', ', @{$hints->{$key}}); } else { $sql .= $hints->{$key} } $sql .= ')'; # Only one of these hints is allowed last; } } return $sql; } return "$table $alias"; } sub format_select_start_sql { my($self, $hints) = @_; return 'SELECT' unless($hints); return 'SELECT ' . ($hints->{'comment'} ? "/* $hints->{'comment'} */" : '') . join(' ', (map { $hints->{$_} ? uc("sql_$_") : () } qw(small_result big_result buffer_result cache no_cache calc_found_rows)), (map { $hints->{$_} ? uc($_) : () } qw(high_priority straight_join))); } sub format_select_lock { my($self, $class, $lock, $tables_list) = @_; $lock = { type => $lock } unless(ref $lock); $lock->{'type'} ||= 'for update' if($lock->{'for_update'}); my %types = ( 'for update' => 'FOR UPDATE', 'shared' => 'LOCK IN SHARE MODE', ); my $sql = $types{$lock->{'type'}} or Carp::croak "Invalid lock type: $lock->{'type'}"; return $sql; } sub validate_date_keyword { no warnings; !ref $_[1] && ($_[1] =~ /^(?:(?:now|cur(?:date|time)|sysdate)\(\)| current_(?:time|date|timestamp)(?:\(\))?|0000-00-00)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } sub validate_datetime_keyword { no warnings; !ref $_[1] && ($_[1] =~ /^(?:(?:now|cur(?:date|time)|sysdate)\(\)| current_(?:time|date|timestamp)(?:\(\))?|0000-00-00[ ]00:00:00)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } sub validate_timestamp_keyword { no warnings; !ref $_[1] && ($_[1] =~ /^(?:(?:now|cur(?:date|time)|sysdate)\(\)| current_(?:time|date|timestamp)(?:\(\))?|0000-00-00[ ]00:00:00|00000000000000)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } *format_timestamp = \&Rose::DB::format_datetime; sub parse_bitfield { my($self, $val, $size, $from_db) = @_; if(ref $val) { if($size && $val->Size != $size) { return Bit::Vector->new_Bin($size, $val->to_Bin); } return $val; } no warnings 'uninitialized'; if($from_db && $val =~ /^\d+$/) { return Bit::Vector->new_Dec($size || (length($val) * 4), $val); } elsif($val =~ /^[10]+$/) { return Bit::Vector->new_Bin($size || length $val, $val); } elsif($val =~ /^\d*[2-9]\d*$/) { return Bit::Vector->new_Dec($size || (length($val) * 4), $val); } elsif($val =~ s/^0x// || $val =~ s/^X'(.*)'$/$1/ || $val =~ /^[0-9a-f]+$/i) { return Bit::Vector->new_Hex($size || (length($val) * 4), $val); } elsif($val =~ s/^B'([10]+)'$/$1/i) { return Bit::Vector->new_Bin($size || length $val, $val); } else { return undef; #return Bit::Vector->new_Bin($size || length($val), $val); } } sub format_bitfield { my($self, $vec, $size) = @_; $vec = Bit::Vector->new_Bin($size, $vec->to_Bin) if($size); # MySQL 5.0.3 or later requires this crap... if($self->database_version >= 5_000_003) { return q(b') . $vec->to_Bin . q('); # 'CAST(' . $vec->to_Dec . ' AS UNSIGNED)'; } return hex($vec->to_Hex); } sub validate_bitfield_keyword { defined $_[1] ? 1 : 0 } sub should_inline_bitfield_value { # MySQL 5.0.3 or later requires this crap... return $_[0]->{'should_inline_bitfield_value'} ||= (shift->database_version >= 5_000_003) ? 1 : 0; } sub select_bitfield_column_sql { my($self, $column, $table) = @_; # MySQL 5.0.3 or later requires this crap... if($self->database_version >= 5_000_003) { return q{CONCAT("b'", BIN(} . $self->auto_quote_column_with_table($column, $table) . q{ + 0), "'")}; } else { return $self->auto_quote_column_with_table($column, $table) . q{ + 0}; } } sub parse_set { my($self) = shift; return $_[0] if(ref $_[0] eq 'ARRAY'); if(@_ > 1 && !ref $_[1]) { pop(@_); return [ @_ ]; } my $val = $_[0]; return undef unless(defined $val); my @set = split(/,/, $val); return \@set; } sub format_set { my($self) = shift; my @set = (ref $_[0]) ? @{$_[0]} : @_; return undef unless(@set && defined $set[0]); return join(',', map { if(!defined $_) { Carp::croak 'Undefined value found in array or list passed to ', __PACKAGE__, '::format_set()'; } else { $_ } } @set); } sub refine_dbi_column_info { my($self, $col_info) = @_; my $method = ref($self)->parent_class . '::refine_dbi_column_info'; no strict 'refs'; $self->$method($col_info); if($col_info->{'TYPE_NAME'} eq 'timestamp' && defined $col_info->{'COLUMN_DEF'}) { if($col_info->{'COLUMN_DEF'} eq '0000-00-00 00:00:00' || $col_info->{'COLUMN_DEF'} eq '00000000000000') { # MySQL uses strange "all zeros" default values for timestamp fields. # We'll just ignore them, since MySQL will use them internally no # matter what we do. $col_info->{'COLUMN_DEF'} = undef; } elsif($col_info->{'COLUMN_DEF'} eq 'CURRENT_TIMESTAMP') { # Translate "current time" value into something that our date parser # will understand. #$col_info->{'COLUMN_DEF'} = 'now'; # Actually, let the database handle this. $col_info->{'COLUMN_DEF'} = undef; } } # Put valid SET and ENUM values in standard keys if($col_info->{'TYPE_NAME'} eq 'set') { $col_info->{'RDBO_SET_VALUES'} = $col_info->{'mysql_values'}; } elsif($col_info->{'TYPE_NAME'} eq 'enum') { $col_info->{'RDBO_ENUM_VALUES'} = $col_info->{'mysql_values'}; } # Consider (big)int autoincrement to be (big)serial if($col_info->{'mysql_is_auto_increment'} && ref($self)->coerce_autoincrement_to_serial) { if($col_info->{'TYPE_NAME'} eq 'int') { $col_info->{'TYPE_NAME'} = 'serial'; } elsif($col_info->{'TYPE_NAME'} eq 'bigint') { $col_info->{'TYPE_NAME'} = 'bigserial'; } } return; } sub supports_arbitrary_defaults_on_insert { 1 } sub likes_redundant_join_conditions { 1 } sub supports_on_duplicate_key_update { my($self) = shift; if(defined $self->{'supports_on_duplicate_key_update'}) { return $self->{'supports_on_duplicate_key_update'}; } if($self->database_version >= 4_001_000) { return $self->{'supports_on_duplicate_key_update'} = 1; } return $self->{'supports_on_duplicate_key_update'} = 0; } sub supports_select_from_subselect { my($self) = shift; if(defined $self->{'supports_select_from_subselect'}) { return $self->{'supports_select_from_subselect'}; } if($self->database_version >= 5_000_045) { return $self->{'supports_select_from_subselect'} = 1; } return $self->{'supports_select_from_subselect'} = 0; } #our %Reserved_Words = map { $_ => 1 } qw(read for case); #sub is_reserved_word { $Reserved_Words{lc $_[1]} } *is_reserved_word = \&SQL::ReservedWords::MySQL::is_reserved; # # Introspection # sub _get_primary_key_column_names { my($self, $catalog, $schema, $table) = @_; my $dbh = $self->dbh or die $self->error; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $fq_table = join('.', grep { defined } ($catalog, $schema, $self->quote_table_name($table))); my $sth = $dbh->prepare("SHOW INDEX FROM $fq_table"); $sth->execute; my @columns; while(my $row = $sth->fetchrow_hashref) { next unless($row->{'Key_name'} eq 'PRIMARY'); push(@columns, $row->{'Column_name'}); } return \@columns; } # Bury warning down here to make nice with version extractors if(defined $DBD::mysql::VERSION && $DBD::mysql::VERSION <= 2.9) { warn "WARNING: Rose::DB may not work correctly with DBD::mysql ", "version 2.9 or earlier. You have version $DBD::mysql::VERSION"; } 1; __END__ =head1 NAME Rose::DB::MySQL - MySQL driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db( domain => 'development', type => 'main', driver => 'mysql', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... # Set max length of varchar columns used to emulate the array data type Rose::DB::MySQL->max_array_characters(128); $db = Rose::DB->new; # $db is really a Rose::DB::MySQL-derived object ... =head1 DESCRIPTION L blesses objects into a class derived from L when the L is "mysql". This mapping of driver names to class names is configurable. See the documentation for L's L and L methods for more information. This class cannot be used directly. You must use L and let its L method return an object blessed into the appropriate class for you, according to its L mappings. Only the methods that are new or have different behaviors than those in L are documented here. See the L documentation for the full list of methods. =head1 CLASS METHODS =over 4 =item B Get or set a boolean value that indicates whether or not "auto-increment" columns will be considered to have the column type "serial." If true, "integer" columns are coerced to the "serial" column type, and "bigint" columns use the "bigserial" column type. The default value is true. This setting comes into play when L is used to auto-create column metadata based on an existing database schema. =item B Get or set the maximum length of varchar columns used to emulate the array data type. The default value is 255. MySQL does not have a native "ARRAY" data type, but this data type can be emulated using a "VARCHAR" column and a specially formatted string. The formatting and parsing of this string is handled by the L and L object methods. The maximum length limit is honored by the L object method. =item B Get or set the maximum length of varchar columns used to emulate the interval data type. The default value is 255. MySQL does not have a native "interval" data type, but this data type can be emulated using a "VARCHAR" column and a specially formatted string. The formatting and parsing of this string is handled by the L and L object methods. The maximum length limit is honored by the L object method. =back =head1 OBJECT METHODS =over 4 =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists, by executing the SQL C. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =back =head2 Value Parsing and Formatting =over 4 =item B Given a reference to an array or a list of values, return a specially formatted string. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. The array or list must not contain undefined values. If the resulting string is longer than L, a fatal error will occur. =item B Given a L object, return a string formatted according to the rules of PostgreSQL's "INTERVAL" column type. If DURATION is undefined, a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. If the resulting string is longer than L, a fatal error will occur. =item B Given a reference to an array or a list of values, return a string formatted according to the rules of MySQL's "SET" data type. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. If the array or list contains undefined values, a fatal error will occur. =item B Parse STRING and return a reference to an array. STRING should be formatted according to the MySQL array data type emulation format returned by L. Undef is returned if STRING is undefined. If a LIST of more than one item is passed, a reference to an array containing the values in LIST is returned. If a an ARRAYREF is passed, it is returned as-is. =item B Parse STRING and return a L object. STRING should be formatted according to the PostgreSQL native "interval" (years, months, days, hours, minutes, seconds) data type. If STRING is a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Otherwise, undef is returned if STRING could not be parsed as a valid "interval" value. =item B Parse STRING and return a reference to an array. STRING should be formatted according to MySQL's "SET" data type. Undef is returned if STRING is undefined. If a LIST of more than one item is passed, a reference to an array containing the values in LIST is returned. If a an ARRAYREF is passed, it is returned as-is. =item B Returns true if STRING is a valid keyword for the MySQL "date" data type. Valid (case-insensitive) date keywords are: curdate() current_date current_date() now() sysdate() 00000-00-00 Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid date keyword if L is true. =item B Returns true if STRING is a valid keyword for the MySQL "datetime" data type, false otherwise. Valid (case-insensitive) datetime keywords are: curdate() current_date current_date() current_time current_time() current_timestamp current_timestamp() curtime() now() sysdate() 0000-00-00 00:00:00 Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid datetime keyword if L is true. =item B Returns true if STRING is a valid keyword for the MySQL "timestamp" data type, false otherwise. Valid (case-insensitive) timestamp keywords are: curdate() current_date current_date() current_time current_time() current_timestamp current_timestamp() curtime() now() sysdate() 0000-00-00 00:00:00 00000000000000 Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid timestamp keyword if L is true. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Oracle.pm000644 000765 000024 00000044514 12502134373 016550 0ustar00johnstaff000000 000000 package Rose::DB::Oracle; use strict; use Carp(); use SQL::ReservedWords::Oracle(); use Rose::DB; our $Debug = 0; our $VERSION = '0.767'; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => '_default_post_connect_sql', ); __PACKAGE__->_default_post_connect_sql ( [ q(ALTER SESSION SET NLS_DATE_FORMAT = ') . ($ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS') . q('), q(ALTER SESSION SET NLS_TIMESTAMP_FORMAT = ') . ($ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF') . q('), q(ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = ') . ($ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM') . q('), ] ); sub default_post_connect_sql { my($class) = shift; if(@_) { if(@_ == 1 && ref $_[0] eq 'ARRAY') { $class->_default_post_connect_sql(@_); } else { $class->_default_post_connect_sql([ @_ ]); } } return $class->_default_post_connect_sql; } sub post_connect_sql { my($self) = shift; unless(@_) { return wantarray ? ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) : [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ]; } if(@_ == 1 && ref $_[0] eq 'ARRAY') { $self->{'post_connect_sql'} = $_[0]; } else { $self->{'post_connect_sql'} = [ @_ ]; } return wantarray ? ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) : [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ]; } sub schema { my($self) = shift; $self->{'schema'} = shift if(@_); return $self->{'schema'} || $self->username; } sub use_auto_sequence_name { 1 } sub auto_sequence_name { my($self, %args) = @_; my($table) = $args{'table'}; Carp::croak 'Missing table argument' unless(defined $table); my($column) = $args{'column'}; Carp::croak 'Missing column argument' unless(defined $column); return uc "${table}_${column}_SEQ"; } sub build_dsn { my($self_or_class, %args) = @_; my $database = $args{'db'} || $args{'database'}; if($args{'host'} || $args{'port'}) { $args{'sid'} = $database; return 'dbi:Oracle:' . join(';', map { "$_=$args{$_}" } grep { $args{$_} } qw(sid host port)); } return "dbi:Oracle:$database"; } sub init_date_handler { Rose::DB::Oracle::DateHandler->new } sub database_version { my($self) = shift; return $self->{'database_version'} if (defined $self->{'database_version'}); my($version) = $self->dbh->get_info(18); # SQL_DBMS_VER. # Convert to an integer, e.g., 10.02.0100 -> 100020100 if($version =~ /^(\d+)\.(\d+)(?:\.(\d+))?/) { $version = sprintf('%d%03d%04d', $1, $2, $3); } return $self->{'database_version'} = $version; } sub dbi_driver { 'Oracle' } sub likes_uppercase_table_names { 1 } sub likes_uppercase_schema_names { 1 } sub likes_uppercase_catalog_names { 1 } sub likes_uppercase_sequence_names { 1 } sub insertid_param { '' } sub list_tables { my($self, %args) = @_; my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE'; my($error, @tables); TRY: { local $@; eval { my($dbh) = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $sth = $dbh->table_info($self->catalog, uc $self->schema, '%', $types); my $info = $sth->fetchall_arrayref({}); # The {} are mandatory. for my $table (@$info) { push @tables, $$table{'TABLE_NAME'} if ($$table{'TABLE_NAME'} !~ /^BIN\$.+\$.+/); } }; $error = $@; } if($error) { Carp::croak 'Could not list tables from ', $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } sub next_value_in_sequence { my($self, $sequence_name) = @_; my $dbh = $self->dbh or return undef; my($error, $value); TRY: { local $@; eval { local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 1; my $sth = $dbh->prepare("SELECT $sequence_name.NEXTVAL FROM DUAL"); $sth->execute; $value = ${$sth->fetch}[0]; $sth->finish; }; $error = $@; } if($error) { $self->error("Could not get the next value in the sequence $sequence_name - $error"); return undef; } return $value; } # Tried to execute a CURRVAL command on a sequence before the # NEXTVAL command was executed at least once. use constant ORA_08002 => 8002; sub current_value_in_sequence { my($self, $sequence_name) = @_; my $dbh = $self->dbh or return undef; my($error, $value); TRY: { local $@; eval { local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 1; my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL"); $sth->execute; $value = ${$sth->fetch}[0]; $sth->finish; }; $error = $@; } if($error) { if(DBI->err == ORA_08002) { if(defined $self->next_value_in_sequence($sequence_name)) { return $self->current_value_in_sequence($sequence_name); } } $self->error("Could not get the current value in the sequence $sequence_name - $error"); return undef; } return $value; } # Sequence does not exist, or the user does not have the required # privilege to perform this operation. use constant ORA_02289 => 2289; sub sequence_exists { my($self, $sequence_name) = @_; my $dbh = $self->dbh or return undef; my $error; TRY: { local $@; eval { local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 1; my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL"); $sth->execute; $sth->fetch; $sth->finish; }; $error = $@; } if($error) { my $dbi_error = DBI->err; if($dbi_error == ORA_08002) { if(defined $self->next_value_in_sequence($sequence_name)) { return $self->sequence_exists($sequence_name); } } elsif($dbi_error == ORA_02289) { return 0; } $self->error("Could not check if sequence $sequence_name exists - $error"); return undef; } return 1; } sub parse_dbi_column_info_default { my($self, $default, $col_info) = @_; # For some reason, given a default value like this: # # MYCOLUMN VARCHAR(128) DEFAULT 'foo' NOT NULL # # DBD::Oracle hands back a COLUMN_DEF value of: # # $col_info->{'COLUMN_DEF'} = "'foo' "; # WTF? # # I have no idea why. Anyway, we just want the value beteen the quotes. return undef unless (defined $default); $default =~ s/^\s*'(.+)'\s*$/$1/; return $default; } *is_reserved_word = \&SQL::ReservedWords::Oracle::is_reserved; sub quote_identifier_for_sequence { my($self, $catalog, $schema, $table) = @_; return join('.', map { uc } grep { defined } ($schema, $table)); } # sub auto_quote_column_name # { # my($self, $name) = @_; # # if($name =~ /[^\w#]/ || $self->is_reserved_word($name)) # { # return $self->quote_column_name($name, @_); # } # # return $name; # } sub supports_schema { 1 } sub max_column_name_length { 30 } sub max_column_alias_length { 30 } sub quote_column_name { my $name = uc $_[1]; $name =~ s/"/""/g; return qq("$name"); } sub quote_table_name { my $name = uc $_[1]; $name =~ s/"/""/g; return qq("$name"); } sub quote_identifier { my($self) = shift; my $method = ref($self)->parent_class . '::quote_identifier'; no strict 'refs'; return uc $self->$method(@_); } sub primary_key_column_names { my($self) = shift; my %args = @_ == 1 ? (table => @_) : @_; my $table = $args{'table'} or Carp::croak "Missing table name parameter"; my $schema = $args{'schema'} || $self->schema; my $catalog = $args{'catalog'} || $self->catalog; no warnings 'uninitialized'; $table = uc $table; $schema = uc $schema; $catalog = uc $catalog; my $table_unquoted = $self->unquote_table_name($table); my($error, $columns); TRY: { local $@; eval { $columns = $self->_get_primary_key_column_names($catalog, $schema, $table_unquoted); }; $error = $@; } if($error || !$columns) { no warnings 'uninitialized'; # undef strings okay $error = 'no primary key columns found' unless(defined $error); Carp::croak "Could not get primary key columns for catalog '" . $catalog . "' schema '" . $schema . "' table '" . $table_unquoted . "' - " . $error; } return wantarray ? @$columns : $columns; } sub format_limit_with_offset { my($self, $limit, $offset, $args) = @_; delete $args->{'limit'}; delete $args->{'offset'}; if($offset) { # http://www.oracle.com/technology/oramag/oracle/06-sep/o56asktom.html # select * # from ( select /*+ FIRST_ROWS(n) */ # a.*, ROWNUM rnum # from ( your_query_goes_here, # with order by ) a # where ROWNUM <= # :MAX_ROW_TO_FETCH ) # where rnum >= :MIN_ROW_TO_FETCH; my $size = $limit; my $start = $offset + 1; my $end = $start + $size - 1; my $n = $offset + $limit; $args->{'limit_prefix'} = "SELECT * FROM (SELECT /*+ FIRST_ROWS($n) */\na.*, ROWNUM oracle_rownum FROM ("; #"SELECT * FROM (SELECT a.*, ROWNUM oracle_rownum FROM ("; $args->{'limit_suffix'} = ") a WHERE ROWNUM <= $end) WHERE oracle_rownum >= $start"; } else { $args->{'limit_prefix'} = "SELECT /*+ FIRST_ROWS($limit) */ a.* FROM ("; #$args->{'limit_prefix'} = "SELECT a.* FROM ("; $args->{'limit_suffix'} = ") a WHERE ROWNUM <= $limit"; } } sub format_select_lock { my($self, $class, $lock, $tables) = @_; $lock = { type => $lock } unless(ref $lock); $lock->{'type'} ||= 'for update' if($lock->{'for_update'}); unless($lock->{'type'} eq 'for update') { Carp::croak "Invalid lock type: $lock->{'type'}"; } my $sql = 'FOR UPDATE'; my @columns; if(my $on = $lock->{'on'}) { @columns = map { $self->column_sql_from_lock_on_value($class, $_, $tables) } @$on; } elsif(my $columns = $lock->{'columns'}) { my %map; if($tables) { my $tn = 1; foreach my $table (@$tables) { (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//; $map{$table_key} = 't' . $tn++; } } @columns = map { ref $_ eq 'SCALAR' ? $$_ : /^([^.]+)\.([^.]+)$/ ? $self->auto_quote_column_with_table($2, defined $map{$1} ? $map{$1} : $1) : $self->auto_quote_column_name($_) } @$columns; } if(@columns) { $sql .= ' OF ' . join(', ', @columns); } if($lock->{'nowait'}) { $sql .= ' NOWAIT'; } elsif(my $wait = $lock->{'wait'}) { $sql .= " WAIT $wait"; } if($lock->{'skip_locked'}) { $sql .= ' SKIP LOCKED'; } return $sql; } sub format_boolean { $_[1] ? 't' : 'f' } # # Date/time keywords and inlining # sub validate_date_keyword { no warnings; $_[1] =~ /^(?:CURRENT_|SYS|LOCAL)(?:TIMESTAMP|DATE)$/i || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } *validate_time_keyword = \&validate_date_keyword; *validate_timestamp_keyword = \&validate_date_keyword; *validate_datetime_keyword = \&validate_date_keyword; sub should_inline_date_keyword { 1 } sub should_inline_datetime_keyword { 1 } sub should_inline_time_keyword { 1 } sub should_inline_timestamp_keyword { 1 } package Rose::DB::Oracle::DateHandler; use Rose::Object; our @ISA = qw(Rose::Object); use DateTime::Format::Oracle; sub parse_date { my($self, $value) = @_; local $DateTime::Format::Oracle::nls_date_format = $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS'; # Add or extend the time to appease DateTime::Format::Oracle if($value =~ /\d\d:/) { $value =~ s/( \d\d:\d\d)([^:]|$)/$1:00$2/; } else { $value .= ' 00:00:00'; } return DateTime::Format::Oracle->parse_date($value); } *parse_datetime = \&parse_date; sub parse_timestamp { my($self, $value) = @_; local $DateTime::Format::Oracle::nls_timestamp_format = $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF'; # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle for($value) { s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ || s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e || s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/; } return DateTime::Format::Oracle->parse_timestamp($value); } sub parse_timestamp_with_time_zone { my($self, $value) = @_; local $DateTime::Format::Oracle::nls_timestamp_tz_format = $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle for($value) { s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ || s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e || s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/; } return DateTime::Format::Oracle->parse_timestamp_with_time_zone($value); } sub format_date { my($self) = shift; local $DateTime::Format::Oracle::nls_date_format = $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS'; return DateTime::Format::Oracle->format_date(@_); } *format_datetime = \&format_date; sub format_timestamp { my($self) = shift; local $DateTime::Format::Oracle::nls_timestamp_format = $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF'; return DateTime::Format::Oracle->format_timestamp(@_); } sub format_timestamp_with_time_zone { my($self) = shift; local $DateTime::Format::Oracle::nls_timestamp_tz_format = $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; return DateTime::Format::Oracle->format_timestamp_with_time_zone(@_); } 1; __END__ =head1 NAME Rose::DB::Oracle - Oracle driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db ( domain => 'development', type => 'main', driver => 'Oracle', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... $db = Rose::DB->new; # $db is really a Rose::DB::Oracle-derived object ... =head1 DESCRIPTION L blesses objects into a class derived from L when the L is "oracle". This mapping of driver names to class names is configurable. See the documentation for L's L and L methods for more information. This class cannot be used directly. You must use L and let its L method return an object blessed into the appropriate class for you, according to its L mappings. Only the methods that are new or have different behaviors than those in L are documented here. See the L documentation for the full list of methods. B B This class is a work in progress. Support for Oracle databases is not yet complete. If you would like to help, please contact John Siracusa at siracusa@gmail.com or post to the L. =head1 CLASS METHODS =over 4 =item B Get or set the default list of SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. The L statements will be run before any statements set using the L method. The default list contains the following: ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS' ALTER SESSION SET NLS_TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF' ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM' If one or more C environment variables are set, the format strings above are replaced by the values that these environment variables have I. =back =head1 OBJECT METHODS =over 4 =item B Get or set the SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to an array (in scalar) or a list of the L statements and the L statements. Example: $db->post_connect_sql('UPDATE mytable SET num = num + 1'); print join("\n", $db->post_connect_sql); ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD HH24:MI:SS' ALTER SESSION SET NLS_TIMESTAMP_FORMAT='YYYY-MM-DD HH24:MI:SSxFF' UPDATE mytable SET num = num + 1 =item B Get or set the database schema name. In Oracle, every user has a corresponding schema. The schema is comprised of all objects that user owns, and has the same name as that user. Therefore, this attribute defaults to the L if it is not set explicitly. =back =head2 Value Parsing and Formatting =over 4 =item B Returns true if STRING is a valid keyword for the PostgreSQL "date" data type. Valid (case-insensitive) date keywords are: current_date current_timestamp localtimestamp months_between sysdate systimestamp The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid date keyword if L is true. =item B Returns true if STRING is a valid keyword for the Oracle "timestamp" data type, false otherwise. Valid timestamp keywords are: current_date current_timestamp localtimestamp months_between sysdate systimestamp The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid timestamp keyword if L is true. =back =head1 AUTHORS John C. Siracusa (siracusa@gmail.com), Ron Savage (ron@savage.net.au) =head1 LICENSE Copyright (c) 2008 by John Siracusa and Ron Savage. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Pg.pm000755 000765 000024 00000057660 12502134373 015722 0ustar00johnstaff000000 000000 package Rose::DB::Pg; use strict; use DateTime::Infinite; use DateTime::Format::Pg; use SQL::ReservedWords::PostgreSQL(); use Rose::DB; our $VERSION = '0.786'; # overshot version number, freeze until caught up our $Debug = 0; # # Object data # use Rose::Object::MakeMethods::Generic ( 'scalar' => [ qw(sslmode service options) ], ); # # Object methods # sub build_dsn { my($self_or_class, %args) = @_; my %info; $info{'dbname'} = $args{'db'} || $args{'database'}; @info{qw(host port options service sslmode)} = @args{qw(host port options service sslmode)}; return "dbi:Pg:" . join(';', map { "$_=$info{$_}" } grep { defined $info{$_} } qw(dbname host port options service sslmode)); } sub dbi_driver { 'Pg' } sub init_date_handler { my($self) = shift; my $parent_class = ref($self)->parent_class; my $european_dates = "${parent_class}::european_dates"; my $server_time_zone = "${parent_class}::server_time_zone"; no strict 'refs'; my $parser = DateTime::Format::Pg->new( ($self->$european_dates() ? (european => 1) : ()), ($self->$server_time_zone() ? (server_tz => $self->$server_time_zone()) : ())); return $parser; } sub default_implicit_schema { 'public' } sub likes_lowercase_table_names { 1 } sub likes_lowercase_schema_names { 1 } sub likes_lowercase_catalog_names { 1 } sub likes_lowercase_sequence_names { 1 } sub supports_multi_column_count_distinct { 0 } sub supports_arbitrary_defaults_on_insert { 1 } sub supports_select_from_subselect { 1 } sub pg_enable_utf8 { shift->dbh_attribute_boolean('pg_enable_utf8', @_) } sub supports_schema { 1 } sub max_column_name_length { 63 } sub max_column_alias_length { 63 } sub last_insertid_from_sth { #my($self, $sth, $obj) = @_; # PostgreSQL demands that the primary key column not be in the insert # statement at all in order for it to auto-generate a value. The # insert SQL will need to be modified to make this work for # Rose::DB::Object... #if($DBD::Pg::VERSION >= 1.40) #{ # my $meta = $obj->meta; # return $self->dbh->last_insert_id(undef, $meta->select_schema, $meta->table, undef); #} return undef; } sub format_select_lock { my($self, $class, $lock, $tables_list) = @_; $lock = { type => $lock } unless(ref $lock); $lock->{'type'} ||= 'for update' if($lock->{'for_update'}); my %types = ( 'for update' => 'FOR UPDATE', 'shared' => 'FOR SHARE', ); my $sql = $types{$lock->{'type'}} or Carp::croak "Invalid lock type: $lock->{'type'}"; my @tables; if(my $on = $lock->{'on'}) { @tables = map { $self->table_sql_from_lock_on_value($class, $_, $tables_list) } @$on; } elsif(my $lock_tables = $lock->{'tables'}) { my %map; if($tables_list) { my $tn = 1; foreach my $table (@$tables_list) { (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//; $map{$table_key} = 't' . $tn++; } } @tables = map { ref $_ eq 'SCALAR' ? $$_ : $self->auto_quote_table_name(defined $map{$_} ? $map{$_} : $_) } @$lock_tables; } if(@tables) { $sql .= ' OF ' . join(', ', @tables); } $sql .= ' NOWAIT' if($lock->{'nowait'}); return $sql; } sub parse_datetime { my($self) = shift; unless(ref $_[0]) { no warnings 'uninitialized'; return DateTime::Infinite::Past->new if($_[0] eq '-infinity'); return DateTime::Infinite::Future->new if($_[0] eq 'infinity'); } my $method = ref($self)->parent_class . '::parse_datetime'; no strict 'refs'; $self->$method(@_); } sub parse_timestamp { my($self) = shift; unless(ref $_[0]) { no warnings 'uninitialized'; return DateTime::Infinite::Past->new if($_[0] eq '-infinity'); return DateTime::Infinite::Future->new if($_[0] eq 'infinity'); } my $method = ref($self)->parent_class . '::parse_timestamp'; no strict 'refs'; $self->$method(@_); } sub parse_timestamp_with_time_zone { my($self, $value) = @_; unless(ref $value) { no warnings 'uninitialized'; return DateTime::Infinite::Past->new if($value eq '-infinity'); return DateTime::Infinite::Future->new if($value eq 'infinity'); } my $method = ref($self)->parent_class . '::parse_timestamp_with_time_zone'; no strict 'refs'; shift->$method(@_); } sub validate_date_keyword { no warnings; $_[1] =~ /^(?:(?:now|timeofday)(?:\(\))?|(?:current_(?:date|time(?:stamp)?) |localtime(?:stamp)?)(?:\(\d*\))?|epoch|today|tomorrow|yesterday|)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_time_keyword { no warnings; $_[1] =~ /^(?:(?:now|timeofday)(?:\(\))?|(?:current_(?:date|time(?:stamp)?) |localtime(?:stamp)?)(?:\(\d*\))?|allballs)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } sub validate_timestamp_keyword { no warnings; $_[1] =~ /^(?:(?:now|timeofday)(?:\(\))?|(?:current_(?:date|time(?:stamp)?) |localtime(?:stamp)?)(?:\(\d*\))?|-?infinity|epoch|today|tomorrow|yesterday|allballs)$/xi || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); } *validate_datetime_keyword = \&validate_timestamp_keyword; sub server_time_zone { my($self) = shift; $self->{'date_handler'} = undef if(@_); my $method = ref($self)->parent_class . '::server_time_zone'; no strict 'refs'; $self->$method(@_); } sub european_dates { my($self) = shift; $self->{'date_handler'} = undef if(@_); my $method = ref($self)->parent_class . '::european_dates'; no strict 'refs'; $self->$method(@_); } sub parse_array { my($self) = shift; return $_[0] if(ref $_[0]); return [ @_ ] if(@_ > 1); my $val = $_[0]; return undef unless(defined $val); $val =~ s/^ (?:\[.+\]=)? \{ (.*) \} $/$1/sx; my @array; while($val =~ s/(?:"((?:[^"\\]+|\\.)*)"|([^",]+))(?:,|$)//) { my($item) = map { $_ eq 'NULL' ? undef : $_ } (defined $1 ? $1 : $2); $item =~ s{\\(.)}{$1}g if(defined $item); push(@array, $item); } return \@array; } sub format_array { my($self) = shift; return undef unless(ref $_[0] || defined $_[0]); my @array = (ref $_[0]) ? @{$_[0]} : @_; return '{' . join(',', map { if(!defined $_) { 'NULL' } elsif(/^[-+]?\d+(?:\.\d*)?$/) { $_ } elsif(ref($_) eq 'ARRAY') { $self->format_array($_); } else { s/\\/\\\\/g; s/"/\\"/g; qq("$_") } } @array) . '}'; } sub parse_interval { my($self, $value, $end_of_month_mode) = @_; if(!defined $value || UNIVERSAL::isa($value, 'DateTime::Duration') || $self->validate_interval_keyword($value) || ($self->keyword_function_calls && $value =~ /^\w+\(.*\)$/)) { return $value; } my($dt_duration, $error); TRY: { local $@; eval { $dt_duration = $self->date_handler->parse_interval($value) }; $error = $@; } my $method = ref($self)->parent_class . '::parse_interval'; no strict 'refs'; return $self->$method($value, $end_of_month_mode) if($error); if(defined $end_of_month_mode && $dt_duration) { # XXX: There is no mutator for end_of_month_mode, so I'm being evil # XXX: and setting it directly. Blah. $dt_duration->{'end_of_month'} = $end_of_month_mode; } return $dt_duration; } BEGIN { require DateTime::Format::Pg; # Handle DateTime::Format::Pg bug # http://rt.cpan.org/Public/Bug/Display.html?id=18487 if($DateTime::Format::Pg::VERSION < 0.11) { *format_interval = sub { my($self, $dur) = @_; return $dur if(!defined $dur || $self->validate_interval_keyword($dur) || ($self->keyword_function_calls && $dur =~ /^\w+\(.*\)$/)); my $val = $self->date_handler->format_interval($dur); $val =~ s/(\S+e\S+) seconds/sprintf('%f seconds', $1)/e; return $val; }; } else { *format_interval = sub { my($self, $dur) = @_; return $dur if(!defined $dur || $self->validate_interval_keyword($dur) || ($self->keyword_function_calls && $dur =~ /^\w+\(.*\)$/)); return $self->date_handler->format_interval($dur); }; } } sub next_value_in_sequence { my($self, $sequence_name) = @_; my $dbh = $self->dbh or return undef; my($value, $error); TRY: { local $@; eval { local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 1; my $sth = $dbh->prepare(qq(SELECT nextval(?))); $sth->execute($sequence_name); $value = ${$sth->fetchrow_arrayref}[0]; }; $error = $@; } if($error) { $self->error("Could not get the next value in the sequence '$sequence_name' - $error"); return undef; } return $value; } sub current_value_in_sequence { my($self, $sequence_name) = @_; my $dbh = $self->dbh or return undef; my($value, $error); TRY: { local $@; eval { local $dbh->{'PrintError'} = 0; local $dbh->{'RaiseError'} = 1; my $name = $dbh->quote_identifier($sequence_name); my $sth = $dbh->prepare(qq(SELECT last_value FROM $name)); $sth->execute; $value = ${$sth->fetchrow_arrayref}[0]; }; $error = $@; } if($error) { $self->error("Could not get the current value in the sequence '$sequence_name' - $error"); return undef; } return $value; } sub sequence_exists { defined shift->current_value_in_sequence(@_) ? 1 : 0 } sub use_auto_sequence_name { 1 } sub auto_sequence_name { my($self, %args) = @_; my $table = $args{'table'}; Carp::croak "Missing table argument" unless(defined $table); my $column = $args{'column'}; Carp::croak "Missing column argument" unless(defined $column); return lc "${table}_${column}_seq"; } *is_reserved_word = \&SQL::ReservedWords::PostgreSQL::is_reserved; # # DBI introspection # sub refine_dbi_column_info { my($self, $col_info, $meta) = @_; # Save default value my $default = $col_info->{'COLUMN_DEF'}; my $method = ref($self)->parent_class . '::refine_dbi_column_info'; no strict 'refs'; $self->$method($col_info); if(defined $default) { # Set sequence name key, if present if($default =~ /^nextval\(\(?'((?:''|[^']+))'::\w+/) { $col_info->{'rdbo_default_value_sequence_name'} = $self->likes_lowercase_sequence_names ? lc $1 : $1; if($meta) { my $seq = $col_info->{'rdbo_default_value_sequence_name'}; my $implicit_schema = $self->default_implicit_schema; # Strip off default implicit schema unless a schema is explicitly # specified in the RDBO metadata object. if(defined $seq && defined $implicit_schema && !defined $meta->schema) { $seq =~ s/^$implicit_schema\.//; } $col_info->{'rdbo_default_value_sequence_name'} = $self->unquote_column_name($seq); # Pg returns serial columns as integer or bigint if($col_info->{'TYPE_NAME'} eq 'integer' || $col_info->{'TYPE_NAME'} eq 'bigint') { my $db = $meta->db; my $auto_seq = $db->auto_sequence_name(table => $meta->table, column => $col_info->{'COLUMN_NAME'}); # Use schema prefix on auto-generated name if necessary if($seq =~ /^[^.]+\./) { my $schema = $meta->select_schema($db); $auto_seq = "$schema.$auto_seq" if($schema); } no warnings 'uninitialized'; if(lc $seq eq lc $auto_seq) { $col_info->{'TYPE_NAME'} = $col_info->{'TYPE_NAME'} eq 'integer' ? 'serial' : 'bigserial'; } } } } elsif($default =~ /^NULL::[\w ]+$/) { # RT 64331: https://rt.cpan.org/Ticket/Display.html?id=64331 $col_info->{'COLUMN_DEF'} = undef; } } my $type_name = $col_info->{'TYPE_NAME'}; # Pg has some odd/different names for types. Convert them to standard forms. if($type_name eq 'character varying') { $col_info->{'TYPE_NAME'} = 'varchar'; } elsif($type_name eq 'bit') { $col_info->{'TYPE_NAME'} = 'bits'; } elsif($type_name eq 'real') { $col_info->{'TYPE_NAME'} = 'float'; } elsif($type_name eq 'time without time zone') { $col_info->{'TYPE_NAME'} = 'time'; $col_info->{'pg_type'} =~ /^time(?:\((\d+)\))? without time zone$/i; $col_info->{'TIME_SCALE'} = $1 || 0; } elsif($type_name eq 'double precision') { $col_info->{'COLUMN_SIZE'} = undef; } elsif($type_name eq 'money') { $col_info->{'COLUMN_SIZE'} = undef; } # Pg does not populate COLUMN_SIZE correctly for bit fields, so # we have to extract the number of bits from pg_type. if($col_info->{'pg_type'} =~ /^bit\((\d+)\)$/) { $col_info->{'COLUMN_SIZE'} = $1; } # Extract precision and scale from numeric types if($col_info->{'pg_type'} =~ /^numeric/i) { no warnings 'uninitialized'; if($col_info->{'COLUMN_SIZE'} =~ /^(\d+),(\d+)$/) { $col_info->{'COLUMN_SIZE'} = $1; $col_info->{'DECIMAL_DIGITS'} = $2; } elsif($col_info->{'pg_type'} =~ /^numeric\((\d+),(\d+)\)$/i) { $col_info->{'COLUMN_SIZE'} = $2; $col_info->{'DECIMAL_DIGITS'} = $1; } } # Treat custom types that look like enums as enums if(ref $col_info->{'pg_enum_values'} && @{$col_info->{'pg_enum_values'}}) { $col_info->{'TYPE_NAME'} = 'enum'; $col_info->{'RDBO_ENUM_VALUES'} = $col_info->{'pg_enum_values'}; $col_info->{'RDBO_DB_TYPE'} = $col_info->{'pg_type'}; } # We currently treat all arrays the same, regardless of what they are # arrays of: integer, character, float, etc. So we covert TYPE_NAMEs # like 'integer[]' into 'array' if($col_info->{'TYPE_NAME'} =~ /^\w.*\[\]$/) { $col_info->{'TYPE_NAME'} = 'array'; } return; } sub parse_dbi_column_info_default { my($self, $string, $col_info) = @_; no warnings 'uninitialized'; local $_ = $string; my $pg_vers = $self->dbh->{'pg_server_version'}; # Example: q(B'00101'::"bit") if(/^B'([01]+)'::(?:bit|"bit")$/ && $col_info->{'TYPE_NAME'} eq 'bit') { return $1; } # Example: 922337203685::bigint elsif(/^(.+)::"?bigint"?$/i && $col_info->{'TYPE_NAME'} eq 'bigint') { return $1; } # TODO: http://rt.cpan.org/Ticket/Display.html?id=35462 # Example: '{foo,"\\"bar,",baz}'::text[] # ... # Example: 'value'::character varying # Example: ('now'::text)::timestamp(0) elsif(/^\(*'(.*)'::.+$/) { my $default = $1; # Single quotes are backslash-escaped, but PostgreSQL 8.1 and # later uses doubled quotes '' instead. Strangely, I see # doubled quotes in 8.0.x as well... if($pg_vers >= 80000 && index($default, q('')) > 0) { $default =~ s/''/'/g; } elsif($pg_vers < 80100 && index($default, q(\')) > 0) { $default = $1; $default =~ s/\\'/'/g; } return $default; } # Handle sequence-based defaults elsewhere elsif(/^nextval\(/) { return undef; } return $string; } sub list_tables { my($self, %args) = @_; my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE'; my @tables; my $schema = $self->schema; $schema = $self->default_implicit_schema unless(defined $schema); my $error; TRY: { local $@; eval { my $dbh = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; local $dbh->{'FetchHashKeyName'} = 'NAME'; my $sth = $dbh->table_info($self->catalog, $schema, '', $types, { noprefix => 1, pg_noprefix => 1 }); $sth->execute; while(my $table_info = $sth->fetchrow_hashref) { push(@tables, $self->unquote_table_name($table_info->{'TABLE_NAME'})); } }; $error = $@; } if($error) { Carp::croak "Could not list tables from ", $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } # sub list_tables # { # my($self) = shift; # # my @tables; # # my $schema = $self->schema; # $schema = $db->default_implicit_schema unless(defined $schema); # # if($DBD::Pg::VERSION >= 1.31) # { # @tables = $self->dbh->tables($self->catalog, $schema, '', 'TABLE', # { noprefix => 1, pg_noprefix => 1 }); # } # else # { # @tables = $dbh->tables; # } # } # # return wantarray ? @tables : \@tables; # } 1; __END__ =head1 NAME Rose::DB::Pg - PostgreSQL driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', server_time_zone => 'UTC', european_dates => 1, ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... $db = Rose::DB->new; # $db is really a Rose::DB::Pg-derived object ... =head1 DESCRIPTION L blesses objects into a class derived from L when the L is "pg". This mapping of driver names to class names is configurable. See the documentation for L's L and L methods for more information. This class cannot be used directly. You must use L and let its L method return an object blessed into the appropriate class for you, according to its L mappings. Only the methods that are new or have different behaviors than those in L are documented here. See the L documentation for the full list of methods. =head1 OBJECT METHODS =over 4 =item B Get or set the boolean value that determines whether or not dates are assumed to be in european dd/mm/yyyy format. The default is to assume US mm/dd/yyyy format (because this is the default for PostgreSQL). This value will be passed to L as the value of the C parameter in the call to the constructor C. This L object is used by L to parse and format date-related column values in methods like L, L, etc. =item B Advance the sequence named SEQUENCE and return the new value. Returns undef if there was an error. =item B Get or set the time zone used by the database server software. TZ should be a time zone name that is understood by L. The default value is "floating". This value will be passed to L as the value of the C parameter in the call to the constructor C. This L object is used by L to parse and format date-related column values in methods like L, L, etc. See the L documentation for acceptable values of TZ. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the SSL mode of the connection. Valid values for MODE are C, C, C, and C. This attribute is used to build the L L. Setting it has no effect until the next Lion. See the L documentation to learn more about this attribute. =back =head2 Value Parsing and Formatting =over 4 =item B Given a reference to an array or a list of values, return a string formatted according to the rules of PostgreSQL's "ARRAY" column type. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. =item B Given a L object, return a string formatted according to the rules of PostgreSQL's "INTERVAL" column type. If DURATION is undefined, a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. =item B Parse STRING and return a reference to an array. STRING should be formatted according to PostgreSQL's "ARRAY" data type. Undef is returned if STRING is undefined. =item B Parse STRING and return a L object. STRING should be formatted according to the PostgreSQL native "interval" (years, months, days, hours, minutes, seconds) data type. If STRING is a L object, a valid interval keyword (according to L), or if it looks like a function call (matches C) and L is true, then it is returned unmodified. Otherwise, undef is returned if STRING could not be parsed as a valid "interval" value. =item B Returns true if STRING is a valid keyword for the PostgreSQL "date" data type. Valid (case-insensitive) date keywords are: current_date epoch now now() today tomorrow yesterday The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid date keyword if L is true. =item B Returns true if STRING is a valid keyword for the PostgreSQL "datetime" data type, false otherwise. Valid (case-insensitive) datetime keywords are: -infinity allballs current_date current_time current_time() current_timestamp current_timestamp() epoch infinity localtime localtime() localtimestamp localtimestamp() now now() timeofday() today tomorrow yesterday The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid datetime keyword if L is true. =item B Returns true if STRING is a valid keyword for the PostgreSQL "time" data type, false otherwise. Valid (case-insensitive) timestamp keywords are: allballs current_time current_time() localtime localtime() now now() timeofday() The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid timestamp keyword if L is true. =item B Returns true if STRING is a valid keyword for the PostgreSQL "timestamp" data type, false otherwise. Valid (case-insensitive) timestamp keywords are: -infinity allballs current_date current_time current_time() current_timestamp current_timestamp() epoch infinity localtime localtime() localtimestamp localtimestamp() now now() timeofday() today tomorrow yesterday The keywords are case sensitive. Any string that looks like a function call (matches C) is also considered a valid timestamp keyword if L is true. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Registry/000750 000765 000024 00000000000 12502143063 016574 5ustar00johnstaff000000 000000 Rose-DB-0.777/lib/Rose/DB/Registry.pm000755 000765 000024 00000022075 12502134373 017154 0ustar00johnstaff000000 000000 package Rose::DB::Registry; use strict; use Carp(); use Rose::DB::Registry::Entry; use Rose::Object; our @ISA = qw(Rose::Object); our $VERSION = '0.728'; our $Debug = 0; # # Object data # use Rose::Object::MakeMethods::Generic ( 'scalar' => [ qw(error) ], 'scalar --get_set_init' => [ 'hash', 'parent', ], ); # # Object methods # sub init_hash { {} } sub init_parent { 'Rose::DB' } sub add_entries { my($self) = shift; # Smuggle parent in with an otherwise nonsensical arrayref arg my $parent = shift->[0] if(ref $_[0] eq 'ARRAY'); $parent ||= $self->parent; my $entries = $self->hash; my @added; foreach my $item (@_) { my($domain, $type, $entry); if(ref $item eq 'HASH') { if($entry = delete $item->{'entry'}) { $domain = delete $item->{'domain'}; $type = delete $item->{'type'}; if(keys(%$item)) { Carp::croak "If an 'entry' parameter is passed, no other ", "parameters (other than 'domain' and 'type') ", "may be passed"; } } else { $entry = Rose::DB::Registry::Entry->new(%$item); } } elsif(ref $item && $item->isa('Rose::DB::Registry::Entry')) { $entry = $item; } else { Carp::croak "Don't know how to add registry entry '$item'" } $domain = $entry->domain unless(defined $domain); $type = $entry->type unless(defined $type); unless(defined $domain) { $domain = $parent->default_domain; $entry->domain($domain); } unless(defined $type) { $type = $parent->default_type; $entry->type($type); } Carp::confess "$parent - Missing domain for registry entry: domain '$domain', type '$type'" unless(defined $domain); Carp::confess "$parent - Missing type for registry entry: domain '$domain', type '$type'" unless(defined $type); Carp::confess "$parent - Missing driver for registry entry: domain '$domain', type '$type'" unless(defined $entry->driver); $entries->{$domain}{$type} = $entry; push(@added, $entry); } return wantarray ? @added : \@added; } sub add_entry { my($self) = shift; # Smuggle parent in with an otherwise nonsensical arrayref arg my $parent = shift if(ref $_[0] eq 'ARRAY'); if(@_ == 1 || (ref $_[0] && $_[0]->isa('Rose::DB::Registry::Entry'))) { return ($self->add_entries(($parent ? $parent : ()), @_))[0]; } return ($self->add_entries(($parent ? $parent : ()), { @_ }))[0]; } sub entry_exists { my($self, %args) = @_; Carp::croak "Missing required 'type' argument" unless(defined $args{'type'}); Carp::croak "Missing required 'domain' argument" unless(defined $args{'domain'}); return exists $self->hash->{$args{'domain'}}{$args{'type'}}; } sub delete_entry { my($self, %args) = @_; return undef unless($self->entry_exists(%args)); return delete $self->hash->{$args{'domain'}}{$args{'type'}}; } sub entry { my($self, %args) = @_; return undef unless($self->entry_exists(%args)); return $self->hash->{$args{'domain'}}{$args{'type'}}; } sub delete_domain { my($self, $domain) = @_; my $entries = $self->hash; delete $entries->{$domain}; } sub registered_types { my($self, $domain) = @_; my @types = sort keys %{ $self->hash->{$domain} || {} }; return wantarray ? @types : \@types; } sub registered_domains { my @domains = sort keys %{ shift->hash }; return wantarray ? @domains : \@domains; } sub dump { my($self) = shift; my $entries = $self->hash; my %reg; foreach my $domain ($self->registered_domains) { foreach my $type ($self->registered_types($domain)) { $reg{$domain}{$type} = $entries->{$domain}{$type}->dump; } } return \%reg; } 1; __END__ =head1 NAME Rose::DB::Registry - Data source registry. =head1 SYNOPSIS use Rose::DB::Registry; $registry = Rose::DB::Registry->new; $registry->add_entry( domain => 'development', type => 'main', driver => 'Pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', server_time_zone => 'UTC'); $entry = Rose::DB::Registry::Entry->new( domain => 'production', type => 'main', driver => 'Pg', database => 'big_db', host => 'dbserver.acme.com', username => 'dbadmin', password => 'prodsecret', server_time_zone => 'UTC'); $registry->add_entry($entry); $entry = $registry->entry(domain => 'development', type => 'main'); $registry->entry_exists(domain => 'foo', type => 'bar'); # false $registry->delete_entry(domain => 'development', type => 'main'); ... =head1 DESCRIPTION L objects manage information about L data sources. Each data source has a corresponding L object that contains its information. The registry entries are organized in a two-level namespace based on a "domain" and a "type." See the L documentation for more information on data source domains and types. L inherits from, and follows the conventions of, L. See the L documentation for more information. =head1 CONSTRUCTOR =over 4 =item B Constructs a L object based on PARAMS, where PARAMS are name/value pairs. Any object method is a valid parameter name. =back =head1 OBJECT METHODS =over 4 =item B Add registry entries. Each ENTRY must be either a L-derived object or reference to a hash of name/value pairs. The name/value pairs must be valid arguments for L's constructor. Each ENTRY must have a defined domain and type, either in the L-derived object or in the name/value pairs. A fatal error will occur if these values are not defined. If a registry entry for the specified domain and type already exists, then the new entry will overwrite it. If you want to know beforehand whether or not an entry exists under a specific domain and type, use the L method. Returns a list (in list context) or reference to an array (in scalar context) of L objects added. =item B Add a registry entry. ENTRY must be either a L-derived object or a list of name/value pairs. The name/value pairs must be valid arguments for L's constructor. The ENTRY must have a defined domain and type, either in the L-derived object or in the name/value pairs. A fatal error will occur if these values are not defined. If a registry entry for the specified domain and type already exists, then the new entry will overwrite it. If you want to know beforehand whether or not an entry exists under a specific domain and type, use the L method. Returns the L object added. =item B Returns a reference to a hash containing information about all registered data sources. The hash is structured like this: { domain1 => { type1 => { # Rose::DB::Registry::Entry attributes # generated by its dump() method driver => ..., database => ..., host => ..., ... }, type2 => { ... }, ... }, domain2 => { ... }, ... } All the registry entry attribute values are copies, not the actual values. =item B Delete an entire domain, including all the registry entries under that domain. =item B Delete the registry entry specified by PARAMS, where PARAMS must be name/value pairs with defined values for C and C. A fatal error will occur if either one is missing or undefined. If the specified entry does not exist, undef is returned. Otherwise, the deleted entry is returned. =item B Get the registry entry specified by PARAMS, where PARAMS must be name/value pairs with defined values for C and C. A fatal error will occur if either one is missing or undefined. If the specified entry does not exist, undef is returned. =item B Returns true if the registry entry specified by PARAMS exists, false otherwise. PARAMS must be name/value pairs with defined values for C and C. A fatal error will occur if either one is missing or undefined. =item B Returns a list (in list context) or reference to an array (in scalar context) of the names of all registered types under the domain named DOMAIN. =item B Returns a list (in list context) or reference to an array (in scalar context) of the names of all registered domains. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/SQLite.pm000755 000765 000024 00000042435 12502134373 016507 0ustar00johnstaff000000 000000 package Rose::DB::SQLite; use strict; use Carp(); use Rose::DB; use SQL::ReservedWords::SQLite(); our $VERSION = '0.765'; #our $Debug = 0; use Rose::Class::MakeMethods::Generic ( inheritable_scalar => 'coerce_autoincrement_to_serial', ); __PACKAGE__->coerce_autoincrement_to_serial(1); # # Object methods # sub build_dsn { my($self_or_class, %args) = @_; my %info; $info{'dbname'} = $args{'db'} || $args{'database'}; return "dbi:SQLite:" . join(';', map { "$_=$info{$_}" } grep { defined $info{$_} } qw(dbname)); } sub dbi_driver { 'SQLite' } sub sqlite_unicode { shift->dbh_attribute_boolean('sqlite_unicode', @_) } sub init_dbh { my($self) = shift; my $database = $self->database; unless($self->auto_create || -e $database) { Carp::croak "Refusing to create non-existent SQLite database ", "file: '$database'"; } my $method = ref($self)->parent_class . '::init_dbh'; no strict 'refs'; return $self->$method(@_); } sub last_insertid_from_sth { shift->dbh->func('last_insert_rowid') } sub supports_multi_column_count_distinct { 0 } sub validate_date_keyword { no warnings; !ref $_[1] && (lc $_[1] eq 'current_timestamp' || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } sub validate_datetime_keyword { no warnings; !ref $_[1] && (lc $_[1] eq 'current_timestamp' || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } sub validate_timestamp_keyword { no warnings; !ref $_[1] && (lc $_[1] eq 'current_timestamp' || ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/)); } sub should_inline_date_keyword { 1 } sub should_inline_datetime_keyword { 1 } sub should_inline_time_keyword { 1 } sub should_inline_timestamp_keyword { 1 } sub parse_date { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_date_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse date '$value' - $error"); return undef; } return $dt; } sub parse_datetime { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_datetime_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse datetime '$value' - $error"); return undef; } return $dt; } sub parse_timestamp { my($self, $value) = @_; if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_timestamp_keyword($value)) { return $value; } my($dt, $error); TRY: { local $@; eval { $dt = Rose::DateTime::Util::parse_date($value) }; $error = $@; } if($error) { $self->error("Could not parse timestamp '$value' - $error"); return undef; } return $dt; } sub format_bitfield { my($self, $vec, $size) = @_; $vec = Bit::Vector->new_Bin($size, $vec->to_Bin) if($size); return q(b') . $vec->to_Bin . q('); } sub refine_dbi_column_info { my($self, $col_info) = @_; my $method = ref($self)->parent_class . '::refine_dbi_column_info'; no strict 'refs'; $self->$method($col_info); if($col_info->{'TYPE_NAME'} eq 'bit') { $col_info->{'TYPE_NAME'} = 'bits'; } elsif($col_info->{'TYPE_NAME'} eq 'datetime' && defined $col_info->{'COLUMN_DEF'}) { if(lc $col_info->{'COLUMN_DEF'} eq 'current_timestamp') { # Translate "current time" value into something that our date parser # will understand. $col_info->{'COLUMN_DEF'} = 'now'; # ...or let the database handle this? #$col_info->{'COLUMN_DEF'} = undef; } } return; } sub likes_implicit_joins { 1 } *is_reserved_word = \&SQL::ReservedWords::SQLite::is_reserved; sub quote_column_name { my $name = $_[1]; $name =~ s/"/""/g; return qq("$name"); } sub quote_table_name { my $name = $_[1]; $name =~ s/"/""/g; return qq("$name"); } # # Introspection # sub list_tables { my($self, %args) = @_; my $types = $args{'include_views'} ? q('table', 'view') : q('table'); my(@tables, $error); TRY: { local $@; eval { my $dbh = $self->dbh or die $self->error; local $dbh->{'RaiseError'} = 1; my $sth = $dbh->prepare("SELECT name FROM sqlite_master WHERE type IN($types)"); $sth->execute; my $name; $sth->bind_columns(\$name); while($sth->fetch) { push(@tables, $name); } }; $error = $@; } if($error) { Carp::croak "Could not list tables from ", $self->dsn, " - $error"; } return wantarray ? @tables : \@tables; } sub _get_primary_key_column_names { my($self, $catalog, $schema, $table) = @_; my $pk_columns = ($self->_table_info($table))[1] || []; return $pk_columns; } sub _table_info { my($self, $table) = @_; my $dbh = $self->dbh or Carp::croak $self->error; my $table_unquoted = $self->unquote_table_name($table); my $sth = $dbh->prepare("SELECT sql FROM sqlite_master WHERE type = 'table' AND name = ?"); my $sql; $sth->execute($table_unquoted); $sth->bind_columns(\$sql); $sth->fetch; $sth->finish; return $self->_info_from_sql($sql); } ## Yay! A Giant Wad o' Regexes "parser"! Yeah, this is lame, but I really ## don't want to load an actual parser, or even a regex lib or helper... our $Paren_Depth = 15; our $Nested_Parens = '\(' . '([^()]|\(' x $Paren_Depth . '[^()]*' . '\))*' x $Paren_Depth . '\)'; # This doesn't seem to work... #$Nested_Parens = qr{\( (?: (?> [^()]+ ) | (??{ $Nested_Parens }) )* \)}x; our $Quoted = qr{(?: ' (?: [^'] | '' )+ ' | " (?: [^"] | "" )+ " | ` (?: [^`] | `` )+ `)}six; our $Name = qr{(?: $Quoted | \w+ )}six; our $Type = qr{\w+ (?: \s* \( \s* \d+ \s* (?: , \s* \d+ \s*)? \) )?}six; our $Conflict_Algorithm = qr{(?: ROLLBACK | ABORT | FAIL | IGNORE | REPLACE )}six; our $Conflict_Clause = qr{(?: ON \s+ CONFLICT \s+ $Conflict_Algorithm )}six; our $Sort_Order = qr{(?: COLLATE \s+ \S+ \s+)? (?:ASC | DESC)}six; our $Column_Constraint = qr{(?: NOT \s+ NULL (?: \s+ $Conflict_Clause)? | PRIMARY \s+ KEY (?: \s+ $Sort_Order)? (?: \s+ $Conflict_Clause)? (?: \s+ AUTOINCREMENT)? | UNIQUE (?: \s+ $Conflict_Clause)? | CHECK \s* $Nested_Parens (?: \s+ $Conflict_Clause)? | REFERENCES \s+ $Name \s* \( \s* $Name \s* \) | DEFAULT \s+ (?: $Name | \w+ \s* $Nested_Parens | [^,)]+ ) | COLLATE \s+ \S+)}six; our $Table_Constraint = qr{(?: (?: PRIMARY \s+ KEY | UNIQUE | CHECK ) \s* $Nested_Parens | FOREIGN \s+ KEY \s+ (?: $Name \s+ )? $Nested_Parens \s+ REFERENCES \s+ $Name \s+ $Nested_Parens )}six; our $Column_Def = qr{($Name) (?:\s+ ($Type))? ( (?: \s+ (?:CONSTRAINT \s+ $Name \s+)? $Column_Constraint )* )}six; # SQLite allows C comments to be unterminated if they're at the end of the # input stream. Crazy, but true: http://www.sqlite.org/lang_comment.html our $C_Comment_Cont = qr{/\*.*$}six; our $C_Comment = qr{/\*[^*]*\*+(?:[^/*][^*]*\*+)*/}six; our $SQL_Comment = qr{--[^\r\n]*(\r?\n)}six; our $Comment = qr{($Quoted)|($C_Comment|$SQL_Comment|$C_Comment_Cont)}six; # These constants are from the DBI documentation. Is there somewhere # I can load these from? use constant SQL_NO_NULLS => 0; use constant SQL_NULLABLE => 1; sub _info_from_sql { my($self, $sql) = @_; my(@col_info, @pk_columns, @uk_info); my($new_sql, $pos); my $class = ref($self) || $self; # Remove comments while($sql =~ /\G((.*?)$Comment)/sgix) { $pos = pos($sql); if(defined $4) # caught comment { no warnings 'uninitialized'; $new_sql .= "$2$3"; } else { $new_sql .= $1; } } $sql = $new_sql . substr($sql, $pos) if(defined $new_sql); # Remove the start and end $sql =~ s/^\s* CREATE \s+ (?:TEMP(?:ORARY)? \s+)? TABLE \s+ $Name \s*\(\s*//sgix; $sql =~ s/\s*\)\s*$//six; # Remove leading space from lines $sql =~ s/^\s+//mg; my $i = 1; # Column definitions while($sql =~ s/^$Column_Def (?:\s*,\s*|\s*$)//six) { my $col_name = _unquote_name($1); my $col_type = $2 || 'scalar'; my $constraints = $3; unless(defined $col_name) { Carp::croak "Could not extract column name from SQL: $sql"; } my %col_info = ( COLUMN_NAME => $col_name, TYPE_NAME => $col_type, ORDINAL_POSITION => $i++, ); if($col_type =~ /^(\w+) \s* \( \s* (\d+) \s* \)$/x) { $col_info{'TYPE_NAME'} = $1; $col_info{'COLUMN_SIZE'} = $2; $col_info{'CHAR_OCTET_LENGTH'} = $2; } elsif($col_type =~ /^\s* (\w+) \s* \( \s* (\d+) \s* , \s* (\d+) \s* \) \s*$/x) { $col_info{'TYPE_NAME'} = $1; $col_info{'DECIMAL_DIGITS'} = $2; $col_info{'COLUMN_SIZE'} = $3; } while($constraints =~ s/^\s* (?:CONSTRAINT \s+ $Name \s+)? ($Column_Constraint) \s*//six) { local $_ = $1; if(/^DEFAULT \s+ ( $Name | \w+ \s* $Nested_Parens | [^,)]+ )/six) { $col_info{'COLUMN_DEF'} = _unquote_name($1); } elsif(/^PRIMARY (?: \s+ KEY )? \b (?: .*? (AUTOINCREMENT) )?/six) { push(@pk_columns, $col_name); if($1 && $class->coerce_autoincrement_to_serial) { $col_info{'TYPE_NAME'} = 'serial'; } } elsif(/^\s* UNIQUE (?: \s+ KEY)? \b/six) { push(@uk_info, [ $col_name ]); } elsif(/^NOT \s+ NULL \b/six) { $col_info{'NULLABLE'} = SQL_NO_NULLS; } } $col_info{'NULLABLE'} = SQL_NULLABLE unless(defined $col_info{'NULLABLE'}); push(@col_info, \%col_info); } while($sql =~ s/^($Table_Constraint) (?:\s*,\s*|\s*$)//six) { my $constraint = $1; if($constraint =~ /^\s* PRIMARY \s+ KEY \s* ($Nested_Parens)/six) { @pk_columns = (); my $columns = $1; $columns =~ s/^\(\s*//; $columns =~ s/\s*\)\s*$//; while($columns =~ s/^\s* ($Name) (?:\s*,\s*|\s*$)//six) { push(@pk_columns, _unquote_name($1)); } } elsif($constraint =~ /^\s* UNIQUE \s* ($Nested_Parens)/six) { my $columns = $1; $columns =~ s/^\(\s*//; $columns =~ s/\s*\)\s*$//; my @uk_columns; while($columns =~ s/^\s* ($Name) (?:\s*,\s*|\s*$)//six) { push(@uk_columns, _unquote_name($1)); } push(@uk_info, \@uk_columns); } } return(\@col_info, \@pk_columns, \@uk_info); } sub _unquote_name { my $name = shift; if($name =~ s/^(['`"]) ( (?: [^\1]+ | \1\1 )+ ) \1 $/$2/six) { my $q = $1; $name =~ s/$q$q/$q/g; } return $name; } 1; __END__ =head1 NAME Rose::DB::SQLite - SQLite driver class for Rose::DB. =head1 SYNOPSIS use Rose::DB; Rose::DB->register_db( domain => 'development', type => 'main', driver => 'sqlite', database => '/path/to/some/file.db', ); Rose::DB->default_domain('development'); Rose::DB->default_type('main'); ... # Set max length of varchar columns used to emulate the array data type Rose::DB::SQLite->max_array_characters(128); $db = Rose::DB->new; # $db is really a Rose::DB::SQLite-derived object ... =head1 DESCRIPTION L blesses objects into a class derived from L when the L is "sqlite". This mapping of driver names to class names is configurable. See the documentation for L's L and L methods for more information. This class cannot be used directly. You must use L and let its L method return an object blessed into the appropriate class for you, according to its L mappings. This class supports SQLite version 3 only. See the SQLite web site for more information on the major versions of SQLite: L Only the methods that are new or have different behaviors than those in L are documented here. See the L documentation for the full list of methods. =head1 DATA TYPES SQLite doesn't care what value you pass for a given column, regardless of that column's nominal data type. L does care, however. The following data type formats are enforced by L's L and L functions. Type Format --------- ------------------------------ DATE YYYY-MM-DD DATETIME YYYY-MM-DD HH:MM::SS TIMESTAMP YYYY-MM-DD HH:MM::SS.NNNNNNNNN =head1 CLASS METHODS =over 4 =item B Get or set a boolean value that indicates whether or not "auto-increment" columns will be considered to have the column type "serial." The default value is true. This setting comes into play when L is used to auto-create column metadata based on an existing database schema. =item B Get or set the maximum length of varchar columns used to emulate the array data type. The default value is 255. SQLite does not have a native "ARRAY" data type, but it can be emulated using a "VARCHAR" column and a specially formatted string. The formatting and parsing of this string is handled by the C and C object methods. The maximum length limit is honored by the C object method. =back =head1 OBJECT METHODS =over 4 =item B Get or set a boolean value indicating whether or not a new SQLite L should be created if it does not already exist. Defaults to true. If false, and if the specified L does not exist, then a fatal error will occur when an attempt is made to L to the database. =item B Get or set a boolean value that indicates whether or not Perl's UTF-8 flag will be set for all text strings coming out of the database. See the L documentation for more information. =back =head2 Value Parsing and Formatting =over 4 =item B Given a reference to an array or a list of values, return a specially formatted string. Undef is returned if ARRAYREF points to an empty array or if LIST is not passed. The array or list must not contain undefined values. If the resulting string is longer than C, a fatal error will occur. =item B Parse STRING and return a reference to an array. STRING should be formatted according to the SQLite array data type emulation format returned by C. Undef is returned if STRING is undefined. If a LIST of more than one item is passed, a reference to an array containing the values in LIST is returned. If a an ARRAYREF is passed, it is returned as-is. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATE" data type. If STRING is a valid date keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATE" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME" data type. If STRING is a valid datetime keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME" value. =item B Parse STRING and return a L object. STRING should be formatted according to the Informix "DATETIME" data type. If STRING is a valid timestamp keyword (according to L) it is returned unmodified. Returns undef if STRING could not be parsed as a valid "DATETIME" value. =item B Returns true if STRING is a valid keyword for the "date" data type. Valid date keywords are: current_timestamp The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid date keyword if L is true. =item B Returns true if STRING is a valid keyword for the "datetime" data type, false otherwise. Valid datetime keywords are: current_timestamp The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid datetime keyword if L is true. =item B Returns true if STRING is a valid keyword for the "timestamp" data type, false otherwise. Valid timestamp keywords are: current_timestamp The keywords are not case sensitive. Any string that looks like a function call (matches /^\w+\(.*\)$/) is also considered a valid timestamp keyword if L is true. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Tutorial.pod000755 000765 000024 00000031274 12502142433 017312 0ustar00johnstaff000000 000000 =head1 NAME Rose::DB::Tutorial - Best practices for using Rose::DB =head1 INTRODUCTION This tutorial describes "best practices" for using L in the most robust, maintainable manner. It does not replace the actual documentation, however. The actual L documentation is still essential, and contains some good examples of its own. In particular, you should read the L section of the L documentation if you have not done so already. It describes the features and philosophy of L. That information that will not be repeated here. =head1 CONVENTIONS The examples in this tutorial will use the fictional C namespace prefix. Your code should use whatever namespace you deem appropriate. Usually, it will be more akin to C (i.e., your corporation, organization, and/or project). I've chosen to use C simply because it's shorter, and will help this tutorial stay within an 80-column width. For the sake of brevity, the C directive and associated "my" declarations have been omitted from the example code. Needless to say, you should always C in your actual code. Similarly, the traditional "1;" true value used at the end of each ".pm" file has been omitted from the examples. Don't forget to add this to the end of your actual Perl module files. =head1 TUTORIAL =head2 Creating a subclass The first step when using L in anything but a throw-away script is to create a trivial subclass. This is important because L has a significant amount of class data. Using L directly means that you will be reading and writing the same data as any other badly-behaved code that also uses L directly. In particular, the L that contains all the information for each data source is class data, and is inherited from (that is, shared with) the base class by default. Creating a subclass allows you to have your own, private data source registry. So, here's our initial L subclass. # File: My/DB.pm package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); # Use a private registry for this class __PACKAGE__->use_private_registry; =head2 Designing your namespace As L in the L documentation, L provides a two-level namespace for data sources, made up of a "domain" and a "type." These are both arbitrary strings, so there's a lot of freedom to break up the namespace in any way you see fit. For example, sub-domains and sub-types can be created within each string using delimiter characters (e.g., "::" as in Perl's package namespace). But let's back up. The simplest case is that you have just one data source, and therefore no need for a namespace at all. If this is the case, you can skip to the L. In the common case, it's usually sufficient to use simple words for both type and domain. As the name "domain" implies, this value usually represents the environment or surroundings. For example, a typical server application might use domains named "development", "qa", "staging", and "production". The "type" portion of the namespace tends to be used to differentiate the applicability or contents of the data sources. Some example type names are "main" for the primary database, "archive" for a data warehouse database, and "session" for a database used to store transient session data. The goal of namespace design is to allow data sources to be referred to symbolically, with names that make sense to you in your environment. =head2 Registering data sources Now that you've decided on your namespace design (or lack thereof, if you have only one data source), it's time to register some data sources. To register a data source, call the L class method. This can be done nearly anywhere, but it's most convenient to do it "early" and to link it somehow to your C subclass. That is, when someone Cs C, they should not have to worry about whether or not all the data sources are registered. In a server environment, there's usually some sort of start-up file that gets loaded before any "end-user" code (e.g., "startup.pl" by convention in a mod_perl Apache web server). That may be a good place to include your data source registration calls, but only if you're absolutely sure that C will never be used outside the server environment. A better, safer alternative is to put the data source registration calls directly in your L subclass. This is the recommended approach. Here are some examples. =head3 Just one data source First, consider the case where a namespace is not necessary. You have a single data source and that's all. You don't care what it's named. Luckily, there are default values for both L and L. Simply register your data source using these values and you're all set. package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); # Use a private registry for this class __PACKAGE__->use_private_registry; # Register your lone data source using the default type and domain __PACKAGE__->register_db( domain => My::DB->default_domain, type => My::DB->default_type, driver => 'pg', database => 'my_db', host => 'localhost', username => 'joeuser', password => 'mysecret', ); The domain and type parameters can actually be omitted entirely and they will still default to the values shown above. In other words, the following call to L is exactly equivalent to the one above. # Register your lone data source using the default type and domain __PACKAGE__->register_db( driver => 'pg', database => 'my_db', host => 'localhost', username => 'joeuser', password => 'mysecret', ); To use C in this kind of setup, simply omit the L and L parameters from your calls to Cnew>. They will automatically get the default values. use My::DB; $db = My::DB->new(); # use default type and default domain print $db->username; # "joeuser" $dbh = $db->dbh; # connect and get DBI database handle =head3 Multiple data sources Most commonly, you will have more than one data source. (And if you don't now, you probably will in the future. Better safe than sorry.) After you've L, data source registration is straightforward. The only wrinkle is how to deal with the default domain and type. I recommend setting the default domain and type to the "safest" values in your environment. For example, a domain of "development" and a type of "main" are reasonable choices. This allows you to use "bare" calls to Cnew()> in your code (as shown in the simple, single data source example L). Here's an example that includes two domains "development" and "production", and two types, "main" and "session." The default data source is the domain "development" and the type "main". package My::DB; use Rose::DB; our @ISA = qw(Rose::DB); # Use a private registry for this class __PACKAGE__->use_private_registry; # Set the default domain and type __PACKAGE__->default_domain('development'); __PACKAGE__->default_type('main'); # Register the data sources # Development: __PACKAGE__->register_db( domain => 'development', type => 'main', driver => 'pg', database => 'dev_db', host => 'localhost', username => 'devuser', password => 'mysecret', ); __PACKAGE__->register_db( domain => 'development', type => 'session', driver => 'mysql', database => 'session_db', host => 'localhost', username => 'devmysql', password => 'mysqlpw', ); # Production: __PACKAGE__->register_db( domain => 'production', type => 'main', driver => 'pg', database => 'big_db', host => 'dbserver.mycorp.com', username => 'dbadmin', password => 'prodsecret', ); __PACKAGE__->register_db( domain => 'production', type => 'session', driver => 'mysql', database => 'session_db', host => 'sessions.mycorp.com', username => 'session_user', password => 'prodsesspw', ); Ideally, and as shown in the example above, all data source types are available in each domain. Combined with the consistent practice of never specifying an explicit domain when constructing your C objects, this allows the domain to be switched as needed, without modifying any code in the actual application. For example, imagine a mod_perl Apache web server environment running application code that constructs its C objects like this: $main_db = My::DB->new('main'); $session_db = My::DB->new('session'); Now imagine a "startup.pl" file that contains the following: # File: startup.pl use My::DB; if($ENV{'MYCORP_PRODUCTION_SERVER'}) { My::DB->default_domain('production'); } else { My::DB->default_domain('development'); } This deliberate use of defaults combined with a healthy dose of convention in your constructor calls can make it simple to move your code from one environment to another without any changes beyond the usual configuration management that must be done (e.g., for apache configuration files). The determination of the current environment can be done in many different ways, of course. Checking an environment variable as shown above is probably not the best way to do it, but it makes for a simple example. Another alternative is to use some sort of configuration/build management system to generate the Apache configuration files from templates. In that case, the L could contain something like this: [% IF in_production %] My::DB->default_domain('production'); [% ELSE %] My::DB->default_domain('development'); [% END %] This would leave only the single, appropriate call in the completed "startup.pl" file. =head2 Using your database objects Before trying to use L objects, it's important to understand the primary goals of L. The L are described in the L documentation, but there is one thing that is left unsaid. Although L is useful in isolation and provides many convenient methods and abstractions, its primary purpose is to encapsulate database-specific behaviors on behalf of L. Of course, it could fill the same role for any L-like module, and for any code that does the same kinds of things. If you need to parse or format L or want to use a simple form of L to keep track of shared database handles, you may find L useful. The most common non-L-related use for L is as a way to get a L database handle without sweating the details of how it's created or where it's connected. The previous sections of this tutorial cover everything you need to know to set up L to be used in this capacity. Please be sure to read the L as well, particularly the L section. =head1 DEVELOPMENT POLICY The L applies to this, and all C modules. Please install L from CPAN and then run C for more information. =head1 SUPPORT Any L questions or problems can be posted to the L mailing list. (If the volume ever gets high enough, I'll create a separate list for L. But it isn't an issue right now.) To subscribe to the list or view the archives, go here: L Although the mailing list is the preferred support mechanism, you can also email the author (see below) or file bugs using the CPAN bug tracking system: L There's also a wiki and other resources linked from the Rose project home page: L =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 COPYRIGHT Copyright (c) 2007 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Registry/Entry.pm000755 000765 000024 00000063307 12502134373 020260 0ustar00johnstaff000000 000000 package Rose::DB::Registry::Entry; use strict; use Clone::PP(); use Rose::Object; our @ISA = qw(Rose::Object); our $VERSION = '0.765'; our $Debug = 0; # # Object data # our %Attrs; BEGIN { our %Attrs = ( # Generic catalog => { type => 'scalar' }, database => { type => 'scalar' }, dbi_driver => { type => 'scalar' }, description => { type => 'scalar' }, domain => { type => 'scalar' }, driver => { type => 'scalar', make_method => 0 }, dsn => { type => 'scalar' }, host => { type => 'scalar' }, password => { type => 'scalar' }, port => { type => 'scalar' }, schema => { type => 'scalar' }, server_time_zone => { type => 'scalar' }, type => { type => 'scalar' }, username => { type => 'scalar' }, connect_options => { type => 'hash', method_spec => { interface => 'get_set_init' } }, pre_disconnect_sql => { type => 'array' }, post_connect_sql => { type => 'array' }, # Pg european_dates => { type => 'boolean', method_spec => { default => 0 } }, pg_enable_utf8 => { type => 'boolean' }, options => { type => 'scalar' }, service => { type => 'scalar' }, sslmode => { type => 'scalar' }, # SQLite auto_create => { type => 'boolean', method_spec => { default => 1 } }, sqlite_unicode => { type => 'boolean' }, # MySQL mysql_auto_reconnect => { type => 'boolean' }, mysql_client_found_rows => { type => 'boolean' }, mysql_compression => { type => 'boolean' }, mysql_connect_timeout => { type => 'boolean' }, mysql_embedded_groups => { type => 'scalar' }, mysql_embedded_options => { type => 'scalar' }, mysql_enable_utf8 => { type => 'boolean' }, mysql_local_infile => { type => 'scalar' }, mysql_multi_statements => { type => 'boolean' }, mysql_read_default_file => { type => 'scalar' }, mysql_read_default_group => { type => 'scalar' }, mysql_socket => { type => 'scalar' }, mysql_ssl => { type => 'boolean' }, mysql_ssl_ca_file => { type => 'scalar' }, mysql_ssl_ca_path => { type => 'scalar' }, mysql_ssl_cipher => { type => 'scalar' }, mysql_ssl_client_cert => { type => 'scalar' }, mysql_ssl_client_key => { type => 'scalar' }, mysql_use_result => { type => 'boolean' }, mysql_bind_type_guessing => { type => 'boolean' }, ); } sub _attrs { my(%args) = @_; my $type = $args{'type'}; # Type filter first my @attrs = $type ? (grep { $Attrs{$_}{'type'} eq $type } keys(%Attrs)) : keys(%Attrs); if($args{'with_defaults'}) { @attrs = grep { $Attrs{$_}{'method_spec'} && defined $Attrs{$_}{'method_spec'}{'default'} } @attrs; } elsif($args{'no_defaults'}) { @attrs = grep { !$Attrs{$_}{'method_spec'} || !defined $Attrs{$_}{'method_spec'}{'default'} } @attrs; } return wantarray ? @attrs : \@attrs; } sub _attr_method_specs { my $attrs = _attrs(@_); my @specs; foreach my $attr (@$attrs) { next if(exists $Attrs{$attr}{'make_method'} && !$Attrs{$attr}{'make_method'}); if(my $spec = $Attrs{$attr}{'method_spec'}) { push(@specs, $attr => $spec); } else { push(@specs, $attr); } } return wantarray ? @specs : \@specs; } use Rose::Object::MakeMethods::Generic ( 'scalar' => [ _attr_method_specs(type => 'scalar'), ], 'boolean' => [ _attr_method_specs(type => 'boolean'), ], 'hash' => [ _attr_method_specs(type => 'hash'), 'connect_option' => { hash_key => 'connect_options' }, ], 'array' => [ _attr_method_specs(type => 'array'), ] ); sub init_connect_options { {} } sub autocommit { shift->connect_option('AutoCommit', @_) } sub print_error { shift->connect_option('PrintError', @_) } sub raise_error { shift->connect_option('RaiseError', @_) } sub handle_error { shift->connect_option('HandleError', @_) } sub driver { my($self) = shift; return $self->{'driver'} unless(@_); $self->{'dbi_driver'} = shift; return $self->{'driver'} = lc $self->{'dbi_driver'}; } sub dump { my($self) = shift; my %dump; foreach my $attr (_attrs(type => 'scalar'), _attrs(type => 'boolean', no_defaults => 1)) { my $value = $self->$attr(); next unless(defined $value); $dump{$attr} = $value; } foreach my $attr (_attrs(type => 'hash'), _attrs(type => 'array')) { my $value = $self->$attr(); next unless(defined $value); $dump{$attr} = Clone::PP::clone($value); } # These booleans have defaults, but we only want the ones # where the values were explicitly set. Ugly... foreach my $attr (_attrs(type => 'boolean', with_defaults => 1)) { my $value = $self->{$attr}; next unless(defined $value); $dump{$attr} = Clone::PP::clone($value); } return \%dump; } sub clone { Clone::PP::clone($_[0]) } 1; __END__ =head1 NAME Rose::DB::Registry::Entry - Data source registry entry. =head1 SYNOPSIS use Rose::DB::Registry::Entry; $entry = Rose::DB::Registry::Entry->new( domain => 'production', type => 'main', driver => 'Pg', database => 'big_db', host => 'dbserver.acme.com', username => 'dbadmin', password => 'prodsecret', server_time_zone => 'UTC'); Rose::DB->register_db($entry); # ...or... Rose::DB->registry->add_entry($entry); ... =head1 DESCRIPTION C objects store information about a single L data source. See the L documentation for more information on data sources, and the L documentation to learn how C objects are managed. C inherits from, and follows the conventions of, L. See the L documentation for more information. =head1 CONSTRUCTOR =over 4 =item B Constructs a C object based on PARAMS, where PARAMS are name/value pairs. Any object method is a valid parameter name. =back =head1 OBJECT METHODS =head2 GENERAL =over 4 =item B Get or set the value of the "AutoCommit" connect option. =item B Get or set the database catalog name. This setting is only relevant to databases that support the concept of catalogs. =item B Returns a clone (i.e., deep copy) of the current object. =item B Get or set the connect option named NAME. Returns the current value of the connect option. =item B Get or set the options passed in a hash reference as the fourth argument to the call to Cconnect()>. See the C documentation for descriptions of the various options. If a reference to a hash is passed, it replaces the connect options hash. If a series of name/value pairs are passed, they are added to the connect options hash. Returns a reference to the hash of options in scalar context, or a list of name/value pairs in list context. =item B Get or set the database name. =item B A description of the data source. =item B Get or set the data source domain. Note that changing the C after a registry entry has been added to the registry has no affect on where the entry appears in the registry. =item B Get or set the driver name. The DRIVER argument is converted to lowercase before being set. =item B Get or set the C DSN (Data Source Name). Note that an explicitly set DSN may render some other attributes inaccurate. For example, the DSN may contain a host name that is different than the object's current C value. I recommend not setting the DSN value explicitly unless you are also willing to manually synchronize (or ignore) the corresponding object attributes. =item B Returns a reference to a hash of the entry's attributes. Only those attributes with defined values are included in the hash keys. All values are deep copies. =item B Get or set the value of the "HandleError" connect option. =item B Get or set the database server host name. =item B Get or set the database password. =item B Get or set the database server port number. =item B Get or set the SQL statements that will be run immediately before disconnecting from the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. =item B Get or set the SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. =item B Get or set the value of the "PrintError" connect option. =item B Get or set the value of the "RaiseError" connect option. =item B Get or set the database schema name. This setting is only useful to databases that support the concept of schemas (e.g., PostgreSQL). =item B Get or set the time zone used by the database server software. TZ should be a time zone name that is understood by C. See the C documentation for acceptable values of TZ. =item B Get or set the data source type. Note that changing the C after a registry entry has been added to the registry has no affect on where the entry appears in the registry. =item B Get or set the database username. =back =head2 DRIVER-SPECIFIC ATTRIBUTES =head3 MySQL These attributes should only be used with registry entries where the L is C. =over 4 =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =back =head3 PostgreSQL These attributes should only be used with registry entries where the L is C. =over 4 =item B Get or set the boolean value that determines whether or not dates are assumed to be in european dd/mm/yyyy format. The default is to assume US mm/dd/yyyy format (because this is the default for PostgreSQL). This value will be passed to L as the value of the C parameter in the call to the constructor C. This L object is used by L to parse and format date-related column values in methods like L, L, etc. =item B Get or set the L database handle attribute. This is set directly on the L, if one exists. Otherwise, it will be set when the L is created. If no value for this attribute is defined (the default) then it will not be set when the L is created, deferring instead to whatever default value L chooses. Returns the value of this attribute in the L, if one exists, or the value that will be set when the L is next created. See the L documentation to learn more about this attribute. =item B Get or set the SSL mode of the connection. Valid values for MODE are C, C, C, and C. See the L documentation to learn more about this attribute. =back =head3 SQLite These attributes should only be used with registry entries where the L is C. =over 4 =item B Get or set a boolean value indicating whether or not a new SQLite L should be created if it does not already exist. Defaults to true. If false, and if the specified L does not exist, then a fatal error will occur when an attempt is made to L to the database. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Rose-DB-0.777/lib/Rose/DB/Cache/Entry.pm000644 000765 000024 00000004362 12502134373 017444 0ustar00johnstaff000000 000000 package Rose::DB::Cache::Entry; use strict; use base 'Rose::Object'; our $VERSION = '0.736'; use Rose::Object::MakeMethods::Generic ( 'scalar' => [ 'db', 'key', ], 'boolean' => [ 'prepared', 'created_during_apache_startup', ] ); *is_prepared = \&prepared; 1; __END__ =head1 NAME Rose::DB::Cache::Entry - A cache entry for use with Rose::DB::Cache objects. =head1 SYNOPSIS package My::DB::Cache::Entry; use base 'Rose::DB::Cache::Entry'; ... package My::DB::Cache; use base 'Rose::DB::Cache'; use My::DB::Cache::Entry; __PACKAGE__->entry_class('My::DB::Cache::Entry'); ... =head1 DESCRIPTION L provides both an API and a default implementation of a cache entry for use with L objects. A L-derived class L L-derived objects to store cache entries. The default implementation includes attributes for storing the cache key, the cached L-derived object itself, and some boolean flags. Subclasses can add new attributes as desired. =head1 CONSTRUCTORS =over 4 =item B Constructs a new L object based on PARAMS, where PARAMS are name/value pairs. Any object method is a valid parameter name. =back =head1 OBJECT METHODS =over 4 =item B Get or set a boolean value indicating whether or not the L object this cache entry contains was created while the apache server was starting up. =item B Get or set the L-derived object stored in this cache entry. =item B Get or set the cache key for this entry. =item B Get or set a boolean value indicating whether or not a cache entry is "prepared." The interpretation of this flag is up to the L-derived class that L this entry class. =item B Returns true if L is true, false otherwise. =back =head1 AUTHOR John C. Siracusa (siracusa@gmail.com) =head1 LICENSE Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.