Build.bat
MANIFEST
MANIFEST.bak
-META.yml
+META.*
+MYMETA.*
Makefile
Makefile.old
-README
_build/
blib/
inc/
lib/DBIx/Class/Optional/Dependencies.pod
+DBIx-Class-*/
+DBIx-Class-*.tar.*
pm_to_blib
t/var/
+.*.sw?
--- /dev/null
+# This file allows us to map authors more correctly
+# so if someone were to legally change their name, we could use it to fix that
+# while maintaining the integrity of the repository
+
+# I've mapped the old single quote version of my name to the double quote
+# version for consistency
+Arthur Axel "fREW" Schmidt <frioux@gmail.com> Arthur Axel 'fREW' Schmidt <frioux@gmail.com>
+Andrew Rodland <andrew@cleverdomain.org> Andrew Rodland <arodland@cpan.org>
\ No newline at end of file
--- /dev/null
+With DBIx::Class on git now, this is the process for contributing.
+
+1) Clone the DBIx::Class master branch
+ > git clone dbsrgits@git.shadowcat.co.uk:DBIx-Class.git
+2) Do your work on your machine. This is git - everything is local!
+3) When you think you're ready, push it back out to the origin as a
+ remote branch. See rebasing for what you should do before pushing.
+ > git push origin my-branch
+4) Notify the other contributors that you're ready to have your branch
+ reviewed.
+5) Another contributor will merge it back into master. See rebasing for
+ what you should do before merging.
+
+Rebasing: Please rebase before merging and pushing; we'd rather not have
+commit messages that say, "Oops" and "typo", in master, and furthermore
+fast-forward merges lead to a cleaner history.
+
+Yes, this does mean that DBIx::Class is moving to a formal code review process.
+Yes, this does mean that you will never merge your own code to master.
Revision history for DBIx::Class
+ * New Features / Changes
+ - Issue a warning when DateTime objects are passed to ->search
+ - Fast populate() in void context is now even more efficient by
+ going directly through execute_for_fetch bypassing execute_array
+ - Fix update()/delete() on complex resultsets to no longer fall back
+ to silly row-by-row deletion, construct a massive OR statement
+ instead
+ - Allow complex update/delete operations on sources without a
+ primary key, as long as they have at least one non-nullable
+ unique constraint
+ - dbicadmin now better supports catalyst-style config files, by
+ unrolling 'config_info' hashkeys
+ - Multiple Improvements MSSQL over DBD::ADO
+ - Transaction support
+ - Support for VARCHAR(MAX)/VARBINARY(MAX)/NVARCHAR(MAX) datatypes
+ - Nomalization of retrieved GUID values
+
+ * Fixes
+ - Fix SkipFirst and FirstSkip limit dialects (Informix and Firebird)
+ - Fix "Skimming limit" dialects (Top, FetchFirst) to properly check
+ the order_by criteria for stability
+ - Fix "Skimming limit" dialects (Top, FetchFirst) to propagate
+ non-selected order criteria when part of a larger subquery
+ - Fix RowNumberOver and all "skimming limits" to correctly assemble
+ bind values when supplied for both select and order_by
+ - Fix all subquery-based dialects to not lose a subquery fragment
+ when we both select and order by the result of the same subquery
+ - Fix the Sybase hubrid limit dialect (RowCountOrGenericSubQ) losing
+ Group/Having/Order clauses when called without an offset (RT#73244)
+ - No longer generate incorrect SQL on ->as_query called on resultsets
+ with software_limit enabled
+ - A number of corner case fixes of void context populate() with \[]
+ - Fix corner case of forked children disconnecting the parents DBI
+ handle
+ - Improve identity/autoinc retrieval code in MSSQL and Sybase -
+ should reduce weird side-effects especially with populate()
+ - Explicitly disable DBD::ODBC batch operations (as of DBD::ODBC 1.35)
+ for the following drivers too buggy to handle the optimized path:
+ - FreeTDS ODBC driver (when used with MSSQL)
+ - The Firebird ODBC driver
+ - The MSAccess ODBC driver
+ - Explicitly disable DBD::ODBC dynamic_cursors when using freetds 0.83
+ or later - they made enough ODBC incompatible changes making it
+ impossible to support sanely
+ - Explicitly disable SCOPE_IDENTITY queries and statement caching for
+ MSSQL on DBD::Sybase compiled against freetds 0.83 or later - way too
+ buggy
+ - Disable statement caching when using Sybase ASE and DBD::Sybase
+ compiled against freetds 0.83 or later
+ - Fix leakage of $schema on in-memory new_related() calls
+ - Fix more cases of $schema leakage in SQLT::Parser::DBIC
+ - Fix leakage of $storage in ::Storage::DBI::Oracle
+ - Fix pessimization of Oracle RowNum limit dialect query when no
+ offset has been specified
+ - Remove useless vestigial pessimization in Ordered.pm for cases
+ when the position column is part of a unique constraint
+ - Fix dbicadmin to no longer ignore the documented 'config' option
+ - The schema-resultsource entanglement is now much more robust
+ under threads
+ - Fix ::Schema::ddl_filename() failing miserably on paths containing
+ certain numeric sequences
+ - t/53lean_startup.t adjusted for new 5.15.x base.pm behavior
+
+ * Misc
+ - Centralized leak-checks for all instances of DBICTest::Schema
+ from within any test
+ - Now passes all tests with Test::Builder 1.005
+ - Codebase is now trailing-whitespace-free
+ - Cleanup of complex resultset update/delete oprations - storage
+ specific code moved back to ResultSet and replaced by checks
+ of storage capabilities
+ - Fixed carp_once only emitting one single warning per package
+ regardless of warning content
+ - Test suite now can be safely executed in parallel (prove -jN
+ or HARNESS_OPTIONS=jN)
+
+0.08196 2011-11-29 05:35 (UTC)
+ * Fixes
+ - Fix tests for DBD::SQLite >= 1.34.
+ - Fix test failures with DBICTEST_SQLITE_USE_FILE set
+ - Fix the find() condition heuristics being invoked even when the
+ call defaults to 'primary' (i.e. when invoked with bare values)
+ - Throw much clearer error on incorrect inflation spec
+ - Fix incorrect storage behavior when first call on a fresh schema
+ is with_deferred_fk_checks
+ - Fix incorrect dependency on Test::Simple/Builder (RT#72282)
+ - Fix uninitialized warning in ::Storage::Sybase::ASE
+ - Improve/cache DBD-specific datatype bind checks (also solves a
+ nasty memleak with version.pm on multiple ->VERSION invocations)
+ - The internal carp module now correctly skips CAG frames when
+ reporting a callsite
+ - Fix test failures on perl < 5.8.7 and new Package::Stash::XS
+ - Fix TxnScopeGuard not behaving correctly when $@ is set at the
+ time of $guard instantiation
+ - Fix the join/prefetch resolver when dealing with ''/undef/()
+ relation specifications
+
+ * Misc
+ - No longer depend on Variable::Magic now that a pure-perl
+ namespace::clean is available
+ - Drop Oracle's Math::BigInt req down to 1.80 - no fixes concerning
+ us were made since
+
+0.08195 2011-07-27 16:20 (UTC)
+ * Fixes
+ - Fix horrible oversight in the Oracle sqlmaker when dealing with
+ queries updating blobs (RT#69829)
+
+0.08194 2011-07-20 16:10 (UTC)
+ * Fixes
+ - Fix $rs->populate([]) to be a no-op rather than an exception
+ - Overhaul t/53lean_startup.t to better dodge false positives
+ - Stop Data::Compare from loading random plugins
+ - Oracle: Recalculate LOB bind indices for UPDATE with LOBs in WHERE
+ (RT#69548)
+
+0.08193 2011-07-14 17:00 (UTC)
+ * New Features / Changes
+ - Allow schema cloning to mutate attributes
+ - DBIC now attempts more aggressive de-duplication of where
+ conditions on resultset chaining
+ - The Ordered component is now smarter wrt reordering of dirty
+ objects, and does its job with less storage queries
+ - Logging via DBIC_TRACE=1=<filename> no longer overwrites the
+ logfile on every program startup, appending loglines instead
+
+ * Fixes
+ - Fix issue where the query was becoming overly mangled when trying
+ to use pagination with a query that has a sub-select in the WHERE
+ clause
+ - Fix possible incorrect pagination on Oracle, when a resultset
+ is not ordered by a unique column
+ - Revert "Fix incorrect signature of the default sqlt_deploy_hook"
+ from 0.08191 - documentation was in fact incorrect, not the code
+ - Fix Sybase ASE IC::DateTime support (::Storage going out of sync
+ with new default format expected by DateTime::Format::Sybase)
+ - Fix a bug in update_all() resulting in the first row receiving a
+ different dataset than the subsequent ones
+ - Accomodate MSAccess supporting only 'INNER JOIN' (not plain 'JOIN')
+ - InflateColumn::DateTime option datetime_undef_if_invalid no longer
+ masks missing dependency exceptions (RT#66823)
+ - Fix bug in Schema::Versioned failing to insert a schema version row
+ during upgrades at the turn of the second
+ - Fix incorrect bind of integers >= 2^^32 (bigint columns) to
+ SQL_INTEGER, resulting in silent conversion to '-1'
+ - Fix pre 5.10 failures of t/55namespaces_cleaned.t due to buggy
+ require() (RT#68814)
+ - Oracle autoinc inserts no longer leave open cursors behind
+
+0.08192 2011-05-10 04:20 (UTC)
+ * Fixes
+ - Fix serious regression on SQLite, corrupting data when an alphanum
+ value does not correspond to a stale numeric datatype in colinfo
+
+0.08191 2011-05-02 00:45 (UTC) (deleted from CPAN)
+ * New Features / Changes
+ - Add quote_names connection option. When set to true automatically
+ sets quote_char and name_sep appropriate for your RDBMS
+ - Add retrieve_on_insert column info flag, allowing to retrieve any
+ column value instead of just autoinc primary keys
+ - Bring back strict ordering of selectors in complex search chains
+ (an ill-fated attempt was made in 0.08127 to order intelligently)
+ - All limit dialects (except for the older Top and FetchFirst) are
+ now using bind parameters for the limits/offsets, making DBI's
+ prepare_cached useful across paged resutsets
+ - Support for savepoints for SQLite
+ - Support for MS Access databases via DBD::ODBC and DBD::ADO (only
+ Win32 support currently tested)
+ - Support for the Firebird RDBMS over the new DBD::Firebird driver
+ - IC::DateTime support for MSSQL over DBD::ADO
+ - Both the ::ODBC and ::ADO dispatchers now warn if a rdbms-specific
+ driver is not found for this connection before falling back to
+ plain ::Storage::DBI
+ - ::Storage::DBI::sth was mistakenly marked/documented as public,
+ privatize and warn on deprecated use
+ - Massive overhaul of bind values/attributes handling - slightly
+ changes the output of as_query (should not cause compat issues)
+ - Support ancient DB2 versions (5.4 and older), with proper limit
+ dialect
+ - Support sub-second precision for TIMESTAMPs for Firebird over ODBC
+ - Support BLOBs and CLOBs in WHERE clauses for Oracle, including LIKE
+ queries for CLOBs.
+
+ * Fixes
+ - Fix ::Storage::DBI::* MRO problems on 5.8.x perls
+ - Disable mysql_auto_reconnect for MySQL - depending on the ENV
+ it sometimes defaults to on and causes major borkage on older
+ DBD::mysql versions
+ - Fix dropped bind values in select/group_by on Oracle (omission
+ from 0542ec57 and 4c2b30d6)
+ - Fix remaining errors with Oracle and identifiers longer than the
+ Oracle-imposed maximum of 30 characters (RT#66390)
+ - Fix older oracle-specific "WhereJoins" to work properly with
+ name quoting
+ - Fix problems with M.A.D. under CGI::SpeedyCGI (RT#65131)
+ - Reenable paging of cached resultsets - breakage erroneously added
+ in 0.08127
+ - Better error handling when prepare() fails silently
+ - Fixes skipped lines when a comment is followed by a statement
+ when deploying a schema via sql file
+ - Fix reverse_relationship_info on prototypical result sources
+ (sources not yet registered with a schema)
+ - Warn and skip relationships missing from a partial schema during
+ dbic cascade_delete
+ - Automatically require the requested cursor class before use
+ (RT#64795)
+ - Work around a Firebird ODBC driver bug exposed by DBD::ODBC 1.29
+ - Fix (to the extent allowed by the driver) transaction support in
+ DBD::Sybase compiled against FreeTDS
+ - Fix exiting via next warnings in ResultSource::sequence()
+ - Fix stripping of table qualifiers in update/delete in arrayref
+ condition elements
+ - Change SQLMaker carp-monkeypatch to be compatible with versions
+ of SQL::Abstract >= 1.73
+ - Fix using \[] literals in the from resultset attribute
+ - Fix populate() with \[], arrays (datatype) and other exotic values
+ - Fix handling of rollbacks in nested transactions
+ - Fix complex limits (RNO/RowNum/FetchFirst/Top/GenSubq) with
+ sub-selects in the selectors list (correlated subqueries)
+ - Fix inconsistency between $rs->next with and without HRI when all
+ the "root" columns are in fact injected from the right rs side
+ - Fix the join optimizer to correctly preserve the non-multi path to
+ a multi relationship ( x -> might_have y -> has_many z )
+ - Fix object-derived custom-relationship resultsets to resultsources
+ with multilevel monikers (e.g. $schema->source('Foo::Bar') )
+ - Fix incorrect signature of the default sqlt_deploy_hook - it now
+ matches the documentation of passing in the result source object
+ - Fix inadequate handling of internal storage methods within
+ ::Storage::Replicated (RT#66295)
+
+ * Misc
+ - Rewire all warnings to a new Carp-like implementation internal
+ to DBIx::Class, and remove the Carp::Clan dependency
+ - Only load Class::C3 and friends if necessary ($] < 5.010)
+ - Greatly reduced loading of non-essential modules to aid startup
+ time (mainly benefiting CGI users)
+ - Make sure all namespaces are clean of rogue imports
+ - Dropped DBI req 2 years back - everything works with 1.57, no
+ point requiring something newer
+
+0.08190-TRIAL 2011-01-24 15:35 (UTC)
+
+ * New Features / Changes
+ - Support for completely arbitrary SQL::Abstract-based conditions
+ in all types of relationships
+
+0.08127 2011-01-19 16:40 (UTC)
+ * New Features / Changes
+ - Schema/resultsource instances are now crossreferenced via a new
+ system guaranteeing leak-free mutually assured destruction
+ - DBIx::Class now warns when the user erroneously supplies
+ AutoCommit => 0 to connect()
+ - A warning is also issued before forcing the RaiseError
+ setting of externally supplied DBI handles
+ - Switch to a warning when find() is invoked with both a 'key'
+ argument and a NULL-containing condition to satisfy the named
+ constraint. Previously (starting with 0.08124) an exception was
+ thrown
+ - Switch to a warning when a commit is attempted with an out-of-sync
+ transaction_depth (someone issued a begin externally to DBIC).
+ Previously (starting with 0.08124) an exception was thrown
+
+ * Fixes
+ - A number of improvements/diagnostics of multiple active resultset
+ handling on MSSQL over DBD::ODBC
+ - Revert default selection to being lazy again (eagerness introduced
+ in 0.08125) - fixes DBIx::Class::Helper::ResultSet::RemoveColumns
+ - Fix losing order of columns provided in select/as (regression from
+ 0.08125)
+ - Unaliased "dark" selectors no longer throw off prefetch
+ - Fix proper composition of bind values across all possible
+ SQL areas ( group_by => \[ ... ] now works properly )
+ - Allow populate to skip empty has_many relationships which makes
+ it easier to pass HashRefInflator data directly to ->populate
+ - Improve freeze/thaw semantics and error messages (RT#62546)
+ - Fix inconsistency in Manual::Features (RT#64500)
+ - Fix incorrect SQL when using for => 'shared' with MySQL (RT#64590)
+ - Throw comprehensible exception on erroneous $schema->source()
+ invocation
+ - Fix sloppy refactor of ResultSource::sequence back from 89170201
+ (RT#64839)
+ - Fix incorrect error detection during populate() on Oracle
+ - Better handling of result_source-less row objects by
+ auto-calling result_source_instance when necessary
+ - Fix reverse_relationship_info and sqlt deploy on partially
+ loaded schemas (relationships point to non-existent sources)
+
+ * Misc
+ - Fix test warning on win32 - at this point the test suite is
+ warning-free on all known OSes
+ - Require newest namespace::clean which in turn depends on new
+ installable Package::Stash
+
+0.08126 2010-12-28 18:10 (UTC)
+ * Fixes
+ - Bump forgotten Class::Accessor::Grouped core dependency
+ - Promote forgotten Hash::Merge optdep to a hard requirement
+ - Skip t/storage/error.t on smokers with leaking perls
+ - Fix t/storage/txn.t deadlocks on slower machines
+ - Do not run on smokers if a trial Package::Stash is found
+
+0.08125 2010-12-27 04:30 (UTC)
+ * New Features / Changes
+ - New method ResultSource columns_info method, returning multiple
+ pairs of column name/info at once
+ - $rs->search now throws when called in void context, as it makes
+ no sense (and is nearly always a sign of a bug/misdesign)
+ - Restore long-lost ability to supply unbalanced select/as pairs
+ e.g. +select => \'DISTINCT(foo, bar)', +as => ['foo', 'bar']
+ - +columns now behaves just like columns by not stripping a
+ fully-qualified 'as' spec (i.e. foo.bar results in $obj->foo->bar)
+ - Deprecate legacy $rs->search( %condition ) syntax (warn once per
+ callsite)
+ - NULL is now supplied unquoted to all debug-objects, in order to
+ differentiate between a real NULL and the string 'NULL'
+ - New search() condition operator -value used to pass complex bind
+ values to DBI: search({ array_col => { -value => [1,2,3] }})
+ - Add full INSERT...RETURNING support for Oracle
+ - Deprecate use of -nest in search conditions (warn once per
+ callsite)
+ - Deprecate the completely useless DBIx::Class::Serialize::Storable
+ result component
+
+ * Fixes
+ - Fixed read-only attribute set attempt in ::Storage::Replicated
+ (RT#62642)
+ - Fix incomplete logic while detecting correct Oracle sequence
+ on insert
+ - Fix detection of Oracle sequences for tables without an explicitly
+ specified schema (RT#63493)
+ - Major overhaul of Storage::Oracle to handle enabled quoting
+ - Fixed incorrect composition of select/as/columns attributes during
+ chaining (RT#61235)
+ - Proper serialization of resultsets with open cursors
+ - Refactor handling of RDBMS-side values during insert() - fix
+ regression of inserts into a Postgres / ::Replicated combination
+ - Missing dependency check in t/60core.t (RT#62635)
+ - Fix regressions in IC::DT registration logic
+ - Fix regression in select-associated bind value handling (RT#61025)
+ - Simplify SQL generated by some LIMITed prefetching queries
+ - Throw an exception when a required group_by on a complex prefetch
+ can not be auto-constructed, instead of continuing to eventually
+ produce invalid SQL
+ - Fix infinite loops on old perls with a recent Try::Tiny
+ - Improve "fork()" on Win32 by reimplementing a more robust DBIC
+ thread support (still problematic, pending a DBI fix)
+ - Properly quote table name on INSERT with no values
+ - Work around possible Storage destruction warnings
+ - Fix count of grouped resultsets using HAVING with aliases
+ - Setting belongs_to columns/relationships no longer leaves the
+ FK value and related object out of sync
+ - Stop stripping newlines from SQL statements in the limit emulators
+ as it is possible that custom sql with comments was provided
+ - Add forgotten attributes to Admin.pm
+ - Fix incorrect 'having' attribute documentation (RT#64129)
+ - Improve fallback-to-master/return-to-slave reporting in
+ ::Replicated::Balancer
+ - Adjust txn_scope_guard code/tests to changes in $@ handling on
+ recent blead (RT#64251)
+
+ * Misc
+ - Add extra option groups to DBIC::Optional::Depencencies, to aid
+ users in requesting the prerequisites for a particular RDBMS
+ - Switch all serialization to use Storable::nfreeze for portable
+ architecture independent ice
+ - Fix the bogus META.yml dependency injection issue for good
+ - Refactor DBIx::Class::Storage::Statistics::debugfh() to be lazy
+
+0.08124 2010-10-28 14:23 (UTC)
+ * New Features / Changes
+ - Add new -ident "function" indicating rhs is a column name
+ { col => { -ident => 'othercol' } } vs { col => \'othercol' }
+ - Extend 'proxy' relationship attribute
+ - Use DBIx::Class::Storage::Debug::PrettyPrint when the
+ environment variable DBIC_TRACE_PROFILE is set, see
+ DBIx::Class::Storage for more information
+ - Implemented add_unique_constraints() which delegates to
+ add_unique_constraint() as appropriate
+ - add_unique_constraint() now poparly throws if called with
+ multiple constraint definitions
+ - No longer depend on SQL::Abstract::Limit - DBIC has been doing
+ most of the heavy lifting for a while anyway
+ - FilterColumn now passes data through when transformations
+ are not specified rather than throwing an exception.
+ - Optimized RowNum based Oracle limit-dialect (RT#61277)
+ - Requesting a pager on a resultset with cached entries now
+ throws an exception, instead of returning a 1-page object
+ since the amount of rows is always equal to the "pagesize"
+ - $rs->pager now uses a lazy count to determine the amount of
+ total entries only when really needed, instead of doing it
+ at instantiation time
+ - New documentation map organized by features
+ (DBIx::Class::Manual::Features)
+ - find( { ... }, { key => $constraint } ) now throws an exception
+ when the supplied data does not fully specify $constraint
+ - find( col1 => $val1, col2 => $val2, ... ) is no longer supported
+ (it has been in deprecated state for more than 4 years)
+ - Make sure exception_action does not allow exception-hiding
+ due to badly-written handlers (the mechanism was never meant
+ to be able to suppress exceptions)
+
+ * Fixes
+ - Fix memory leak during populate() on 5.8.x perls
+ - Temporarily fixed 5.13.x failures (RT#58225)
+ (perl-core fix still pending)
+ - Fix result_soutrce_instance leaks on compose_namespace
+ - Fix $_ volatility on load_namespaces (a class changing $_
+ at compile time no longer causes a massive fail)
+ - Fix find() without a key attr. choosing constraints even if
+ some of the supplied values are NULL (RT#59219)
+ - Fixed rels ending with me breaking subqueried limit realiasing
+ - Fixed $rs->update/delete on resutsets constrained by an
+ -or condition
+ - Remove rogue GROUP BY on non-multiplying prefetch-induced
+ subqueries
+ - Fix incorrect order_by handling with prefetch on
+ $ordered_rs->search_related ('has_many_rel') resultsets
+ - Oracle sequence detection now *really* works across schemas
+ (fixed some ommissions from 0.08123)
+ - dbicadmin now uses a /usr/bin/env shebang to work better with
+ perlbrew and other local perl builds
+ - bulk-inserts via $dbh->bind_array (void $rs->populate) now
+ display properly in DBIC_TRACE
+ - Incomplete exception thrown on relationship auto-fk-inference
+ failures
+ - Fixed distinct with order_by to not double-specify the same
+ column in the GROUP BY clause
+ - Properly support column names with symbols (e.g. single quote)
+ via custom accessors
+ - Fixed ::Schema::Versioned to work properly with quoting on
+ (RT#59619)
+ - Fixed t/54taint fails under local-lib
+ - Fixed SELECT ... FOR UPDATE with LIMIT regression (RT#58554)
+ - Fixed CDBICompat to preserve order of column-group additions,
+ so that test relying on the order of %{} will no longer fail
+ - Fixed mysterious ::Storage::DBI goto-shim failures on older
+ perl versions
+ - Non-blessed reference exceptions are now correctly preserved
+ when thrown from udner DBIC (e.g. from txn_do)
+ - No longer disconnecting database handles supplied to connect
+ via a coderef
+ - Fixed t/inflate/datetime_pg.t failures due to a low dependency
+ on DateTime::Format::Pg (RT#61503)
+ - Fix dirtyness detection on source-less objects
+ - Fix incorrect limit_dialect assignment on Replicated pool members
+ - Fix invalid sql on relationship attr order_by with prefetch
+ - Fix primary key sequence detection for Oracle
+ (first trigger instead of trigger for column)
+ - Add various missing things to Optional::Dependencies
+ - Skip a test that breaks due to serious bugs in current DBD::SQLite
+ - Fix tests related to leaks and leaky perls (5.13.5, 5.13.6)
+
+ * Misc
+ - Entire test suite now passes under DBIC_TRACE=1
+ - Makefile.PL no longer imports GetOptions() to interoperate
+ better with Catalyst installers
+ - Bumped minimum Module::Install for developers
+ - Bumped DBD::SQLite dependency and removed some TODO markers
+ from tests (RT#59565)
+ - Do not execute t/zzzzzzz_sqlite_deadlock.t for regular module
+ installs - test is prone to spontaneous blow up
+ - DT-related tests now require a DateTime >= 0.55 (RT#60324)
+ - Makefile.PL now provides a pre-parsed DBIC version to the
+ Opt::Dep pod generator
+ - t/52leaks.t now performs very aggressive leak detection in
+ author/smoker mode
+
+0.08123 2010-06-12 14:46 (UTC)
+ * Fixes
+ - Make sure Oracle identifier shortener applies to auto-generated
+ column names, so we stay within the 30-char limit (RT#58271)
+ - Oracle sequence detection now works across schemas
+ - Fix a Storage/$dbh leak introduced by the migration to
+ Try::Tiny (this is *not* a Try::Tiny bug)
+ - Fix corner case of count with group-by over a 1:1 join column
+ where the selector ends up with column name clashes
+ - POD fixes (RT#58247)
+
+ * Misc
+ - Test suite default on-disk database now checks for Win32
+ fail-conditions even when running on other OSes
+
+0.08122 2010-06-03 17:41 (UTC)
+ * New Features
+ - Add DBIx::Class::FilterColumn for non-ref filtering
+ - ::Storage::DBI now correctly preserves a parent $dbh from
+ terminating children, even during interpreter-global
+ out-of-order destruction
+ - dbicadmin supports an -I option with the same semantics as
+ perl itself
+ - InflateColumn::DateTime support for MSSQL via DBD::Sybase
+ - Millisecond precision support for MSSQL datetimes for
+ InflateColumn::DateTime
+ - Oracle-specific hierarchical query syntax support:
+ CONNECT BY (NOCYCLE) / START WITH / ORDER SIBLINGS BY
+ - Support connecting using $ENV{DBI_DSN} and $ENV{DBI_DRIVER}
+ - current_source_alias method on ResultSet objects to
+ determine the alias to use in programatically assembled
+ search()es (originally added in 0.08100 but unmentioned)
+ - Rewrite/unification of all subselecting limit emulations
+ (RNO, Top, RowNum) to be much more robust wrt complex joined
+ resultsets
+ - MSSQL limits now don't require nearly as many applications of
+ the unsafe_subselect_ok attribute, due to optimized queries
+ - Support for Generic Subquery limit "emulation" - awfully slow
+ and inefficient but works on almost any db, and is preferred
+ to software limit emulation
+ - Sybase ASE driver now uses SET ROWCOUNT where possible, and
+ Generic Subquery otherwise for limit support instead of always
+ using software limit emulation
+ - create_ddl_dir (and derivatives) now attempt to create the given
+ $ddl_dir if it does not already exist
+ - deployment_statements now automatically supplies the current RDBMS
+ version to SQLT producer_args for MySQL, Pg, SQLite and Oracle
+
+ * Fixes
+ - Fix nasty potentially data-eating bug when deleting/updating
+ a limited resultset
+ - Fix find() to use result_class set on object
+ - Fix result_class setter behaviour to not mistakenly stuff attrs.
+ - Don't try and ensure_class_loaded an object. This doesn't work.
+ - Fix as_subselect_rs to not inject resultset class-wide where
+ conditions outside of the resulting subquery
+ - Fix count() failing with {for} resultset attribute (RT#56257)
+ - Fixed incorrect detection of Limit dialect on unconnected $schema
+ - update() on row not in_storage no longer throws an exception
+ if there are no dirty columns to update (fixes cascaded update
+ annoyances)
+ - update()/delete() on prefetching resultsets no longer results
+ in malformed SQL (some $rs attributes were erroneously left in)
+ - Fix dbicadmin to allow deploy() on non-versioned schema
+ - Fix dbicadmin to respect sql_dir on upgrade() (RT#57732)
+ - Update Schema::Versioned to respect hashref style of
+ connection_info
+ - Do not recreate the same related object twice during MultiCreate
+ (solves the problem of orphaned IC::FS files)
+ - Fully qualify xp_msver selector when using DBD::Sybase with
+ MSSQL (RT#57467)
+ - Fix ::DBI::Storage to always be able to present a full set of
+ connect() attributes to e.g. Schema::Versioned
+ - Fix Oracle auto-inc trigger detection of "INSERT OR UPDATE"-type
+ triggers
+
+ * Misc
+ - Reformatted Changelog \o/
+ - DBIC goes git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git
+ - Allow developers to skip optional dependency forcing when working
+ from a checkout
+ - Add a warning to load_namespaces if a class in ResultSet/ is not
+ a subclass of DBIx::Class::ResultSet
+ - All DBIC exception-handling switched to Try::Tiny
+ - All DBIC modules are now free of imports via namespace::clean
+ - Depend on optimized SQL::Abstract (faster SQL generation)
+ - Depend on new Class::Accessor::Grouped reintroducing optional use
+ of Class::XSAccessor (just install C::XSA and get lightning fast
+ column accessors)
+
+0.08121 2010-04-11 18:43:00 (UTC)
+ - Support for Firebird RDBMS with DBD::InterBase and ODBC
+ - Add core support for INSERT RETURNING (for storages that
+ supports this syntax, currently PostgreSQL and Firebird)
+ - Fix spurious warnings on multiple UTF8Columns component loads
+ - DBIx::Class::UTF8Columns entered deprecated state
+ - DBIx::Class::InflateColumn::File entered deprecated state
+ - DBIx::Class::Optional::Dependencies left experimental state
+ - Add req_group_list to Opt::Deps (RT#55211)
+ - Add support for mysql-specific STRAIGHT_JOIN (RT#55579)
+ - Cascading delete/update are now wrapped in a transaction
+ for atomicity
+ - Fix accidental autovivification of ENV vars
+ - Fix update_all and delete_all to be wrapped in a transaction
+ - Fix multiple deficiencies when using MultiCreate with
+ data-encoder components (e.g. ::EncodedColumn)
+ - Fix regression where SQL files with comments were not
+ handled properly by ::Schema::Versioned.
- Fix regression on not properly throwing when $obj->relationship
is unresolvable
+ - Fix the join-optimiser to consider unqualified column names
+ whenever possible
+ - Fix an issue with multiple same-table joins confusing the join
+ optimizier
+ - Add has_relationship method to row objects
+ - Fix regression in set_column on PK-less objects
+ - Better error text on malformed/missing relationships
+ - Add POD about the significance of PK columns
+ - Fix for SQLite to ignore the (unsupported) { for => ... }
+ attribute
+ - Fix ambiguity in default directory handling of create_ddl_dir
+ (RT#54063)
+ - Support add_columns('+colname' => { ... }) to augment column
+ definitions.
0.08120 2010-02-24 08:58:00 (UTC)
- Make sure possibly overwritten deployment_statements methods in
-^(?!script/|examples/|lib/|inc/|t/|Makefile.PL$|README$|MANIFEST$|Changes$|META.yml$)
-
+^(?!script/|examples/|lib/|inc/|t/|xt/|Makefile\.PL$|maint/|README$|MANIFEST$|Changes$|META\.(?:yml|json)$)
# Avoid version control files.
\bRCS\b
\bCVS\b
,v$
\B\.svn\b
-\B\.git\b
-\B\.gitignore\b
\b_darcs\b
-# Avoid Makemaker generated and utility files.
-\bMakefile$
-\bblib
-\bMakeMaker-\d
-\bpm_to_blib$
-\bblibdirs$
-^MANIFEST\.SKIP$
-
-# for developers only :)
-^TODO$
-^Features_09$
-
-# Avoid Module::Build generated and utility files.
-\bBuild$
-\b_build
-
# Avoid temp and backup files.
~$
\.tmp$
# Don't ship the test db
^t/var
-# Don't ship the last dist we built :)
-\.tar\.gz$
-
-# Skip maint stuff
-^maint/
-
# Avoid patch remnants
\.orig$
\.rej$
-# Dont use Module::Build anymore
-^Build.PL$
-use inc::Module::Install 0.93;
use strict;
use warnings;
-use POSIX ();
use 5.008001;
+use inc::Module::Install 1.06;
+
+##
+## DO NOT USE THIS HACK IN YOUR DISTS!!! (it makes #toolchain sad)
+##
+# get cpanX --installdeps . to behave in a checkout (most users do not expect
+# the deps for a full test suite run, and if they do - there's MI::AutoInstall
+# for that)
+BEGIN {
+ $Module::Install::AUTHOR = 0 if (grep { $ENV{"PERL5_${_}_IS_RUNNING"} } (qw/CPANM CPANPLUS CPAN/) );
+}
+
+name 'DBIx-Class';
+perl_version '5.008001';
+all_from 'lib/DBIx/Class.pm';
-use FindBin;
-use lib "$FindBin::Bin/lib";
+tests_recursive (qw|
+ t
+|);
-# adjust ENV for $AUTHOR system() calls
-use Config;
-$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+install_script (qw|
+ script/dbicadmin
+|);
+homepage 'http://www.dbix-class.org/';
+resources 'IRC' => 'irc://irc.perl.org/#dbix-class';
+resources 'license' => 'http://dev.perl.org/licenses/';
+resources 'repository' => 'git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git';
+resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class';
+resources 'bugtracker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class';
###
### DO NOT ADD OPTIONAL DEPENDENCIES HERE, EVEN AS recommends()
-### All of them should go to DBIx::Class::Optional::Dependencies
+### All of them *MUST* go to DBIx::Class::Optional::Dependencies
###
+my $runtime_requires = {
+ # FIXME - temporary, needs throwing out for something more efficient
+ 'Data::Compare' => '1.22',
+ # Moo does not yet depend on this higher version
+ 'strictures' => '1.003001',
-name 'DBIx-Class';
-perl_version '5.008001';
-all_from 'lib/DBIx/Class.pm';
-
-my $build_requires = {
- 'DBD::SQLite' => '1.25',
-};
+ # DBI itself should be capable of installation and execution in pure-perl
+ # mode. However it has never been tested yet, so consider XS for the time
+ # being
+ 'DBI' => '1.57',
-my $test_requires = {
- 'File::Temp' => '0.22',
- 'Test::Builder' => '0.33',
- 'Test::Exception' => '0',
- 'Test::More' => '0.92',
- 'Test::Warn' => '0.21',
-};
+ # XS (or XS-dependent) libs
+ 'Sub::Name' => '0.04',
-my $runtime_requires = {
- 'Carp::Clan' => '6.0',
- 'Class::Accessor::Grouped' => '0.09002',
- 'Class::C3::Componentised' => '1.0005',
+ # pure-perl (FatPack-able) libs
+ 'Class::Accessor::Grouped' => '0.10002',
+ 'Class::C3::Componentised' => '1.0009',
'Class::Inspector' => '1.24',
+ 'Class::Method::Modifiers' => '1.06',
+ 'Config::Any' => '0.20',
+ 'Context::Preserve' => '0.01',
+ 'Data::Dumper::Concise' => '2.020',
'Data::Page' => '2.00',
- 'DBI' => '1.609',
+ 'Hash::Merge' => '0.12',
+ 'Moo' => '0.009014',
'MRO::Compat' => '0.09',
'Module::Find' => '0.06',
+ 'namespace::clean' => '0.20',
'Path::Class' => '0.18',
- 'SQL::Abstract' => '1.61',
- 'SQL::Abstract::Limit' => '0.13',
- 'Sub::Name' => '0.04',
- 'Data::Dumper::Concise' => '1.000',
'Scope::Guard' => '0.03',
- 'Context::Preserve' => '0.01',
+ 'SQL::Abstract' => '1.72',
+ 'Try::Tiny' => '0.04',
+
+ # dual-life corelibs needing a specific bugfixed version
+ 'File::Path' => '2.07',
+};
+
+my $build_requires = {
+ # needed for testing only, not for operation
+ # we will move away from this dep eventually, perhaps to DBD::CSV or something
+ 'DBD::SQLite' => '1.29',
+};
+
+my $test_requires = {
+ 'File::Temp' => '0.22',
+ 'Test::Exception' => '0.31',
+ 'Test::Warn' => '0.21',
+ 'Test::More' => '0.94',
+ # not sure if this is necessary at all, ask schwern some day
+ 'Test::Builder' => '0.94',
+
+ # this is already a dep of n::c, but just in case - used by t/55namespaces_cleaned.t
+ # remove and do a manual glob-collection if n::c is no longer a dep
+ 'Package::Stash' => '0.28',
};
+# make strictures.pm happy (DO NOT LIKE, TOO MUCH XS!)
+# (i.e. what if the .git/.svn is *not* because of DBIC?)
+#
+# Note - this is added as test_requires *directly*, so it gets properly
+# excluded on META.yml cleansing
+if (-e '.git' or -e '.svn') {
+ test_requires 'indirect' => '0.25';
+ test_requires 'multidimensional' => '0.008';
+ test_requires 'bareword::filehandles' => '0.003';
+}
+
+# if the user has this env var set and no SQLT installed, tests will fail
+# same rationale for direct test_requires as the strictures stuff above
+# (even though no dist will be created from this)
+# we force this req regarless of author_deps, worst case scenario it will
+# be specified twice
+if ($ENV{DBICTEST_SQLT_DEPLOY}) {
+ local @INC = ('lib', @INC);
+ require DBIx::Class::Optional::Dependencies;
+ my $dep_req = DBIx::Class::Optional::Dependencies->req_list_for('deploy');
+ for (keys %$dep_req) {
+ test_requires ($_ => $dep_req->{$_})
+ }
+}
+
# this is so we can order requires alphabetically
-# copies are needed for author requires injection
+# copies are needed for potential author requires injection
my $reqs = {
build_requires => { %$build_requires },
requires => { %$runtime_requires },
test_requires => { %$test_requires },
};
-
-# require extra modules for testing if we're in a checkout
-if ($Module::Install::AUTHOR) {
- warn <<'EOW';
-******************************************************************************
-******************************************************************************
-*** ***
-*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
-*** ***
-******************************************************************************
-******************************************************************************
-
-EOW
-
- require DBIx::Class::Optional::Dependencies;
- $reqs->{test_requires} = {
- %{$reqs->{test_requires}},
- %{DBIx::Class::Optional::Dependencies->_all_optional_requirements},
+# only do author-includes if not part of a `make` run
+if ($Module::Install::AUTHOR and ! $ENV{MAKELEVEL}) {
+ # get options here, make $args available to all snippets
+ require Getopt::Long;
+ my $getopt = Getopt::Long::Parser->new(
+ config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/]
+ );
+ my $args = {
+ skip_author_deps => undef,
};
+ $getopt->getoptions($args, qw/
+ skip_author_deps|skip-author-deps
+ /);
+ if (@ARGV) {
+ warn "\nIgnoring unrecognized option(s): @ARGV\n\n";
+ }
+
+ require File::Spec;
+ # string-eval, not do(), because we need to provide the
+ # $reqs and $*_requires lexicals to the included file
+ # (some includes *do* modify $reqs above)
+ for (sort glob ( File::Spec->catfile('maint', 'Makefile.PL.inc', '*') ) ) {
+ eval scalar do { local (@ARGV, $/) = $_; <> }
+ or die ($@ || $!);
+ }
+}
+else {
+ # make sure this Makefile can not be used to make a dist
+ # (without the author includes there are no meta cleanup, no sanity checks, etc)
+ postamble <<EOP;
+.PHONY: nonauthor_stop_distdir_creation
+create_distdir: nonauthor_stop_distdir_creation
+nonauthor_stop_distdir_creation:
+\t\$(NOECHO) \$(ECHO) Creation of dists in non-author mode is not allowed
+\t\$(NOECHO) \$(FALSE)
+EOP
}
# compose final req list, for alphabetical ordering
$rtype->($mod, $ver);
}
+# author-mode or not - this is where we show a list of missing deps
+# IFF we are running interactively
auto_install();
-# re-create various autogenerated documentation bits
-if ($Module::Install::AUTHOR) {
-
- print "Regenerating README\n";
- system('pod2text lib/DBIx/Class.pm > README');
-
- if (-f 'MANIFEST') {
- print "Removing MANIFEST\n";
- unlink 'MANIFEST';
- }
-
- print "Regenerating Optional/Dependencies.pod\n";
- require DBIx::Class::Optional::Dependencies;
- DBIx::Class::Optional::Dependencies->_gen_pod;
-
- # FIXME Disabled due to unsolved issues, ask theorbtwo
- # require Module::Install::Pod::Inherit;
- # PodInherit();
-}
-
-tests_recursive (qw|
- t
-|);
-
-install_script (qw|
- script/dbicadmin
-|);
-
-
-### Mangle makefile - read the comments for more info
-#
-postamble <<"EOP";
-
-# This will add an extra dep-spec for the distdir target,
-# which `make` will fold together in a first-come first-serve
-# fashion. What we do here is essentially adding extra
-# commands to execute once the distdir is assembled (via
-# create_distdir), but before control is returned to a higher
-# calling rule.
-distdir : dbicadmin_pod_inject
-
-# The pod self-injection code is in fact a hidden option in
-# dbicadmin itself
-dbicadmin_pod_inject :
-\tcd \$(DISTVNAME) && \$(ABSPERL) -Ilib script/dbicadmin --selfinject-pod
-
-# Regenerate manifest before running create_distdir.
-create_distdir : manifest
-
-EOP
-
-
-
-resources 'IRC' => 'irc://irc.perl.org/#dbix-class';
-resources 'license' => 'http://dev.perl.org/licenses/';
-resources 'repository' => 'http://dev.catalyst.perl.org/repos/bast/DBIx-Class/';
-resources 'MailingList' => 'http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class';
-
-# Deprecated/internal modules need no exposure
-no_index directory => $_ for (qw|
- lib/DBIx/Class/Admin
- lib/DBIx/Class/SQLAHacks
- lib/DBIx/Class/PK/Auto
- lib/DBIx/Class/CDBICompat
-|);
-no_index package => $_ for (qw/
- DBIx::Class::SQLAHacks DBIx::Class::Storage::DBIHacks
-/);
-
-
WriteAll();
-
-
-# Re-write META.yml to _exclude_ all forced requires (we do not want to ship this)
-if ($Module::Install::AUTHOR) {
-
- # FIXME test_requires is not yet part of META
- my %original_build_requires = ( %$build_requires, %$test_requires );
-
- print "Regenerating META with author requires excluded\n";
- Meta->{values}{build_requires} = [ grep
- { exists $original_build_requires{$_->[0]} }
- ( @{Meta->{values}{build_requires}} )
- ];
-
- Meta->write;
-}
- find why XSUB dumper kills schema in Catalyst (may be Pg only?)
2006-03-25 by mst
- - find a way to un-wantarray search without breaking compat
- delay relationship setup if done via ->load_classes
- double-sided relationships
- make short form of class specifier in relationships work
-2006-01-31 by bluefeet
- - Create a DBIx::Class::FilterColumn to replace inflate/deflate. This
- component would provide a new syntax for filtering column update and
- retrieval through a simple syntax. The syntax would be:
- __PACKAGE__->add_columns(phone => { set=>sub{ ... }, get=>sub{ ... } });
- We should still support the old inflate/deflate syntax, but this new
- way should be recommended.
-
2006-03-18 by bluefeet
- Support table locking.
-2006-03-21 by bluefeet
- - When subclassing a dbic class make it so you don't have to do
- __PACKAGE__->table(__PACKAGE__->table()); for the result set to
- return the correct object type.
-
2006-05-25 by mst (TODOed by bluefeet)
Add the search attributes "limit" and "rows_per_page".
limit: work as expected just like offset does
rows_per_page: only be used if you used the page attr or called $rs->page
- rows: modify to be an alias that gets used to populate either as appropriate,
+ rows: modify to be an alias that gets used to populate either as appropriate,
if you haven't specified one of the others
2008-10-30 by ribasushi
- Rewrite the test suite to rely on $schema->deploy, allowing for seamless
testing of various RDBMS using the same tests
- - Automatically infer quote_char/name_sep from $schema->storage
- - Fix and properly test chained search attribute merging
- Recursive update() (all code seems to be already available)
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Benchmark qw/cmpthese/;
+use FindBin;
+use lib "$FindBin::Bin/../../t/lib";
+use lib "$FindBin::Bin/../../lib";
+use DBICTest::Schema;
+use DBIx::Class::ResultClass::HashRefInflator; # older dbic didn't load it
+
+printf "Benchmarking DBIC version %s\n", DBIx::Class->VERSION;
+
+my $schema = DBICTest::Schema->connect ('dbi:SQLite::memory:');
+$schema->deploy;
+
+my $rs = $schema->resultset ('Artist');
+$rs->populate ([ map { { name => "Art_$_"} } (1 .. 10000) ]);
+
+my $dbh = $schema->storage->dbh;
+my $sql = sprintf ('SELECT %s FROM %s %s',
+ join (',', @{$rs->_resolved_attrs->{select}} ),
+ $rs->result_source->name,
+ $rs->_resolved_attrs->{alias},
+);
+
+my $compdbi = sub {
+ my @r = $schema->storage->dbh->selectall_arrayref ('SELECT * FROM ' . ${$rs->as_query}->[0] )
+} if $rs->can ('as_query');
+
+cmpthese(-3, {
+ Cursor => sub { $rs->reset; my @r = $rs->cursor->all },
+ HRI => sub { $rs->reset; my @r = $rs->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' } )->all },
+ RowObj => sub { $rs->reset; my @r = $rs->all },
+ RawDBI => sub { my @r = $dbh->selectall_arrayref ($sql) },
+ $compdbi ? (CompDBI => $compdbi) : (),
+});
--- /dev/null
+#!/usr/bin/env perl
+
+#
+# So you wrote a new mk_hash implementation which passed all tests
+# (particularly t/inflate/hri.t) and would like to see how it holds
+# up against older (and often buggy) versions of the same. Just run
+# this script and wait (no editing necessary)
+
+use warnings;
+use strict;
+
+use FindBin;
+use lib ("$FindBin::Bin/../../lib", "$FindBin::Bin/../../t/lib");
+
+use Class::Unload '0.07';
+use Benchmark ();
+use Dumbbench;
+use Benchmark::Dumb ':all';
+use DBICTest;
+
+# for git reporting to work, and to use it as INC key directly
+chdir ("$FindBin::Bin/../../lib");
+my $hri_fn = 'DBIx/Class/ResultClass/HashRefInflator.pm';
+
+require Getopt::Long;
+my $getopt = Getopt::Long::Parser->new(
+ config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/]
+);
+my $args = {
+ 'bench-commits' => 2,
+ 'no-cpufreq-checks' => undef,
+};
+$getopt->getoptions($args, qw/
+ bench-commits
+ no-cpufreq-checks
+/);
+
+if (
+ !$args->{'no-cpufreq-checks'}
+ and
+ $^O eq 'linux'
+ and
+ -r '/sys/devices/system/cpu/cpu0/cpufreq/scaling_cur_freq'
+) {
+ my ($min_freq, $max_freq, $governor) = map { local @ARGV = $_; my $s = <>; chomp $s; $s } qw|
+ /sys/devices/system/cpu/cpu0/cpufreq/scaling_min_freq
+ /sys/devices/system/cpu/cpu0/cpufreq/scaling_max_freq
+ /sys/devices/system/cpu/cpu0/cpufreq/scaling_governor
+ |;
+
+ if ($min_freq != $max_freq) {
+ die "Your OS seems to have an active CPU governor '$governor' -"
+ . ' this will render benchmark results meaningless. Disable it'
+ . ' by setting /sys/devices/system/cpu/cpu*/cpufreq/scaling_max_freq'
+ . ' to the same value as /sys/devices/system/cpu/cpu*/cpufreq/scaling_min_freq'
+ . " ($min_freq). Alternatively skip this check with --no-cpufreq-checks.\n";
+ }
+}
+
+my %skip_commits = map { $_ => 1 } qw/
+ e1540ee
+ a5b2936
+ 4613ee1
+ 419ff18
+/;
+my (@to_bench, $not_latest);
+for my $commit (`git log --format=%h HEAD ^8330454^ $hri_fn `) {
+ chomp $commit;
+ next if $skip_commits{$commit};
+ my $diff = `git show -w -U0 --format=%ar%n%b $commit $hri_fn`;
+ if ($diff =~ /^ (?: \@\@ \s .+? | [+-] sub \s) \$? mk_hash /xm ) {
+ my ($age) = $diff =~ /\A(.+?)\n/;
+
+ push @to_bench, {
+ commit => $commit,
+ title => $not_latest ? $commit : 'LATEST',
+ desc => sprintf ("commit %s (%smade %s)...\t\t",
+ $commit,
+ $not_latest ? '' : 'LATEST, ',
+ $age,
+ ),
+ code => scalar `git show $commit:lib/DBIx/Class/ResultClass/HashRefInflator.pm`,
+ };
+
+ last if @to_bench == $args->{'bench-commits'};
+ $not_latest = 1;
+ }
+}
+die "Can't find any commits... something is wrong\n" unless @to_bench;
+
+unshift @to_bench, {
+ desc => "the current uncommitted HRI...\t\t\t\t",
+ title => 'CURRENT',
+ code => do { local (@ARGV, $/) = ($hri_fn); <> },
+} if `git status --porcelain $hri_fn`;
+
+printf "\nAbout to benchmark %d HRI variants (%s)\n",
+ scalar @to_bench,
+ (join ', ', map { $_->{title} } @to_bench),
+;
+
+my $schema = DBICTest->init_schema();
+
+# add some extra data for the complex test
+$schema->resultset ('Artist')->create({
+ name => 'largggge',
+ cds => [
+ {
+ genre => { name => 'massive' },
+ title => 'largesse',
+ year => 2011,
+ tracks => [
+ {
+ title => 'larguitto',
+ cd_single => {
+ title => 'mongo',
+ year => 2012,
+ artist => 1,
+ genre => { name => 'massive' },
+ tracks => [
+ { title => 'yo momma' },
+ { title => 'so much momma' },
+ ],
+ },
+ },
+ ],
+ },
+ ],
+});
+
+# get what data to feed during benchmarks
+{
+ package _BENCH_::DBIC::InflateResult::Trap;
+ sub inflate_result { shift; return \@_ }
+}
+my %bench_dataset = (
+ simple => do {
+ my $rs = $schema->resultset ('Artist')->search ({}, {
+ prefetch => { cds => 'tracks' },
+ result_class => '_BENCH_::DBIC::InflateResult::Trap',
+ });
+ [ $rs->all ];
+ },
+ complex => do {
+ my $rs = $schema->resultset ('Artist')->search ({}, {
+ prefetch => { cds => [ { tracks => { cd_single => [qw/artist genre tracks/] } }, 'genre' ] },
+ result_class => '_BENCH_::DBIC::InflateResult::Trap',
+ });
+ [ $rs->all ];
+ },
+);
+
+# benchmark coderefs (num iters is set below)
+my %num_iters;
+my %bench = ( map { $_ => eval "sub {
+ for (1 .. (\$num_iters{$_}||1) ) {
+ DBIx::Class::ResultClass::HashRefInflator->inflate_result(\$bench_dataset{$_})
+ }
+}" } qw/simple complex/ );
+
+$|++;
+print "\nPre-timing current HRI to determine iteration counts...";
+# crude unreliable and quick test how many to run in the loop
+# designed to return a value so that there ~ 1/$div runs in a second
+# (based on the current @INC implementation)
+my $div = 1;
+require DBIx::Class::ResultClass::HashRefInflator;
+for (qw/simple complex/) {
+ local $SIG{__WARN__} = sub {};
+ my $tst = Benchmark::timethis(-1, $bench{$_}, '', 'none');
+ $num_iters{$_} ||= int( $tst->[5] / $tst->[1] / $div );
+ $num_iters{$_} ||= 1;
+}
+print " done\n\nBenchmarking - this can taka a LOOOOOONG time\n\n";
+
+my %results;
+
+for my $bch (@to_bench) {
+ Class::Unload->unload('DBIx::Class::ResultClass::HashRefInflator');
+ eval $bch->{code} or die $@;
+ $INC{'DBIx/Class/ResultClass/HashRefInflator.pm'} = $bch->{title};
+
+ for my $t (qw/simple complex/) {
+ my $label = "Timing $num_iters{$t} $t iterations of $bch->{desc}";
+
+ my $bench = Dumbbench->new(
+ initial_runs => 30,
+ target_rel_precision => 0.0005,
+ );
+ $bench->add_instances( Dumbbench::Instance::PerlSub->new (
+ name => $label, code => $bench{$t},
+ ));
+
+ print $label;
+ $bench->run;
+
+ print(
+ ($results{ (substr $t, 0, 1) . "_$bch->{title}" }
+ = Benchmark::Dumb->_new( instance => ($bench->instances)[0] ) )
+ ->timestr('')
+ );
+ print "\n";
+ }
+}
+
+for my $t (qw/s c/) {
+ cmpthese ({ map { $_ =~ /^${t}_/ ? ( $_ => $results{$_}) : () } keys %results }, '', '');
+}
-#!/usr/bin/perl
+#!/usr/bin/env perl
use warnings;
use strict;
my $s = CPANDB::Schema->connect (sub { CPANDB->dbh } );
# reference names are unstable - just create rels manually
-# is there a saner way to do that?
-my $distclass = $s->class('Distribution');
-$distclass->has_many (
+my $distrsrc = $s->source('Distribution');
+
+# the has_many helper is a class-only method (why?), thus
+# manual add_rel
+$distrsrc->add_relationship (
'deps',
$s->class('Dependency'),
- 'distribution',
+ { 'foreign.distribution' => 'self.' . ($distrsrc->primary_columns)[0] },
+ { accessor => 'multi', join_type => 'left' },
);
-$s->unregister_source ('Distribution');
-$s->register_class ('Distribution', $distclass);
+
+# here is how one could use the helper currently:
+#
+#my $distresult = $s->class('Distribution');
+#$distresult->has_many (
+# 'deps',
+# $s->class('Dependency'),
+# 'distribution',
+#);
+#$s->unregister_source ('Distribution');
+#$s->register_class ('Distribution', $distresult);
# a proof of concept how to find out who uses us *AND* SQLT
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
-use MyDatabase::Main;
use strict;
+use warnings;
+
+use MyDatabase::Main;
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
-use MyDatabase::Main;
+use warnings;
use strict;
+use MyDatabase::Main;
+
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
# for other DSNs, e.g. MySql, see the perldoc for the relevant dbd
# driver, e.g perldoc L<DBD::mysql>.
print "\n";
}
-
sub get_cd_by_track {
my $tracktitle = shift;
print "get_cd_by_track($tracktitle):\n";
print "\n";
}
-
-
sub get_artist_by_track {
my $tracktitle = shift;
print "get_artist_by_track($tracktitle):\n";
print $artist->name . "\n\n";
}
-
sub get_artist_by_cd {
my $cdtitle = shift;
print "get_artist_by_cd($cdtitle):\n";
use strict;
use warnings;
-use MRO::Compat;
+our $VERSION;
+# Always remember to do all digits for the version even if they're 0
+# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
+# brain damage and presumably various other packaging systems too
+
+# $VERSION declaration must stay up here, ahead of any other package
+# declarations, as to not confuse various modules attempting to determine
+# this ones version, whether that be s.c.o. or Module::Metadata, etc
+$VERSION = '0.08196';
+
+$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
+
+BEGIN {
+ package # hide from pause
+ DBIx::Class::_ENV_;
+
+ if ($] < 5.009_005) {
+ require MRO::Compat;
+ *OLD_MRO = sub () { 1 };
+ }
+ else {
+ require mro;
+ *OLD_MRO = sub () { 0 };
+ }
+
+ # ::Runmode would only be loaded by DBICTest, which in turn implies t/
+ *DBICTEST = eval { DBICTest::RunMode->is_author }
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+ # There was a brief period of p5p insanity when $@ was invisible in a DESTROY
+ *INVISIBLE_DOLLAR_AT = ($] >= 5.013001 and $] <= 5.013007)
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+
+ # During 5.13 dev cycle HELEMs started to leak on copy
+ *PEEPEENESS = (defined $ENV{DBICTEST_ALL_LEAKS}
+ # request for all tests would force "non-leaky" illusion and vice-versa
+ ? ! $ENV{DBICTEST_ALL_LEAKS}
+
+ # otherwise confess that this perl is busted ONLY on smokers
+ : do {
+ if (eval { DBICTest::RunMode->is_smoker }) {
+
+ # leaky 5.13.6 (fixed in blead/cefd5c7c)
+ if ($] == '5.013006') { 1 }
+
+ # not sure why this one leaks, but disable anyway - ANDK seems to make it weep
+ elsif ($] == '5.013005') { 1 }
+
+ else { 0 }
+ }
+ else { 0 }
+ }
+ ) ? sub () { 1 } : sub () { 0 };
+
+}
+
use mro 'c3';
use DBIx::Class::Optional::Dependencies;
-use vars qw($VERSION);
-use base qw/DBIx::Class::Componentised Class::Accessor::Grouped/;
+use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
use DBIx::Class::StartupCheck;
+__PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
+__PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve');
+
sub mk_classdata {
shift->mk_classaccessor(@_);
}
sub component_base_class { 'DBIx::Class' }
-# Always remember to do all digits for the version even if they're 0
-# i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports
-# brain damage and presumably various other packaging systems too
-$VERSION = '0.08120_1';
-
-$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
-
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
$class->mk_classdata('__attr_cache' => {})
sub _attr_cache {
my $self = shift;
my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};
- my $rest = eval { $self->next::method };
- return $@ ? $cache : { %$cache, %$rest };
+
+ return {
+ %$cache,
+ %{ $self->maybe::next::method || {} },
+ };
}
1;
=over
-=item * IRC: L<irc.perl.org#dbix-class (click for instant chatroom login)
-|http://mibbit.com/chat/#dbix-class@irc.perl.org>
+=item * Web Site: L<http://www.dbix-class.org/>
+
+=item * IRC: irc.perl.org#dbix-class
+
+=for html
+<a href="http://chat.mibbit.com/#dbix-class@irc.perl.org">(click for instant chatroom login)</a>
=item * Mailing list: L<http://lists.scsys.co.uk/mailman/listinfo/dbix-class>
=item * RT Bug Tracker: L<https://rt.cpan.org/Dist/Display.html?Queue=DBIx-Class>
-=item * SVNWeb: L<http://dev.catalyst.perl.org/svnweb/bast/browse/DBIx-Class/0.08>
+=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git>
+
+=item * git: L<git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git>
-=item * SVN: L<http://dev.catalyst.perl.org/repos/bast/DBIx-Class/0.08>
+=item * twitter L<http://www.twitter.com/dbix_class>
=back
=head1 SYNOPSIS
-Create a schema class called MyDB/Schema.pm:
+Create a schema class called MyApp/Schema.pm:
- package MyDB::Schema;
+ package MyApp::Schema;
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_namespaces();
1;
Create a result class to represent artists, who have many CDs, in
-MyDB/Schema/Result/Artist.pm:
+MyApp/Schema/Result/Artist.pm:
See L<DBIx::Class::ResultSource> for docs on defining result classes.
- package MyDB::Schema::Result::Artist;
+ package MyApp::Schema::Result::Artist;
use base qw/DBIx::Class::Core/;
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
+ __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD', 'artistid');
1;
A result class to represent a CD, which belongs to an artist, in
-MyDB/Schema/Result/CD.pm:
+MyApp/Schema/Result/CD.pm:
- package MyDB::Schema::Result::CD;
+ package MyApp::Schema::Result::CD;
use base qw/DBIx::Class::Core/;
__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
__PACKAGE__->table('cd');
__PACKAGE__->add_columns(qw/ cdid artistid title year /);
__PACKAGE__->set_primary_key('cdid');
- __PACKAGE__->belongs_to(artist => 'MyDB::Schema::Artist', 'artistid');
+ __PACKAGE__->belongs_to(artist => 'MyApp::Schema::Result::Artist', 'artistid');
1;
Then you can use these classes in your application's code:
# Connect to your database.
- use MyDB::Schema;
- my $schema = MyDB::Schema->connect($dbi_dsn, $user, $pass, \%dbi_params);
+ use MyApp::Schema;
+ my $schema = MyApp::Schema->connect($dbi_dsn, $user, $pass, \%dbi_params);
# Query for all artists and put them in an array,
# or retrieve them as a result set object.
handle as requested in order to minimise memory usage. It has auto-increment
support for SQLite, MySQL, PostgreSQL, Oracle, SQL Server and DB2 and is
known to be used in production on at least the first four, and is fork-
-and thread-safe out of the box (although your DBD may not be).
+and thread-safe out of the box (although
+L<your DBD may not be|DBI/Threads and Thread Safety>).
This project is still under rapid development, so large new features may be
marked EXPERIMENTAL - such APIs are still usable but may have edge bugs.
=head1 CONTRIBUTORS
-abraxxa: Alexander Hartmaier <alex_hartmaier@hotmail.com>
+abraxxa: Alexander Hartmaier <abraxxa@cpan.org>
+
+acca: Alexander Kuznetsov <acca@cpan.org>
aherzog: Adam Herzog <adam@herzogdesigns.com>
+Alexander Keusch <cpan@keusch.at>
+
+alnewkirk: Al Newkirk <we@ana.im>
+
+amiri: Amiri Barksdale <amiri@metalabel.com>
+
+amoore: Andrew Moore <amoore@cpan.org>
+
andyg: Andy Grundman <andy@hybridized.org>
ank: Andres Kievsky
+arc: Aaron Crane <arc@cpan.org>
+
arcanez: Justin Hunter <justin.d.hunter@gmail.com>
ash: Ash Berlin <ash@cpan.org>
bluefeet: Aran Deltac <bluefeet@cpan.org>
+bphillips: Brian Phillips <bphillips@cpan.org>
+
boghead: Bryan Beeley <cpan@beeley.org>
+brd: Brad Davis <brd@FreeBSD.org>
+
bricas: Brian Cassidy <bricas@cpan.org>
brunov: Bruno Vecchi <vecchi.b@gmail.com>
caelum: Rafael Kitover <rkitover@cpan.org>
+caldrin: Maik Hentsche <maik.hentsche@amd.com>
+
castaway: Jess Robinson
claco: Christopher H. Laco
dnm: Justin Wheeler <jwheeler@datademons.com>
+dpetrov: Dimitar Petrov <mitakaa@gmail.com>
+
dwc: Daniel Westermann-Clark <danieltwc@cpan.org>
dyfrgi: Michael Leuchtenburg <michael@slashhome.org>
+edenc: Eden Cardim <edencardim@gmail.com>
+
+felliott: Fitz Elliott <fitz.elliott@gmail.com>
+
+freetime: Bill Moseley <moseley@hank.org>
+
frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
goraxe: Gordon Irving <goraxe@cpan.org>
gphat: Cory G Watson <gphat@cpan.org>
+Grant Street Group L<http://www.grantstreet.com/>
+
groditi: Guillermo Roditi <groditi@cpan.org>
+Haarg: Graham Knop <haarg@haarg.org>
+
+hobbs: Andrew Rodland <arodland@cpan.org>
+
ilmari: Dagfinn Ilmari MannsE<aring>ker <ilmari@ilmari.org>
+initself: Mike Baas <mike@initselftech.com>
+
+ironcamel: Naveed Massjouni <naveedm9@gmail.com>
+
+jawnsy: Jonathan Yu <jawnsy@cpan.org>
+
jasonmay: Jason May <jason.a.may@gmail.com>
jesper: Jesper Krogh
jshirley: J. Shirley <jshirley@gmail.com>
+kaare: Kaare Rasmussen
+
konobi: Scott McWhirter
+littlesavage: Alexey Illarionov <littlesavage@orionet.ru>
+
lukes: Luke Saunders <luke.saunders@gmail.com>
marcus: Marcus Ramberg <mramberg@cpan.org>
mattlaw: Matt Lawrence
+mattp: Matt Phillips <mattp@cpan.org>
+
michaelr: Michael Reddick <michael.reddick@gmail.com>
+milki: Jonathan Chu <milki@rescomp.berkeley.edu>
+
+mstratman: Mark A. Stratman <stratman@gmail.com>
+
ned: Neil de Carteret
nigel: Nigel Metheringham <nigelm@cpan.org>
ovid: Curtis "Ovid" Poe <ovid@cpan.org>
-oyse: Øystein Torget <oystein.torget@dnv.com>
+oyse: E<Oslash>ystein Torget <oystein.torget@dnv.com>
paulm: Paul Makepeace
peter: Peter Collingbourne <peter@pcc.me.uk>
+Peter Valdemar ME<oslash>rch <peter@morch.com>
+
phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
plu: Johannes Plunien <plu@cpan.org>
+Possum: Daniel LeWarne <possum@cpan.org>
+
quicksilver: Jules Bean
rafl: Florian Ragwitz <rafl@debian.org>
+rainboxx: Matthias Dietrich <perl@rb.ly>
+
+rbo: Robert Bohne <rbo@cpan.org>
+
rbuels: Robert Buels <rmb32@cornell.edu>
rdj: Ryan D Johnson <ryan@innerfence.com>
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Robert Olson <bob@rdolson.org>
+
Roman: Roman Filippov <romanf@cpan.org>
+Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
+
sc_: Just Another Perl Hacker
scotty: Scotty Allen <scotty@scottyallen.com>
semifor: Marc Mims <marc@questright.com>
+SineSwiper: Brendan Byrd <bbyrd@cpan.org>
+
solomon: Jared Johnson <jaredj@nmgi.com>
spb: Stephen Bennett <stephen@freenode.net>
+Squeeks <squeek@cpan.org>
+
sszabo: Stephan Szabo <sszabo@bigpanda.com>
+talexb: Alex Beamish <talexb@gmail.com>
+
+tamias: Ronald J Kimball <rjk@tamias.net>
+
teejay : Aaron Trevena <teejay@cpan.org>
Todd Lipcon
Tom Hukins
+tonvoon: Ton Voon <tonvoon@cpan.org>
+
triode: Pete Gamache <gamache@cpan.org>
typester: Daisuke Murase <typester@cpan.org>
wdh: Will Hawes
+wesm: Wes Malone <wes@mitsi.com>
+
willert: Sebastian Willert <willert@cpan.org>
wreis: Wallace Reis <wreis@cpan.org>
+xenoterracide: Caleb Cushing <xenoterracide@gmail.com>
+
+yrlnry: Mark Jason Dominus <mjd@plover.com>
+
zamolxes: Bogdan Lucaciu <bogdan@wiz.ro>
=head1 COPYRIGHT
-Copyright (c) 2005 - 2010 the DBIx::Class L</AUTHOR> and L</CONTRIBUTORS>
+Copyright (c) 2005 - 2011 the DBIx::Class L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
use warnings;
use base qw/Class::Accessor::Grouped/;
+use Scalar::Util qw/weaken/;
+use namespace::clean;
+
+my $successfully_loaded_components;
+
+sub get_component_class {
+ my $class = $_[0]->get_inherited($_[1]);
+
+ if (defined $class and ! $successfully_loaded_components->{$class} ) {
+ $_[0]->ensure_class_loaded($class);
+
+ no strict 'refs';
+ $successfully_loaded_components->{$class}
+ = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ = do { \(my $anon = 'loaded') };
+ weaken($successfully_loaded_components->{$class});
+ }
+
+ $class;
+};
+
+sub set_component_class {
+ shift->set_inherited(@_);
+}
1;
# check deps
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
+ die('The following modules are required for DBIx::Class::Admin ' . DBIx::Class::Optional::Dependencies->req_missing_for ('admin') )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('admin');
}
sub _build_schema {
my ($self) = @_;
+
require Class::MOP;
Class::MOP::load_class($self->schema_class);
-
- $self->connect_info->[3]->{ignore_version} =1;
- return $self->schema_class->connect(@{$self->connect_info()} ); # , $self->connect_info->[3], { ignore_version => 1} );
+ $self->connect_info->[3]{ignore_version} = 1;
+ return $self->schema_class->connect(@{$self->connect_info});
}
-
=head2 resultset
a resultset from the schema to operate on
=head2 attrs
-a hash ref or json string to be used for passing additonal info to the ->search call
+a hash ref or json string to be used for passing additional info to the ->search call
=cut
config_file provide a config_file to read connect_info from, if this is provided
config_stanze should also be provided to locate where the connect_info is in the config
-The config file should be in a format readable by Config::General
+The config file should be in a format readable by Config::Any.
=cut
=head2 config_stanza
-config_stanza for use with config_file should be a '::' deliminated 'path' to the connection information
+config_stanza for use with config_file should be a '::' delimited 'path' to the connection information
designed for use with catalyst config files
=cut
=head2 config
-Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
+Instead of loading from a file the configuration can be provided directly as a hash ref. Please note
config_stanza will still be required.
=cut
sub _build_config {
my ($self) = @_;
- eval { require Config::Any }
- or die ("Config::Any is required to parse the config file.\n");
+ try { require Config::Any }
+ catch { die ("Config::Any is required to parse the config file.\n") };
my $cfg = Config::Any->load_files ( {files => [$self->config_file], use_ext =>1, flatten_to_hash=>1});
);
+=head2 sql_type
+
+The type of sql dialect to use for creating sql files from schema
+
+=cut
+
+has 'sql_type' => (
+ is => 'ro',
+ isa => Str,
+);
+
=head2 version
Used for install, the version which will be 'installed' in the schema
=head2 preversion
-Previouse version of the schema to create an upgrade diff for, the full sql for that version of the sql must be in the sql_dir
+Previous version of the schema to create an upgrade diff for, the full sql for that version of the sql must be in the sql_dir
=cut
);
+=head2 trace
+
+Toggle DBIx::Class debug output
+
+=cut
+
+has trace => (
+ is => 'rw',
+ isa => Bool,
+ trigger => \&_trigger_trace,
+);
+
+sub _trigger_trace {
+ my ($self, $new, $old) = @_;
+ $self->schema->storage->debug($new);
+}
+
+
=head1 METHODS
=head2 create
=back
-L<create> will generate sql for the supplied schema_class in sql_dir. The flavour of sql to
-generate can be controlled by suppling a sqlt_type which should be a L<SQL::Translator> name.
+C<create> will generate sql for the supplied schema_class in sql_dir. The
+flavour of sql to generate can be controlled by supplying a sqlt_type which
+should be a L<SQL::Translator> name.
Arguments for L<SQL::Translator> can be supplied in the sqlt_args hashref.
my ($self, $sqlt_type, $sqlt_args, $preversion) = @_;
$preversion ||= $self->preversion();
+ $sqlt_type ||= $self->sql_type();
my $schema = $self->schema();
# create the dir if does not exist
sub upgrade {
my ($self) = @_;
my $schema = $self->schema();
+
if (!$schema->get_db_version()) {
# schema is unversioned
$schema->throw_exception ("Could not determin current schema version, please either install() or deploy().\n");
} else {
+ $schema->upgrade_directory ($self->sql_dir) if $self->sql_dir; # this will override whatever default the schema has
my $ret = $schema->upgrade();
return $ret;
}
=back
-install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
-database. install will take a version and add the version tracking tables and 'install' the version. No
-further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
+install is here to help when you want to move to L<DBIx::Class::Schema::Versioned> and have an existing
+database. install will take a version and add the version tracking tables and 'install' the version. No
+further ddl modification takes place. Setting the force attribute to a true value will allow overriding of
already versioned databases.
=cut
$version ||= $self->version();
if (!$schema->get_db_version() ) {
# schema is unversioned
- print "Going to install schema version\n";
+ print "Going to install schema version\n" if (!$self->quiet);
my $ret = $schema->install($version);
- print "retun is $ret\n";
+ print "return is $ret\n" if (!$self->quiet);
}
elsif ($schema->get_db_version() and $self->force ) {
- carp "Forcing install may not be a good idea";
+ warn "Forcing install may not be a good idea\n";
if($self->_confirm() ) {
$self->schema->_set_db_version({ version => $version});
}
=back
-deploy will create the schema at the connected database. C<$args> are passed straight to
+deploy will create the schema at the connected database. C<$args> are passed straight to
L<DBIx::Class::Schema/deploy>.
=cut
sub deploy {
my ($self, $args) = @_;
my $schema = $self->schema();
- if (!$schema->get_db_version() ) {
- # schema is unversioned
- $schema->deploy( $args, $self->sql_dir)
- or $schema->throw_exception ("Could not deploy schema.\n"); # FIXME deploy() does not return 1/0 on success/fail
- } else {
- $schema->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
- }
+ $schema->deploy( $args, $self->sql_dir );
}
=head2 insert
=back
-select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
+select takes the name of a resultset from the schema_class, a where hashref and a attrs to pass to ->search.
The found data is returned in a array ref where the first row will be the columns list.
=cut
my @data;
my @columns = $resultset->result_source->columns();
- push @data, [@columns];#
+ push @data, [@columns];#
while (my $row = $resultset->next()) {
my @fields;
sub _confirm {
my ($self) = @_;
- print "Are you sure you want to do this? (type YES to confirm) \n";
+
# mainly here for testing
return 1 if ($self->meta->get_attribute('_confirm')->get_value($self));
+
+ print "Are you sure you want to do this? (type YES to confirm) \n";
my $response = <STDIN>;
- return 1 if ($response=~/^YES/);
- return;
+
+ return ($response=~/^YES/);
}
sub _find_stanza {
die ("Could not find $stanza in config, $path does not seem to exist.\n");
}
}
+ $cfg = $cfg->{connect_info} if exists $cfg->{connect_info};
return $cfg;
}
package # hide from PAUSE
DBIx::Class::Admin::Descriptive;
-use DBIx::Class::Admin::Usage;
use base 'Getopt::Long::Descriptive';
+require DBIx::Class::Admin::Usage;
sub usage_class { 'DBIx::Class::Admin::Usage'; }
1;
use base 'Class::Accessor::Grouped';
-use Class::C3;
-
__PACKAGE__->mk_group_accessors('simple', 'synopsis', 'short_description');
sub prog_name {
$spec = Getopt::Long::Descriptive->_strip_assignment($spec);
$string .= "=item " . join " or ", map { length > 1 ? "B<--$_>" : "B<-$_>" }
- split /\|/, $spec;
+ split /\|/, $spec;
$string .= "\n\n$desc\n\n=cut\n\n";
}
use strict;
use warnings;
use base qw/DBIx::Class::Core DBIx::Class::DB/;
-use Carp::Clan qw/^DBIx::Class/;
# Modules CDBICompat needs that DBIx::Class does not.
my @Extra_Modules = qw(
for my $module (@Extra_Modules) {
push @didnt_load, $module unless eval qq{require $module};
}
-croak("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
+__PACKAGE__->throw_exception("@{[ join ', ', @didnt_load ]} are missing and are required for CDBICompat")
if @didnt_load;
=head1 DESCRIPTION
DBIx::Class features a fully featured compatibility layer with L<Class::DBI>
-and some common plugins to ease transition for existing CDBI users.
+and some common plugins to ease transition for existing CDBI users.
This is not a wrapper or subclass of DBIx::Class but rather a series of plugins. The result being that even though you're using the Class::DBI emulation layer you are still getting DBIx::Class objects. You can use all DBIx::Class features and methods via CDBICompat. This allows you to take advantage of DBIx::Class features without having to rewrite your CDBI code.
=head2 Choosing Features
In fact, this class is just a recipe containing all the features emulated.
-If you like, you can choose which features to emulate by building your
+If you like, you can choose which features to emulate by building your
own class and loading it like this:
package My::DB;
sub accessor_name_for {
my ($class, $column) = @_;
- if ($class->can('accessor_name')) {
- return $class->accessor_name($column)
+ if ($class->can('accessor_name')) {
+ return $class->accessor_name($column)
}
return $column;
sub mutator_name_for {
my ($class, $column) = @_;
- if ($class->can('mutator_name')) {
- return $class->mutator_name($column)
+ if ($class->can('mutator_name')) {
+ return $class->mutator_name($column)
}
return $column;
sub has_many {
my ($class, $rel, $f_class, $f_key, @rest) = @_;
- return $class->next::method($rel, $f_class, ( ref($f_key) ?
- $f_key :
- lc($f_key) ), @rest);
+ return $class->next::method(
+ $rel,
+ $f_class,
+ (ref($f_key) ?
+ $f_key :
+ lc($f_key||'')
+ ),
+ @rest
+ );
}
sub get_inflated_column {
use warnings;
use Sub::Name ();
use Storable 'dclone';
+use List::Util ();
use base qw/DBIx::Class::Row/;
$class->_add_column_group($group => @_) if @_;
return $class->all_columns if $group eq "All";
return $class->primary_column if $group eq "Primary";
- return keys %{$class->_column_groups->{$group}};
+
+ my $grp = $class->_column_groups->{$group};
+ my @grp_cols = sort { $grp->{$b} <=> $grp->{$a} } (keys %$grp);
+ return @grp_cols;
}
sub _add_column_group {
if ($group eq 'Primary') {
$class->set_primary_key(@cols);
- $groups->{'Essential'}{$_} ||= 1 for @cols;
+ delete $groups->{'Essential'}{$_} for @cols;
+ my $first = List::Util::max(values %{$groups->{'Essential'}});
+ $groups->{'Essential'}{$_} = ++$first for reverse @cols;
}
if ($group eq 'All') {
}
}
- $groups->{$group}{$_} ||= 1 for @cols;
+ delete $groups->{$group}{$_} for @cols;
+ my $first = List::Util::max(values %{$groups->{$group}});
+ $groups->{$group}{$_} = ++$first for reverse @cols;
$class->_column_groups($groups);
}
$self->throw_exception( "No relationship to JOIN from ${from_class} to ${to_class}" )
unless $rel_obj;
my $join = $from_class->storage->sql_maker->_join_condition(
- $from_class->result_source_instance->_resolve_condition(
- $rel_obj->{cond}, $to, $from) );
+ scalar $from_class->result_source_instance->_resolve_condition(
+ $rel_obj->{cond}, $to, $from
+ )
+ );
return $join;
}
sub {
my $sql = $sql;
my $class = shift;
- return $class->storage->sth($class->transform_sql($sql, @_));
+ return $class->storage->_sth($class->transform_sql($sql, @_));
};
if ($sql =~ /select/i) {
my $search_name = "search_${name}";
}
-# Emulate that CDBI throws out all changed columns and reloads them on
+# Emulate that CDBI throws out all changed columns and reloads them on
# request in case the database modifies the new value (say, via a trigger)
sub update {
my $self = shift;
--- /dev/null
+package DBIx::Class::Carp;
+
+use strict;
+use warnings;
+
+# This is here instead of DBIx::Class because of load-order issues
+BEGIN {
+ # something is tripping up V::M on 5.8.1, leading to segfaults.
+ # A similar test in n::c itself is disabled on 5.8.1 for the same
+ # reason. There isn't much motivation to try to find why it happens
+ *DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN = ($] < 5.008005)
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+}
+
+use Carp ();
+use namespace::clean ();
+
+sub __find_caller {
+ my ($skip_pattern, $class) = @_;
+
+ my $skip_class_data = $class->_skip_namespace_frames
+ if ($class and $class->can('_skip_namespace_frames'));
+
+ $skip_pattern = qr/$skip_pattern|$skip_class_data/
+ if $skip_class_data;
+
+ my $fr_num = 1; # skip us and the calling carp*
+ my @f;
+ while (@f = caller($fr_num++)) {
+ last unless $f[0] =~ $skip_pattern;
+
+ if (
+ $f[0]->can('_skip_namespace_frames')
+ and
+ my $extra_skip = $f[0]->_skip_namespace_frames
+ ) {
+ $skip_pattern = qr/$skip_pattern|$extra_skip/;
+ }
+ }
+
+ my ($ln, $calling) = @f # if empty - nothing matched - full stack
+ ? ( "at $f[1] line $f[2]", $f[3] )
+ : ( Carp::longmess(), '{UNKNOWN}' )
+ ;
+
+ return (
+ $ln,
+ $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+ );
+};
+
+my $warn = sub {
+ my ($ln, @warn) = @_;
+ @warn = "Warning: something's wrong" unless @warn;
+
+ # back-compat with Carp::Clan - a warning ending with \n does
+ # not include caller info
+ warn (
+ @warn,
+ $warn[-1] =~ /\n$/ ? '' : " $ln\n"
+ );
+};
+
+sub import {
+ my (undef, $skip_pattern) = @_;
+ my $into = caller;
+
+ $skip_pattern = $skip_pattern
+ ? qr/ ^ $into $ | $skip_pattern /xo
+ : qr/ ^ $into $ /xo
+ ;
+
+ no strict 'refs';
+
+ *{"${into}::carp"} = sub {
+ $warn->(
+ __find_caller($skip_pattern, $into),
+ @_
+ );
+ };
+
+ my $fired = {};
+ *{"${into}::carp_once"} = sub {
+ return if $fired->{$_[0]};
+ $fired->{$_[0]} = 1;
+
+ $warn->(
+ __find_caller($skip_pattern, $into),
+ @_,
+ );
+ };
+
+ my $seen;
+ *{"${into}::carp_unique"} = sub {
+ my ($ln, $calling) = __find_caller($skip_pattern, $into);
+ my $msg = join ('', $calling, @_);
+
+ # unique carping with a hidden caller makes no sense
+ $msg =~ s/\n+$//;
+
+ return if $seen->{$ln}{$msg};
+ $seen->{$ln}{$msg} = 1;
+
+ $warn->(
+ $ln,
+ $msg,
+ );
+ };
+
+ # cleanup after ourselves
+ namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/)
+ ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
+ # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
+ # see if this starts working
+ unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+}
+
+sub unimport {
+ die (__PACKAGE__ . " does not implement unimport yet\n");
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
+
+=head1 DESCRIPTION
+
+Documentation is lacking on purpose - this an experiment not yet fit for
+mass consumption. If you use this do not count on any kind of stability,
+in fact don't even count on this module's continuing existence (it has
+been noindexed for a reason).
+
+In addition to the classic interface:
+
+ use DBIx::Class::Carp '^DBIx::Class'
+
+this module also supports a class-data based way to specify the exclusion
+regex. A message is only carped from a callsite that matches neither the
+closed over string, nor the value of L</_skip_namespace_frames> as declared
+on any callframe already skipped due to the same mechanism. This is to ensure
+that intermediate callsites can declare their own additional skip-namespaces.
+
+=head1 CLASS ATTRIBUTES
+
+=head2 _skip_namespace_frames
+
+A classdata attribute holding the stringified regex matching callsites that
+should be skipped by the carp methods below. An empty string C<q{}> is treated
+like no setting/C<undef> (the distinction is necessary due to semantics of the
+class data accessors provided by L<Class::Accessor::Grouped>)
+
+=head1 EXPORTED FUNCTIONS
+
+This module export the following 3 functions. Only warning related C<carp*>
+is being handled here, for C<croak>-ing you must use
+L<DBIx::Class::Schema/throw_exception> or L<DBIx::Class::Exception>.
+
+=head2 carp
+
+Carps message with the file/line of the first callsite not matching
+L</_skip_namespace_frames> nor the closed-over arguments to
+C<use DBIx::Class::Carp>.
+
+=head2 carp_unique
+
+Like L</carp> but warns once for every distinct callsite (subject to the
+same ruleset as L</carp>).
+
+=head2 carp_once
+
+Like L</carp> but warns only once for the life of the perl interpreter
+(regardless of callsite).
+
+=cut
use warnings;
use base 'Class::C3::Componentised';
-use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
use mro 'c3';
+use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised';
+
# this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
+# if and only if it is placed before something overriding store_column
sub inject_base {
my $class = shift;
- my $target = shift;
+ my ($target, @complist) = @_;
+
+ # we already did load the component
+ my $keep_checking = ! (
+ $target->isa ('DBIx::Class::UTF8Columns')
+ ||
+ $target->isa ('DBIx::Class::ForceUTF8')
+ );
+
+ my @target_isa;
+
+ while ($keep_checking && @complist) {
+
+ @target_isa = do { no strict 'refs'; @{"$target\::ISA"} }
+ unless @target_isa;
+
+ my $comp = pop @complist;
+
+ # warn here on use of either component, as we have no access to ForceUTF8,
+ # the author does not respond, and the Catalyst wiki used to recommend it
+ for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
+ if ($comp->isa ($_) ) {
+ $keep_checking = 0; # no use to check from this point on
+ carp_once "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
+ unless $ENV{DBIC_UTF8COLUMNS_OK};
+ last;
+ }
+ }
- my @present_components = (@{mro::get_linear_isa ($target)||[]});
+ # something unset $keep_checking - we got a unicode mangler
+ if (! $keep_checking) {
- no strict 'refs';
- for my $comp (reverse @_) {
+ my $base_store_column = do { require DBIx::Class::Row; DBIx::Class::Row->can ('store_column') };
- if ($comp->isa ('DBIx::Class::UTF8Columns') ) {
- require B;
my @broken;
+ for my $existing_comp (@target_isa) {
+ my $sc = $existing_comp->can ('store_column')
+ or next;
- for (@present_components) {
- my $cref = $_->can ('store_column')
- or next;
- push @broken, $_ if B::svref_2object($cref)->STASH->NAME ne 'DBIx::Class::Row';
+ if ($sc ne $base_store_column) {
+ require B;
+ my $definer = B::svref_2object($sc)->STASH->NAME;
+ push @broken, ($definer eq $existing_comp)
+ ? $existing_comp
+ : "$existing_comp (via $definer)"
+ ;
+ }
}
- carp "Incorrect loading order of $comp by ${target} will affect other components overriding store_column ("
+ carp "Incorrect loading order of $comp by $target will affect other components overriding 'store_column' ("
. join (', ', @broken)
.'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
- if @broken;
+ if @broken;
}
- unshift @present_components, $comp;
+ unshift @target_isa, $comp;
}
- $class->next::method($target, @_);
+ $class->next::method(@_);
}
1;
=item L<DBIx::Class::InflateColumn>
-=item L<DBIx::Class::Relationship>
+=item L<DBIx::Class::Relationship> (See also L<DBIx::Class::Relationship::Base>)
=item L<DBIx::Class::PK::Auto>
=item L<DBIx::Class::Row>
-=item L<DBIx::Class::ResultSourceProxy::Table>
+=item L<DBIx::Class::ResultSourceProxy::Table> (See also L<DBIx::Class::ResultSource>)
=back
use DBIx::Class::Storage::DBI;
use DBIx::Class::ClassResolver::PassThrough;
use DBI;
-use Scalar::Util;
+use Scalar::Util 'blessed';
+use namespace::clean;
unless ($INC{"DBIx/Class/CDBICompat.pm"}) {
warn "IMPORTANT: DBIx::Class::DB is DEPRECATED AND *WILL* BE REMOVED. DO NOT USE.\n";
__PACKAGE__->load_components(qw/ResultSetProxy/);
-{
- no warnings 'once';
- *dbi_commit = \&txn_commit;
- *dbi_rollback = \&txn_rollback;
-}
-
sub storage { shift->schema_instance(@_)->storage; }
+sub dbi_commit { shift->txn_commit(@_) }
+sub dbi_rollback { shift->txn_rollback(@_) }
=head1 NAME
to being a CDBICompat-only component before 1.0. In order to discourage further
use, documentation has been removed as of 0.08000
-=begin HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
-
=head1 METHODS
-=head2 storage
+Hidden.
+
+=begin hidden head2 storage
Sets or gets the storage backend. Defaults to L<DBIx::Class::Storage::DBI>.
-=head2 class_resolver
+=end hidden
+
+=cut
+
+=begin hidden head2 class_resolver
****DEPRECATED****
L<DBIx::Class::ClassResolver::Passthrough>, which returns whatever you give
it. See resolve_class below.
+=end hidden
+
=cut
__PACKAGE__->mk_classdata('class_resolver' =>
'DBIx::Class::ClassResolver::PassThrough');
-=head2 connection
+=begin hidden head2 connection
__PACKAGE__->connection($dsn, $user, $pass, $attrs);
Specifies the arguments that will be passed to DBI->connect(...) to
instantiate the class dbh when required.
+=end hidden
+
=cut
sub connection {
$class->schema_instance->connection(@info);
}
-=head2 setup_schema_instance
+=begin hidden head2 setup_schema_instance
Creates a class method ->schema_instance which contains a DBIx::Class::Schema;
all class-method operations are proxies through to this object. If you don't
call ->setup_schema_instance in order for subclasses to find the schema and
register themselves with it.
+=end hidden
+
=cut
sub setup_schema_instance {
$class->mk_classdata('schema_instance' => $schema);
}
-=head2 txn_begin
+=begin hidden head2 txn_begin
Begins a transaction (does nothing if AutoCommit is off).
+=end hidden
+
=cut
sub txn_begin { shift->schema_instance->txn_begin(@_); }
-=head2 txn_commit
+=begin hidden head2 txn_commit
Commits the current transaction.
+=end hidden
+
=cut
sub txn_commit { shift->schema_instance->txn_commit(@_); }
-=head2 txn_rollback
+=begin hidden head2 txn_rollback
Rolls back the current transaction.
+=end hidden
+
=cut
sub txn_rollback { shift->schema_instance->txn_rollback(@_); }
-=head2 txn_do
+=begin hidden head2 txn_do
Executes a block of code transactionally. If this code reference
throws an exception, the transaction is rolled back and the exception
is rethrown. See L<DBIx::Class::Schema/"txn_do"> for more details.
+=end hidden
+
=cut
sub txn_do { shift->schema_instance->txn_do(@_); }
}
}
-=head2 resultset_instance
+=begin hidden head2 resultset_instance
Returns an instance of a resultset for this class - effectively
mapping the L<Class::DBI> connection-as-classdata paradigm into the
native L<DBIx::Class::ResultSet> system.
+=end hidden
+
=cut
sub resultset_instance {
$_[0]->result_source_instance->resultset
}
-=head2 result_source_instance
+=begin hidden head2 result_source_instance
Returns an instance of the result source for this class
+=end hidden
+
=cut
__PACKAGE__->mk_classdata('_result_source_instance' => []);
}
my($source, $result_class) = @{$class->_result_source_instance};
- return unless Scalar::Util::blessed($source);
+ return unless blessed $source;
if ($result_class ne $class) { # new class
# Give this new class its own source and register it.
- $source = $source->new({
- %$source,
+ $source = $source->new({
+ %$source,
source_name => $class,
result_class => $class
} );
return $source;
}
-=head2 resolve_class
+=begin hidden head2 resolve_class
****DEPRECATED****
-See L<class_resolver>
+See L</class_resolver>
-=head2 dbi_commit
+=end hidden
+
+=begin hidden head2 dbi_commit
****DEPRECATED****
-Alias for L<txn_commit>
+Alias for L</txn_commit>
+
+=end hidden
-=head2 dbi_rollback
+=begin hidden head2 dbi_rollback
****DEPRECATED****
-Alias for L<txn_rollback>
+Alias for L</txn_rollback>
-=end HIDE_BECAUSE_THIS_CLASS_IS_DEPRECATED
+=end hidden
=head1 AUTHORS
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util qw/blessed/;
+use DBIx::Class::Carp ();
use overload
'""' => sub { shift->{msg} },
Exception objects of this class are used internally by
the default error handling of L<DBIx::Class::Schema/throw_exception>
-to prevent confusing and/or redundant re-application of L<Carp>'s
-stack trace information.
+and derivatives.
These objects stringify to the contained error message, and use
overload fallback to give natural boolean/numeric values.
code, and shouldn't be used directly elsewhere.
Expects a scalar exception message. The optional argument
-C<$stacktrace> tells it to use L<Carp/longmess> instead of
-L<Carp::Clan/croak>.
+C<$stacktrace> tells it to output a full trace similar to L<Carp/confess>.
DBIx::Class::Exception->throw('Foo');
- eval { ... }; DBIx::Class::Exception->throw($@) if $@;
+ try { ... } catch { DBIx::Class::Exception->throw(shift) }
=cut
my ($class, $msg, $stacktrace) = @_;
# Don't re-encapsulate exception objects of any kind
- die $msg if blessed($msg);
+ die $msg if ref($msg);
+
+ # all exceptions include a caller
+ $msg =~ s/\n$//;
- # use Carp::Clan's croak if we're not stack tracing
if(!$stacktrace) {
- local $@;
- eval { croak $msg };
- $msg = $@
+ # skip all frames that match the original caller, or any of
+ # the dbic-wide classdata patterns
+ my ($ln, $calling) = DBIx::Class::Carp::__find_caller(
+ '^' . caller() . '$',
+ 'DBIx::Class',
+ );
+
+ $msg = "${calling}${msg} ${ln}\n";
}
else {
$msg = Carp::longmess($msg);
--- /dev/null
+package DBIx::Class::FilterColumn;
+use strict;
+use warnings;
+
+use base qw/DBIx::Class::Row/;
+
+sub filter_column {
+ my ($self, $col, $attrs) = @_;
+
+ my $colinfo = $self->column_info($col);
+
+ $self->throw_exception('FilterColumn does not work with InflateColumn')
+ if $self->isa('DBIx::Class::InflateColumn') &&
+ defined $colinfo->{_inflate_info};
+
+ $self->throw_exception("No such column $col to filter")
+ unless $self->has_column($col);
+
+ $self->throw_exception('filter_column expects a hashref of filter specifications')
+ unless ref $attrs eq 'HASH';
+
+ $self->throw_exception('An invocation of filter_column() must specify either a filter_from_storage or filter_to_storage')
+ unless $attrs->{filter_from_storage} || $attrs->{filter_to_storage};
+
+ $colinfo->{_filter_info} = $attrs;
+ my $acc = $colinfo->{accessor};
+ $self->mk_group_accessors(filtered_column => [ (defined $acc ? $acc : $col), $col]);
+ return 1;
+}
+
+sub _column_from_storage {
+ my ($self, $col, $value) = @_;
+
+ return $value unless defined $value;
+
+ my $info = $self->column_info($col)
+ or $self->throw_exception("No column info for $col");
+
+ return $value unless exists $info->{_filter_info};
+
+ my $filter = $info->{_filter_info}{filter_from_storage};
+
+ return defined $filter ? $self->$filter($value) : $value;
+}
+
+sub _column_to_storage {
+ my ($self, $col, $value) = @_;
+
+ my $info = $self->column_info($col) or
+ $self->throw_exception("No column info for $col");
+
+ return $value unless exists $info->{_filter_info};
+
+ my $unfilter = $info->{_filter_info}{filter_to_storage};
+
+ return defined $unfilter ? $self->$unfilter($value) : $value;
+}
+
+sub get_filtered_column {
+ my ($self, $col) = @_;
+
+ $self->throw_exception("$col is not a filtered column")
+ unless exists $self->column_info($col)->{_filter_info};
+
+ return $self->{_filtered_column}{$col}
+ if exists $self->{_filtered_column}{$col};
+
+ my $val = $self->get_column($col);
+
+ return $self->{_filtered_column}{$col} = $self->_column_from_storage($col, $val);
+}
+
+sub get_column {
+ my ($self, $col) = @_;
+ if (exists $self->{_filtered_column}{$col}) {
+ return $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col});
+ }
+
+ return $self->next::method ($col);
+}
+
+# sadly a separate codepath in Row.pm ( used by insert() )
+sub get_columns {
+ my $self = shift;
+
+ foreach my $col (keys %{$self->{_filtered_column}||{}}) {
+ $self->{_column_data}{$col} ||= $self->_column_to_storage ($col, $self->{_filtered_column}{$col})
+ if exists $self->{_filtered_column}{$col};
+ }
+
+ $self->next::method (@_);
+}
+
+sub store_column {
+ my ($self, $col) = (shift, @_);
+
+ # blow cache
+ delete $self->{_filtered_column}{$col};
+
+ $self->next::method(@_);
+}
+
+sub set_filtered_column {
+ my ($self, $col, $filtered) = @_;
+
+ # do not blow up the cache via set_column unless necessary
+ # (filtering may be expensive!)
+ if (exists $self->{_filtered_column}{$col}) {
+ return $filtered
+ if ($self->_eq_column_values ($col, $filtered, $self->{_filtered_column}{$col} ) );
+
+ $self->make_column_dirty ($col); # so the comparison won't run again
+ }
+
+ $self->set_column($col, $self->_column_to_storage($col, $filtered));
+
+ return $self->{_filtered_column}{$col} = $filtered;
+}
+
+sub update {
+ my ($self, $attrs, @rest) = @_;
+
+ foreach my $key (keys %{$attrs||{}}) {
+ if (
+ $self->has_column($key)
+ &&
+ exists $self->column_info($key)->{_filter_info}
+ ) {
+ $self->set_filtered_column($key, delete $attrs->{$key});
+
+ # FIXME update() reaches directly into the object-hash
+ # and we may *not* have a filtered value there - thus
+ # the void-ctx filter-trigger
+ $self->get_column($key) unless exists $self->{_column_data}{$key};
+ }
+ }
+
+ return $self->next::method($attrs, @rest);
+}
+
+sub new {
+ my ($class, $attrs, @rest) = @_;
+ my $source = $attrs->{-result_source}
+ or $class->throw_exception('Sourceless rows are not supported with DBIx::Class::FilterColumn');
+
+ my $obj = $class->next::method($attrs, @rest);
+ foreach my $key (keys %{$attrs||{}}) {
+ if ($obj->has_column($key) &&
+ exists $obj->column_info($key)->{_filter_info} ) {
+ $obj->set_filtered_column($key, $attrs->{$key});
+ }
+ }
+
+ return $obj;
+}
+
+1;
+
+=head1 NAME
+
+DBIx::Class::FilterColumn - Automatically convert column data
+
+=head1 SYNOPSIS
+
+In your Schema or DB class add "FilterColumn" to the top of the component list.
+
+ __PACKAGE__->load_components(qw( FilterColumn ... ));
+
+Set up filters for the columns you want to convert.
+
+ __PACKAGE__->filter_column( money => {
+ filter_to_storage => 'to_pennies',
+ filter_from_storage => 'from_pennies',
+ });
+
+ sub to_pennies { $_[1] * 100 }
+
+ sub from_pennies { $_[1] / 100 }
+
+ 1;
+
+
+=head1 DESCRIPTION
+
+This component is meant to be a more powerful, but less DWIM-y,
+L<DBIx::Class::InflateColumn>. One of the major issues with said component is
+that it B<only> works with references. Generally speaking anything that can
+be done with L<DBIx::Class::InflateColumn> can be done with this component.
+
+=head1 METHODS
+
+=head2 filter_column
+
+ __PACKAGE__->filter_column( colname => {
+ filter_from_storage => 'method'|\&coderef,
+ filter_to_storage => 'method'|\&coderef,
+ })
+
+This is the method that you need to call to set up a filtered column. It takes
+exactly two arguments; the first being the column name the second being a hash
+reference with C<filter_from_storage> and C<filter_to_storage> set to either
+a method name or a code reference. In either case the filter is invoked as:
+
+ $row_obj->$filter_specification ($value_to_filter)
+
+with C<$filter_specification> being chosen depending on whether the
+C<$value_to_filter> is being retrieved from or written to permanent
+storage.
+
+If a specific directional filter is not specified, the original value will be
+passed to/from storage unfiltered.
+
+=head2 get_filtered_column
+
+ $obj->get_filtered_column('colname')
+
+Returns the filtered value of the column
+
+=head2 set_filtered_column
+
+ $obj->set_filtered_column(colname => 'new_value')
+
+Sets the filtered value of the column
+
+=head1 EXAMPLE OF USE
+
+Some databases have restrictions on values that can be passed to
+boolean columns, and problems can be caused by passing value that
+perl considers to be false (such as C<undef>).
+
+One solution to this is to ensure that the boolean values are set
+to something that the database can handle - such as numeric zero
+and one, using code like this:-
+
+ __PACKAGE__->filter_column(
+ my_boolean_column => {
+ filter_to_storage => sub { $_[1] ? 1 : 0 },
+ }
+ );
+
+In this case the C<filter_from_storage> is not required, as just
+passing the database value through to perl does the right thing.
--- /dev/null
+# This is just a concept-test. If works as intended will ship in its own
+# right as Devel::GlobalDestruction::PP or perhaps even as part of rafls
+# D::GD itself
+
+package # hide from pause
+ DBIx::Class::GlobalDestruction;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+our @EXPORT = 'in_global_destruction';
+
+use DBIx::Class::Exception;
+
+if (defined ${^GLOBAL_PHASE}) {
+ eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }';
+}
+elsif (eval { require Devel::GlobalDestruction }) { # use the XS version if available
+ *in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
+}
+else {
+ my ($in_global_destruction, $before_is_installed);
+
+ eval <<'PP_IGD';
+
+sub in_global_destruction () { $in_global_destruction }
+
+END {
+ # SpeedyCGI runs END blocks every cycle but keeps object instances
+ # hence we have to disable the globaldestroy hatch, and rely on the
+ # eval traps (which appears to work, but are risky done so late)
+ $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy;
+}
+
+# threads do not execute the global ENDs (it would be stupid). However
+# one can register a new END via simple string eval within a thread, and
+# achieve the same result. A logical place to do this would be CLONE, which
+# is claimed to run in the context of the new thread. However this does
+# not really seem to be the case - any END evaled in a CLONE is ignored :(
+# Hence blatantly hooking threads::create
+if ($INC{'threads.pm'}) {
+ require Class::Method::Modifiers;
+ Class::Method::Modifiers::install_modifier( threads => before => create => sub {
+ my $orig_target_cref = $_[1];
+ $_[1] = sub {
+ { local $@; eval 'END { $in_global_destruction = 1 }' }
+ $orig_target_cref->();
+ };
+ });
+ $before_is_installed = 1;
+}
+
+# just in case threads got loaded after DBIC (silly)
+sub CLONE {
+ DBIx::Class::Exception->throw("You must load the 'threads' module before @{[ __PACKAGE__ ]}")
+ unless $before_is_installed;
+}
+
+PP_IGD
+
+}
+
+1;
use strict;
use warnings;
-use Scalar::Util qw/blessed/;
use base qw/DBIx::Class::Row/;
to work.
If you want to filter plain scalar values and replace them with
-something else, contribute a filtering component.
+something else, see L<DBIx::Class::FilterColumn>.
=head1 METHODS
sub inflate_column {
my ($self, $col, $attrs) = @_;
+
+ my $colinfo = $self->column_info($col);
+
+ $self->throw_exception("InflateColumn does not work with FilterColumn")
+ if $self->isa('DBIx::Class::FilterColumn') &&
+ defined $colinfo->{_filter_info};
+
$self->throw_exception("No such column $col to inflate")
unless $self->has_column($col);
$self->throw_exception("inflate_column needs attr hashref")
unless ref $attrs eq 'HASH';
- $self->column_info($col)->{_inflate_info} = $attrs;
- my $acc = $self->column_info($col)->{accessor};
+ $colinfo->{_inflate_info} = $attrs;
+ my $acc = $colinfo->{accessor};
$self->mk_group_accessors('inflated_column' => [ (defined $acc ? $acc : $col), $col]);
return 1;
}
$self->set_column($col, $self->_deflated_column($col, $inflated));
# if (blessed $inflated) {
if (ref $inflated && ref($inflated) ne 'SCALAR') {
- $self->{_inflated_column}{$col} = $inflated;
+ $self->{_inflated_column}{$col} = $inflated;
} else {
- delete $self->{_inflated_column}{$col};
+ delete $self->{_inflated_column}{$col};
}
return $inflated;
}
use strict;
use warnings;
use base qw/DBIx::Class/;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
+use Try::Tiny;
+use namespace::clean;
=head1 NAME
=head1 SYNOPSIS
-Load this component and then declare one or more
+Load this component and then declare one or more
columns to be of the datetime, timestamp or date datatype.
package Event;
=head1 DESCRIPTION
-This module figures out the type of DateTime::Format::* class to
-inflate/deflate with based on the type of DBIx::Class::Storage::DBI::*
-that you are using. If you switch from one database to a different
+This module figures out the type of DateTime::Format::* class to
+inflate/deflate with based on the type of DBIx::Class::Storage::DBI::*
+that you are using. If you switch from one database to a different
one your code should continue to work without modification (though note
that this feature is new as of 0.07, so it may not be perfect yet - bug
reports to the list very much welcome).
sub register_column {
my ($self, $column, $info, @rest) = @_;
- $self->next::method($column, $info, @rest);
- return unless defined($info->{data_type});
- my $type;
+ $self->next::method($column, $info, @rest);
- for (qw/date datetime timestamp/) {
+ my $requested_type;
+ for (qw/datetime timestamp date/) {
my $key = "inflate_${_}";
+ if (exists $info->{$key}) {
- next unless exists $info->{$key};
- return unless $info->{$key};
+ # this bailout is intentional
+ return unless $info->{$key};
- $type = $_;
- last;
- }
-
- unless ($type) {
- $type = lc($info->{data_type});
- if ($type eq "timestamp with time zone" || $type eq "timestamptz") {
- $type = "timestamp";
- $info->{_ic_dt_method} ||= "timestamp_with_timezone";
- } elsif ($type eq "timestamp without time zone") {
- $type = "timestamp";
- $info->{_ic_dt_method} ||= "timestamp_without_timezone";
- } elsif ($type eq "smalldatetime") {
- $type = "datetime";
- $info->{_ic_dt_method} ||= "datetime";
+ $requested_type = $_;
+ last;
}
}
- if ( defined $info->{extra}{timezone} ) {
- carp "Putting timezone into extra => { timezone => '...' } has been deprecated, ".
- "please put it directly into the '$column' column definition.";
- $info->{timezone} = $info->{extra}{timezone} unless defined $info->{timezone};
+ return if (!$requested_type and !$info->{data_type});
+
+ my $data_type = lc( $info->{data_type} || '' );
+
+ # _ic_dt_method will follow whatever the registration requests
+ # thus = instead of ||=
+ if ($data_type eq 'timestamp with time zone' || $data_type eq 'timestamptz') {
+ $info->{_ic_dt_method} = 'timestamp_with_timezone';
+ }
+ elsif ($data_type eq 'timestamp without time zone') {
+ $info->{_ic_dt_method} = 'timestamp_without_timezone';
+ }
+ elsif ($data_type eq 'smalldatetime') {
+ $info->{_ic_dt_method} = 'smalldatetime';
+ }
+ elsif ($data_type =~ /^ (?: date | datetime | timestamp ) $/x) {
+ $info->{_ic_dt_method} = $data_type;
+ }
+ elsif ($requested_type) {
+ $info->{_ic_dt_method} = $requested_type;
+ }
+ else {
+ return;
}
- if ( defined $info->{extra}{locale} ) {
- carp "Putting locale into extra => { locale => '...' } has been deprecated, ".
- "please put it directly into the '$column' column definition.";
- $info->{locale} = $info->{extra}{locale} unless defined $info->{locale};
+ if ($info->{extra}) {
+ for my $slot (qw/timezone locale floating_tz_ok/) {
+ if ( defined $info->{extra}{$slot} ) {
+ carp "Putting $slot into extra => { $slot => '...' } has been deprecated, ".
+ "please put it directly into the '$column' column definition.";
+ $info->{$slot} = $info->{extra}{$slot} unless defined $info->{$slot};
+ }
+ }
}
- my $undef_if_invalid = $info->{datetime_undef_if_invalid};
+ # shallow copy to avoid unfounded(?) Devel::Cycle complaints
+ my $infcopy = {%$info};
- if ($type eq 'datetime' || $type eq 'date' || $type eq 'timestamp') {
- # This shallow copy of %info avoids t/52_cycle.t treating
- # the resulting deflator as a circular reference.
- my %info = ( '_ic_dt_method' => $type , %{ $info } );
+ $self->inflate_column(
+ $column =>
+ {
+ inflate => sub {
+ my ($value, $obj) = @_;
- if (defined $info->{extra}{floating_tz_ok}) {
- carp "Putting floating_tz_ok into extra => { floating_tz_ok => 1 } has been deprecated, ".
- "please put it directly into the '$column' column definition.";
- $info{floating_tz_ok} = $info->{extra}{floating_tz_ok};
- }
+ # propagate for error reporting
+ $infcopy->{__dbic_colname} = $column;
- $self->inflate_column(
- $column =>
- {
- inflate => sub {
- my ($value, $obj) = @_;
-
- my $dt = eval { $obj->_inflate_to_datetime( $value, \%info ) };
- if (my $err = $@ ) {
- return undef if ($undef_if_invalid);
- $self->throw_exception ("Error while inflating ${value} for ${column} on ${self}: $err");
- }
-
- return $obj->_post_inflate_datetime( $dt, \%info );
- },
- deflate => sub {
- my ($value, $obj) = @_;
-
- $value = $obj->_pre_deflate_datetime( $value, \%info );
- $obj->_deflate_from_datetime( $value, \%info );
- },
- }
- );
- }
+ my $dt = $obj->_inflate_to_datetime( $value, $infcopy );
+
+ return (defined $dt)
+ ? $obj->_post_inflate_datetime( $dt, $infcopy )
+ : undef
+ ;
+ },
+ deflate => sub {
+ my ($value, $obj) = @_;
+
+ $value = $obj->_pre_deflate_datetime( $value, $infcopy );
+ $obj->_deflate_from_datetime( $value, $infcopy );
+ },
+ }
+ );
}
sub _flate_or_fallback
my $parser = $self->_datetime_parser;
my $preferred_method = sprintf($method_fmt, $info->{ _ic_dt_method });
- my $method = $parser->can($preferred_method) ? $preferred_method : sprintf($method_fmt, 'datetime');
- return $parser->$method($value);
+ my $method = $parser->can($preferred_method) || sprintf($method_fmt, 'datetime');
+
+ return try {
+ $parser->$method($value);
+ }
+ catch {
+ $self->throw_exception ("Error while inflating ${value} for $info->{__dbic_colname} on ${self}: $_")
+ unless $info->{datetime_undef_if_invalid};
+ undef; # rv
+ };
}
sub _inflate_to_datetime {
=over 4
-=item More information about the add_columns method, and column metadata,
+=item More information about the add_columns method, and column metadata,
can be found in the documentation for L<DBIx::Class::ResultSource>.
=item Further discussion of problems inherent to the Floating timezone:
- L<Floating DateTimes|DateTime/Floating_DateTimes>
+ L<Floating DateTimes|DateTime/Floating DateTimes>
and L<< $dt->set_time_zone|DateTime/"Set" Methods >>
=back
use File::Path;
use File::Copy;
use Path::Class;
+use DBIx::Class::Carp;
+use namespace::clean;
+
+carp 'InflateColumn::File has entered a deprecation cycle. This component '
+ .'has a number of architectural deficiencies that can quickly drive '
+ .'your filesystem and database out of sync and is not recommended '
+ .'for further use. It will be retained for backwards '
+ .'compatibility, but no new functionality patches will be accepted. '
+ .'Please consider using the much more mature and actively maintained '
+ .'DBIx::Class::InflateColumn::FS. You can set the environment variable '
+ .'DBIC_IC_FILE_NOWARN to a true value to disable this warning.'
+unless $ENV{DBIC_IC_FILE_NOWARN};
+
+
__PACKAGE__->load_components(qw/InflateColumn/);
return unless defined($info->{is_file_column});
$self->inflate_column($column => {
- inflate => sub {
+ inflate => sub {
my ($value, $obj) = @_;
$obj->_inflate_file_column($column, $value);
},
=head1 NAME
-DBIx::Class::InflateColumn::File - map files from the Database to the filesystem.
+DBIx::Class::InflateColumn::File - DEPRECATED (superseded by DBIx::Class::InflateColumn::FS)
+
+=head2 Deprecation Notice
+
+ This component has a number of architectural deficiencies that can quickly
+ drive your filesystem and database out of sync and is not recommended for
+ further use. It will be retained for backwards compatibility, but no new
+ functionality patches will be accepted. Please consider using the much more
+ mature and actively supported DBIx::Class::InflateColumn::FS. You can set
+ the environment variable DBIC_IC_FILE_NOWARN to a true value to disable
+ this warning.
=head1 SYNOPSIS
data_type => "varchar",
is_file_column => 1,
file_column_path =>'/tmp/uploaded_files',
- # or for a Catalyst application
+ # or for a Catalyst application
# file_column_path => MyApp->path_to('root','static','files'),
default_value => undef,
is_nullable => 1,
FileColumn requires a hash that contains L<IO::File> as handle and the file's
name as name.
- my $entry = $c->model('MyAppDB::Articles')->create({
+ my $entry = $c->model('MyAppDB::Articles')->create({
subject => 'blah',
- filename => {
- handle => $c->req->upload('myupload')->fh,
- filename => $c->req->upload('myupload')->basename
+ filename => {
+ handle => $c->req->upload('myupload')->fh,
+ filename => $c->req->upload('myupload')->basename
},
body => '....'
});
And Place the following in your TT template
Article Subject: [% entry.subject %]
- Uploaded File:
+ Uploaded File:
<a href="/static/files/[% entry.id %]/[% entry.filename.filename %]">File</a>
Body: [% entry.body %]
-=head1 NAME
+=head1 NAME
DBIx::Class::Manual - Index of the Manual
=head1 DESCRIPTION
-This is the L<DBIx::Class> users manual. DBIx::Class is a SQL->OOP mapper.
+This is the L<DBIx::Class> users manual. DBIx::Class is a SQL->OOP mapper.
This means that it can represent your SQL tables as perl classes, and give
you convenient accessors and methods for retrieving and updating information
from your SQL database.
Short answers and doc pointers to questions.
+=head2 L<DBIx::Class::Manual::Glossary>
+
+Explanations of terms used in this documentation.
+
=head2 L<DBIx::Class::Manual::Intro>
-Beginner guide to using DBIx::Class.
+Beginner guide to using DBIx::Class.
=head2 L<DBIx::Class::Manual::Example>
Convenient recipes for DBIC usage.
+=head2 L<DBIx::Class::Manual::Reading>
+
+How to read (and write) the reference documentation.
+
=head2 L<DBIx::Class::Manual::DocMap>
Lists of modules by task to help you find the correct document.
=head2 L<DBIx::Class::Manual::Component>
-Existing components, and documentation and example on how to
+Existing components, and documentation and example on how to
develop new ones.
=cut
# Do stuff with $self, like set default values.
return $self->next::method( @_ );
}
-
+
sub delete {
my $self = shift;
# Do stuff with $self.
return $self->next::method( @_ );
}
-Now, the order that a component is loaded is very important. Components
-that are loaded first are the first ones in the inheritance stack. So, if
-you override insert() but the DBIx::Class::Row component is loaded first
-then your insert() will never be called, since the DBIx::Class::Row insert()
-will be called first. If you are unsure as to why a given method is not
-being called try printing out the Class::C3 inheritance stack.
-
- print join ', ' => Class::C3::calculateMRO('YourClass::Name');
+Now, the order that a component is loaded is very important. Components
+that are loaded first are the first ones in the inheritance stack. So, if
+you override insert() but the DBIx::Class::Row component is loaded first
+then your insert() will never be called, since the DBIx::Class::Row insert()
+will be called first. If you are unsure as to why a given method is not
+being called try printing out the current linearized MRO.
-Check out the L<Class::C3> docs for more information about inheritance.
+ print join ', ' => mro::get_linear_isa('YourClass::Name');
=head1 EXISTING COMPONENTS
=head2 Extra
-These components provide extra functionality beyond
+These components provide extra functionality beyond
basic functionality that you can't live without.
-L<DBIx::Class::Serialize::Storable> - Hooks for Storable freeze/thaw.
-
L<DBIx::Class::CDBICompat> - Class::DBI Compatibility layer.
L<DBIx::Class::FormTools> - Build forms with multiple interconnected objects.
L<DBIx::Class::RandomStringColumns> - Declare virtual columns that return random strings.
-L<DBIx::Class::UTF8Columns> - Force UTF8 (Unicode) flag on columns.
-
L<DBIx::Class::UUIDColumns> - Implicit UUID columns.
L<DBIx::Class::WebForm> - CRUD methods.
=item * NOTE
If you're using the old deprecated C<< $rsrc_instance->name(\'( SELECT ...') >>
-method for custom SQL execution, you are highly encouraged to update your code
+method for custom SQL execution, you are highly encouraged to update your code
to use a virtual view as above. If you do not want to change your code, and just
want to suppress the deprecation warning when you call
L<DBIx::Class::Schema/deploy>, add this line to your source definition, so that
# FROM artist
Note that the C<as> attribute B<has absolutely nothing to do> with the SQL
-syntax C< SELECT foo AS bar > (see the documentation in
+syntax C< SELECT foo AS bar > (see the documentation in
L<DBIx::Class::ResultSet/ATTRIBUTES>). You can control the C<AS> part of the
generated SQL via the C<-as> field attribute as follows:
);
# Equivalent SQL
- # SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds
- # FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid
- # GROUP BY me.artistid, me.name, me.rank, me.charfield
- # ORDER BY amount_of_cds DESC
+ # SELECT me.artistid, me.name, me.rank, me.charfield, COUNT( cds.cdid ) AS amount_of_cds
+ # FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid
+ # GROUP BY me.artistid, me.name, me.rank, me.charfield
+ # ORDER BY amount_of_cds DESC
If your alias exists as a column in your base class (i.e. it was added with
my $count = $rs->count;
# Equivalent SQL:
- # SELECT COUNT( * ) FROM (SELECT me.name FROM artist me GROUP BY me.name) count_subq:
+ # SELECT COUNT( * ) FROM (SELECT me.name FROM artist me GROUP BY me.name) me:
=head2 Grouping results
});
my $rs = $schema->resultset('CD')->search({
- artist_id => { 'IN' => $inside_rs->get_column('id')->as_query },
+ artist_id => { -in => $inside_rs->get_column('id')->as_query },
});
-The usual operators ( =, !=, IN, NOT IN, etc.) are supported.
+The usual operators ( '=', '!=', -in, -not_in, etc.) are supported.
B<NOTE>: You have to explicitly use '=' when doing an equality comparison.
The following will B<not> work:
my $rs = $cdrs->search({
year => {
'=' => $cdrs->search(
- { artist_id => { '=' => \'me.artist_id' } },
+ { artist_id => { '=' => { -ident => 'me.artist_id' } } },
{ alias => 'inner' }
)->get_column('year')->max_rs->as_query,
},
=head2 Predefined searches
-You can write your own L<DBIx::Class::ResultSet> class by inheriting from it
-and defining often used searches as methods:
+You can define frequently used searches as methods by subclassing
+L<DBIx::Class::ResultSet>:
package My::DBIC::ResultSet::CD;
use strict;
good idea since it requires a scan of the entire table. (Unless your RDBMS
supports indexes on expressions - including return values of functions - and
you create an index on the return value of the function in question.) However,
-it can be accomplished with C<DBIx::Class> when necessary.
-
-If you do not have quoting on, simply include the function in your search
-specification as you would any column:
-
- $rs->search({ 'YEAR(date_of_birth)' => 1979 });
-
-With quoting on, or for a more portable solution, use literal SQL values with
-placeholders:
+it can be accomplished with C<DBIx::Class> when necessary by resorting to
+literal SQL:
$rs->search(\[ 'YEAR(date_of_birth) = ?', [ plain_value => 1979 ] ]);
# Equivalent SQL:
# SELECT * FROM employee WHERE YEAR(date_of_birth) = ?
- $rs->search({
+ $rs->search({ -and => [
name => 'Bob',
- -nest => \[ 'YEAR(date_of_birth) = ?', [ plain_value => 1979 ] ],
- });
+ \[ 'YEAR(date_of_birth) = ?', [ plain_value => 1979 ] ],
+ ]});
# Equivalent SQL:
# SELECT * FROM employee WHERE name = ? AND YEAR(date_of_birth) = ?
Note: the C<plain_value> string in the C<< [ plain_value => 1979 ] >> part
should be either the same as the name of the column (do this if the type of the
-return value of the function is the same as the type of the column) or
-otherwise it's essentially a dummy string currently (use C<plain_value> as a
-habit). It is used by L<DBIx::Class> to handle special column types.
+return value of the function is the same as the type of the column) or in the
+case of a function it's currently treated as a dummy string (it is a good idea
+to use C<plain_value> or something similar to convey intent). The value is
+currently only significant when handling special column types (BLOBs, arrays,
+etc.), but this may change in the future.
See also L<SQL::Abstract/Literal SQL with placeholders and bind values
(subqueries)>.
__PACKAGE__->has_many('pages' => 'Page', 'book', { where => { scrap => 0 } } );
-=head2 Many-to-many relationships
+=head2 Many-to-many relationship bridges
This is straightforward using L<ManyToMany|DBIx::Class::Relationship/many_to_many>:
=head1 TRANSACTIONS
+=head2 Transactions with txn_do
+
As of version 0.04001, there is improved transaction support in
L<DBIx::Class::Storage> and L<DBIx::Class::Schema>. Here is an
example of the recommended way to use it:
return $genus->species;
};
+ use Try::Tiny;
my $rs;
- eval {
+ try {
$rs = $schema->txn_do($coderef1);
- };
-
- if ($@) { # Transaction failed
+ } catch {
+ # Transaction failed
die "the sky is falling!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+ if ($_ =~ /Rollback failed/); # Rollback failed
deal_with_failed_transaction();
- }
+ };
+
+Note: by default C<txn_do> will re-run the coderef one more time if an
+error occurs due to client disconnection (e.g. the server is bounced).
+You need to make sure that your coderef can be invoked multiple times
+without terrible side effects.
Nested transactions will work as expected. That is, only the outermost
transaction will actually issue a commit to the $dbh, and a rollback
at any level of any transaction will cause the entire nested
transaction to fail.
-
+
=head2 Nested transactions and auto-savepoints
If savepoints are supported by your RDBMS, it is possible to achieve true
my $schema = MySchema->connect("dbi:Pg:dbname=my_db");
- # Start a transaction. Every database change from here on will only be
- # committed into the database if the eval block succeeds.
- eval {
+ # Start a transaction. Every database change from here on will only be
+ # committed into the database if the try block succeeds.
+ use Try::Tiny;
+ my $exception;
+ try {
$schema->txn_do(sub {
# SQL: BEGIN WORK;
for (1..10) {
# Start a nested transaction, which in fact sets a savepoint.
- eval {
+ try {
$schema->txn_do(sub {
# SQL: SAVEPOINT savepoint_0;
# WHERE ( id = 42 );
}
});
- };
- if ($@) {
+ } catch {
# SQL: ROLLBACK TO SAVEPOINT savepoint_0;
# There was an error while creating a $thing. Depending on the error
# changes related to the creation of this $thing
# Abort the whole job
- if ($@ =~ /horrible_problem/) {
+ if ($_ =~ /horrible_problem/) {
print "something horrible happend, aborting job!";
- die $@; # rethrow error
+ die $_; # rethrow error
}
# Ignore this $thing, report the error, and continue with the
# next $thing
- print "Cannot create thing: $@";
+ print "Cannot create thing: $_";
}
- # There was no error, so save all changes since the last
+ # There was no error, so save all changes since the last
# savepoint.
# SQL: RELEASE SAVEPOINT savepoint_0;
}
});
- };
- if ($@) {
+ } catch {
+ $exception = $_;
+ }
+
+ if ($caught) {
# There was an error while handling the $job. Rollback all changes
# since the transaction started, including the already committed
# ('released') savepoints. There will be neither a new $job nor any
# SQL: ROLLBACK;
- print "ERROR: $@\n";
+ print "ERROR: $exception\n";
}
else {
# There was no error while handling the $job. Commit all changes.
In this example it might be hard to see where the rollbacks, releases and
commits are happening, but it works just the same as for plain L<<txn_do>>: If
-the C<eval>-block around C<txn_do> fails, a rollback is issued. If the C<eval>
+the C<try>-block around C<txn_do> fails, a rollback is issued. If the C<try>
succeeds, the transaction is committed (or the savepoint released).
-While you can get more fine-grained controll using C<svp_begin>, C<svp_release>
+While you can get more fine-grained control using C<svp_begin>, C<svp_release>
and C<svp_rollback>, it is strongly recommended to use C<txn_do> with coderefs.
+=head2 Simple Transactions with DBIx::Class::Storage::TxnScopeGuard
+
+An easy way to use transactions is with
+L<DBIx::Class::Storage::TxnScopeGuard>. See L</Automatically creating
+related objects> for an example.
+
+Note that unlike txn_do, TxnScopeGuard will only make sure the connection is
+alive when issuing the C<BEGIN> statement. It will not (and really can not)
+retry if the server goes away mid-operations, unlike C<txn_do>.
+
=head1 SQL
=head2 Creating Schemas From An Existing Database
L<DBIx::Class::Schema::Loader> will connect to a database and create a
L<DBIx::Class::Schema> and associated sources by examining the database.
-The recommend way of achieving this is to use the
+The recommend way of achieving this is to use the L<dbicdump> utility or the
+L<Catalyst> helper, as described in
+L<Manual::Intro|DBIx::Class::Manual::Intro/Using DBIx::Class::Schema::Loader>.
+
+Alternatively, use the
L<make_schema_at|DBIx::Class::Schema::Loader/make_schema_at> method:
perl -MDBIx::Class::Schema::Loader=make_schema_at,dump_to_dir:./lib \
- -e 'make_schema_at("My::Schema", { debug => 1 }, [ "dbi:Pg:dbname=foo","postgres" ])'
+ -e 'make_schema_at("My::Schema", \
+ { db_schema => 'myschema', components => ["InflateColumn::DateTime"] }, \
+ [ "dbi:Pg:dbname=foo", "username", "password" ])'
-This will create a tree of files rooted at C<./lib/My/Schema/> containing
-source definitions for all the tables found in the C<foo> database.
+This will create a tree of files rooted at C<./lib/My/Schema/> containing source
+definitions for all the tables found in the C<myschema> schema in the C<foo>
+database.
=head2 Creating DDL SQL
Check the documentation of your database for the correct quote
characters to use. C<name_sep> needs to be set to allow the SQL
-generator to put the quotes the correct place.
+generator to put the quotes the correct place, and defaults to
+C<.> if not supplied.
In most cases you should set these as part of the arguments passed to
L<DBIx::Class::Schema/connect>:
return $rv;
}
-=head2 Setting limit dialect for SQL::Abstract::Limit
-
-In some cases, SQL::Abstract::Limit cannot determine the dialect of
-the remote SQL server by looking at the database handle. This is a
-common problem when using the DBD::JDBC, since the DBD-driver only
-know that in has a Java-driver available, not which JDBC driver the
-Java component has loaded. This specifically sets the limit_dialect
-to Microsoft SQL-server (See more names in SQL::Abstract::Limit
--documentation.
-
- __PACKAGE__->storage->sql_maker->limit_dialect('mssql');
-
-The JDBC bridge is one way of getting access to a MSSQL server from a platform
-that Microsoft doesn't deliver native client libraries for. (e.g. Linux)
-
-The limit dialect can also be set at connect time by specifying a
-C<limit_dialect> key in the final hash as shown above.
-
=head2 Working with PostgreSQL array types
You can also assign values to PostgreSQL array columns by passing array
placeholders and bind values (subqueries)> for more explanation. Note that
L<DBIx::Class> sets L<SQL::Abstract/bindtype> to C<columns>, so you must pass
the bind values (the C<[1, 2, 3]> arrayref in the above example) wrapped in
-arrayrefs together with the column name, like this: C<< [column_name => value]
->>.
+arrayrefs together with the column name, like this:
+C<< [column_name => value] >>.
+
+=head2 Formatting DateTime objects in queries
+
+To ensure C<WHERE> conditions containing L<DateTime> arguments are properly
+formatted to be understood by your RDBMS, you must use the C<DateTime>
+formatter returned by L<DBIx::Class::Storage::DBI/datetime_parser> to format
+any L<DateTime> objects you pass to L<search|DBIx::Class::ResultSet/search>
+conditions. Any L<Storage|DBIx::Class::Storage> object attached to your
+L<Schema|DBIx::Class::Schema> provides a correct C<DateTime> formatter, so
+all you have to do is:
+
+ my $dtf = $schema->storage->datetime_parser;
+ my $rs = $schema->resultset('users')->search(
+ {
+ signup_date => {
+ -between => [
+ $dtf->format_datetime($dt_start),
+ $dtf->format_datetime($dt_end),
+ ],
+ }
+ },
+ );
+
+Without doing this the query will contain the simple stringification of the
+C<DateTime> object, which almost never matches the RDBMS expectations.
+
+This kludge is necessary only for conditions passed to
+L<DBIx::Class::ResultSet/search>, whereas
+L<create|DBIx::Class::ResultSet/create>,
+L<find|DBIx::Class::ResultSet/find>,
+L<DBIx::Class::Row/update> (but not L<DBIx::Class::ResultSet/update>) are all
+L<DBIx::Class::InflateColumn>-aware and will do the right thing when supplied
+an inflated C<DateTime> object.
+
+=head2 Using Unicode
+
+When using unicode character data there are two alternatives -
+either your database supports unicode characters (including setting
+the utf8 flag on the returned string), or you need to encode/decode
+data appropriately each time a string field is inserted into or
+retrieved from the database. It is better to avoid
+encoding/decoding data and to use your database's own unicode
+capabilities if at all possible.
+
+The L<DBIx::Class::UTF8Columns> component handles storing selected
+unicode columns in a database that does not directly support
+unicode. If used with a database that does correctly handle unicode
+then strange and unexpected data corrupt B<will> occur.
+
+The Catalyst Wiki Unicode page at
+L<http://wiki.catalystframework.org/wiki/tutorialsandhowtos/using_unicode>
+has additional information on the use of Unicode with Catalyst and
+DBIx::Class.
+
+The following databases do correctly handle unicode data:-
+
+=head3 MySQL
+
+MySQL supports unicode, and will correctly flag utf8 data from the
+database if the C<mysql_enable_utf8> is set in the connect options.
+
+ my $schema = My::Schema->connection('dbi:mysql:dbname=test',
+ $user, $pass,
+ { mysql_enable_utf8 => 1} );
+
+
+When set, a data retrieved from a textual column type (char,
+varchar, etc) will have the UTF-8 flag turned on if necessary. This
+enables character semantics on that string. You will also need to
+ensure that your database / table / column is configured to use
+UTF8. See Chapter 10 of the mysql manual for details.
+
+See L<DBD::mysql> for further details.
+
+=head3 Oracle
+
+Information about Oracle support for unicode can be found in
+L<DBD::Oracle/Unicode>.
+
+=head3 PostgreSQL
+
+PostgreSQL supports unicode if the character set is correctly set
+at database creation time. Additionally the C<pg_enable_utf8>
+should be set to ensure unicode data is correctly marked.
+
+ my $schema = My::Schema->connection('dbi:Pg:dbname=test',
+ $user, $pass,
+ { pg_enable_utf8 => 1} );
+
+Further information can be found in L<DBD::Pg>.
+
+=head3 SQLite
+
+SQLite version 3 and above natively use unicode internally. To
+correctly mark unicode strings taken from the database, the
+C<sqlite_unicode> flag should be set at connect time (in versions
+of L<DBD::SQLite> prior to 1.27 this attribute was named
+C<unicode>).
+
+ my $schema = My::Schema->connection('dbi:SQLite:/tmp/test.db',
+ '', '',
+ { sqlite_unicode => 1} );
=head1 BOOTSTRAPPING/MIGRATING
=head2 Easy migration from class-based to schema-based setup
You want to start using the schema-based approach to L<DBIx::Class>
-(see L<SchemaIntro.pod>), but have an established class-based setup with lots
-of existing classes that you don't want to move by hand. Try this nifty script
-instead:
+(see L<DBIx::Class::Manual::Intro/Setting it up manually>), but have an
+established class-based setup with lots of existing classes that you don't
+want to move by hand. Try this nifty script instead:
use MyDB;
use SQL::Translator;
For example, say that you have three columns, C<id>, C<number>, and
C<squared>. You would like to make changes to C<number> and have
C<squared> be automagically set to the value of C<number> squared.
-You can accomplish this by overriding C<store_column>:
+You can accomplish this by wrapping the C<number> accessor with
+L<Class::Method::Modifiers>:
+
+ around number => sub {
+ my ($orig, $self) = (shift, shift);
- sub store_column {
- my ( $self, $name, $value ) = @_;
- if ($name eq 'number') {
- $self->squared($value * $value);
+ if (@_) {
+ my $value = $_[0];
+ $self->squared( $value * $value );
}
- $self->next::method($name, $value);
+
+ $self->$orig(@_);
}
-Note that the hard work is done by the call to C<next::method>, which
+Note that the hard work is done by the call to C<< $self->$orig >>, which
redispatches your call to store_column in the superclass(es).
+Generally, if this is a calculation your database can easily do, try
+and avoid storing the calculated value, it is safer to calculate when
+needed, than rely on the data being in sync.
+
=head2 Automatically creating related objects
You might have a class C<Artist> which has many C<CD>s. Further, you
sub insert {
my ( $self, @args ) = @_;
$self->next::method(@args);
- $self->cds->new({})->fill_from_artist($self)->insert;
+ $self->create_related ('cds', \%initial_cd_data );
return $self;
}
-where C<fill_from_artist> is a method you specify in C<CD> which sets
-values in C<CD> based on the data in the C<Artist> object you pass in.
+If you want to wrap the two inserts in a transaction (for consistency,
+an excellent idea), you can use the awesome
+L<DBIx::Class::Storage::TxnScopeGuard>:
+
+ sub insert {
+ my ( $self, @args ) = @_;
+
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
+ $self->next::method(@args);
+ $self->create_related ('cds', \%initial_cd_data );
+
+ $guard->commit;
+
+ return $self
+ }
+
=head2 Wrapping/overloading a column accessor
sub query_start {
my $self = shift();
my $sql = shift();
- my $params = @_;
+ my @params = @_;
$self->print("Executing $sql: ".join(', ', @params)."\n");
$start = time();
statement and dig down to see if certain parameters cause aberrant behavior.
You might want to check out L<DBIx::Class::QueryLog> as well.
+=head1 IMPROVING PERFORMANCE
+
+=over
+
+=item *
+
+Install L<Class::XSAccessor> to speed up L<Class::Accessor::Grouped>.
+
+=item *
+
+On Perl 5.8 install L<Class::C3::XS>.
+
+=item *
+
+L<prefetch|DBIx::Class::ResultSet/prefetch> relationships, where possible. See
+L</Using joins and prefetch>.
+
+=item *
+
+Use L<populate|DBIx::Class::ResultSet/populate> in void context to insert data
+when you don't need the resulting L<DBIx::Class::Row> objects, if possible, but
+see the caveats.
+
+When inserting many rows, for best results, populate a large number of rows at a
+time, but not so large that the table is locked for an unacceptably long time.
+
+If using L<create|DBIx::Class::ResultSet/create> instead, use a transaction and
+commit every C<X> rows; where C<X> gives you the best performance without
+locking the table for too long.
+
+=item *
+
+When selecting many rows, if you don't need full-blown L<DBIx::Class::Row>
+objects, consider using L<DBIx::Class::ResultClass::HashRefInflator>.
+
+=item *
+
+See also L</STARTUP SPEED> and L</MEMORY USAGE> in this document.
+
+=back
+
=head1 STARTUP SPEED
L<DBIx::Class|DBIx::Class> programs can have a significant startup delay
=item L<DBIx::Class::Manual> - User's Manual overview.
-=item L<DBIx::Class::Manual::FAQ> - Frequently Asked Questions, gathered from IRC and the mailing list.
-
=item L<DBIx::Class::Manual::Intro> - Introduction to setting up and using DBIx::Class.
=item L<DBIx::Class::Manual::Example> - Full example Schema.
+=item L<DBIx::Class::Manual::SQLHackers::TOC> - How to use DBIx::Class if you know SQL (external, available on CPAN)
+
+=item L<DBIx::Class::Manual::Glossary> - What do all those terms mean?
+
=item L<DBIx::Class::Manual::Cookbook> - Various short recipes on how to do things.
+=item L<DBIx::Class::Manual::FAQ> - Frequently Asked Questions, gathered from IRC and the mailing list.
+
=item L<DBIx::Class::Manual::Troubleshooting> - What to do if things go wrong (diagnostics of known error messages).
=item L<DBIx::Class::Manual::Component> - How to write your own DBIx::Class components.
-=item L<DBIx::Class::Manual::Glossary> - What do all those terms mean?
-
=back
=head1 Setting up
insertdb.pl
- #!/usr/bin/perl -w
+ #!/usr/bin/perl
- use MyDatabase::Main;
use strict;
+ use warnings;
+
+ use MyDatabase::Main;
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
testdb.pl:
- #!/usr/bin/perl -w
+ #!/usr/bin/perl
- use MyDatabase::Main;
use strict;
+ use warnings;
+
+ use MyDatabase::Main;
my $schema = MyDatabase::Main->connect('dbi:SQLite:db/example.db');
# for other DSNs, e.g. MySQL, see the perldoc for the relevant dbd
=item .. create a database to use?
-First, choose a database. For testing/experimenting, we reccommend
+First, choose a database. For testing/experimenting, we recommend
L<DBD::SQLite>, which is a self-contained small database (i.e. all you
-need to do is to install L<DBD::SQLite> from CPAN, and it's usable).
+need to do is to install L<DBD::SQLite> from CPAN, and it works).
Next, spend some time defining which data you need to store, and how
it relates to the other data you have. For some help on normalisation,
L<DBIx::Class::Schema/deploy>. See there for details, or the
L<DBIx::Class::Manual::Cookbook>.
+=item .. store/retrieve Unicode data in my database?
+
+Make sure you database supports Unicode and set the connect
+attributes appropriately - see
+L<DBIx::Class::Manual::Cookbook/Using Unicode>
+
=item .. connect to my database?
Once you have created all the appropriate table/source classes, and an
Add the name of the schema to the L<DBIx::Class::ResultSource/table>
as part of the name, and make sure you give the one user you are going
-to connect with rights to read/write all the schemas/tables as
+to connect with has permissions to read/write all the schemas/tables as
necessary.
=back
the tables are to be joined. The condition may contain as many fields
as you like. See L<DBIx::Class::Relationship::Base>.
-=item .. define a relatiopnship across an intermediate table? (many-to-many)
+=item .. define a relationship bridge across an intermediate table? (many-to-many)
-Read the documentation on L<DBIx::Class::Relationship/many_to_many>.
+The term 'relationship' is used loosely with many_to_many as it is not considered a
+relationship in the fullest sense. For more info, read the documentation on L<DBIx::Class::Relationship/many_to_many>.
=item .. stop DBIx::Class from attempting to cascade deletes on my has_many and might_have relationships?
=item .. search for data?
-Create a C<$schema> object, as mentioned above in ".. connect to my
-database". Find the L<ResultSet|DBIx::Class::Manual::Glossary/ResultSet>
-that you want to search in, and call C<search> on it. See
-L<DBIx::Class::ResultSet/search>.
+Create a C<$schema> object, as mentioned above in L</.. connect to my
+database?>. Find the
+L<ResultSet|DBIx::Class::Manual::Glossary/ResultSet> that you want to
+search in, by calling C<< $schema->resultset('MySource') >> and call
+C<search> on it. See L<DBIx::Class::ResultSet/search>.
=item .. search using database functions?
=item .. sort my results based on fields I've aliased using C<as>?
-You don't. You'll need to supply the same functions/expressions to
-C<order_by>, as you did to C<select>.
-
-To get "fieldname AS alias" in your SQL, you'll need to supply a
-literal chunk of SQL in your C<select> attribute, such as:
-
- ->search({}, { select => [ \'now() AS currenttime'] })
-
-Then you can use the alias in your C<order_by> attribute.
+You didn't alias anything, since L<as|DBIx::Class::ResultSet/as>
+B<has nothing to do> with the produced SQL. See
+L<DBIx::Class::ResultSet/select> for details.
=item .. group the results of my search?
=item .. group my results based on fields I've aliased using C<as>?
-You don't. You'll need to supply the same functions/expressions to
-C<group_by>, as you did to C<select>.
-
-To get "fieldname AS alias" in your SQL, you'll need to supply a
-literal chunk of SQL in your C<select> attribute, such as:
-
- ->search({}, { select => [ \'now() AS currenttime'] })
-
-Then you can use the alias in your C<group_by> attribute.
+You don't. See the explanation on ordering by an alias above.
=item .. filter the results of my search?
=item .. search with an SQL function on the left hand side?
-To use an SQL function on the left hand side of a comparison:
+To use an SQL function on the left hand side of a comparison you currently need
+to resort to literal SQL:
- ->search({ -nest => \[ 'YEAR(date_of_birth) = ?', [ plain_value => 1979 ] ] });
+ ->search( \[ 'YEAR(date_of_birth) = ?', [ plain_value => 1979 ] ] );
Note: the C<plain_value> string in the C<< [ plain_value => 1979 ] >> part
should be either the same as the name of the column (do this if the type of the
-return value of the function is the same as the type of the column) or
-otherwise it's essentially a dummy string currently (use C<plain_value> as a
-habit). It is used by L<DBIx::Class> to handle special column types.
-
-Or, if you have quoting off:
-
- ->search({ 'YEAR(date_of_birth)' => 1979 });
+return value of the function is the same as the type of the column) or in the
+case of a function it's currently treated as a dummy string (it is a good idea
+to use C<plain_value> or something similar to convey intent). The value is
+currently only significant when handling special column types (BLOBs, arrays,
+etc.), but this may change in the future.
=item .. find more help on constructing searches?
Then, in the same class, implement a subroutine called "my_column" that
fetches the real value and does the formatting you want.
-See the Cookbook for more details.
+See the L<Cookbook|DBIx::Class::Manual::Cookbook> for more details.
=item .. fetch a single (or topmost) row?
-See L<DBIx::Class::Manual::Cookbook/Retrieve_one_and_only_one_row_from_a_resultset>.
+Use the L<DBIx::Class::ResultSet/rows> and
+L<DBIx::Class::ResultSet/order_by> attributes to order your data and
+pick off a single row.
+
+See also L<DBIx::Class::Manual::Cookbook/Retrieve one and only one row from a resultset>.
A less readable way is to ask a regular search to return 1 row, using
L<DBIx::Class::ResultSet/slice>:
=item .. refresh a row from storage?
-Use L<DBIx::Class::PK/discard_changes>.
+Use L<DBIx::Class::Row/discard_changes>.
$row->discard_changes
Discarding changes and refreshing from storage are two sides fo the same coin. When you
want to discard your local changes, just re-fetch the row from storage. When you want
to get a new, fresh copy of the row, just re-fetch the row from storage.
-L<DBIx::Class::PK/discard_changes> does just that by re-fetching the row from storage
+L<DBIx::Class::Row/discard_changes> does just that by re-fetching the row from storage
using the row's primary key.
=item .. fetch my data a "page" at a time?
=item .. insert a row with an auto incrementing primary key?
-In versions of L<DBIx::Class> less than 0.07, you need to ensure your
-table class loads the L<PK::Auto|DBIx::Class::PK::Auto>
-component. This will attempt to fetch the value of your primary key
-from the database after the insert has happened, and store it in the
-created object. In versions 0.07 and above, this component is
-automatically loaded.
+This happens automatically. After
+L<creating|DBIx::Class::ResultSet/create> a row object, the primary
+key value created by your database can be fetched by calling C<id> (or
+the access of your primary key column) on the object.
=item .. insert a row with a primary key that uses a sequence?
You need to create a trigger in your database that updates your
-primary key field from the sequence. To help PK::Auto find your
-inserted key, you can tell it the name of the sequence in the
+primary key field from the sequence. To help PK::Auto find the next
+key value, you can tell it the name of the sequence in the
C<column_info> supplied with C<add_columns>.
->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
The C<populate> method in L<DBIx::Class::ResultSet> provides
efficient bulk inserts.
+L<DBIx::Class::Fixtures> provides an alternative way to do this.
+
=item .. update a collection of rows at the same time?
-Create a resultset using a search, to filter the rows of data you
-would like to update, then call update on the resultset to change all
+Create a resultset using a C<search>, to filter the rows of data you
+would like to update, then call C<update> on the resultset to change all
the rows at once.
=item .. use database functions when updating rows?
=item .. update a column using data from another column?
-To stop the column name from being quoted, you'll need to supply a
-scalar reference:
+To stop the column name from being quoted, you'll need to tell DBIC
+that the right hand side is an SQL identifier (it will be quoted
+properly if you have quoting enabled):
+
+ ->update({ somecolumn => { -ident => 'othercolumn' } })
- ->update({ somecolumn => \'othercolumn' })
+This method will not retrieve the new value and put it in your Row
+object. To fetch the new value, use the C<discard_changes> method on
+the Row.
-But note that when using a scalar reference the column in the database
-will be updated but when you read the value from the object with e.g.
+ # will return the scalar reference:
+ $row->somecolumn()
- ->somecolumn()
+ # issue a select using the PK to re-fetch the row data:
+ $row->discard_changes();
-you still get back the scalar reference to the string, B<not> the new
-value in the database. To get that you must refresh the row from storage
-using C<discard_changes()>. Or chain your function calls like this:
+ # Now returns the correct new value:
+ $row->somecolumn()
- ->update->discard_changes
+To update and refresh at once, chain your calls:
-to update the database and refresh the object in one step.
+ $row->update({ 'somecolumn' => { -ident => 'othercolumn' } })->discard_changes;
=item .. store JSON/YAML in a column and have it deflate/inflate automatically?
=head2 Custom methods in Result classes
-You can add custom methods that do arbitrary things, even to unrelated tables.
-For example, to provide a C<< $book->foo() >> method which searches the
+You can add custom methods that do arbitrary things, even to unrelated tables.
+For example, to provide a C<< $book->foo() >> method which searches the
cd table, you'd could add this to Book.pm:
sub foo {
write your own methods, you can.
For example, to provide a C<< $book->foo() >> method to manually implement
-what create_related() from L<DBIx::Class::Relationship::Base> does, you could
+what create_related() from L<DBIx::Class::Relationship::Base> does, you could
add this to Book.pm:
sub foo {
=item How do I store my own (non-db) data in my DBIx::Class objects?
-You can add your own data accessors to your classes.
+You can add your own data accessors to your Result classes.
One method is to use the built in mk_group_accessors (via L<Class::Accessor::Grouped>)
- package MyTable;
+ package App::Schema::Result::MyTable;
- use parent 'DBIx::Class';
+ use parent 'DBIx::Class::Core';
__PACKAGE__->table('foo'); #etc
__PACKAGE__->mk_group_accessors('simple' => qw/non_column_data/); # must use simple group
An another method is to use L<Moose> with your L<DBIx::Class> package.
- package MyTable;
+ package App::Schema::Result::MyTable;
use Moose; # import Moose
use Moose::Util::TypeConstraint; # import Moose accessor type constraints
- extends 'DBIx::Class'; # Moose changes the way we define our parent (base) package
+ extends 'DBIx::Class::Core'; # Moose changes the way we define our parent (base) package
has 'non_column_data' => ( is => 'rw', isa => 'Str' ); # define a simple attribute
calling methods in list context. When calling relationship accessors
you will not get resultsets, but a list of all the related objects.
-Starting with version 0.07, you can use L<DBIx::Class::ResultSet/search_rs>
-to work around this issue.
+Use the L<DBIx::Class::ResultSet/search_rs> method, or the
+relationship accessor methods ending with "_rs" to work around this
+issue.
+
+See also L<DBIx::Class::Relationship/has_many>.
=item See the SQL statements my code is producing?
-Turn on debugging! See L<DBIx::Class::Storage> for details of how
+Set the shell environment variable C<DBIC_TRACE> to a true value.
+
+For more info see L<DBIx::Class::Storage> for details of how
to turn on debugging in the environment, pass your own filehandle to
save debug to, or create your own callback.
package Your::Schema::Group;
use Class::Method::Modifiers;
-
+
# ... declare columns ...
-
+
__PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
__PACKAGE__->many_to_many('servers', 'group_servers', 'server');
-
+
# if the server group is a "super group", then return all servers
# otherwise return only servers that belongs to the given group
around 'servers' => sub {
package Your::Schema::Group;
use Method::Signatures::Simple;
-
+
# ... declare columns ...
-
+
__PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
__PACKAGE__->many_to_many('servers', 'group_servers', 'server');
-
+
# The method keyword automatically injects the annoying my $self = shift; for you.
method servers {
return $self->result_source->schema->resultset('Server')->search({ ... });
package Your::Schema::Group;
use Sub::Name;
-
+
# ... declare columns ...
-
+
__PACKAGE__->has_many('group_servers', 'Your::Schema::GroupServer', 'group_id');
__PACKAGE__->many_to_many('servers', 'group_servers', 'server');
-
+
*servers = subname servers => sub {
my $self = shift;
return $self->result_source->schema->resultset('Server')->search({ ... });
};
-
+
=back
=head2 Notes for CDBI users
--- /dev/null
+=head1 NAME
+
+DBIx::Class::Manual::Features - A boatload of DBIx::Class features with links to respective documentation
+
+=head1 META
+
+=head2 Large Community
+
+Currently there are 88 people listed as contributors to DBIC. That ranges
+from documentation help, to test help, to added features, to entire database
+support.
+
+=head2 Active Community
+
+Currently (June 9, 2010) 6 active branches (committed to
+in the last two weeks) in git. Last release (0.08122)
+had 14 new features, and 16 bug fixes. Of course that
+L<ebbs and flows|http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=blob;f=Changes>.)
+
+=head2 Responsive Community
+
+=over 1
+
+=item I needed MSSQL order-by support; the community helped me add support
+
+=item generally very welcoming of people willing to help
+
+=back
+
+=head1 General ORM
+
+These are things that are in most other ORMs, but are still reasons to use
+DBIC over raw SQL.
+
+=head2 Cross DB
+
+The vast majority of code should run on all databases without needing tweaking
+
+=head2 Basic CRUD
+
+=over 1
+
+=item C - Create
+
+=item R - Retrieve
+
+=item U - Update
+
+=item D - Delete
+
+=back
+
+=head2 SQL: Create
+
+ my $sth = $dbh->prepare('
+ INSERT INTO books
+ (title, author_id)
+ values (?,?)
+ ');
+
+ $sth->execute( 'A book title', $author_id );
+
+=head2 DBIC: Create
+
+ my $book = $book_rs->create({
+ title => 'A book title',
+ author_id => $author_id,
+ });
+
+See L<DBIx::Class::ResultSet/create>
+
+=over 1
+
+=item No need to pair placeholders and values
+
+=item Automatically gets autoincremented id for you
+
+=item Transparently uses INSERT ... RETURNING for databases that support it
+
+=back
+
+=head2 SQL: Read
+
+ my $sth = $dbh->prepare('
+ SELECT title,
+ authors.name as author_name
+ FROM books, authors
+ WHERE books.author = authors.id
+ ');
+
+ while ( my $book = $sth->fetchrow_hashref ) {
+ say "Author of $book->{title} is $book->{author_name}";
+ }
+
+=head2 DBIC: Read
+
+ my $book = $book_rs->find($book_id);
+
+or
+
+ my $book = $book_rs->search({ title => 'A book title' }, { rows => 1 })->next;
+
+or
+
+ my @books = $book_rs->search({ author => $author_id })->all;
+
+or
+
+ while( my $book = $books_rs->next ) {
+ printf "Author of %s is %s\n", $book->title, $book->author->name;
+ }
+
+See L<DBIx::Class::ResultSet/find>, L<DBIx::Class::ResultSet/search>, L<DBIx::Class::ResultSet/next>, and L<DBIx::Class::ResultSet/all>
+
+B<TMTOWTDI!>
+
+=head2 SQL: Update
+
+ my $update = $dbh->prepare('
+ UPDATE books
+ SET title = ?
+ WHERE id = ?
+ ');
+
+ $update->execute( 'New title', $book_id );
+
+=head2 DBIC: Update
+
+ $book->update({ title => 'New title' });
+
+See L<DBIx::Class::Row/update>
+
+Will not update unless value changes
+
+=head2 SQL: Delete
+
+ my $delete = $dbh->prepare('DELETE FROM books WHERE id = ?');
+
+ $delete->execute($book_id);
+
+=head2 DBIC: Delete
+
+ $book->delete
+
+See L<DBIx::Class::Row/delete>
+
+=head2 SQL: Search
+
+ my $sth = $dbh->prepare('
+ SELECT title,
+ authors.name as author_name
+ FROM books
+ WHERE books.name LIKE "%monte cristo%" AND
+ books.topic = "jailbreak"
+ ');
+
+=head2 DBIC: Search
+
+ my $book = $book_rs->search({
+ 'me.name' => { -like => '%monte cristo%' },
+ 'me.topic' => 'jailbreak',
+ })->next;
+
+=over 1
+
+=item See L<SQL::Abstract>, L<DBIx::Class::ResultSet/next>, and L<DBIx::Class::ResultSet/search>
+
+=item (kinda) introspectible
+
+=item Prettier than SQL
+
+=back
+
+=head2 OO Overridability
+
+=over 1
+
+=item Override new if you want to do validation
+
+=item Override delete if you want to disable deletion
+
+=item and on and on
+
+=back
+
+=head2 Convenience Methods
+
+=over 1
+
+=item L<DBIx::Class::ResultSet/find_or_create>
+
+=item L<DBIx::Class::ResultSet/update_or_create>
+
+=back
+
+=head2 Non-column methods
+
+Need a method to get a user's gravatar URL? Add a C<gravatar_url> method to the
+Result class
+
+=head2 RELATIONSHIPS
+
+=over 1
+
+=item L<DBIx::Class::Relationship/belongs_to>
+
+=item L<DBIx::Class::Relationship/has_many>
+
+=item L<DBIx::Class::Relationship/might_have>
+
+=item L<DBIx::Class::Relationship/has_one>
+
+=item L<DBIx::Class::Relationship/many_to_many>
+
+=item SET AND FORGET
+
+=back
+
+=head1 DBIx::Class Specific Features
+
+These things may be in other ORM's, but they are very specific, so doubtful
+
+=head2 ->deploy
+
+Create a database from your DBIx::Class schema.
+
+ my $schema = Frew::Schema->connect( $dsn, $user, $pass );
+
+ $schema->deploy
+
+See L<DBIx::Class::Schema/deploy>.
+
+See also: L<DBIx::Class::DeploymentHandler>
+
+=head2 Schema::Loader
+
+Create a DBIx::Class schema from your database.
+
+ package Frew::Schema;
+
+ use strict;
+ use warnings;
+
+ use base 'DBIx::Class::Schema::Loader';
+
+ __PACKAGE__->loader_options({
+ naming => 'v7',
+ debug => $ENV{DBIC_TRACE},
+ });
+
+ 1;
+
+ # elsewhere...
+
+ my $schema = Frew::Schema->connect( $dsn, $user, $pass );
+
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base/CONSTRUCTOR OPTIONS>.
+
+=head2 Populate
+
+Made for inserting lots of rows very quicky into database
+
+ $schema->populate([ Users =>
+ [qw( username password )],
+ [qw( frew >=4char$ )],
+ [qw( ... )],
+ [qw( ... )],
+ );
+
+See L<DBIx::Class::Schema/populate>
+
+I use populate L<here|http://blog.afoolishmanifesto.com/archives/1255> to export our whole
+(200M~) db to SQLite
+
+=head2 Multicreate
+
+Create an object and it's related objects all at once
+
+ $schema->resultset('Author')->create({
+ name => 'Stephen King',
+ books => [{ title => 'The Dark Tower' }],
+ address => {
+ street => '123 Turtle Back Lane',
+ state => { abbreviation => 'ME' },
+ city => { name => 'Lowell' },
+ },
+ });
+
+See L<DBIx::Class::ResultSet/create>
+
+=over 1
+
+=item books is a has_many
+
+=item address is a belongs_to which in turn belongs to state and city each
+
+=item for this to work right state and city must mark abbreviation and name as unique
+
+=back
+
+=head2 Extensible
+
+DBIx::Class helped pioneer fast MI in Perl 5 with Class::C3, so it is made to
+allow extensions to nearly every part of it.
+
+=head2 Extensibility example: DBIx::Class::Helpers
+
+=over 1
+
+=item L<DBIx::Class::Helper::ResultSet::IgnoreWantarray>
+
+=item L<DBIx::Class::Helper::ResultSet::Random>
+
+=item L<DBIx::Class::Helper::ResultSet::SetOperations>
+
+=item L<DBIx::Class::Helper::Row::JoinTable>
+
+=item L<DBIx::Class::Helper::Row::NumifyGet>
+
+=item L<DBIx::Class::Helper::Row::SubClass>
+
+=item L<DBIx::Class::Helper::Row::ToJSON>
+
+=item L<DBIx::Class::Helper::Row::StorageValues>
+
+=item L<DBIx::Class::Helper::Row::OnColumnChange>
+
+=back
+
+=head2 Extensibility example: DBIx::Class::TimeStamp
+
+=over 1
+
+=item See L<DBIx::Class::TimeStamp>
+
+=item Cross DB
+
+=item set_on_create
+
+=item set_on_update
+
+=back
+
+=head2 Extensibility example: Kioku
+
+=over 1
+
+=item See L<DBIx::Class::Schema::KiokuDB>
+
+=item Kioku is the new hotness
+
+=item Mix RDBMS with Object DB
+
+=back
+
+=head2 Result vs ResultSet
+
+=over 1
+
+=item Result == Row
+
+=item ResultSet == Query Plan
+
+=over 1
+
+=item Internal Join Optimizer for all DB's (!!!)
+
+=back
+
+=item (less important but...)
+
+=item ResultSource == Queryable collection of rows (Table, View, etc)
+
+=item Storage == Database
+
+=item Schema == associates a set of ResultSources with a Storage
+
+=back
+
+=head2 ResultSet methods
+
+ package MyApp::Schema::ResultSet::Book;
+
+ use strict;
+ use warnings;
+
+ use base 'DBIx::Class::ResultSet';
+
+ sub good {
+ my $self = shift;
+ $self->search({
+ $self->current_source_alias . '.rating' => { '>=' => 4 }
+ })
+ };
+
+ sub cheap {
+ my $self = shift;
+ $self->search({
+ $self->current_source_alias . '.price' => { '<=' => 5}
+ })
+ };
+
+ # ...
+
+ 1;
+
+See L<DBIx::Class::Manual::Cookbook/Predefined searches>
+
+=over 1
+
+=item All searches should be ResultSet methods
+
+=item Name has obvious meaning
+
+=item L<DBIx::Class::ResultSet/current_source_alias> helps things to work no matter what
+
+=back
+
+=head2 ResultSet method in Action
+
+ $schema->resultset('Book')->good
+
+=head2 ResultSet Chaining
+
+ $schema->resultset('Book')
+ ->good
+ ->cheap
+ ->recent
+
+=head2 search_related
+
+ my $score = $schema->resultset('User')
+ ->search({'me.userid' => 'frew'})
+ ->related_resultset('access')
+ ->related_resultset('mgmt')
+ ->related_resultset('orders')
+ ->telephone
+ ->search_related( shops => {
+ 'shops.datecompleted' => {
+ -between => ['2009-10-01','2009-10-08']
+ }
+ })->completed
+ ->related_resultset('rpt_score')
+ ->search(undef, { rows => 1})
+ ->get_column('raw_scores')
+ ->next;
+
+The SQL that this produces (with placeholders filled in for clarity's sake)
+on our system (Microsoft SQL) is:
+
+ SELECT raw_scores
+ FROM (
+ SELECT raw_scores, ROW_NUMBER() OVER (
+ ORDER BY (
+ SELECT (1)
+ )
+ ) AS rno__row__index
+ FROM (
+ SELECT rpt_score.raw_scores
+ FROM users me
+ JOIN access access
+ ON access.userid = me.userid
+ JOIN mgmt mgmt
+ ON mgmt.mgmtid = access.mgmtid
+ JOIN [order] orders
+ ON orders.mgmtid = mgmt.mgmtid
+ JOIN shop shops
+ ON shops.orderno = orders.orderno
+ JOIN rpt_scores rpt_score
+ ON rpt_score.shopno = shops.shopno
+ WHERE (
+ datecompleted IS NOT NULL AND
+ (
+ (shops.datecompleted BETWEEN '2009-10-01' AND '2009-10-08') AND
+ (type = '1' AND me.userid = 'frew')
+ )
+ )
+ ) rpt_score
+ ) rpt_score
+ WHERE rno__row__index BETWEEN 1 AND 1
+
+See: L<DBIx::Class::ResultSet/related_resultset>, L<DBIx::ClassResultSet/search_related>, and L<DBIx::Class::ResultSet/get_column>.
+
+=head2 bonus rel methods
+
+ my $book = $author->create_related(
+ books => {
+ title => 'Another Discworld book',
+ }
+ );
+
+ my $book2 = $pratchett->add_to_books({
+ title => 'MOAR Discworld book',
+ });
+
+See L<DBIx::Class::Relationship::Base/create_related> and L<DBIx::Class::Relationship::Base/add_to_$rel>
+
+Note that it automatically fills in foreign key for you
+
+=head2 Excellent Transaction Support
+
+ $schema->txn_do(sub {
+ ...
+ });
+
+ $schema->txn_begin; # <-- low level
+ # ...
+ $schema->txn_commit;
+
+See L<DBIx::Class::Schema/txn_do>, L<DBIx::Class::Schema/txn_begin>,
+and L<DBIx::Class::Schema/txn_commit>.
+
+=head2 InflateColumn
+
+ package Frew::Schema::Result::Book;
+
+ use strict;
+ use warnings;
+
+ use base 'DBIx::Class::Core';
+
+ use DateTime::Format::MySQL;
+
+ # Result code here
+
+ __PACKAGE__->load_components('InflateColumn');
+
+ __PACKAGE__->inflate_column(
+ date_published => {
+ inflate => sub { DateTime::Format::MySQL->parse_date( shift ) },
+ deflate => sub { shift->ymd },
+ },
+ );
+
+See L<DBIx::Class::InflateColumn>, L<DBIx::Class::InflateColumn/inflate_column>, and
+L<DBIx::Class::InflateColumn::DateTime>.
+
+=head2 InflateColumn: deflation
+
+ $book->date_published(DateTime->now);
+ $book->update;
+
+=head2 InflateColumn: inflation
+
+ say $book->date_published->month_abbr; # Nov
+
+=head2 FilterColumn
+
+ package Frew::Schema::Result::Book;
+
+ use strict;
+ use warnings;
+
+ use base 'DBIx::Class::Core';
+
+ # Result code here
+
+ __PACKAGE__->load_components('FilterColumn');
+
+ __PACKAGE__->filter_column(
+ length => {
+ to_storage => 'to_metric',
+ from_storage => 'to_imperial',
+ },
+ );
+
+ sub to_metric { $_[1] * .305 }
+ sub to_imperial { $_[1] * 3.28 }
+
+See L<DBIx::Class::FilterColumn> and L<DBIx::Class::FilterColumn/filter_column>
+
+=head2 ResultSetColumn
+
+ my $rsc = $schema->resultset('Book')->get_column('price');
+ $rsc->first;
+ $rsc->all;
+ $rsc->min;
+ $rsc->max;
+ $rsc->sum;
+
+See L<DBIx::Class::ResultSetColumn>
+
+=head2 Aggregates
+
+ my @res = $rs->search(undef, {
+ select => [
+ 'price',
+ 'genre',
+ { max => price },
+ { avg => price },
+ ],
+ as => [
+ qw(price genre max_price avg_price)
+ ],
+ group_by => [qw(price genre)],
+ });
+ for (@res) {
+ say $_->price . ' ' . $_->genre;
+ say $_->get_column('max_price');
+ say $_->get_column('avg_price');
+ }
+
+See L<DBIx::Class::ResultSet/select>, L<DBIx::Class::ResultSet/as>, and
+L<DBIx::Class::ResultSet/group_by>
+
+=over 1
+
+=item Careful, get_column can basicaly mean B<three> things
+
+=item private in which case you should use an accessor
+
+=item public for what there is no accessor for
+
+=item public for get resultset column (prev example)
+
+=back
+
+=head2 HRI
+
+ $rs->search(undef, {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ });
+
+See L<DBIx::Class::ResultSet/result_class> and L<DBIx::Class::ResultClass::HashRefInflator>.
+
+=over 1
+
+=item Easy on memory
+
+=item Mega fast
+
+=item Great for quick debugging
+
+=item Great for performance tuning (we went from 2m to < 3s)
+
+=back
+
+=head2 Subquery Support
+
+ my $inner_query = $schema->resultset('Artist')
+ ->search({
+ name => [ 'Billy Joel', 'Brittany Spears' ],
+ })->get_column('id')->as_query;
+
+ my $rs = $schema->resultset('CD')->search({
+ artist_id => { -in => $inner_query },
+ });
+
+See L<DBIx::Class::Manual::Cookbook/Subqueries>
+
+=head2 Bare SQL w/ Placeholders
+
+ $rs->update({
+ # !!! SQL INJECTION VECTOR
+ price => \"price + $inc", # DON'T DO THIS
+ });
+
+Better:
+
+ $rs->update({
+ price => \['price + ?', [inc => $inc]],
+ });
+
+See L<SQL::Abstract/Literal_SQL_with_placeholders_and_bind_values_(subqueries)>
+
This document lists various terms used in DBIx::Class and attempts to
explain them.
-=head1 TERMS
+=head1 DBIx::Class TERMS
=head2 DB schema
=head2 Inflation
The act of turning database row data into objects in
-language-space. DBIx::Class further allows you to inflate your data
-into perl objects which more usefully represent their contents. For
-example: L<DBIx::Class::InflateColumn::DateTime> for datetime or
-timestamp column data.
+language-space. DBIx::Class result classes can be set up to inflate
+your data into perl objects which more usefully represent their
+contents. For example: L<DBIx::Class::InflateColumn::DateTime> for
+datetime or timestamp column data.
-=head2 Join
+See also L<DBIx::Class::InflateColumn>.
-This is an SQL keyword that gets mentioned a lot. It is used to fetch
-data from more than one table at once, by C<join>ing the tables on
-fields where they have common data.
+=head2 Deflation
-=head2 Normalisation
+The opposite of L</Inflation>. Existing perl objects that represent
+column values can be passed to DBIx::Class methods to store into the
+database. For example a L<DateTime> object can be automatically
+deflated into a datetime string for insertion.
-A normalised database is a sane database. Each table contains only
-data belonging to one concept, related tables refer to the key field
-or fields of each other. Some links to webpages about normalisation
-can be found in L<DBIx::Class::Manual::FAQ|the FAQ>.
+See L<DBIx::Class::InflateColumn> and other modules in that namespace.
=head2 ORM
A relationship bridge, such as C<many_to_many> defines an accessor to
retrieve row contents across multiple relationships.
-=head2 ResultSet
+The difference between a bridge and a relationship is, that the bridge
+cannot be used to C<join> tables in a C<search>, instead its component
+relationships must be used.
-This is an object representing a set of data. It can either be an
-entire table, or the results of a query. The actual data is not held
-in the ResultSet, it is only a description of how to fetch the data.
+=head2 Schema
-See also: L<DBIx::Class::ResultSet/METHODS>
+A Schema object represents your entire table collection, plus the
+connection to the database. You can create one or more schema objects,
+connected to various databases, with various users, using the same set
+of table L</Result class> definitions.
+
+At least one L<DBIx::Class::Schema> class is needed per database.
+
+=head2 Result class
+
+A Result class defines both a source of data (usually one per table),
+and the methods that will be available in the L</Row> objects created
+using that source.
+
+One Result class is needed per data source (table, view, query) used
+in your application, they should inherit from L<DBIx::Class::Core>.
=head2 ResultSource
-ResultSource objects represent the source of your data, they are also known as
-a table objects.
+ResultSource objects represent the source of your data, these are
+sometimes (incorrectly) called table objects.
+
+ResultSources do not need to be directly created, a ResultSource
+instance is created for each L</Result class> in your L</Schema>, by
+the proxied methods C<table> and C<add_columns>.
See also: L<DBIx::Class::ResultSource/METHODS>
+=head2 ResultSet
+
+This is an object representing a set of conditions to filter data. It
+can either be an entire table, or the results of a query. The actual
+data is not held in the ResultSet, it is only a description of how to
+fetch the data.
+
+See also: L<DBIx::Class::ResultSet/METHODS>
+
=head2 Record
See Row.
See Row.
-=head2 Schema
+=head2 join
-A Schema object represents your entire table collection, plus the
-connection to the database. You can create one or more schema objects,
-connected to various databases, with various users, using the same set
-of table (ResultSource) definitions.
+=head2 prefetch
+
+
+=head1 SQL TERMS
+
+=head2 Join
+
+This is an SQL keyword, it is used to link multiple tables in one SQL
+statement. This enables us to fetch data from more than one table at
+once, or filter data based on content in another table, without having
+to issue multiple SQL queries.
+
+=head2 Normalisation
+
+A normalised database is a sane database. Each table contains only
+data belonging to one concept, related tables refer to the key field
+or fields of each other. Some links to webpages about normalisation
+can be found in L<DBIx::Class::Manual::FAQ|the FAQ>.
+
+=head2 Related data
+
+In SQL, related data actually refers to data that are normalised into
+the same table. (Yes. DBIC does mis-use this term).
Let's look at how you can set and use your first native L<DBIx::Class> tree.
First we'll see how you can set up your classes yourself. If you want them to
-be auto-discovered, just skip to the next section, which shows you how to use
+be auto-discovered, just skip to the L<next section|/Using
+DBIx::Class::Schema::Loader>, which shows you how to use
L<DBIx::Class::Schema::Loader>.
=head2 Setting it up manually
__PACKAGE__->load_components(qw/ Ordered /);
__PACKAGE__->position_column('rank');
+Ordered will refer to a field called 'position' unless otherwise directed. Here you are defining
+the ordering field to be named 'rank'. (NOTE: Insert errors may occur if you use the Ordered
+component, but have not defined a position column or have a 'position' field in your row.)
+
Set the table for your class:
__PACKAGE__->table('album');
See L<DBIx::Class::Relationship> for more information about the various types of
available relationships and how you can design your own.
-=head2 Using L<DBIx::Class::Schema::Loader>
+=head2 Using DBIx::Class::Schema::Loader
-This is an external module, and not part of the L<DBIx::Class> distribution.
-Like L<Class::DBI::Loader>, it inspects your database, and automatically creates
-classes for all the tables in your database. Here's a simple setup:
+This module (L<DBIx::Class::Schema::Loader>) is an external module, and not part
+of the L<DBIx::Class> distribution. It inspects your database, and automatically
+creates classes for all the tables in your schema.
- package My::Schema;
- use base qw/DBIx::Class::Schema::Loader/;
+The simplest way to use it is via the L<dbicdump> script from the
+L<DBIx::Class::Schema::Loader> distribution. For example:
+
+ $ dbicdump -o dump_directory=./lib \
+ -o components='["InflateColumn::DateTime"]' \
+ MyApp::Schema dbi:mysql:mydb user pass
- __PACKAGE__->loader_options( relationships => 1 );
+If you have a mixed-case database, use the C<preserve_case> option, e.g.:
- 1;
+ $ dbicdump -o dump_directory=./lib -o preserve_case=1 \
+ -o components='["InflateColumn::DateTime"]' \
+ MyApp::Schema dbi:mysql:mydb user pass
-The actual autoloading process will occur when you create a connected instance
-of your schema below.
+If you are using L<Catalyst>, then you can use the helper that comes with
+L<Catalyst::Model::DBIC::Schema>:
-See the L<DBIx::Class::Schema::Loader> documentation for more information on its
-many options.
+ $ script/myapp_create.pl model MyDB DBIC::Schema MyDB::Schema \
+ create=static moniker_map='{ foo => "FOO" }' dbi:SQLite:./myapp.db \
+ on_connect_do='PRAGMA foreign_keys=ON' quote_char='"'
+
+See L<Catalyst::Helper::Model::DBIC::Schema> for more information on this
+helper.
+
+See the L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>
+documentation for more information on the many loader options.
=head2 Connecting
{ on_connect_do => \@on_connect_sql_statments }
);
-See L<DBIx::Class::Schema::Storage::DBI/connect_info> for more information about
+See L<DBIx::Class::Storage::DBI/connect_info> for more information about
this and other special C<connect>-time options.
=head3 Via a database handle
=head1 NOTES
+=head2 The Significance and Importance of Primary Keys
+
+The concept of a L<primary key|DBIx::Class::ResultSource/set_primary_key> in
+DBIx::Class warrants special discussion. The formal definition (which somewhat
+resembles that of a classic RDBMS) is I<a unique constraint that is least
+likely to change after initial row creation>. However this is where the
+similarity ends. Any time you call a CRUD operation on a row (e.g.
+L<delete|DBIx::Class::Row/delete>,
+L<update|DBIx::Class::Row/update>,
+L<discard_changes|DBIx::Class::Row/discard_changes>,
+etc.) DBIx::Class will use the values of of the
+L<primary key|DBIx::Class::ResultSource/set_primary_key> columns to populate
+the C<WHERE> clause necessary to accomplish the operation. This is why it is
+important to declare a L<primary key|DBIx::Class::ResultSource/set_primary_key>
+on all your result sources B<even if the underlying RDBMS does not have one>.
+In a pinch one can always declare each row identifiable by all its columns:
+
+ __PACKAGE__->set_primary_keys (__PACKAGE__->columns);
+
+Note that DBIx::Class is smart enough to store a copy of the PK values before
+any row-object changes take place, so even if you change the values of PK
+columns the C<WHERE> clause will remain correct.
+
+If you elect not to declare a C<primary key>, DBIx::Class will behave correctly
+by throwing exceptions on any row operation that relies on unique identifiable
+rows. If you inherited datasets with multiple identical rows in them, you can
+still operate with such sets provided you only utilize
+L<DBIx::Class::ResultSet> CRUD methods:
+L<search|DBIx::Class::ResultSet/search>,
+L<update|DBIx::Class::ResultSet/update>,
+L<delete|DBIx::Class::ResultSet/delete>
+
+For example, the following would not work (assuming C<People> does not have
+a declared PK):
+
+ my $row = $schema->resultset('People')
+ ->search({ last_name => 'Dantes' })
+ ->next;
+ $row->update({ children => 2 }); # <-- exception thrown because $row isn't
+ # necessarily unique
+
+So instead the following should be done:
+
+ $schema->resultset('People')
+ ->search({ last_name => 'Dantes' })
+ ->update({ children => 2 }); # <-- update's ALL Dantes to have children of 2
+
=head2 Problems on RHEL5/CentOS5
There used to be an issue with the system perl on Red Hat Enterprise
-=head1 NAME
+=head1 NAME
DBIx::Class::Manual::Joining - Manual on joining tables with DBIx::Class
Instead C<get_column> must be used:
while(my $row = $search_rs->next) {
- print $row->get_colum('track_name'); ## WORKS
+ print $row->get_column('track_name'); ## WORKS
}
=head2 Incomplete related objects
output. This is better solved by storing that field in a separate
table which you only join to when needed.
-To fetch an incomplete related object, supply the dotted notation to the '+as' attribute:
+To fetch an incomplete related object, supply the dotted notation to the '+as' attribute:
$schema->resultset('CD')->search(
{ 'Title' => 'Funky CD',
},
{ join => 'tracks',
'+select' => ['tracks.Name'],
- '+as' => ['tracks.Name'],
+ '+as' => ['tracks.Name'],
order_by => ['tracks.id'],
}
);
To perform joins using relations of the tables you are joining to, use
a hashref to indicate the join depth. This can theoretically go as
-deep as you like (warning: contrived examples!):
+deep as you like (warning: contrived examples!):
join => { room => { table => 'leg' } }
To join two relations at the same level, use an arrayref instead:
- join => { room => [ 'chair', 'table' ] }
+ join => { room => [ 'chair', 'table' ] }
Or combine the two:
=item *
-| - Alternate argument content types.
+| - Alternate argument content types.
At least one of these must be supplied unless the argument is also
marked optional.
There's likely a syntax error in the table class referred to elsewhere
in this error message. In particular make sure that the package
-declaration is correct. For example, for a schema C< MySchema >
+declaration is correct. For example, for a schema C< MySchema >
you need to specify a fully qualified namespace: C< package MySchema::MyTable; >.
=head2 syntax error at or near "<something>" ...
2) syntax error at or near "user" - due to "user" in the JOIN clause
The solution is to enable quoting - see
-L<DBIx::Class::Manual::Cookbook/Setting_quoting_for_the_generated_SQL> for
+L<DBIx::Class::Manual::Cookbook/Setting quoting for the generated SQL> for
details.
=head2 column "foo DESC" does not exist ...
$rs->search( {}, { order_by => { -desc => 'name' } } );
For more ways to express order clauses refer to
-L<SQL::Abstract/ORDER_BY_CLAUSES>
+L<SQL::Abstract/ORDER BY CLAUSES>
=head2 Perl Performance Issues on Red Hat Systems
=head2 Excessive Memory Allocation with TEXT/BLOB/etc. Columns and Large LongReadLen
-It has been observed, using L<DBD::ODBC>, that creating a L<DBIx::Class::Row>
-object which includes a column of data type TEXT/BLOB/etc. will allocate
-LongReadLen bytes. This allocation does not leak, but if LongReadLen
-is large in size, and many such row objects are created, e.g. as the
-output of a ResultSet query, the memory footprint of the Perl interpreter
+It has been observed, using L<DBD::ODBC>, that creating a L<DBIx::Class::Row>
+object which includes a column of data type TEXT/BLOB/etc. will allocate
+LongReadLen bytes. This allocation does not leak, but if LongReadLen
+is large in size, and many such row objects are created, e.g. as the
+output of a ResultSet query, the memory footprint of the Perl interpreter
can grow very large.
The solution is to use the smallest practical value for LongReadLen.
use warnings;
use strict;
-use Carp;
+use Carp ();
# NO EXTERNAL NON-5.8.1 CORE DEPENDENCIES EVER (e.g. C::A::G)
# This module is to be loaded by Makefile.PM on a pristine system
# POD is generated automatically by calling _gen_pod from the
# Makefile.PL in $AUTHOR mode
+my $json_any = {
+ 'JSON::Any' => '1.22',
+};
+
my $moose_basic = {
- 'Moose' => '0.98',
- 'MooseX::Types' => '0.21',
+ 'Moose' => '0.98',
+ 'MooseX::Types' => '0.21',
+};
+
+my $replicated = {
+ %$moose_basic,
};
my $admin_basic = {
%$moose_basic,
- 'MooseX::Types::Path::Class' => '0.05',
- 'MooseX::Types::JSON' => '0.02',
- 'JSON::Any' => '1.22',
- 'namespace::autoclean' => '0.09',
+ %$json_any,
+ 'MooseX::Types::Path::Class' => '0.05',
+ 'MooseX::Types::JSON' => '0.02',
+ 'namespace::autoclean' => '0.09',
+};
+
+my $datetime_basic = {
+ 'DateTime' => '0.55',
+ 'DateTime::Format::Strptime' => '1.2',
+};
+
+my $id_shortener = {
+ 'Math::BigInt' => '1.80',
+ 'Math::Base36' => '0.07',
+};
+
+my $rdbms_sqlite = {
+ 'DBD::SQLite' => '0',
+};
+my $rdbms_pg = {
+ 'DBD::Pg' => '0',
+};
+my $rdbms_mssql_odbc = {
+ 'DBD::ODBC' => '0',
+};
+my $rdbms_mssql_sybase = {
+ 'DBD::Sybase' => '0',
+};
+my $rdbms_mssql_ado = {
+ 'DBD::ADO' => '0',
+};
+my $rdbms_msaccess_odbc = {
+ 'DBD::ODBC' => '0',
+};
+my $rdbms_msaccess_ado = {
+ 'DBD::ADO' => '0',
+};
+my $rdbms_mysql = {
+ 'DBD::mysql' => '0',
+};
+my $rdbms_oracle = {
+ 'DBD::Oracle' => '0',
+ %$id_shortener,
+};
+my $rdbms_ase = {
+ 'DBD::Sybase' => '0',
+};
+my $rdbms_db2 = {
+ 'DBD::DB2' => '0',
+};
+my $rdbms_db2_400 = {
+ 'DBD::ODBC' => '0',
+};
+my $rdbms_informix = {
+ 'DBD::Informix' => '0',
+};
+my $rdbms_sqlanywhere = {
+ 'DBD::SQLAnywhere' => '0',
+};
+my $rdbms_sqlanywhere_odbc = {
+ 'DBD::ODBC' => '0',
+};
+my $rdbms_firebird = {
+ 'DBD::Firebird' => '0',
+};
+my $rdbms_firebird_interbase = {
+ 'DBD::InterBase' => '0',
+};
+my $rdbms_firebird_odbc = {
+ 'DBD::ODBC' => '0',
};
my $reqs = {
},
replicated => {
- req => {
- %$moose_basic,
- 'namespace::clean' => '0.11',
- 'Hash::Merge' => '0.12',
- },
+ req => $replicated,
pod => {
title => 'Storage::Replicated',
desc => 'Modules required for L<DBIx::Class::Storage::DBI::Replicated>',
},
},
+ test_replicated => {
+ req => {
+ %$replicated,
+ 'Test::Moose' => '0',
+ },
+ },
+
+
admin => {
req => {
%$admin_basic,
deploy => {
req => {
- 'SQL::Translator' => '0.11005',
+ 'SQL::Translator' => '0.11006',
},
pod => {
title => 'Storage::DBI::deploy()',
- desc => 'Modules required for L<DBIx::Class::Storage::DBI/deploy> and L<DBIx::Class::Storage::DBI/deploymen_statements>',
+ desc => 'Modules required for L<DBIx::Class::Storage::DBI/deploy> and L<DBIx::Class::Storage::DBI/deployment_statements>',
},
},
+ id_shortener => {
+ req => $id_shortener,
+ },
+
+ test_component_accessor => {
+ req => {
+ 'Class::Unload' => '0.07',
+ },
+ },
test_pod => {
req => {
test_notabs => {
req => {
- #'Test::NoTabs' => '0.9',
+ 'Test::NoTabs' => '0.9',
},
},
test_eol => {
req => {
- #'Test::EOL' => '0.6',
+ 'Test::EOL' => '1.0',
},
},
- test_cycle => {
+ test_prettydebug => {
+ req => $json_any,
+ },
+
+ test_leaks => {
req => {
'Test::Memory::Cycle' => '0',
'Devel::Cycle' => '1.10',
},
},
- test_dtrelated => {
+ test_dt => {
+ req => $datetime_basic,
+ },
+
+ test_dt_sqlite => {
req => {
+ %$datetime_basic,
# t/36datetime.t
# t/60core.t
'DateTime::Format::SQLite' => '0',
+ },
+ },
- # t/96_is_deteministic_value.t
- 'DateTime::Format::Strptime'=> '0',
-
+ test_dt_mysql => {
+ req => {
+ %$datetime_basic,
# t/inflate/datetime_mysql.t
# (doesn't need Mysql itself)
- 'DateTime::Format::MySQL' => '0',
+ 'DateTime::Format::MySQL' => '0',
+ },
+ },
+ test_dt_pg => {
+ req => {
+ %$datetime_basic,
# t/inflate/datetime_pg.t
# (doesn't need PG itself)
- 'DateTime::Format::Pg' => '0',
+ 'DateTime::Format::Pg' => '0.16004',
},
},
- cdbicompat => {
+ test_cdbicompat => {
req => {
- 'DBIx::ContextualFetch' => '0',
+ 'Class::DBI' => 0,
'Class::DBI::Plugin::DeepAbstractSearch' => '0',
- 'Class::Trigger' => '0',
+ %$datetime_basic,
'Time::Piece::MySQL' => '0',
- 'Clone' => '0',
'Date::Simple' => '3.03',
},
},
+ # this is just for completeness as SQLite
+ # is a core dep of DBIC for testing
+ rdbms_sqlite => {
+ req => {
+ %$rdbms_sqlite,
+ },
+ pod => {
+ title => 'SQLite support',
+ desc => 'Modules required to connect to SQLite',
+ },
+ },
+
rdbms_pg => {
req => {
+ %$rdbms_pg,
+ },
+ pod => {
+ title => 'PostgreSQL support',
+ desc => 'Modules required to connect to PostgreSQL',
+ },
+ },
+
+ rdbms_mssql_odbc => {
+ req => {
+ %$rdbms_mssql_odbc,
+ },
+ pod => {
+ title => 'MSSQL support via DBD::ODBC',
+ desc => 'Modules required to connect to MSSQL via DBD::ODBC',
+ },
+ },
+
+ rdbms_mssql_sybase => {
+ req => {
+ %$rdbms_mssql_sybase,
+ },
+ pod => {
+ title => 'MSSQL support via DBD::Sybase',
+ desc => 'Modules required to connect to MSSQL via DBD::Sybase',
+ },
+ },
+
+ rdbms_mssql_ado => {
+ req => {
+ %$rdbms_mssql_ado,
+ },
+ pod => {
+ title => 'MSSQL support via DBD::ADO (Windows only)',
+ desc => 'Modules required to connect to MSSQL via DBD::ADO. This particular DBD is available on Windows only',
+ },
+ },
+
+ rdbms_msaccess_odbc => {
+ req => {
+ %$rdbms_msaccess_odbc,
+ },
+ pod => {
+ title => 'MS Access support via DBD::ODBC',
+ desc => 'Modules required to connect to MS Access via DBD::ODBC',
+ },
+ },
+
+ rdbms_msaccess_ado => {
+ req => {
+ %$rdbms_msaccess_ado,
+ },
+ pod => {
+ title => 'MS Access support via DBD::ADO (Windows only)',
+ desc => 'Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only',
+ },
+ },
+
+ rdbms_mysql => {
+ req => {
+ %$rdbms_mysql,
+ },
+ pod => {
+ title => 'MySQL support',
+ desc => 'Modules required to connect to MySQL',
+ },
+ },
+
+ rdbms_oracle => {
+ req => {
+ %$rdbms_oracle,
+ },
+ pod => {
+ title => 'Oracle support',
+ desc => 'Modules required to connect to Oracle',
+ },
+ },
+
+ rdbms_ase => {
+ req => {
+ %$rdbms_ase,
+ },
+ pod => {
+ title => 'Sybase ASE support',
+ desc => 'Modules required to connect to Sybase ASE',
+ },
+ },
+
+ rdbms_db2 => {
+ req => {
+ %$rdbms_db2,
+ },
+ pod => {
+ title => 'DB2 support',
+ desc => 'Modules required to connect to DB2',
+ },
+ },
+
+ rdbms_db2_400 => {
+ req => {
+ %$rdbms_db2_400,
+ },
+ pod => {
+ title => 'DB2 on AS/400 support',
+ desc => 'Modules required to connect to DB2 on AS/400',
+ },
+ },
+
+ rdbms_informix => {
+ req => {
+ %$rdbms_informix,
+ },
+ pod => {
+ title => 'Informix support',
+ desc => 'Modules required to connect to Informix',
+ },
+ },
+
+ rdbms_sqlanywhere => {
+ req => {
+ %$rdbms_sqlanywhere,
+ },
+ pod => {
+ title => 'SQLAnywhere support',
+ desc => 'Modules required to connect to SQLAnywhere',
+ },
+ },
+
+ rdbms_sqlanywhere_odbc => {
+ req => {
+ %$rdbms_sqlanywhere_odbc,
+ },
+ pod => {
+ title => 'SQLAnywhere support via DBD::ODBC',
+ desc => 'Modules required to connect to SQLAnywhere via DBD::ODBC',
+ },
+ },
+
+ rdbms_firebird => {
+ req => {
+ %$rdbms_firebird,
+ },
+ pod => {
+ title => 'Firebird support',
+ desc => 'Modules required to connect to Firebird',
+ },
+ },
+
+ rdbms_firebird_interbase => {
+ req => {
+ %$rdbms_firebird_interbase,
+ },
+ pod => {
+ title => 'Firebird support via DBD::InterBase',
+ desc => 'Modules required to connect to Firebird via DBD::InterBase',
+ },
+ },
+
+ rdbms_firebird_odbc => {
+ req => {
+ %$rdbms_firebird_odbc,
+ },
+ pod => {
+ title => 'Firebird support via DBD::ODBC',
+ desc => 'Modules required to connect to Firebird via DBD::ODBC',
+ },
+ },
+
+# the order does matter because the rdbms support group might require
+# a different version that the test group
+ test_rdbms_pg => {
+ req => {
$ENV{DBICTEST_PG_DSN}
? (
- 'Sys::SigAction' => '0',
+ %$rdbms_pg,
+ ($^O ne 'MSWin32' ? ('Sys::SigAction' => '0') : ()),
'DBD::Pg' => '2.009002',
) : ()
},
},
- rdbms_mysql => {
+ test_rdbms_mssql_odbc => {
+ req => {
+ $ENV{DBICTEST_MSSQL_ODBC_DSN}
+ ? (
+ %$rdbms_mssql_odbc,
+ ) : ()
+ },
+ },
+
+ test_rdbms_mssql_ado => {
+ req => {
+ $ENV{DBICTEST_MSSQL_ADO_DSN}
+ ? (
+ %$rdbms_mssql_ado,
+ ) : ()
+ },
+ },
+
+ test_rdbms_mssql_sybase => {
+ req => {
+ $ENV{DBICTEST_MSSQL_DSN}
+ ? (
+ %$rdbms_mssql_sybase,
+ ) : ()
+ },
+ },
+
+ test_rdbms_msaccess_odbc => {
+ req => {
+ $ENV{DBICTEST_MSACCESS_ODBC_DSN}
+ ? (
+ %$rdbms_msaccess_odbc,
+ %$datetime_basic,
+ 'Data::GUID' => '0',
+ ) : ()
+ },
+ },
+
+ test_rdbms_msaccess_ado => {
+ req => {
+ $ENV{DBICTEST_MSACCESS_ADO_DSN}
+ ? (
+ %$rdbms_msaccess_ado,
+ %$datetime_basic,
+ 'Data::GUID' => 0,
+ ) : ()
+ },
+ },
+
+ test_rdbms_mysql => {
req => {
$ENV{DBICTEST_MYSQL_DSN}
? (
- 'DBD::mysql' => '0',
+ %$rdbms_mysql,
) : ()
},
},
- rdbms_oracle => {
+ test_rdbms_oracle => {
req => {
$ENV{DBICTEST_ORA_DSN}
? (
+ %$rdbms_oracle,
'DateTime::Format::Oracle' => '0',
+ 'DBD::Oracle' => '1.24',
) : ()
},
},
- rdbms_ase => {
+ test_rdbms_ase => {
req => {
$ENV{DBICTEST_SYBASE_DSN}
? (
- 'DateTime::Format::Sybase' => 0,
+ %$rdbms_ase,
) : ()
},
},
- rdbms_asa => {
+ test_rdbms_db2 => {
req => {
- (scalar grep $_, @ENV{qw/DBICTEST_SYBASE_ASA_DSN DBICTEST_SYBASE_ASA_ODBC_DSN/})
+ $ENV{DBICTEST_DB2_DSN}
? (
- 'DateTime::Format::Strptime' => 0,
+ %$rdbms_db2,
) : ()
},
},
- rdbms_db2 => {
+ test_rdbms_db2_400 => {
req => {
- $ENV{DBICTEST_DB2_DSN}
+ $ENV{DBICTEST_DB2_400_DSN}
? (
- 'DBD::DB2' => 0,
+ %$rdbms_db2_400,
) : ()
},
},
-};
+ test_rdbms_informix => {
+ req => {
+ $ENV{DBICTEST_INFORMIX_DSN}
+ ? (
+ %$rdbms_informix,
+ ) : ()
+ },
+ },
+ test_rdbms_sqlanywhere => {
+ req => {
+ $ENV{DBICTEST_SQLANYWHERE_DSN}
+ ? (
+ %$rdbms_sqlanywhere,
+ ) : ()
+ },
+ },
+
+ test_rdbms_sqlanywhere_odbc => {
+ req => {
+ $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN}
+ ? (
+ %$rdbms_sqlanywhere_odbc,
+ ) : ()
+ },
+ },
+
+ test_rdbms_firebird => {
+ req => {
+ $ENV{DBICTEST_FIREBIRD_DSN}
+ ? (
+ %$rdbms_firebird,
+ ) : ()
+ },
+ },
+
+ test_rdbms_firebird_interbase => {
+ req => {
+ $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}
+ ? (
+ %$rdbms_firebird_interbase,
+ ) : ()
+ },
+ },
+
+ test_rdbms_firebird_odbc => {
+ req => {
+ $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
+ ? (
+ %$rdbms_firebird_odbc,
+ ) : ()
+ },
+ },
+
+ test_memcached => {
+ req => {
+ $ENV{DBICTEST_MEMCACHED}
+ ? (
+ 'Cache::Memcached' => 0,
+ ) : ()
+ },
+ },
+
+};
-sub _all_optional_requirements {
- return { map { %{ $reqs->{$_}{req} || {} } } (keys %$reqs) };
-}
sub req_list_for {
my ($class, $group) = @_;
- croak "req_list_for() expects a requirement group name"
+ Carp::croak "req_list_for() expects a requirement group name"
unless $group;
my $deps = $reqs->{$group}{req}
- or croak "Requirement group '$group' does not exist";
+ or Carp::croak "Requirement group '$group' does not exist";
return { %$deps };
}
sub req_ok_for {
my ($class, $group) = @_;
- croak "req_ok_for() expects a requirement group name"
+ Carp::croak "req_ok_for() expects a requirement group name"
unless $group;
- $class->_check_deps ($group) unless $req_availability_cache{$group};
-
- return $req_availability_cache{$group}{status};
+ return $class->_check_deps($group)->{status};
}
sub req_missing_for {
my ($class, $group) = @_;
- croak "req_missing_for() expects a requirement group name"
+ Carp::croak "req_missing_for() expects a requirement group name"
unless $group;
- $class->_check_deps ($group) unless $req_availability_cache{$group};
-
- return $req_availability_cache{$group}{missing};
+ return $class->_check_deps($group)->{missing};
}
sub req_errorlist_for {
my ($class, $group) = @_;
- croak "req_errorlist_for() expects a requirement group name"
+ Carp::croak "req_errorlist_for() expects a requirement group name"
unless $group;
- $class->_check_deps ($group) unless $req_availability_cache{$group};
-
- return $req_availability_cache{$group}{errorlist};
+ return $class->_check_deps($group)->{errorlist};
}
sub _check_deps {
my ($class, $group) = @_;
- my $deps = $class->req_list_for ($group);
+ return $req_availability_cache{$group} ||= do {
+
+ my $deps = $class->req_list_for ($group);
+
+ my %errors;
+ for my $mod (keys %$deps) {
+ my $req_line = "require $mod;";
+ if (my $ver = $deps->{$mod}) {
+ $req_line .= "$mod->VERSION($ver);";
+ }
+
+ eval $req_line;
- my %errors;
- for my $mod (keys %$deps) {
- if (my $ver = $deps->{$mod}) {
- eval "use $mod $ver ()";
+ $errors{$mod} = $@ if $@;
+ }
+
+ my $res;
+
+ if (keys %errors) {
+ my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
+ $missing .= " (see $class for details)" if $reqs->{$group}{pod};
+ $res = {
+ status => 0,
+ errorlist => \%errors,
+ missing => $missing,
+ };
}
else {
- eval "require $mod";
+ $res = {
+ status => 1,
+ errorlist => {},
+ missing => '',
+ };
}
- $errors{$mod} = $@ if $@;
- }
+ $res;
+ };
+}
- if (keys %errors) {
- my $missing = join (', ', map { $deps->{$_} ? "$_ >= $deps->{$_}" : $_ } (sort keys %errors) );
- $missing .= " (see $class for details)" if $reqs->{$group}{pod};
- $req_availability_cache{$group} = {
- status => 0,
- errorlist => { %errors },
- missing => $missing,
- };
- }
- else {
- $req_availability_cache{$group} = {
- status => 1,
- errorlist => {},
- missing => '',
- };
- }
+sub req_group_list {
+ return { map { $_ => { %{ $reqs->{$_}{req} || {} } } } (keys %$reqs) };
}
-# This is to be called by the author onbly (automatically in Makefile.PL)
+# This is to be called by the author only (automatically in Makefile.PL)
sub _gen_pod {
- my $class = shift;
+ my ($class, $distver) = @_;
+
my $modfn = __PACKAGE__ . '.pm';
$modfn =~ s/\:\:/\//g;
- require DBIx::Class;
- my $distver = DBIx::Class->VERSION;
+ my $podfn = __FILE__;
+ $podfn =~ s/\.pm$/\.pod/;
+
+ $distver ||=
+ eval { require DBIx::Class; DBIx::Class->VERSION; }
+ ||
+ die
+"\n\n---------------------------------------------------------------------\n" .
+'Unable to load core DBIx::Class module to determine current version, '.
+'possibly due to missing dependencies. Author-mode autodocumentation ' .
+"halted\n\n" . $@ .
+"\n\n---------------------------------------------------------------------\n"
+ ;
+
+ my $sqltver = $class->req_list_for ('deploy')->{'SQL::Translator'}
+ or die "Hrmm? No sqlt dep?";
my @chunks = (
- <<"EOC",
+ <<'EOC',
#########################################################################
##################### A U T O G E N E R A T E D ########################
#########################################################################
EOC
'=head1 NAME',
"$class - Optional module dependency specifications (for module authors)",
- '=head1 SYNOPSIS (EXPERIMENTAL)',
- <<EOS,
-B<THE USAGE SHOWN HERE IS EXPERIMENTAL>
-
+ '=head1 SYNOPSIS',
+ <<"EOS",
Somewhere in your build-file (e.g. L<Module::Install>'s Makefile.PL):
...
require $class;
- my \$deploy_deps = $class->req_list_for ('deploy');
+ my \$deploy_deps = $class->req_list_for('deploy');
for (keys %\$deploy_deps) {
requires \$_ => \$deploy_deps->{\$_};
<<'EOD',
Dependencies are organized in C<groups> and each group can list one or more
required modules, with an optional minimum version (or 0 for any version).
-The group name can be used in the
+The group name can be used in the
EOD
);
push @chunks, (
'=head1 METHODS',
+ '=head2 req_group_list',
+ '=over',
+ '=item Arguments: none',
+ '=item Returns: \%list_of_requirement_groups',
+ '=back',
+ <<'EOD',
+This method should be used by DBIx::Class packagers, to get a hashref of all
+dependencies keyed by dependency group. Each key (group name) can be supplied
+to one of the group-specific methods below.
+EOD
+
'=head2 req_list_for',
'=over',
'=item Arguments: $group_name',
'=item Returns: \%list_of_module_version_pairs',
'=back',
- <<EOD,
+ <<'EOD',
This method should be used by DBIx::Class extension authors, to determine the
version of modules a specific feature requires in the B<current> version of
-DBIx::Class. See the L<SYNOPSIS|/SYNOPSIS (EXPERIMENTAL)> for a real-world
+DBIx::Class. See the L</SYNOPSIS> for a real-world
example.
EOD
'=item Arguments: $group_name',
'=item Returns: 1|0',
'=back',
- 'Returns true or false depending on whether all modules required by C<$group_name> are present on the system and loadable',
+ <<'EOD',
+Returns true or false depending on whether all modules required by
+C<$group_name> are present on the system and loadable.
+EOD
'=head2 req_missing_for',
'=over',
'=item Arguments: $group_name',
'=item Returns: $error_message_string',
'=back',
- <<EOD,
+ <<"EOD",
Returns a single line string suitable for inclusion in larger error messages.
This method would normally be used by DBIx::Class core-module author, to
indicate to the user that he needs to install specific modules before he will
be able to use a specific feature.
-For example if the requirements for C<replicated> are not available, the
-returned string would look like:
+For example if some of the requirements for C<deploy> are not available,
+the returned string could look like:
- Moose >= 0.98, MooseX::Types >= 0.21, namespace::clean (see $class for details)
+ SQL::Translator >= $sqltver (see $class for details)
The author is expected to prepend the necessary text to this message before
returning the actual error seen by the user.
'You may distribute this code under the same terms as Perl itself',
);
- my $fn = __FILE__;
- $fn =~ s/\.pm$/\.pod/;
-
- open (my $fh, '>', $fn) or croak "Unable to write to $fn: $!";
+ open (my $fh, '>', $podfn) or Carp::croak "Unable to write to $podfn: $!";
print $fh join ("\n\n", @chunks);
close ($fh);
}
use warnings;
use base qw( DBIx::Class );
+use List::Util 'first';
+use namespace::clean;
+
=head1 NAME
DBIx::Class::Ordered - Modify the position of objects in an ordered list.
position INTEGER NOT NULL
);
-Optionally, add one or more columns to specify groupings, allowing you
+Optionally, add one or more columns to specify groupings, allowing you
to maintain independent ordered lists within one table:
CREATE TABLE items (
other_group_id INTEGER NOT NULL
);
-In your Schema or DB class add "Ordered" to the top
+In your Schema or DB class add "Ordered" to the top
of the component list.
__PACKAGE__->load_components(qw( Ordered ... ));
-Specify the column that stores the position number for
+Specify the column that stores the position number for
each row.
package My::Item;
=head1 DESCRIPTION
-This module provides a simple interface for modifying the ordered
+This module provides a simple interface for modifying the ordered
position of DBIx::Class objects.
=head1 AUTO UPDATE
-All of the move_* methods automatically update the rows involved in
-the query. This is not configurable and is due to the fact that if you
+All of the move_* methods automatically update the rows involved in
+the query. This is not configurable and is due to the fact that if you
move a record it always causes other records in the list to be updated.
=head1 METHODS
__PACKAGE__->position_column('position');
-Sets and retrieves the name of the column that stores the
+Sets and retrieves the name of the column that stores the
positional value of each record. Defaults to "position".
=cut
__PACKAGE__->grouping_column('group_id');
-This method specifies a column to limit all queries in
-this module by. This effectively allows you to have multiple
+This method specifies a column to limit all queries in
+this module by. This effectively allows you to have multiple
ordered lists within the same table.
=cut
my $sibling = $item->first_sibling();
-Returns the first sibling object, or 0 if the first sibling
+Returns the first sibling object, or 0 if the first sibling
is this sibling.
=cut
my $sibling = $item->last_sibling();
-Returns the last sibling, or 0 if the last sibling is this
+Returns the last sibling, or 0 if the last sibling is this
sibling.
=cut
my $position_column = $self->position_column;
- my $guard;
-
if ($self->is_column_changed ($position_column) ) {
- # something changed our position, we have no idea where we
- # used to be - requery without using discard_changes
- # (we need only a specific column back)
-
- $guard = $self->result_source->schema->txn_scope_guard;
-
- my $cursor = $self->result_source->resultset->search(
- $self->ident_condition,
- { select => $position_column },
- )->cursor;
-
- my ($pos) = $cursor->next;
- $self->$position_column ($pos);
+ # something changed our position, we need to know where we
+ # used to be - use the stashed value
+ $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column});
delete $self->{_dirty_columns}{$position_column};
}
my $from_position = $self->_position;
if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order
- $guard->commit if $guard;
return 0;
}
- $guard ||= $self->result_source->schema->txn_scope_guard;
+ my $guard = $self->result_source->schema->txn_scope_guard;
my ($direction, @between);
if ( $from_position < $to_position ) {
1 is returned on success, and 0 is returned if the object is
already at the specified position of the specified group.
-$group may be specified as a single scalar if only one
+$group may be specified as a single scalar if only one
grouping column is in use, or as a hashref of column => value pairs
if multiple grouping columns are in use.
return 0 if ( defined($to_position) and $to_position < 1 );
# check if someone changed the _grouping_columns - this will
- # prevent _is_in_group working, so we need to requery the db
- # for the original values
- my (@dirty_cols, %values, $guard);
+ # prevent _is_in_group working, so we need to restore the
+ # original stashed values
for ($self->_grouping_columns) {
- $values{$_} = $self->get_column ($_);
- push @dirty_cols, $_ if $self->is_column_changed ($_);
- }
-
- # re-query only the dirty columns, and restore them on the
- # object (subsequent code will update them to the correct
- # after-move values)
- if (@dirty_cols) {
- $guard = $self->result_source->schema->txn_scope_guard;
-
- my $cursor = $self->result_source->resultset->search(
- $self->ident_condition,
- { select => \@dirty_cols },
- )->cursor;
-
- my @original_values = $cursor->next;
- $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
- delete $self->{_dirty_columns}{$_} for (@dirty_cols);
+ if ($self->is_column_changed ($_)) {
+ $self->store_column($_, delete $self->{_column_data_in_storage}{$_});
+ delete $self->{_dirty_columns}{$_};
+ }
}
if ($self->_is_in_group ($to_group) ) {
$ret = $self->move_to ($to_position);
}
- $guard->commit if $guard;
return $ret||0;
}
- $guard ||= $self->result_source->schema->txn_scope_guard;
+ my $guard = $self->result_source->schema->txn_scope_guard;
# Move to end of current group to adjust siblings
$self->move_last;
=head2 insert
-Overrides the DBIC insert() method by providing a default
-position number. The default will be the number of rows in
+Overrides the DBIC insert() method by providing a default
+position number. The default will be the number of rows in
the table +1, thus positioning the new record at the last position.
=cut
=cut
sub update {
- my $self = shift;
-
- # this is set by _ordered_internal_update()
- return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
-
- my $position_column = $self->position_column;
- my @ordering_columns = ($self->_grouping_columns, $position_column);
-
-
- # these steps are necessary to keep the external appearance of
- # ->update($upd) so that other things overloading update() will
- # work properly
- my %original_values = $self->get_columns;
- my %existing_changes = $self->get_dirty_columns;
-
- # See if any of the *supplied* changes would affect the ordering
- # The reason this is so contrived, is that we want to leverage
- # the datatype aware value comparing, while at the same time
- # keep the original value intact (it will be updated later by the
- # corresponding routine)
-
- my %upd = %{shift || {}};
- my %changes = %existing_changes;
-
- for (@ordering_columns) {
- next unless exists $upd{$_};
-
- # we do not want to keep propagating this to next::method
- # as it will be a done deal by the time get there
- my $value = delete $upd{$_};
- $self->set_inflated_columns ({ $_ => $value });
-
- # see if an update resulted in a dirty column
- # it is important to preserve the old value, as it
- # will be needed to carry on a successfull move()
- # operation without re-querying the database
- if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) {
- $changes{$_} = $value;
- $self->set_inflated_columns ({ $_ => $original_values{$_} });
- delete $self->{_dirty_columns}{$_};
- }
- }
-
- # if nothing group/position related changed - short circuit
- if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
- return $self->next::method( \%upd, @_ );
- }
+ my $self = shift;
+
+ # this is set by _ordered_internal_update()
+ return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE};
+
+ my $upd = shift;
+ $self->set_inflated_columns($upd) if $upd;
+
+ my $position_column = $self->position_column;
+ my @group_columns = $self->_grouping_columns;
+
+ # see if the order is already changed
+ my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) };
+
+ # nothing changed - short circuit
+ if (! keys %$changed_ordering_cols) {
+ return $self->next::method( undef, @_ );
+ }
+ elsif (defined first { exists $changed_ordering_cols->{$_} } @group_columns ) {
+ $self->move_to_group(
+ # since the columns are already re-set the _grouping_clause is correct
+ # move_to_group() knows how to get the original storage values
+ { $self->_grouping_clause },
+
+ # The FIXME bit contradicts the documentation: POD states that
+ # when changing groups without supplying explicit positions in
+ # move_to_group(), we push the item to the end of the group.
+ # However when I was rewriting this, the position from the old
+ # group was clearly passed to the new one
+ # Probably needs to go away (by ribasushi)
+ (exists $changed_ordering_cols->{$position_column}
+ ? $changed_ordering_cols->{$position_column} # means there was a position change supplied with the update too
+ : $self->_position # FIXME! (replace with undef)
+ ),
+ );
+ }
+ else {
+ $self->move_to($changed_ordering_cols->{$position_column});
+ }
- {
- my $guard = $self->result_source->schema->txn_scope_guard;
-
- # if any of our grouping columns have been changed
- if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
-
- # create new_group by taking the current group and inserting changes
- my $new_group = {$self->_grouping_clause};
- foreach my $col (keys %$new_group) {
- $new_group->{$col} = $changes{$col} if exists $changes{$col};
- }
-
- $self->move_to_group(
- $new_group,
- (exists $changes{$position_column}
- # The FIXME bit contradicts the documentation: POD states that
- # when changing groups without supplying explicit positions in
- # move_to_group(), we push the item to the end of the group.
- # However when I was rewriting this, the position from the old
- # group was clearly passed to the new one
- # Probably needs to go away (by ribasushi)
- ? $changes{$position_column} # means there was a position change supplied with the update too
- : $self->_position # FIXME! (replace with undef)
- ),
- );
- }
- elsif (exists $changes{$position_column}) {
- $self->move_to($changes{$position_column});
- }
-
- my @res;
- my $want = wantarray();
- if (not defined $want) {
- $self->next::method( \%upd, @_ );
- }
- elsif ($want) {
- @res = $self->next::method( \%upd, @_ );
- }
- else {
- $res[0] = $self->next::method( \%upd, @_ );
- }
-
- $guard->commit;
- return $want ? @res : $res[0];
- }
+ return $self;
}
=head2 delete
-Overrides the DBIC delete() method by first moving the object
+Overrides the DBIC delete() method by first moving the object
to the last position, then deleting it, thus ensuring the
integrity of the positions.
$self->move_last;
- my @res;
- my $want = wantarray();
- if (not defined $want) {
- $self->next::method( @_ );
- }
- elsif ($want) {
- @res = $self->next::method( @_ );
- }
- else {
- $res[0] = $self->next::method( @_ );
- }
+ $self->next::method( @_ );
$guard->commit;
- return $want ? @res : $res[0];
+
+ return $self;
+}
+
+# add the current position/group to the things we track old values for
+sub _track_storage_value {
+ my ($self, $col) = @_;
+ return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns);
}
=head1 METHODS FOR EXTENDING ORDERED
Shifts all siblings with B<positions values> in the range @between
(inclusive) by one position as specified by $direction (left if < 0,
right if > 0). By default simply increments/decrements each
-L<position_column> value by 1, doing so in a way as to not violate
+L</position_column> value by 1, doing so in a way as to not violate
any existing constraints.
Note that if you override this method and have unique constraints
-including the L<position_column> the shift is not a trivial task.
+including the L</position_column> the shift is not a trivial task.
Refer to the implementation source of the default method for more
information.
$ord = 'desc';
}
- my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
-
- # some databases (sqlite) are dumb and can not do a blanket
- # increment/decrement. So what we do here is check if the
- # position column is part of a unique constraint, and do a
- # one-by-one update if this is the case
-
- my $rsrc = $self->result_source;
-
- if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
-
- my @pcols = $rsrc->_pri_cols;
- my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
- my $rs = $self->result_source->resultset;
-
- my @all_pks = $cursor->all;
- while (my $pks = shift @all_pks) {
- my $cond;
- for my $i (0.. $#pcols) {
- $cond->{$pcols[$i]} = $pks->[$i];
- }
-
- $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
- }
- }
- else {
- $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
- }
+ $self->_group_rs
+ ->search ({ $position_column => { -between => \@between } })
+ ->update ({ $position_column => \ "$position_column $op 1" } );
}
-=head1 PRIVATE METHODS
-
-These methods are used internally. You should never have the
-need to use them.
-=head2 _group_rs
-
-This method returns a resultset containing all members of the row
-group (including the row itself).
-
-=cut
+# This method returns a resultset containing all members of the row
+# group (including the row itself).
sub _group_rs {
my $self = shift;
return $self->result_source->resultset->search({$self->_grouping_clause()});
}
-=head2 _siblings
-
-Returns an unordered resultset of all objects in the same group
-excluding the object you called this method on.
-
-=cut
+# Returns an unordered resultset of all objects in the same group
+# excluding the object you called this method on.
sub _siblings {
my $self = shift;
my $position_column = $self->position_column;
- return $self->_group_rs->search(
- { $position_column => { '!=' => $self->get_column($position_column) } },
- );
+ my $pos;
+ return defined ($pos = $self->get_column($position_column))
+ ? $self->_group_rs->search(
+ { $position_column => { '!=' => $pos } },
+ )
+ : $self->_group_rs
+ ;
}
-=head2 _position
-
- my $num_pos = $item->_position;
-
-Returns the B<absolute numeric position> of the current object, with the
-first object being at position 1, its sibling at position 2 and so on.
-
-=cut
+# Returns the B<absolute numeric position> of the current object, with the
+# first object being at position 1, its sibling at position 2 and so on.
sub _position {
my $self = shift;
return $self->_position_from_value ($self->get_column ($self->position_column) );
}
-=head2 _grouping_clause
-
-This method returns one or more name=>value pairs for limiting a search
-by the grouping column(s). If the grouping column is not defined then
-this will return an empty list.
-
-=cut
+# This method returns one or more name=>value pairs for limiting a search
+# by the grouping column(s). If the grouping column is not defined then
+# this will return an empty list.
sub _grouping_clause {
my( $self ) = @_;
return map { $_ => $self->get_column($_) } $self->_grouping_columns();
}
-=head2 _get_grouping_columns
-
-Returns a list of the column names used for grouping, regardless of whether
-they were specified as an arrayref or a single string, and returns ()
-if there is no grouping.
-
-=cut
+# Returns a list of the column names used for grouping, regardless of whether
+# they were specified as an arrayref or a single string, and returns ()
+# if there is no grouping.
sub _grouping_columns {
my( $self ) = @_;
my $col = $self->grouping_column();
}
}
-=head2 _is_in_group
-
- $item->_is_in_group( {user => 'fred', list => 'work'} )
-
-Returns true if the object is in the group represented by hashref $other
-
-=cut
+# Returns true if the object is in the group represented by hashref $other
sub _is_in_group {
my ($self, $other) = @_;
my $current = {$self->_grouping_clause};
return 1;
}
-=head2 _ordered_internal_update
-
-This is a short-circuited method, that is used internally by this
-module to update positioning values in isolation (i.e. without
-triggering any of the positioning integrity code).
-
-Some day you might get confronted by datasets that have ambiguous
-positioning data (e.g. duplicate position values within the same group,
-in a table without unique constraints). When manually fixing such data
-keep in mind that you can not invoke L<DBIx::Class::Row/update> like
-you normally would, as it will get confused by the wrong data before
-having a chance to update the ill-defined row. If you really know what
-you are doing use this method which bypasses any hooks introduced by
-this module.
-
-=cut
-
+# This is a short-circuited method, that is used internally by this
+# module to update positioning values in isolation (i.e. without
+# triggering any of the positioning integrity code).
+#
+# Some day you might get confronted by datasets that have ambiguous
+# positioning data (e.g. duplicate position values within the same group,
+# in a table without unique constraints). When manually fixing such data
+# keep in mind that you can not invoke L<DBIx::Class::Row/update> like
+# you normally would, as it will get confused by the wrong data before
+# having a chance to update the ill-defined row. If you really know what
+# you are doing use this method which bypasses any hooks introduced by
+# this module.
sub _ordered_internal_update {
my $self = shift;
- local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
+ local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
return $self->update (@_);
}
=head1 CAVEATS
+=head2 Resultset Methods
+
+Note that all Insert/Create/Delete overrides are happening on
+L<DBIx::Class::Row> methods only. If you use the
+L<DBIx::Class::ResultSet> versions of
+L<update|DBIx::Class::ResultSet/update> or
+L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
+module will be bypassed entirely (possibly resulting in a broken
+order-tree). Instead always use the
+L<update_all|DBIx::Class::ResultSet/update_all> and
+L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
+invoke the corresponding L<row|DBIx::Class::Row> method on every
+member of the given resultset.
+
=head2 Race Condition on Insert
-If a position is not specified for an insert than a position
+If a position is not specified for an insert, a position
will be chosen based either on L</_initial_position_value> or
L</_next_position_value>, depending if there are already some
items in the current group. The space of time between the
=head2 Multiple Moves
-Be careful when issuing move_* methods to multiple objects. If
-you've pre-loaded the objects then when you move one of the objects
-the position of the other object will not reflect their new value
+Be careful when issuing move_* methods to multiple objects. If
+you've pre-loaded the objects then when you move one of the objects
+the position of the other object will not reflect their new value
until you reload them from the database - see
L<DBIx::Class::Row/discard_changes>.
-There are times when you will want to move objects as groups, such
-as changing the parent of several objects at once - this directly
-conflicts with this problem. One solution is for us to write a
-ResultSet class that supports a parent() method, for example. Another
-solution is to somehow automagically modify the objects that exist
+There are times when you will want to move objects as groups, such
+as changing the parent of several objects at once - this directly
+conflicts with this problem. One solution is for us to write a
+ResultSet class that supports a parent() method, for example. Another
+solution is to somehow automagically modify the objects that exist
in the current object's result set to have the new position value.
=head2 Default Values
}
sub _ident_values {
- my ($self) = @_;
+ my ($self, $use_storage_state) = @_;
+
my (@ids, @missing);
for ($self->_pri_cols) {
- push @ids, $self->get_column($_);
+ push @ids, ($use_storage_state and exists $self->{_column_data_in_storage}{$_})
+ ? $self->{_column_data_in_storage}{$_}
+ : $self->get_column($_)
+ ;
push @missing, $_ if (! defined $ids[-1] and ! $self->has_column_loaded ($_) );
}
=cut
sub ident_condition {
- my ($self, $alias) = @_;
+ shift->_mk_ident_cond(@_);
+}
+
+sub _storage_ident_condition {
+ shift->_mk_ident_cond(shift, 1);
+}
+
+sub _mk_ident_cond {
+ my ($self, $alias, $use_storage_state) = @_;
my @pks = $self->_pri_cols;
- my @vals = $self->_ident_values;
+ my @vals = $self->_ident_values($use_storage_state);
my (%cond, @undef);
my $prefix = defined $alias ? $alias.'.' : '';
use strict;
use warnings;
+1;
+
=head1 NAME
DBIx::Class::PK::Auto - Automatic primary key class
=head2 sequence
-Manually define the correct sequence for your table, to avoid the overhead
-associated with looking up the sequence automatically.
-
-=cut
-
-sub sequence {
- my ($self,$seq) = @_;
- foreach my $pri ($self->primary_columns) {
- $self->column_info($pri)->{sequence} = $seq;
- }
-}
-
-1;
+The code that was handled here is now in ResultSource, and is being proxied to
+Row as well.
=head1 AUTHORS
=head1 SYNOPSIS
## Creating relationships
- MyDB::Schema::Actor->has_many('actorroles' => 'MyDB::Schema::ActorRole',
+ MyApp::Schema::Actor->has_many('actorroles' => 'MyApp::Schema::ActorRole',
'actor');
- MyDB::Schema::Role->has_many('actorroles' => 'MyDB::Schema::ActorRole',
+ MyApp::Schema::Role->has_many('actorroles' => 'MyApp::Schema::ActorRole',
'role');
- MyDB::Schema::ActorRole->belongs_to('role' => 'MyDB::Schema::Role');
- MyDB::Schema::ActorRole->belongs_to('actor' => 'MyDB::Schema::Actor');
+ MyApp::Schema::ActorRole->belongs_to('role' => 'MyApp::Schema::Role');
+ MyApp::Schema::ActorRole->belongs_to('actor' => 'MyApp::Schema::Actor');
- MyDB::Schema::Role->many_to_many('actors' => 'actorroles', 'actor');
- MyDB::Schema::Actor->many_to_many('roles' => 'actorroles', 'role');
+ MyApp::Schema::Role->many_to_many('actors' => 'actorroles', 'actor');
+ MyApp::Schema::Actor->many_to_many('roles' => 'actorroles', 'role');
## Using relationships
$schema->resultset('Actor')->find({ id => 1})->roles();
All helper methods are called similar to the following template:
- __PACKAGE__->$method_name('relname', 'Foreign::Class', \%cond | \@cond, \%attrs);
+ __PACKAGE__->$method_name('relname', 'Foreign::Class', \%cond|\@cond|\&cond?, \%attrs?);
-Both C<$cond> and C<$attrs> are optional. Pass C<undef> for C<$cond> if
-you want to use the default value for it, but still want to set C<\%attrs>.
+Both C<cond> and C<attrs> are optional. Pass C<undef> for C<cond> if
+you want to use the default value for it, but still want to set C<attrs>.
-See L<DBIx::Class::Relationship::Base> for documentation on the
-attributes that are allowed in the C<\%attrs> argument.
+See L<DBIx::Class::Relationship::Base/condition> for full documentation on
+definition of the C<cond> argument.
+
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on the
+attributes that are allowed in the C<attrs> argument.
=head2 belongs_to
=over 4
-=item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond?, \%attrs?
+=item Arguments: $accessor_name, $related_class, $our_fk_column|\%cond|\@cond|\$cond?, \%attrs?
=back
This relationship defaults to using C<$accessor_name> as the column
name in this class to resolve the join against the primary key from
C<$related_class>, unless C<$our_fk_column> specifies the foreign key column
-in this class or C<cond> specifies a reference to a join condition hash.
+in this class or C<cond> specifies a reference to a join condition.
=over
=item cond
-A hashref where the keys are C<foreign.$column_on_related_table> and
-the values are C<self.$our_fk_column>. This is useful for
-relations that are across multiple columns.
+A hashref, arrayref or coderef specifying a custom join expression. For
+more info see L<DBIx::Class::Relationship::Base/condition>.
=back
-
# in a Book class (where Author has many Books)
- My::DBIC::Schema::Book->belongs_to(
- author =>
- 'My::DBIC::Schema::Author',
+ My::DBIC::Schema::Book->belongs_to(
+ author =>
+ 'My::DBIC::Schema::Author',
'author_id'
);
My::DBIC::Schema::Book->belongs_to(
author =>
'My::DBIC::Schema::Author',
- { 'foreign.author_id' => 'self.author_id' }
+ { 'foreign.author_id' => 'self.author_id' }
);
# OR (similar result but uglier accessor name)
- My::DBIC::Schema::Book->belongs_to(
+ My::DBIC::Schema::Book->belongs_to(
author_id =>
'My::DBIC::Schema::Author'
);
$book->get_column('author_id');
-If the relationship is optional -- i.e. the column containing the foreign key
-can be NULL -- then the belongs_to relationship does the right thing. Thus, in
-the example above C<$obj-E<gt>author> would return C<undef>. However in this
-case you would probably want to set the C<join_type> attribute so that a C<LEFT
-JOIN> is done, which makes complex resultsets involving C<join> or C<prefetch>
-operations work correctly. The modified declaration is shown below:
+If the relationship is optional -- i.e. the column containing the
+foreign key can be NULL -- then the belongs_to relationship does the
+right thing. Thus, in the example above C<< $obj->author >> would
+return C<undef>. However in this case you would probably want to set
+the L<join_type|DBIx::Class::Relationship/join_type> attribute so that
+a C<LEFT JOIN> is done, which makes complex resultsets involving
+C<join> or C<prefetch> operations work correctly. The modified
+declaration is shown below:
# in a Book class (where Author has_many Books)
__PACKAGE__->belongs_to(
- author =>
+ author =>
'My::DBIC::Schema::Author',
- 'author',
+ 'author',
{ join_type => 'left' }
);
By default, DBIC will return undef and avoid querying the database if a
C<belongs_to> accessor is called when any part of the foreign key IS NULL. To
-disable this behavior, pass C<< undef_on_null_fk => 0 >> in the C<$attr>
+disable this behavior, pass C<< undef_on_null_fk => 0 >> in the C<\%attrs>
hashref.
NOTE: If you are used to L<Class::DBI> relationships, this is the equivalent
of C<has_a>.
-See L<DBIx::Class::Relationship::Base> for documentation on relationship
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on relationship
methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
which can be assigned to relationships as well.
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs?
=back
Creates a one-to-many relationship where the foreign class refers to
this class's primary key. This relationship refers to zero or more
-records in the foreign table (e.g. a C<LEFT JOIN>). This relationship
+records in the foreign table (e.g. a C<LEFT JOIN>). This relationship
defaults to using the end of this classes namespace as the foreign key
in C<$related_class> to resolve the join, unless C<$their_fk_column>
specifies the foreign key column in C<$related_class> or C<cond>
-specifies a reference to a join condition hash.
+specifies a reference to a join condition.
=over
=item cond
-A hashref where the keys are C<foreign.$their_fk_column> and
-the values are C<self.$matching_column>. This is useful for
-relations that are across multiple columns.
-
-OR
-
-An arrayref containing an SQL::Abstract-like condition. For example a
-link table where two columns link back to the same table. This is an
-OR condition.
-
- My::Schema::Item->has_many('rels', 'My::Schema::Relationships',
- [ { 'foreign.LItemID' => 'self.ID' },
- { 'foreign.RItemID' => 'self.ID'} ]);
+A hashref, arrayref or coderef specifying a custom join expression. For
+more info see L<DBIx::Class::Relationship::Base/condition>.
=back
# in an Author class (where Author has_many Books)
# assuming related class is storing our PK in "author_id"
My::DBIC::Schema::Author->has_many(
- books =>
- 'My::DBIC::Schema::Book',
+ books =>
+ 'My::DBIC::Schema::Book',
'author_id'
);
# OR (same result)
My::DBIC::Schema::Author->has_many(
- books =>
- 'My::DBIC::Schema::Book',
+ books =>
+ 'My::DBIC::Schema::Book',
{ 'foreign.author_id' => 'self.id' },
);
# OR (similar result, assuming related_class is storing our PK, in "author")
# (the "author" is guessed at from "Author" in the class namespace)
My::DBIC::Schema::Author->has_many(
- books =>
- 'My::DBIC::Schema::Book',
+ books =>
+ 'My::DBIC::Schema::Book',
);
# Usage
- # resultset of Books belonging to author
+ # resultset of Books belonging to author
my $booklist = $author->books;
# resultset of Books belonging to author, restricted by author name
$author->add_to_books(\%col_data);
-Three methods are created when you create a has_many relationship. The first
-method is the expected accessor method, C<$accessor_name()>. The second is
-almost exactly the same as the accessor method but "_rs" is added to the end of
-the method name. This method works just like the normal accessor, except that
-it always returns a resultset, even in list context. The third method,
-named C<< add_to_$relname >>, will also be added to your Row items; this
-allows you to insert new related items, using the same mechanism as in
+Three methods are created when you create a has_many relationship.
+The first method is the expected accessor method, C<$accessor_name()>.
+The second is almost exactly the same as the accessor method but "_rs"
+is added to the end of the method name, eg C<$accessor_name_rs()>.
+This method works just like the normal accessor, except that it always
+returns a resultset, even in list context. The third method, named C<<
+add_to_$relname >>, will also be added to your Row items; this allows
+you to insert new related items, using the same mechanism as in
L<DBIx::Class::Relationship::Base/"create_related">.
If you delete an object in a class with a C<has_many> relationship, all
pass C<< cascade_copy => 0 >> in the C<$attr> hashref. The behaviour
defaults to C<< cascade_copy => 1 >>.
-See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
-for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
-which can be assigned to relationships as well.
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on
+relationship methods and valid relationship attributes. Also see
+L<DBIx::Class::ResultSet> for a L<list of standard resultset
+attributes|DBIx::Class::ResultSet/ATTRIBUTES> which can be assigned to
+relationships as well.
=head2 might_have
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs?
=back
defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
resolve the join, unless C<$their_fk_column> specifies the foreign key
column in C<$related_class> or C<cond> specifies a reference to a join
-condition hash.
+condition.
=over
=item cond
-A hashref where the keys are C<foreign.$their_fk_column> and
-the values are C<self.$matching_column>. This is useful for
-relations that are across multiple columns.
+A hashref, arrayref or coderef specifying a custom join expression. For
+more info see L<DBIx::Class::Relationship::Base/condition>.
=back
will have deleted/updated the related records or raised an exception
before DBIx::Class gets to perform the cascaded operation.
-See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
-for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
-which can be assigned to relationships as well.
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on
+relationship methods and valid relationship attributes. Also see
+L<DBIx::Class::ResultSet> for a L<list of standard resultset
+attributes|DBIx::Class::ResultSet/ATTRIBUTES> which can be assigned to
+relationships as well.
-Note that if you supply a condition on which to join, if the column in the
+Note that if you supply a condition on which to join, and the column in the
current table allows nulls (i.e., has the C<is_nullable> attribute set to a
true value), than C<might_have> will warn about this because it's naughty and
-you shouldn't do that.
+you shouldn't do that. The warning will look something like:
- "might_have/has_one" must not be on columns with is_nullable set to true (MySchema::SomeClass/key)
+ "might_have/has_one" must not be on columns with is_nullable set to true (MySchema::SomeClass/key)
If you must be naughty, you can suppress the warning by setting
C<DBIC_DONT_VALIDATE_RELS> environment variable to a true value. Otherwise,
-you probably just want to use C<DBIx::Class::Relationship/belongs_to>.
+you probably just meant to use C<DBIx::Class::Relationship/belongs_to>.
=head2 has_one
=over 4
-=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond?, \%attrs?
+=item Arguments: $accessor_name, $related_class, $their_fk_column|\%cond|\@cond|\&cond?, \%attrs?
=back
defaults to using C<$accessor_name> as the foreign key in C<$related_class> to
resolve the join, unless C<$their_fk_column> specifies the foreign key
column in C<$related_class> or C<cond> specifies a reference to a join
-condition hash.
+condition.
=over
=item cond
-A hashref where the keys are C<foreign.$their_fk_column> and
-the values are C<self.$matching_column>. This is useful for
-relations that are across multiple columns.
+A hashref, arrayref or coderef specifying a custom join expression. For
+more info see L<DBIx::Class::Relationship::Base/condition>.
=back
# Every book has exactly one ISBN
My::DBIC::Schema::Book->has_one(
- isbn =>
+ isbn =>
'My::DBIC::Schema::ISBN',
'book_id',
);
# OR (same result, assuming related_class stores our PK)
My::DBIC::Schema::Book->has_one(
- isbn =>
+ isbn =>
'My::DBIC::Schema::ISBN',
);
# OR (same result)
My::DBIC::Schema::Book->has_one(
- isbn =>
+ isbn =>
'My::DBIC::Schema::ISBN',
{ 'foreign.book_id' => 'self.id' },
);
C<might_have> is that C<has_one> uses an (ordinary) inner join,
whereas C<might_have> defaults to a left join.
-The has_one relationship should be used when a row in the table has exactly one
-related row in another table. If the related row might not exist in the foreign
-table, use the L<DBIx::Class::Relationship/might_have> relationship.
+The has_one relationship should be used when a row in the table must
+have exactly one related row in another table. If the related row
+might not exist in the foreign table, use the
+L<DBIx::Class::Relationship/might_have> relationship.
In the above example, each Book in the database is associated with exactly one
ISBN object.
-See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
-for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
-which can be assigned to relationships as well.
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on
+relationship methods and valid relationship attributes. Also see
+L<DBIx::Class::ResultSet> for a L<list of standard resultset
+attributes|DBIx::Class::ResultSet/ATTRIBUTES> which can be assigned to
+relationships as well.
Note that if you supply a condition on which to join, if the column in the
current table allows nulls (i.e., has the C<is_nullable> attribute set to a
C<many_to_many> is not strictly a relationship in its own right. Instead, it is
a bridge between two resultsets which provide the same kind of convenience
-accessors as true relationships provide. Although the accessor will return a
-resultset or collection of objects just like has_many does, you cannot call
+accessors as true relationships provide. Although the accessor will return a
+resultset or collection of objects just like has_many does, you cannot call
C<related_resultset> and similar methods which operate on true relationships.
=over
will be created for the Role class for the C<actors> many_to_many
relationship.
-See L<DBIx::Class::Relationship::Base> for documentation on relationship
-methods and valid relationship attributes. Also see L<DBIx::Class::ResultSet>
-for a L<list of standard resultset attributes|DBIx::Class::ResultSet/ATTRIBUTES>
-which can be assigned to relationships as well.
+See L<DBIx::Class::Relationship::Base/attributes> for documentation on
+relationship methods and valid relationship attributes. Also see
+L<DBIx::Class::ResultSet> for a L<list of standard resultset
+attributes|DBIx::Class::ResultSet/ATTRIBUTES> which can be assigned to
+relationships as well.
=cut
use warnings;
use Sub::Name ();
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::Accessor' => 'DBIx::Class::Relationship' }
);
return $self->{_relationship_data}{$rel};
} else {
my $cond = $self->result_source->_resolve_condition(
- $rel_info->{cond}, $rel, $self
+ $rel_info->{cond}, $rel, $self, $rel
);
if ($rel_info->{attrs}->{undef_on_null_fk}){
return undef unless ref($cond) eq 'HASH';
use strict;
use warnings;
-use Scalar::Util ();
use base qw/DBIx::Class/;
+use Scalar::Util qw/weaken blessed/;
+use Try::Tiny;
+use namespace::clean;
+
=head1 NAME
DBIx::Class::Relationship::Base - Inter-table relationships
=head1 SYNOPSIS
+ __PACKAGE__->add_relationship(
+ spiders => 'My::DB::Result::Creatures',
+ sub {
+ my $args = shift;
+ return {
+ "$args->{foreign_alias}.id" => { -ident => "$args->{self_alias}.id" },
+ "$args->{foreign_alias}.type" => 'arachnid'
+ };
+ },
+ );
+
=head1 DESCRIPTION
This class provides methods to describe the relationships between the
=over 4
-=item Arguments: 'relname', 'Foreign::Class', $cond, $attrs
+=item Arguments: 'relname', 'Foreign::Class', $condition, $attrs
=back
- __PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
+ __PACKAGE__->add_relationship('relname',
+ 'Foreign::Class',
+ $condition, $attrs);
+
+Create a custom relationship between one result source and another
+source, indicated by its class name.
=head3 condition
-The condition needs to be an L<SQL::Abstract>-style representation of the
-join between the tables. When resolving the condition for use in a C<JOIN>,
-keys using the pseudo-table C<foreign> are resolved to mean "the Table on the
-other side of the relationship", and values using the pseudo-table C<self>
-are resolved to mean "the Table this class is representing". Other
-restrictions, such as by value, sub-select and other tables, may also be
-used. Please check your database for C<JOIN> parameter support.
+The condition argument describes the C<ON> clause of the C<JOIN>
+expression used to connect the two sources when creating SQL queries.
+
+To create simple equality joins, supply a hashref containing the
+remote table column name as the key(s), and the local table column
+name as the value(s), for example given:
+
+ My::Schema::Author->has_many(
+ books => 'My::Schema::Book',
+ { 'foreign.author_id' => 'self.id' }
+ );
+
+A query like:
+
+ $author_rs->search_related('books')->next
+
+will result in the following C<JOIN> clause:
+
+ ... FROM author me LEFT JOIN book books ON books.author_id = me.id ...
+
+This describes a relationship between the C<Author> table and the
+C<Book> table where the C<Book> table has a column C<author_id>
+containing the ID value of the C<Author>.
+
+C<foreign> and C<self> are pseudo aliases and must be entered
+literally. They will be replaced with the actual correct table alias
+when the SQL is produced.
+
+Similarly:
+
+ My::Schema::Book->has_many(
+ editions => 'My::Schema::Edition',
+ {
+ 'foreign.publisher_id' => 'self.publisher_id',
+ 'foreign.type_id' => 'self.type_id',
+ }
+ );
+
+ ...
+
+ $book_rs->search_related('editions')->next
+
+will result in the C<JOIN> clause:
+
+ ... FROM book me
+ LEFT JOIN edition editions ON
+ editions.publisher_id = me.publisher_id
+ AND editions.type_id = me.type_id ...
+
+This describes the relationship from C<Book> to C<Edition>, where the
+C<Edition> table refers to a publisher and a type (e.g. "paperback"):
+
+As is the default in L<SQL::Abstract>, the key-value pairs will be
+C<AND>ed in the result. C<OR> can be achieved with an arrayref, for
+example a condition like:
+
+ My::Schema::Item->has_many(
+ related_item_links => My::Schema::Item::Links,
+ [
+ { 'foreign.left_itemid' => 'self.id' },
+ { 'foreign.right_itemid' => 'self.id' },
+ ],
+ );
-For example, if you're creating a relationship from C<Author> to C<Book>, where
-the C<Book> table has a column C<author_id> containing the ID of the C<Author>
-row:
+will translate to the following C<JOIN> clause:
- { 'foreign.author_id' => 'self.id' }
+ ... FROM item me JOIN item_relations related_item_links ON
+ related_item_links.left_itemid = me.id
+ OR related_item_links.right_itemid = me.id ...
-will result in the C<JOIN> clause
+This describes the relationship from C<Item> to C<Item::Links>, where
+C<Item::Links> is a many-to-many linking table, linking items back to
+themselves in a peer fashion (without a "parent-child" designation)
- author me JOIN book book ON book.author_id = me.id
+To specify joins which describe more than a simple equality of column
+values, the custom join condition coderef syntax can be used. For
+example:
-For multi-column foreign keys, you will need to specify a C<foreign>-to-C<self>
-mapping for each column in the key. For example, if you're creating a
-relationship from C<Book> to C<Edition>, where the C<Edition> table refers to a
-publisher and a type (e.g. "paperback"):
+ My::Schema::Artist->has_many(
+ cds_80s => 'My::Schema::CD',
+ sub {
+ my $args = shift;
- {
- 'foreign.publisher_id' => 'self.publisher_id',
- 'foreign.type_id' => 'self.type_id',
+ return {
+ "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
+ "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" },
+ };
+ }
+ );
+
+ ...
+
+ $artist_rs->search_related('cds_80s')->next;
+
+will result in the C<JOIN> clause:
+
+ ... FROM artist me LEFT JOIN cd cds_80s ON
+ cds_80s.artist = me.artistid
+ AND cds_80s.year < ?
+ AND cds_80s.year > ?
+
+with the bind values:
+
+ '1990', '1979'
+
+C<< $args->{foreign_alias} >> and C<< $args->{self_alias} >> are supplied the
+same values that would be otherwise substituted for C<foreign> and C<self>
+in the simple hashref syntax case.
+
+The coderef is expected to return a valid L<SQL::Abstract> query-structure, just
+like what one would supply as the first argument to
+L<DBIx::Class::ResultSet/search>. The return value will be passed directly to
+L<SQL::Abstract> and the resulting SQL will be used verbatim as the C<ON>
+clause of the C<JOIN> statement associated with this relationship.
+
+While every coderef-based condition must return a valid C<ON> clause, it may
+elect to additionally return a simplified join-free condition hashref when
+invoked as C<< $row_object->relationship >>, as opposed to
+C<< $rs->related_resultset('relationship') >>. In this case C<$row_object> is
+passed to the coderef as C<< $args->{self_rowobj} >>, so a user can do the
+following:
+
+ sub {
+ my $args = shift;
+
+ return (
+ {
+ "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
+ "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" },
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid,
+ "$args->{foreign_alias}.year" => { '>', "1979", '<', "1990" },
+ },
+ );
}
-This will result in the C<JOIN> clause:
+Now this code:
+
+ my $artist = $schema->resultset("Artist")->find({ id => 4 });
+ $artist->cds_80s->all;
+
+Can skip a C<JOIN> altogether and instead produce:
+
+ SELECT cds_80s.cdid, cds_80s.artist, cds_80s.title, cds_80s.year, cds_80s.genreid, cds_80s.single_track
+ FROM cd cds_80s
+ WHERE cds_80s.artist = ?
+ AND cds_80s.year < ?
+ AND cds_80s.year > ?
- book me JOIN edition edition ON edition.publisher_id = me.publisher_id
- AND edition.type_id = me.type_id
+With the bind values:
-Each key-value pair provided in a hashref will be used as C<AND>ed conditions.
-To add an C<OR>ed condition, use an arrayref of hashrefs. See the
-L<SQL::Abstract> documentation for more details.
+ '4', '1990', '1979'
+
+Note that in order to be able to use
+L<< $row->create_related|DBIx::Class::Relationship::Base/create_related >>,
+the coderef must not only return as its second such a "simple" condition
+hashref which does not depend on joins being available, but the hashref must
+contain only plain values/deflatable objects, such that the result can be
+passed directly to L<DBIx::Class::Relationship::Base/set_from_related>. For
+instance the C<year> constraint in the above example prevents the relationship
+from being used to to create related objects (an exception will be thrown).
+
+In order to allow the user to go truly crazy when generating a custom C<ON>
+clause, the C<$args> hashref passed to the subroutine contains some extra
+metadata. Currently the supplied coderef is executed as:
+
+ $relationship_info->{cond}->({
+ self_alias => The alias of the invoking resultset ('me' in case of a row object),
+ foreign_alias => The alias of the to-be-joined resultset (often matches relname),
+ self_resultsource => The invocant's resultsource,
+ foreign_relname => The relationship name (does *not* always match foreign_alias),
+ self_rowobj => The invocant itself in case of $row_obj->relationship
+ });
=head3 attributes
join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
command immediately before C<JOIN>.
-=item proxy
+=item proxy =E<gt> $column | \@columns | \%column
+
+=over 4
+
+=item \@columns
An arrayref containing a list of accessors in the foreign class to create in
the main class. If, for example, you do the following:
- MyDB::Schema::CD->might_have(liner_notes => 'MyDB::Schema::LinerNotes',
+ MyApp::Schema::CD->might_have(liner_notes => 'MyApp::Schema::LinerNotes',
undef, {
proxy => [ qw/notes/ ],
});
-Then, assuming MyDB::Schema::LinerNotes has an accessor named notes, you can do:
+Then, assuming MyApp::Schema::LinerNotes has an accessor named notes, you can do:
- my $cd = MyDB::Schema::CD->find(1);
+ my $cd = MyApp::Schema::CD->find(1);
$cd->notes('Notes go here'); # set notes -- LinerNotes object is
# created if it doesn't exist
+=item \%column
+
+A hashref where each key is the accessor you want installed in the main class,
+and its value is the name of the original in the fireign class.
+
+ MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', {
+ proxy => { cd_title => 'title' },
+ });
+
+This will create an accessor named C<cd_title> on the C<$track> row object.
+
+=back
+
+NOTE: you can pass a nested struct too, for example:
+
+ MyApp::Schema::Track->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', {
+ proxy => [ 'year', { cd_title => 'title' } ],
+ });
+
=item accessor
Specifies the type of accessor that should be created for the relationship.
=item is_foreign_key_constraint
If you are using L<SQL::Translator> to create SQL for you and you find that it
-is creating constraints where it shouldn't, or not creating them where it
+is creating constraints where it shouldn't, or not creating them where it
should, set this attribute to a true or false value to override the detection
of when to create constraints.
+=item cascade_copy
+
+If C<cascade_copy> is true on a C<has_many> relationship for an
+object, then when you copy the object all the related objects will
+be copied too. To turn this behaviour off, pass C<< cascade_copy => 0 >>
+in the C<$attr> hashref.
+
+The behaviour defaults to C<< cascade_copy => 1 >> for C<has_many>
+relationships.
+
+=item cascade_delete
+
+By default, DBIx::Class cascades deletes across C<has_many>,
+C<has_one> and C<might_have> relationships. You can disable this
+behaviour on a per-relationship basis by supplying
+C<< cascade_delete => 0 >> in the relationship attributes.
+
+The cascaded operations are performed after the requested delete,
+so if your database has a constraint on the relationship, it will
+have deleted/updated the related records or raised an exception
+before DBIx::Class gets to perform the cascaded operation.
+
+=item cascade_update
+
+By default, DBIx::Class cascades updates across C<has_one> and
+C<might_have> relationships. You can disable this behaviour on a
+per-relationship basis by supplying C<< cascade_update => 0 >> in
+the relationship attributes.
+
+This is not a RDMS style cascade update - it purely means that when
+an object has update called on it, all the related objects also
+have update called. It will not change foreign keys automatically -
+you must arrange to do this yourself.
+
=item on_delete / on_update
If you are using L<SQL::Translator> to create SQL for you, you can use these
-attributes to explicitly set the desired C<ON DELETE> or C<ON UPDATE> constraint
-type. If not supplied the SQLT parser will attempt to infer the constraint type by
+attributes to explicitly set the desired C<ON DELETE> or C<ON UPDATE> constraint
+type. If not supplied the SQLT parser will attempt to infer the constraint type by
interrogating the attributes of the B<opposite> relationship. For any 'multi'
-relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to
-relationship will be created with an C<ON DELETE CASCADE> constraint. For any
+relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to
+relationship will be created with an C<ON DELETE CASCADE> constraint. For any
relationship bearing C<< cascade_copy => 1 >> the resulting belongs_to constraint
will be C<ON UPDATE CASCADE>. If you wish to disable this autodetection, and just
-use the RDBMS' default constraint type, pass C<< on_delete => undef >> or
+use the RDBMS' default constraint type, pass C<< on_delete => undef >> or
C<< on_delete => '' >>, and the same for C<on_update> respectively.
=item is_deferrable
# condition resolution may fail if an incomplete master-object prefetch
# is encountered - that is ok during prefetch construction (not yet in_storage)
- my $cond = eval { $source->_resolve_condition( $rel_info->{cond}, $rel, $self ) };
- if (my $err = $@) {
+ my ($cond, $is_crosstable) = try {
+ $source->_resolve_condition( $rel_info->{cond}, $rel, $self, $rel )
+ }
+ catch {
if ($self->in_storage) {
- $self->throw_exception ($err);
+ $self->throw_exception ($_);
}
- else {
- $cond = $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION;
- }
- }
- if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
- my $reverse = $source->reverse_relationship_info($rel);
- foreach my $rev_rel (keys %$reverse) {
- if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
- $attrs->{related_objects}{$rev_rel} = [ $self ];
- Scalar::Util::weaken($attrs->{related_object}{$rev_rel}[0]);
- } else {
- $attrs->{related_objects}{$rev_rel} = $self;
- Scalar::Util::weaken($attrs->{related_object}{$rev_rel});
+ $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION; # RV
+ };
+
+ # keep in mind that the following if() block is part of a do{} - no return()s!!!
+ if ($is_crosstable) {
+ $self->throw_exception (
+ "A cross-table relationship condition returned for statically declared '$rel'")
+ unless ref $rel_info->{cond} eq 'CODE';
+
+ # A WHOREIFFIC hack to reinvoke the entire condition resolution
+ # with the correct alias. Another way of doing this involves a
+ # lot of state passing around, and the @_ positions are already
+ # mapped out, making this crap a less icky option.
+ #
+ # The point of this exercise is to retain the spirit of the original
+ # $obj->search_related($rel) where the resulting rset will have the
+ # root alias as 'me', instead of $rel (as opposed to invoking
+ # $rs->search_related)
+
+ local $source->{_relationships}{me} = $source->{_relationships}{$rel}; # make the fake 'me' rel
+ my $obj_table_alias = lc($source->source_name) . '__row';
+ $obj_table_alias =~ s/\W+/_/g;
+
+ $source->resultset->search(
+ $self->ident_condition($obj_table_alias),
+ { alias => $obj_table_alias },
+ )->search_related('me', $query, $attrs)
+ }
+ else {
+ # FIXME - this conditional doesn't seem correct - got to figure out
+ # at some point what it does. Also the entire UNRESOLVABLE_CONDITION
+ # business seems shady - we could simply not query *at all*
+ if ($cond eq $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION) {
+ my $reverse = $source->reverse_relationship_info($rel);
+ foreach my $rev_rel (keys %$reverse) {
+ if ($reverse->{$rev_rel}{attrs}{accessor} && $reverse->{$rev_rel}{attrs}{accessor} eq 'multi') {
+ weaken($attrs->{related_objects}{$rev_rel}[0] = $self);
+ } else {
+ weaken($attrs->{related_objects}{$rev_rel} = $self);
+ }
}
}
- }
- if (ref $cond eq 'ARRAY') {
- $cond = [ map {
- if (ref $_ eq 'HASH') {
- my $hash;
- foreach my $key (keys %$_) {
- my $newkey = $key !~ /\./ ? "me.$key" : $key;
- $hash->{$newkey} = $_->{$key};
+ elsif (ref $cond eq 'ARRAY') {
+ $cond = [ map {
+ if (ref $_ eq 'HASH') {
+ my $hash;
+ foreach my $key (keys %$_) {
+ my $newkey = $key !~ /\./ ? "me.$key" : $key;
+ $hash->{$newkey} = $_->{$key};
+ }
+ $hash;
+ } else {
+ $_;
}
- $hash;
- } else {
- $_;
+ } @$cond ];
+ }
+ elsif (ref $cond eq 'HASH') {
+ foreach my $key (grep { ! /\./ } keys %$cond) {
+ $cond->{"me.$key"} = delete $cond->{$key};
}
- } @$cond ];
- } elsif (ref $cond eq 'HASH') {
- foreach my $key (grep { ! /\./ } keys %$cond) {
- $cond->{"me.$key"} = delete $cond->{$key};
}
+
+ $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
+ $self->result_source->related_source($rel)->resultset->search(
+ $query, $attrs
+ );
}
- $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
- $self->result_source->related_source($rel)->resultset->search(
- $query, $attrs
- );
};
}
( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs);
-This method works exactly the same as search_related, except that
+This method works exactly the same as search_related, except that
it guarantees a resultset, even in list context.
=cut
my $new_obj = $obj->new_related('relname', \%col_data);
Create a new item of the related foreign class. If called on a
-L<Row|DBIx::Class::Manual::Glossary/"Row"> object, it will magically
-set any foreign key columns of the new object to the related primary
-key columns of the source object for you. The newly created item will
+L<Row|DBIx::Class::Manual::Glossary/"Row"> object, it will magically
+set any foreign key columns of the new object to the related primary
+key columns of the source object for you. The newly created item will
not be saved into your storage until you call L<DBIx::Class::Row/insert>
on it.
sub new_related {
my ($self, $rel, $values, $attrs) = @_;
- return $self->search_related($rel)->new($values, $attrs);
+
+ # FIXME - this is a bad position for this (also an identical copy in
+ # set_from_related), but I have no saner way to hook, and I absolutely
+ # want this to throw at least for coderefs, instead of the "insert a NULL
+ # when it gets hard" insanity --ribasushi
+ #
+ # sanity check - currently throw when a complex coderef rel is encountered
+ # FIXME - should THROW MOAR!
+
+ if (ref $self) { # cdbi calls this as a class method, /me vomits
+
+ my $rsrc = $self->result_source;
+ my (undef, $crosstable, $relcols) = $rsrc->_resolve_condition (
+ $rsrc->relationship_info($rel)->{cond}, $rel, $self, $rel
+ );
+
+ $self->throw_exception("Custom relationship '$rel' does not resolve to a join-free condition fragment")
+ if $crosstable;
+
+ if (@{$relcols || []} and @$relcols = grep { ! exists $values->{$_} } @$relcols) {
+ $self->throw_exception(sprintf (
+ "Custom relationship '%s' not definitive - returns conditions instead of values for column(s): %s",
+ $rel,
+ map { "'$_'" } @$relcols
+ ));
+ }
+ }
+
+ my $row = $self->search_related($rel)->new($values, $attrs);
+ return $row;
}
=head2 create_related
sub create_related {
my $self = shift;
my $rel = shift;
- my $obj = $self->search_related($rel)->create(@_);
+ my $obj = $self->new_related($rel, @_)->insert;
delete $self->{related_resultsets}->{$rel};
return $obj;
}
sub set_from_related {
my ($self, $rel, $f_obj) = @_;
- my $rel_info = $self->relationship_info($rel);
- $self->throw_exception( "No such relationship ${rel}" ) unless $rel_info;
- my $cond = $rel_info->{cond};
- $self->throw_exception(
- "set_from_related can only handle a hash condition; the ".
- "condition for $rel is of type ".
- (ref $cond ? ref $cond : 'plain scalar')
- ) unless ref $cond eq 'HASH';
+
+ my $rsrc = $self->result_source;
+ my $rel_info = $rsrc->relationship_info($rel)
+ or $self->throw_exception( "No such relationship ${rel}" );
+
if (defined $f_obj) {
my $f_class = $rel_info->{class};
$self->throw_exception( "Object $f_obj isn't a ".$f_class )
- unless Scalar::Util::blessed($f_obj) and $f_obj->isa($f_class);
+ unless blessed $f_obj and $f_obj->isa($f_class);
}
- $self->set_columns(
- $self->result_source->_resolve_condition(
- $rel_info->{cond}, $f_obj, $rel));
+
+
+ # FIXME - this is a bad position for this (also an identical copy in
+ # new_related), but I have no saner way to hook, and I absolutely
+ # want this to throw at least for coderefs, instead of the "insert a NULL
+ # when it gets hard" insanity --ribasushi
+ #
+ # sanity check - currently throw when a complex coderef rel is encountered
+ # FIXME - should THROW MOAR!
+ my ($cond, $crosstable, $relcols) = $rsrc->_resolve_condition (
+ $rel_info->{cond}, $f_obj, $rel, $rel
+ );
+ $self->throw_exception("Custom relationship '$rel' does not resolve to a join-free condition fragment")
+ if $crosstable;
+ $self->throw_exception(sprintf (
+ "Custom relationship '%s' not definitive - returns conditions instead of values for column(s): %s",
+ $rel,
+ map { "'$_'" } @$relcols
+ )) if @{$relcols || []};
+
+ $self->set_columns($cond);
+
return 1;
}
=back
my $actor = $schema->resultset('Actor')->find(1);
- my @roles = $schema->resultset('Role')->search({ role =>
+ my @roles = $schema->resultset('Role')->search({ role =>
{ '-in' => ['Fred', 'Barney'] } } );
$actor->set_roles(\@roles);
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::BelongsTo' => 'DBIx::Class::Relationship' }
);
my ($class, $rel, $f_class, $cond, $attrs) = @_;
# assume a foreign key contraint unless defined otherwise
- $attrs->{is_foreign_key_constraint} = 1
+ $attrs->{is_foreign_key_constraint} = 1
if not exists $attrs->{is_foreign_key_constraint};
$attrs->{undef_on_null_fk} = 1
if not exists $attrs->{undef_on_null_fk};
# no join condition or just a column name
if (!ref $cond) {
$class->ensure_class_loaded($f_class);
- my %f_primaries = map { $_ => 1 } eval { $f_class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition for ${rel} on ${class}: $@"
- ) if $@;
+ my %f_primaries = map { $_ => 1 } try { $f_class->_pri_cols }
+ catch {
+ $class->throw_exception( "Can't infer join condition for ${rel} on ${class}: $_");
+ };
my ($pri, $too_many) = keys %f_primaries;
$class->throw_exception(
"$fk is not a column of $class"
) unless $class->has_column($fk);
- my $acc_type = $class->has_column($rel) ? 'filter' : 'single';
- $class->add_relationship($rel, $f_class,
- { "foreign.${pri}" => "self.${fk}" },
- { accessor => $acc_type, %{$attrs || {}} }
- );
+ $cond = { "foreign.${pri}" => "self.${fk}" };
+
}
# explicit join condition
elsif (ref $cond) {
}
$cond = $cond_rel;
}
- my $acc_type = ((ref $cond eq 'HASH')
- && keys %$cond == 1
- && $class->has_column($rel))
- ? 'filter'
- : 'single';
- $class->add_relationship($rel, $f_class,
- $cond,
- { accessor => $acc_type, %{$attrs || {}} }
- );
}
+ # dunno
else {
$class->throw_exception(
'third argument for belongs_to must be undef, a column name, '.
'or a join condition'
);
}
+
+ my $acc_type = (
+ ref $cond eq 'HASH'
+ and
+ keys %$cond == 1
+ and
+ $class->has_column($rel)
+ ) ? 'filter' : 'single';
+
+ my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH')
+ ? { map { $_ =~ /^self\.(.+)/ ? ( $1 => 1 ) : () } (values %$cond ) }
+ : undef
+ ;
+
+ $class->add_relationship($rel, $f_class,
+ $cond,
+ {
+ accessor => $acc_type,
+ $fk_columns ? ( fk_columns => $fk_columns ) : (),
+ %{$attrs || {}}
+ }
+ );
+
return 1;
}
use strict;
use warnings;
+use DBIx::Class::Carp;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::CascadeActions' => 'DBIx::Class::Relationship' }
);
# be handling this anyway. Assuming we have joins we probably actually
# *could* do them, but I'd rather not.
- my $ret = $self->next::method(@rest);
-
my $source = $self->result_source;
my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
- foreach my $rel (@cascade) {
- $self->search_related($rel)->delete_all;
+
+ if (@cascade) {
+ my $guard = $source->schema->txn_scope_guard;
+
+ my $ret = $self->next::method(@rest);
+
+ foreach my $rel (@cascade) {
+ if( my $rel_rs = eval{ $self->search_related($rel) } ) {
+ $rel_rs->delete_all;
+ } else {
+ carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
+ next;
+ }
+ }
+
+ $guard->commit;
+ return $ret;
}
- return $ret;
+
+ $self->next::method(@rest);
}
sub update {
return $self->next::method(@rest) unless ref $self;
# Because update cascades on a class *really* don't make sense!
- my $ret = $self->next::method(@rest);
-
my $source = $self->result_source;
my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
- foreach my $rel (@cascade) {
- next if (
- $rels{$rel}{attrs}{accessor}
- &&
- $rels{$rel}{attrs}{accessor} eq 'single'
- &&
- !exists($self->{_relationship_data}{$rel})
- );
- $_->update for grep defined, $self->$rel;
+
+ if (@cascade) {
+ my $guard = $source->schema->txn_scope_guard;
+
+ my $ret = $self->next::method(@rest);
+
+ foreach my $rel (@cascade) {
+ next if (
+ $rels{$rel}{attrs}{accessor}
+ &&
+ $rels{$rel}{attrs}{accessor} eq 'single'
+ &&
+ !exists($self->{_relationship_data}{$rel})
+ );
+ $_->update for grep defined, $self->$rel;
+ }
+
+ $guard->commit;
+ return $ret;
}
- return $ret;
+
+ $self->next::method(@rest);
}
1;
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::HasMany' => 'DBIx::Class::Relationship' }
);
unless (ref $cond) {
$class->ensure_class_loaded($f_class);
- my ($pri, $too_many) = eval { $class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition for ${rel} on ${class}: $@"
- ) if $@;
+ my ($pri, $too_many) = try { $class->_pri_cols }
+ catch {
+ $class->throw_exception("Can't infer join condition for ${rel} on ${class}: $_");
+ };
$class->throw_exception(
"has_many can only infer join for a single primary key; ".
$guess = "using our class name '$class' as foreign key";
}
- my $f_class_loaded = eval { $f_class->columns };
+ my $f_class_loaded = try { $f_class->columns };
$class->throw_exception(
"No such column ${f_key} on foreign class ${f_class} ($guess)"
) if $f_class_loaded && !$f_class->has_column($f_key);
$cond = { "foreign.${f_key}" => "self.${pri}" };
}
+ my $default_cascade = ref $cond eq 'CODE' ? 0 : 1;
+
$class->add_relationship($rel, $f_class, $cond, {
accessor => 'multi',
join_type => 'LEFT',
- cascade_delete => 1,
- cascade_copy => 1,
+ cascade_delete => $default_cascade,
+ cascade_copy => $default_cascade,
%{$attrs||{}}
});
}
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
+use Try::Tiny;
+use namespace::clean;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::HasOne' => 'DBIx::Class::Relationship' }
);
"${class} has none"
) if !defined $pri && (!defined $cond || !length $cond);
- my $f_class_loaded = eval { $f_class->columns };
+ my $f_class_loaded = try { $f_class->columns };
my ($f_key,$too_many,$guess);
if (defined $cond && length $cond) {
$f_key = $cond;
) if $f_class_loaded && !$f_class->has_column($f_key);
$cond = { "foreign.${f_key}" => "self.${pri}" };
}
- $class->_validate_cond($cond);
+ $class->_validate_has_one_condition($cond);
+
+ my $default_cascade = ref $cond eq 'CODE' ? 0 : 1;
+
$class->add_relationship($rel, $f_class,
$cond,
{ accessor => 'single',
- cascade_update => 1, cascade_delete => 1,
+ cascade_update => $default_cascade,
+ cascade_delete => $default_cascade,
($join_type ? ('join_type' => $join_type) : ()),
%{$attrs || {}} });
1;
sub _get_primary_key {
my ( $class, $target_class ) = @_;
$target_class ||= $class;
- my ($pri, $too_many) = eval { $target_class->_pri_cols };
- $class->throw_exception(
- "Can't infer join condition on ${target_class}: $@"
- ) if $@;
+ my ($pri, $too_many) = try { $target_class->_pri_cols }
+ catch {
+ $class->throw_exception("Can't infer join condition on ${target_class}: $_");
+ };
$class->throw_exception(
"might_have/has_one can only infer join for a single primary key; ".
return $pri;
}
-sub _validate_cond {
+sub _validate_has_one_condition {
my ($class, $cond ) = @_;
return if $ENV{DBIC_DONT_VALIDATE_RELS};
# warning
return unless $self_id =~ /^self\.(.*)$/;
my $key = $1;
+ $class->throw_exception("Defining rel on ${class} that includes ${key} but no such column defined here yet")
+ unless $class->has_column($key);
my $column_info = $class->column_info($key);
if ( $column_info->{is_nullable} ) {
carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.');
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
-use Sub::Name ();
+use DBIx::Class::Carp;
+use Sub::Name qw/subname/;
+use Scalar::Util qw/blessed/;
-our %_pod_inherit_config =
+use namespace::clean;
+
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
);
$rel_attrs->{alias} ||= $f_rel;
my $rs_meth_name = join '::', $class, $rs_meth;
- *$rs_meth_name = Sub::Name::subname $rs_meth_name, sub {
+ *$rs_meth_name = subname $rs_meth_name, sub {
my $self = shift;
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
};
my $meth_name = join '::', $class, $meth;
- *$meth_name = Sub::Name::subname $meth_name, sub {
+ *$meth_name = subname $meth_name, sub {
my $self = shift;
my $rs = $self->$rs_meth( @_ );
return (wantarray ? $rs->all : $rs);
};
my $add_meth_name = join '::', $class, $add_meth;
- *$add_meth_name = Sub::Name::subname $add_meth_name, sub {
+ *$add_meth_name = subname $add_meth_name, sub {
my $self = shift;
@_ > 0 or $self->throw_exception(
"${add_meth} needs an object or hashref"
};
my $set_meth_name = join '::', $class, $set_meth;
- *$set_meth_name = Sub::Name::subname $set_meth_name, sub {
+ *$set_meth_name = subname $set_meth_name, sub {
my $self = shift;
@_ > 0 or $self->throw_exception(
"{$set_meth} needs a list of objects or hashrefs"
};
my $remove_meth_name = join '::', $class, $remove_meth;
- *$remove_meth_name = Sub::Name::subname $remove_meth_name, sub {
- my $self = shift;
- @_ > 0 && ref $_[0] ne 'HASH'
- or $self->throw_exception("${remove_meth} needs an object");
- my $obj = shift;
+ *$remove_meth_name = subname $remove_meth_name, sub {
+ my ($self, $obj) = @_;
+ $self->throw_exception("${remove_meth} needs an object")
+ unless blessed ($obj);
my $rel_source = $self->search_related($rel)->result_source;
my $cond = $rel_source->relationship_info($f_rel)->{cond};
- my $link_cond = $rel_source->_resolve_condition(
- $cond, $obj, $f_rel
+ my ($link_cond, $crosstable) = $rel_source->_resolve_condition(
+ $cond, $obj, $f_rel, $f_rel
);
+
+ $self->throw_exception(
+ "Custom relationship '$rel' does not resolve to a join-free condition, "
+ ."unable to use with the ManyToMany helper '$f_rel'"
+ ) if $crosstable;
+
$self->search_related($rel, $link_cond)->delete;
};
use Sub::Name ();
use base qw/DBIx::Class/;
-our %_pod_inherit_config =
+our %_pod_inherit_config =
(
class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' }
);
sub register_relationship {
my ($class, $rel, $info) = @_;
- if (my $proxy_list = $info->{attrs}{proxy}) {
- $class->proxy_to_related($rel,
- (ref $proxy_list ? @$proxy_list : $proxy_list));
+ if (my $proxy_args = $info->{attrs}{proxy}) {
+ $class->proxy_to_related($rel, $proxy_args);
}
$class->next::method($rel, $info);
}
sub proxy_to_related {
- my ($class, $rel, @proxy) = @_;
+ my ($class, $rel, $proxy_args) = @_;
+ my %proxy_map = $class->_build_proxy_map_from($proxy_args);
no strict 'refs';
no warnings 'redefine';
- foreach my $proxy (@proxy) {
- my $name = join '::', $class, $proxy;
- *$name = Sub::Name::subname $name,
- sub {
- my $self = shift;
- my $val = $self->$rel;
- if (@_ && !defined $val) {
- $val = $self->create_related($rel, { $proxy => $_[0] });
- @_ = ();
- }
- return ($val ? $val->$proxy(@_) : undef);
- }
+ foreach my $meth_name ( keys %proxy_map ) {
+ my $proxy_to_col = $proxy_map{$meth_name};
+ my $name = join '::', $class, $meth_name;
+ *$name = Sub::Name::subname $name => sub {
+ my $self = shift;
+ my $relobj = $self->$rel;
+ if (@_ && !defined $relobj) {
+ $relobj = $self->create_related($rel, { $proxy_to_col => $_[0] });
+ @_ = ();
+ }
+ return ($relobj ? $relobj->$proxy_to_col(@_) : undef);
+ }
+ }
+}
+
+sub _build_proxy_map_from {
+ my ( $class, $proxy_arg ) = @_;
+ my $ref = ref $proxy_arg;
+
+ if ($ref eq 'HASH') {
+ return %$proxy_arg;
+ }
+ elsif ($ref eq 'ARRAY') {
+ return map {
+ (ref $_ eq 'HASH')
+ ? (%$_)
+ : ($_ => $_)
+ } @$proxy_arg;
+ }
+ elsif ($ref) {
+ $class->throw_exception("Unable to process the 'proxy' argument $proxy_arg");
+ }
+ else {
+ return ( $proxy_arg => $proxy_arg );
}
}
my $rs = $schema->resultset('CD');
$rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
while (my $hashref = $rs->next) {
- ...
+ ...
+ }
+
+ OR as an attribute:
+
+ my $rs = $schema->resultset('CD')->search({}, {
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ });
+ while (my $hashref = $rs->next) {
+ ...
}
=head1 DESCRIPTION
-DBIx::Class is faster than older ORMs like Class::DBI but it still isn't
+DBIx::Class is faster than older ORMs like Class::DBI but it still isn't
designed primarily for speed. Sometimes you need to quickly retrieve the data
from a massive resultset, while skipping the creation of fancy row objects.
Specifying this class as a C<result_class> for a resultset will change C<< $rs->next >>
#
# Generally people use this to gain as much speed as possible. If a new &mk_hash is
# implemented, it should be benchmarked using the maint/benchmark_hashrefinflator.pl
-# script (in addition to passing all tests of course :). Additional instructions are
-# provided in the script itself.
-#
+# script (in addition to passing all tests of course :)
# This coderef is a simple recursive function
-# Arguments: ($me, $prefetch) from inflate_result() below
+# Arguments: ($me, $prefetch, $is_root) from inflate_result() below
my $mk_hash;
$mk_hash = sub {
- if (ref $_[0] eq 'ARRAY') { # multi relationship
- return [ map { $mk_hash->(@$_) || () } (@_) ];
- }
- else {
- my $hash = {
- # the main hash could be an undef if we are processing a skipped-over join
- $_[0] ? %{$_[0]} : (),
-
- # the second arg is a hash of arrays for each prefetched relation
- map
- { $_ => $mk_hash->( @{$_[1]->{$_}} ) }
- ( $_[1] ? (keys %{$_[1]}) : () )
- };
-
- # if there is at least one defined column consider the resultset real
- # (and not an emtpy has_many rel containing one empty hashref)
- # an empty arrayref is an empty multi-sub-prefetch - don't consider
- # those either
- for (values %$hash) {
- if (ref $_ eq 'ARRAY') {
- return $hash if @$_;
- }
- elsif (defined $_) {
- return $hash;
- }
- }
-
- return undef;
- }
+
+ my $hash = {
+ # the main hash could be an undef if we are processing a skipped-over join
+ $_[0] ? %{$_[0]} : (),
+
+ # the second arg is a hash of arrays for each prefetched relation
+ map {
+ ref $_[1]->{$_}[0] eq 'ARRAY' # multi rel or not?
+ ? ( $_ => [ map
+ { $mk_hash->(@$_) || () }
+ @{$_[1]->{$_}}
+ ] )
+ : ( $_ => $mk_hash->( @{$_[1]->{$_}} ) )
+
+ } ( $_[1] ? ( keys %{$_[1]} ) : () )
+ };
+
+ # if there is at least one defined column *OR* we are at the root of
+ # the resultset - consider the result real (and not an emtpy has_many
+ # rel containing one empty hashref)
+ # an empty arrayref is an empty multi-sub-prefetch - don't consider
+ # those either
+ return $hash if $_[2];
+
+ for (values %$hash) {
+ return $hash if (
+ defined $_
+ and
+ (ref $_ ne 'ARRAY' or scalar @$_)
+ );
+ }
+
+ return undef;
};
=head1 METHODS
# inflate_result is invoked as:
# HRI->inflate_result ($resultsource_instance, $main_data_hashref, $prefetch_data_hashref)
sub inflate_result {
- return $mk_hash->($_[2], $_[3]);
+ return $mk_hash->($_[2], $_[3], 'is_root');
}
my $cds = $artist->cds;
$cds->result_class('DBIx::Class::ResultClass::HashRefInflator');
- my $first = $cds->first;
+ my $first = $cds->first;
-C<$first> will B<not> be a hashref, it will be a normal CD row since
+C<$first> will B<not> be a hashref, it will be a normal CD row since
HashRefInflator only affects resultsets at inflation time, and prefetch causes
relations to be inflated when the master C<$artist> row is inflated.
use strict;
use warnings;
-use overload
- '0+' => "count",
- 'bool' => "_bool",
- fallback => 1;
-use Carp::Clan qw/^DBIx::Class/;
+use base qw/DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
-use Data::Page;
-use Storable;
use DBIx::Class::ResultSetColumn;
-use DBIx::Class::ResultSourceHandle;
+use Scalar::Util qw/blessed weaken/;
+use Try::Tiny;
+use Data::Compare (); # no imports!!! guard against insane architecture
+
+# not importing first() as it will clash with our own method
use List::Util ();
-use Scalar::Util ();
-use base qw/DBIx::Class/;
+BEGIN {
+ # De-duplication in _merge_attr() is disabled, but left in for reference
+ # (the merger is used for other things that ought not to be de-duped)
+ *__HM_DEDUP = sub () { 0 };
+}
-#use Test::Deep::NoTest (qw/eq_deeply/);
-use Data::Dumper::Concise;
+use namespace::clean;
-__PACKAGE__->mk_group_accessors('simple' => qw/_result_class _source_handle/);
+use overload
+ '0+' => "count",
+ 'bool' => "_bool",
+ fallback => 1;
+
+__PACKAGE__->mk_group_accessors('simple' => qw/_result_class result_source/);
=head1 NAME
=head1 SYNOPSIS
my $users_rs = $schema->resultset('User');
+ while( $user = $users_rs->next) {
+ print $user->username;
+ }
+
my $registered_users_rs = $schema->resultset('User')->search({ registered => 1 });
my @cds_in_2005 = $schema->resultset('CD')->search({ year => 2005 })->all();
The query that the ResultSet represents is B<only> executed against
the database when these methods are called:
-L</find> L</next> L</all> L</first> L</single> L</count>
+L</find>, L</next>, L</all>, L</first>, L</single>, L</count>.
+
+If a resultset is used in a numeric context it returns the L</count>.
+However, if it is used in a boolean context it is B<always> true. So if
+you want to check if a resultset has any results, you must use C<if $rs
+!= 0>.
+
+=head1 CUSTOM ResultSet CLASSES THAT USE Moose
+
+If you want to make your custom ResultSet classes with L<Moose>, use a template
+similar to:
+
+ package MyApp::Schema::ResultSet::User;
+
+ use Moose;
+ use namespace::autoclean;
+ use MooseX::NonMoose;
+ extends 'DBIx::Class::ResultSet';
+
+ sub BUILDARGS { $_[2] }
+
+ ...your code...
+
+ __PACKAGE__->meta->make_immutable;
+
+ 1;
+
+The L<MooseX::NonMoose> is necessary so that the L<Moose> constructor does not
+clash with the regular ResultSet constructor. Alternatively, you can use:
+
+ __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
+The L<BUILDARGS|Moose::Manual::Construction/BUILDARGS> is necessary because the
+signature of the ResultSet C<new> is C<< ->new($source, \%args) >>.
=head1 EXAMPLES
sub get_data {
my $self = shift;
my $request = $self->get_request; # Get a request object somehow.
- my $schema = $self->get_schema; # Get the DBIC schema object somehow.
+ my $schema = $self->result_source->schema;
my $cd_rs = $schema->resultset('CD')->search({
title => $request->param('title'),
year => $request->param('year'),
});
- $self->apply_security_policy( $cd_rs );
+ $cd_rs = $self->apply_security_policy( $cd_rs );
return $cd_rs->all();
}
L</join>, L</prefetch>, L</+select>, L</+as> attributes are merged
into the existing ones from the original resultset.
-The L</where>, L</having> attribute, and any search conditions are
+The L</where> and L</having> attributes, and any search conditions, are
merged with an SQL C<AND> to the existing condition from the original
resultset.
See: L</search>, L</count>, L</get_column>, L</all>, L</create>.
-=head1 OVERLOADING
-
-If a resultset is used in a numeric context it returns the L</count>.
-However, if it is used in a boolean context it is always true. So if
-you want to check if a resultset has any results use C<if $rs != 0>.
-C<if $rs> will always be true.
-
=head1 METHODS
=head2 new
return $class->new_result(@_) if ref $class;
my ($source, $attrs) = @_;
- $source = $source->handle
- unless $source->isa('DBIx::Class::ResultSourceHandle');
+ $source = $source->resolve
+ if $source->isa('DBIx::Class::ResultSourceHandle');
$attrs = { %{$attrs||{}} };
if ($attrs->{page}) {
$attrs->{alias} ||= 'me';
- # Creation of {} and bless separated to mitigate RH perl bug
- # see https://bugzilla.redhat.com/show_bug.cgi?id=196836
- my $self = {
- _source_handle => $source,
+ my $self = bless {
+ result_source => $source,
cond => $attrs->{where},
- count => undef,
pager => undef,
- attrs => $attrs
- };
+ attrs => $attrs,
+ }, $class;
- bless $self, $class;
+ # if there is a dark selector, this means we are already in a
+ # chain and the cleanup/sanification was taken care of by
+ # _search_rs already
+ $self->_normalize_selection($attrs)
+ unless $attrs->{_dark_selector};
$self->result_class(
- $attrs->{result_class} || $source->resolve->result_class
+ $attrs->{result_class} || $source->result_class
);
- return $self;
+ $self;
}
=head2 search
=item Arguments: $cond, \%attrs?
-=item Return Value: $resultset (scalar context), @row_objs (list context)
+=item Return Value: $resultset (scalar context) || @row_objs (list context)
=back
my $new_rs = $cd_rs->search([ { year => 2005 }, { year => 2004 } ]);
# year = 2005 OR year = 2004
+In list context, C<< ->all() >> is called implicitly on the resultset, thus
+returning a list of row objects instead. To avoid that, use L</search_rs>.
+
If you need to pass in additional attributes but no additional condition,
call it as C<search(undef, \%attrs)>.
For a list of attributes that can be passed to C<search>, see
L</ATTRIBUTES>. For more examples of using this function, see
L<Searching|DBIx::Class::Manual::Cookbook/Searching>. For a complete
-documentation for the first argument, see L<SQL::Abstract>.
+documentation for the first argument, see L<SQL::Abstract>
+and its extension L<DBIx::Class::SQLMaker>.
For more help on using joins with search, see L<DBIx::Class::Manual::Joining>.
+=head3 CAVEAT
+
+Note that L</search> does not process/deflate any of the values passed in the
+L<SQL::Abstract>-compatible search condition structure. This is unlike other
+condition-bound methods L</new>, L</create> and L</find>. The user must ensure
+manually that any value passed to this method will stringify to something the
+RDBMS knows how to deal with. A notable example is the handling of L<DateTime>
+objects, for more info see:
+L<DBIx::Class::Manual::Cookbook/Formatting DateTime objects in queries>.
+
=cut
sub search {
my $self = shift;
my $rs = $self->search_rs( @_ );
- return (wantarray ? $rs->all : $rs);
+
+ if (wantarray) {
+ return $rs->all;
+ }
+ elsif (defined wantarray) {
+ return $rs;
+ }
+ else {
+ # we can be called by a relationship helper, which in
+ # turn may be called in void context due to some braindead
+ # overload or whatever else the user decided to be clever
+ # at this particular day. Thus limit the exception to
+ # external code calls only
+ $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
+ if (caller)[0] !~ /^\QDBIx::Class::/;
+
+ return ();
+ }
}
=head2 search_rs
# Special-case handling for (undef, undef).
if ( @_ == 2 && !defined $_[1] && !defined $_[0] ) {
- pop(@_); pop(@_);
+ @_ = ();
}
- my $attrs = {};
- $attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH';
- my $our_attrs = { %{$self->{attrs}} };
- my $having = delete $our_attrs->{having};
- my $where = delete $our_attrs->{where};
-
- my $rows;
+ my $call_attrs = {};
+ if (@_ > 1) {
+ if (ref $_[-1] eq 'HASH') {
+ # copy for _normalize_selection
+ $call_attrs = { %{ pop @_ } };
+ }
+ elsif (! defined $_[-1] ) {
+ pop @_; # search({}, undef)
+ }
+ }
+ # see if we can keep the cache (no $rs changes)
+ my $cache;
my %safe = (alias => 1, cache => 1);
+ if ( ! List::Util::first { !$safe{$_} } keys %$call_attrs and (
+ ! defined $_[0]
+ or
+ ref $_[0] eq 'HASH' && ! keys %{$_[0]}
+ or
+ ref $_[0] eq 'ARRAY' && ! @{$_[0]}
+ )) {
+ $cache = $self->get_cache;
+ }
- unless (
- (@_ && defined($_[0])) # @_ == () or (undef)
- ||
- (keys %$attrs # empty attrs or only 'safe' attrs
- && List::Util::first { !$safe{$_} } keys %$attrs)
- ) {
- # no search, effectively just a clone
- $rows = $self->get_cache;
- }
-
- # reset the selector list
- if (List::Util::first { exists $attrs->{$_} } qw{columns select as}) {
- delete @{$our_attrs}{qw{select as columns +select +as +columns include_columns}};
- }
-
- my $new_attrs = { %{$our_attrs}, %{$attrs} };
-
- # merge new attrs into inherited
- foreach my $key (qw/join prefetch +select +as +columns include_columns bind/) {
- next unless exists $attrs->{$key};
- $new_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key});
- }
-
- my $cond = (@_
- ? (
- (@_ == 1 || ref $_[0] eq "HASH")
- ? (
- (ref $_[0] eq 'HASH')
- ? (
- (keys %{ $_[0] } > 0)
- ? shift
- : undef
- )
- : shift
- )
- : (
- (@_ % 2)
- ? $self->throw_exception("Odd number of arguments to search")
- : {@_}
- )
- )
- : undef
- );
+ my $rsrc = $self->result_source;
- if (defined $where) {
- $new_attrs->{where} = (
- defined $new_attrs->{where}
- ? { '-and' => [
- map {
- ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_
- } $where, $new_attrs->{where}
- ]
- }
- : $where);
+ my $old_attrs = { %{$self->{attrs}} };
+ my $old_having = delete $old_attrs->{having};
+ my $old_where = delete $old_attrs->{where};
+
+ my $new_attrs = { %$old_attrs };
+
+ # take care of call attrs (only if anything is changing)
+ if (keys %$call_attrs) {
+
+ my @selector_attrs = qw/select as columns cols +select +as +columns include_columns/;
+
+ # reset the current selector list if new selectors are supplied
+ if (List::Util::first { exists $call_attrs->{$_} } qw/columns cols select as/) {
+ delete @{$old_attrs}{(@selector_attrs, '_dark_selector')};
+ }
+
+ # Normalize the new selector list (operates on the passed-in attr structure)
+ # Need to do it on every chain instead of only once on _resolved_attrs, in
+ # order to allow detection of empty vs partial 'as'
+ $call_attrs->{_dark_selector} = $old_attrs->{_dark_selector}
+ if $old_attrs->{_dark_selector};
+ $self->_normalize_selection ($call_attrs);
+
+ # start with blind overwriting merge, exclude selector attrs
+ $new_attrs = { %{$old_attrs}, %{$call_attrs} };
+ delete @{$new_attrs}{@selector_attrs};
+
+ for (@selector_attrs) {
+ $new_attrs->{$_} = $self->_merge_attr($old_attrs->{$_}, $call_attrs->{$_})
+ if ( exists $old_attrs->{$_} or exists $call_attrs->{$_} );
+ }
+
+ # older deprecated name, use only if {columns} is not there
+ if (my $c = delete $new_attrs->{cols}) {
+ if ($new_attrs->{columns}) {
+ carp "Resultset specifies both the 'columns' and the legacy 'cols' attributes - ignoring 'cols'";
+ }
+ else {
+ $new_attrs->{columns} = $c;
+ }
+ }
+
+
+ # join/prefetch use their own crazy merging heuristics
+ foreach my $key (qw/join prefetch/) {
+ $new_attrs->{$key} = $self->_merge_joinpref_attr($old_attrs->{$key}, $call_attrs->{$key})
+ if exists $call_attrs->{$key};
+ }
+
+ # stack binds together
+ $new_attrs->{bind} = [ @{ $old_attrs->{bind} || [] }, @{ $call_attrs->{bind} || [] } ];
}
- if (defined $cond) {
- $new_attrs->{where} = (
- defined $new_attrs->{where}
- ? { '-and' => [
- map {
- ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_
- } $cond, $new_attrs->{where}
- ]
- }
- : $cond);
+
+ # rip apart the rest of @_, parse a condition
+ my $call_cond = do {
+
+ if (ref $_[0] eq 'HASH') {
+ (keys %{$_[0]}) ? $_[0] : undef
+ }
+ elsif (@_ == 1) {
+ $_[0]
+ }
+ elsif (@_ % 2) {
+ $self->throw_exception('Odd number of arguments to search')
+ }
+ else {
+ +{ @_ }
+ }
+
+ } if @_;
+
+ if( @_ > 1 and ! $rsrc->result_class->isa('DBIx::Class::CDBICompat') ) {
+ carp_unique 'search( %condition ) is deprecated, use search( \%condition ) instead';
}
- if (defined $having) {
- $new_attrs->{having} = (
- defined $new_attrs->{having}
- ? { '-and' => [
- map {
- ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_
- } $having, $new_attrs->{having}
- ]
- }
- : $having);
+ for ($old_where, $call_cond) {
+ if (defined $_) {
+ $new_attrs->{where} = $self->_stack_cond (
+ $_, $new_attrs->{where}
+ );
+ }
}
- my $rs = (ref $self)->new($self->result_source, $new_attrs);
+ if (defined $old_having) {
+ $new_attrs->{having} = $self->_stack_cond (
+ $old_having, $new_attrs->{having}
+ )
+ }
- $rs->set_cache($rows) if ($rows);
+ my $rs = (ref $self)->new($rsrc, $new_attrs);
+
+ $rs->set_cache($cache) if ($cache);
return $rs;
}
+my $dark_sel_dumper;
+sub _normalize_selection {
+ my ($self, $attrs) = @_;
+
+ # legacy syntax
+ $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns})
+ if exists $attrs->{include_columns};
+
+ # columns are always placed first, however
+
+ # Keep the X vs +X separation until _resolved_attrs time - this allows to
+ # delay the decision on whether to use a default select list ($rsrc->columns)
+ # allowing stuff like the remove_columns helper to work
+ #
+ # select/as +select/+as pairs need special handling - the amount of select/as
+ # elements in each pair does *not* have to be equal (think multicolumn
+ # selectors like distinct(foo, bar) ). If the selector is bare (no 'as'
+ # supplied at all) - try to infer the alias, either from the -as parameter
+ # of the selector spec, or use the parameter whole if it looks like a column
+ # name (ugly legacy heuristic). If all fails - leave the selector bare (which
+ # is ok as well), but make sure no more additions to the 'as' chain take place
+ for my $pref ('', '+') {
+
+ my ($sel, $as) = map {
+ my $key = "${pref}${_}";
+
+ my $val = [ ref $attrs->{$key} eq 'ARRAY'
+ ? @{$attrs->{$key}}
+ : $attrs->{$key} || ()
+ ];
+ delete $attrs->{$key};
+ $val;
+ } qw/select as/;
+
+ if (! @$as and ! @$sel ) {
+ next;
+ }
+ elsif (@$as and ! @$sel) {
+ $self->throw_exception(
+ "Unable to handle ${pref}as specification (@$as) without a corresponding ${pref}select"
+ );
+ }
+ elsif( ! @$as ) {
+ # no as part supplied at all - try to deduce (unless explicit end of named selection is declared)
+ # if any @$as has been supplied we assume the user knows what (s)he is doing
+ # and blindly keep stacking up pieces
+ unless ($attrs->{_dark_selector}) {
+ SELECTOR:
+ for (@$sel) {
+ if ( ref $_ eq 'HASH' and exists $_->{-as} ) {
+ push @$as, $_->{-as};
+ }
+ # assume any plain no-space, no-parenthesis string to be a column spec
+ # FIXME - this is retarded but is necessary to support shit like 'count(foo)'
+ elsif ( ! ref $_ and $_ =~ /^ [^\s\(\)]+ $/x) {
+ push @$as, $_;
+ }
+ # if all else fails - raise a flag that no more aliasing will be allowed
+ else {
+ $attrs->{_dark_selector} = {
+ plus_stage => $pref,
+ string => ($dark_sel_dumper ||= do {
+ require Data::Dumper::Concise;
+ Data::Dumper::Concise::DumperObject()->Indent(0);
+ })->Values([$_])->Dump
+ ,
+ };
+ last SELECTOR;
+ }
+ }
+ }
+ }
+ elsif (@$as < @$sel) {
+ $self->throw_exception(
+ "Unable to handle an ${pref}as specification (@$as) with less elements than the corresponding ${pref}select"
+ );
+ }
+ elsif ($pref and $attrs->{_dark_selector}) {
+ $self->throw_exception(
+ "Unable to process named '+select', resultset contains an unnamed selector $attrs->{_dark_selector}{string}"
+ );
+ }
+
+
+ # merge result
+ $attrs->{"${pref}select"} = $self->_merge_attr($attrs->{"${pref}select"}, $sel);
+ $attrs->{"${pref}as"} = $self->_merge_attr($attrs->{"${pref}as"}, $as);
+ }
+}
+
+sub _stack_cond {
+ my ($self, $left, $right) = @_;
+
+ # collapse single element top-level conditions
+ # (single pass only, unlikely to need recursion)
+ for ($left, $right) {
+ if (ref $_ eq 'ARRAY') {
+ if (@$_ == 0) {
+ $_ = undef;
+ }
+ elsif (@$_ == 1) {
+ $_ = $_->[0];
+ }
+ }
+ elsif (ref $_ eq 'HASH') {
+ my ($first, $more) = keys %$_;
+
+ # empty hash
+ if (! defined $first) {
+ $_ = undef;
+ }
+ # one element hash
+ elsif (! defined $more) {
+ if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') {
+ $_ = $_->{'-and'};
+ }
+ elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') {
+ $_ = $_->{'-or'};
+ }
+ }
+ }
+ }
+
+ # merge hashes with weeding out of duplicates (simple cases only)
+ if (ref $left eq 'HASH' and ref $right eq 'HASH') {
+
+ # shallow copy to destroy
+ $right = { %$right };
+ for (grep { exists $right->{$_} } keys %$left) {
+ # the use of eq_deeply here is justified - the rhs of an
+ # expression can contain a lot of twisted weird stuff
+ delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} );
+ }
+
+ $right = undef unless keys %$right;
+ }
+
+
+ if (defined $left xor defined $right) {
+ return defined $left ? $left : $right;
+ }
+ elsif (! defined $left) {
+ return undef;
+ }
+ else {
+ return { -and => [ $left, $right ] };
+ }
+}
+
=head2 search_literal
=over 4
=item Arguments: $sql_fragment, @bind_values
-=item Return Value: $resultset (scalar context), @row_objs (list context)
+=item Return Value: $resultset (scalar context) || @row_objs (list context)
=back
=over 4
-=item Arguments: @values | \%cols, \%attrs?
+=item Arguments: \%columns_values | @pk_values, \%attrs?
=item Return Value: $row_object | undef
=back
-Finds a row based on its primary key or unique constraint. For example, to find
-a row by its primary key:
+Finds and returns a single row based on supplied criteria. Takes either a
+hashref with the same format as L</create> (including inference of foreign
+keys from related objects), or a list of primary key values in the same
+order as the L<primary columns|DBIx::Class::ResultSource/primary_columns>
+declaration on the L</result_source>.
+
+In either case an attempt is made to combine conditions already existing on
+the resultset with the condition passed to this method.
+
+To aid with preparing the correct query for the storage you may supply the
+C<key> attribute, which is the name of a
+L<unique constraint|DBIx::Class::ResultSource/add_unique_constraint> (the
+unique constraint corresponding to the
+L<primary columns|DBIx::Class::ResultSource/primary_columns> is always named
+C<primary>). If the C<key> attribute has been supplied, and DBIC is unable
+to construct a query that satisfies the named unique constraint fully (
+non-NULL values for each column member of the constraint) an exception is
+thrown.
+
+If no C<key> is specified, the search is carried over all unique constraints
+which are fully defined by the available condition.
+
+If no such constraint is found, C<find> currently defaults to a simple
+C<< search->(\%column_values) >> which may or may not do what you expect.
+Note that this fallback behavior may be deprecated in further versions. If
+you need to search with arbitrary conditions - use L</search>. If the query
+resulting from this fallback produces more than one row, a warning to the
+effect is issued, though only the first row is constructed and returned as
+C<$row_object>.
- my $cd = $schema->resultset('CD')->find(5);
+In addition to C<key>, L</find> recognizes and applies standard
+L<resultset attributes|/ATTRIBUTES> in the same way as L</search> does.
-You can also find a row by a specific unique constraint using the C<key>
-attribute. For example:
+Note that if you have extra concerns about the correctness of the resulting
+query you need to specify the C<key> attribute and supply the entire condition
+as an argument to find (since it is not always possible to perform the
+combination of the resultset condition with the supplied one, especially if
+the resultset condition contains literal sql).
- my $cd = $schema->resultset('CD')->find('Massive Attack', 'Mezzanine', {
- key => 'cd_artist_title'
- });
+For example, to find a row by its primary key:
+
+ my $cd = $schema->resultset('CD')->find(5);
-Additionally, you can specify the columns explicitly by name:
+You can also find a row by a specific unique constraint:
my $cd = $schema->resultset('CD')->find(
{
{ key => 'cd_artist_title' }
);
-If the C<key> is specified as C<primary>, it searches only on the primary key.
-
-If no C<key> is specified, it searches on all unique constraints defined on the
-source for which column data is provided, including the primary key.
-
-If your table does not have a primary key, you B<must> provide a value for the
-C<key> attribute matching one of the unique constraints on the source.
-
-In addition to C<key>, L</find> recognizes and applies standard
-L<resultset attributes|/ATTRIBUTES> in the same way as L</search> does.
-
-Note: If your query does not return only one row, a warning is generated:
-
- Query returned more than one row
-
-See also L</find_or_create> and L</update_or_create>. For information on how to
-declare unique constraints, see
-L<DBIx::Class::ResultSource/add_unique_constraint>.
+See also L</find_or_create> and L</update_or_create>.
=cut
my $self = shift;
my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
- # Default to the primary key, but allow a specific key
- my @cols = exists $attrs->{key}
- ? $self->result_source->unique_constraint_columns($attrs->{key})
- : $self->result_source->primary_columns;
- $self->throw_exception(
- "Can't find unless a primary key is defined or unique constraint is specified"
- ) unless @cols;
+ my $rsrc = $self->result_source;
+
+ my $constraint_name;
+ if (exists $attrs->{key}) {
+ $constraint_name = defined $attrs->{key}
+ ? $attrs->{key}
+ : $self->throw_exception("An undefined 'key' resultset attribute makes no sense")
+ ;
+ }
+
+ # Parse out the condition from input
+ my $call_cond;
- # Parse out a hashref from input
- my $input_query;
if (ref $_[0] eq 'HASH') {
- $input_query = { %{$_[0]} };
- }
- elsif (@_ == @cols) {
- $input_query = {};
- @{$input_query}{@cols} = @_;
+ $call_cond = { %{$_[0]} };
}
else {
- # Compatibility: Allow e.g. find(id => $value)
- carp "Find by key => value deprecated; please use a hashref instead";
- $input_query = {@_};
- }
-
- my (%related, $info);
-
- KEY: foreach my $key (keys %$input_query) {
- if (ref($input_query->{$key})
- && ($info = $self->result_source->relationship_info($key))) {
- my $val = delete $input_query->{$key};
- next KEY if (ref($val) eq 'ARRAY'); # has_many for multi_create
- my $rel_q = $self->result_source->_resolve_condition(
- $info->{cond}, $val, $key
- );
- die "Can't handle OR join condition in find" if ref($rel_q) eq 'ARRAY';
+ # if only values are supplied we need to default to 'primary'
+ $constraint_name = 'primary' unless defined $constraint_name;
+
+ my @c_cols = $rsrc->unique_constraint_columns($constraint_name);
+
+ $self->throw_exception(
+ "No constraint columns, maybe a malformed '$constraint_name' constraint?"
+ ) unless @c_cols;
+
+ $self->throw_exception (
+ 'find() expects either a column/value hashref, or a list of values '
+ . "corresponding to the columns of the specified unique constraint '$constraint_name'"
+ ) unless @c_cols == @_;
+
+ $call_cond = {};
+ @{$call_cond}{@c_cols} = @_;
+ }
+
+ my %related;
+ for my $key (keys %$call_cond) {
+ if (
+ my $keyref = ref($call_cond->{$key})
+ and
+ my $relinfo = $rsrc->relationship_info($key)
+ ) {
+ my $val = delete $call_cond->{$key};
+
+ next if $keyref eq 'ARRAY'; # has_many for multi_create
+
+ my $rel_q = $rsrc->_resolve_condition(
+ $relinfo->{cond}, $val, $key, $key
+ );
+ die "Can't handle complex relationship conditions in find" if ref($rel_q) ne 'HASH';
@related{keys %$rel_q} = values %$rel_q;
}
}
- if (my @keys = keys %related) {
- @{$input_query}{@keys} = values %related;
- }
+ # relationship conditions take precedence (?)
+ @{$call_cond}{keys %related} = values %related;
- # Build the final query: Default to the disjunction of the unique queries,
- # but allow the input query in case the ResultSet defines the query or the
- # user is abusing find
my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias};
- my $query;
- if (exists $attrs->{key}) {
- my @unique_cols = $self->result_source->unique_constraint_columns($attrs->{key});
- my $unique_query = $self->_build_unique_query($input_query, \@unique_cols);
- $query = $self->_add_alias($unique_query, $alias);
+ my $final_cond;
+ if (defined $constraint_name) {
+ $final_cond = $self->_qualify_cond_columns (
+
+ $self->_build_unique_cond (
+ $constraint_name,
+ $call_cond,
+ ),
+
+ $alias,
+ );
}
elsif ($self->{attrs}{accessor} and $self->{attrs}{accessor} eq 'single') {
# This means that we got here after a merger of relationship conditions
# relationship
}
else {
- my @unique_queries = $self->_unique_queries($input_query, $attrs);
- $query = @unique_queries
- ? [ map { $self->_add_alias($_, $alias) } @unique_queries ]
- : $self->_add_alias($input_query, $alias);
+ # no key was specified - fall down to heuristics mode:
+ # run through all unique queries registered on the resultset, and
+ # 'OR' all qualifying queries together
+ my (@unique_queries, %seen_column_combinations);
+ for my $c_name ($rsrc->unique_constraint_names) {
+ next if $seen_column_combinations{
+ join "\x00", sort $rsrc->unique_constraint_columns($c_name)
+ }++;
+
+ push @unique_queries, try {
+ $self->_build_unique_cond ($c_name, $call_cond, 'croak_on_nulls')
+ } || ();
+ }
+
+ $final_cond = @unique_queries
+ ? [ map { $self->_qualify_cond_columns($_, $alias) } @unique_queries ]
+ : $self->_non_unique_find_fallback ($call_cond, $attrs)
+ ;
}
- # Run the query
- my $rs = $self->search ($query, {result_class => $self->result_class, %$attrs});
+ # Run the query, passing the result_class since it should propagate for find
+ my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs});
if ($rs->_resolved_attrs->{collapse}) {
my $row = $rs->next;
carp "Query returned more than one row" if $rs->next;
}
}
-# _add_alias
+# This is a stop-gap method as agreed during the discussion on find() cleanup:
+# http://lists.scsys.co.uk/pipermail/dbix-class/2010-October/009535.html
+#
+# It is invoked when find() is called in legacy-mode with insufficiently-unique
+# condition. It is provided for overrides until a saner way forward is devised
#
-# Add the specified alias to the specified query hash. A copy is made so the
-# original query is not modified.
+# *NOTE* This is not a public method, and it's *GUARANTEED* to disappear down
+# the road. Please adjust your tests accordingly to catch this situation early
+# DBIx::Class::ResultSet->can('_non_unique_find_fallback') is reasonable
+#
+# The method will not be removed without an adequately complete replacement
+# for strict-mode enforcement
+sub _non_unique_find_fallback {
+ my ($self, $cond, $attrs) = @_;
+
+ return $self->_qualify_cond_columns(
+ $cond,
+ exists $attrs->{alias}
+ ? $attrs->{alias}
+ : $self->{attrs}{alias}
+ );
+}
-sub _add_alias {
- my ($self, $query, $alias) = @_;
- my %aliased = %$query;
- foreach my $col (grep { ! m/\./ } keys %aliased) {
- $aliased{"$alias.$col"} = delete $aliased{$col};
+sub _qualify_cond_columns {
+ my ($self, $cond, $alias) = @_;
+
+ my %aliased = %$cond;
+ for (keys %aliased) {
+ $aliased{"$alias.$_"} = delete $aliased{$_}
+ if $_ !~ /\./;
}
return \%aliased;
}
-# _unique_queries
-#
-# Build a list of queries which satisfy unique constraints.
-
-sub _unique_queries {
- my ($self, $query, $attrs) = @_;
-
- my @constraint_names = exists $attrs->{key}
- ? ($attrs->{key})
- : $self->result_source->unique_constraint_names;
+sub _build_unique_cond {
+ my ($self, $constraint_name, $extra_cond, $croak_on_null) = @_;
- my $where = $self->_collapse_cond($self->{attrs}{where} || {});
- my $num_where = scalar keys %$where;
+ my @c_cols = $self->result_source->unique_constraint_columns($constraint_name);
- my (@unique_queries, %seen_column_combinations);
- foreach my $name (@constraint_names) {
- my @constraint_cols = $self->result_source->unique_constraint_columns($name);
-
- my $constraint_sig = join "\x00", sort @constraint_cols;
- next if $seen_column_combinations{$constraint_sig}++;
-
- my $unique_query = $self->_build_unique_query($query, \@constraint_cols);
+ # combination may fail if $self->{cond} is non-trivial
+ my ($final_cond) = try {
+ $self->_merge_with_rscond ($extra_cond)
+ } catch {
+ +{ %$extra_cond }
+ };
- my $num_cols = scalar @constraint_cols;
- my $num_query = scalar keys %$unique_query;
+ # trim out everything not in $columns
+ $final_cond = { map {
+ exists $final_cond->{$_}
+ ? ( $_ => $final_cond->{$_} )
+ : ()
+ } @c_cols };
- my $total = $num_query + $num_where;
- if ($num_query && ($num_query == $num_cols || $total == $num_cols)) {
- # The query is either unique on its own or is unique in combination with
- # the existing where clause
- push @unique_queries, $unique_query;
- }
+ if (my @missing = grep
+ { ! ($croak_on_null ? defined $final_cond->{$_} : exists $final_cond->{$_}) }
+ (@c_cols)
+ ) {
+ $self->throw_exception( sprintf ( "Unable to satisfy requested constraint '%s', no values for column(s): %s",
+ $constraint_name,
+ join (', ', map { "'$_'" } @missing),
+ ) );
}
- return @unique_queries;
-}
-
-# _build_unique_query
-#
-# Constrain the specified query hash based on the specified column names.
-
-sub _build_unique_query {
- my ($self, $query, $unique_cols) = @_;
+ if (
+ !$croak_on_null
+ and
+ !$ENV{DBIC_NULLABLE_KEY_NOWARN}
+ and
+ my @undefs = grep { ! defined $final_cond->{$_} } (keys %$final_cond)
+ ) {
+ carp_unique ( sprintf (
+ "NULL/undef values supplied for requested unique constraint '%s' (NULL "
+ . 'values in column(s): %s). This is almost certainly not what you wanted, '
+ . 'though you can set DBIC_NULLABLE_KEY_NOWARN to disable this warning.',
+ $constraint_name,
+ join (', ', map { "'$_'" } @undefs),
+ ));
+ }
- return {
- map { $_ => $query->{$_} }
- grep { exists $query->{$_} }
- @$unique_cols
- };
+ return $final_cond;
}
=head2 search_related
=over 4
-=item Arguments: $rel, $cond, \%attrs?
+=item Arguments: $rel, $cond?, \%attrs?
-=item Return Value: $new_resultset
+=item Return Value: $new_resultset (scalar context) || @row_objs (list context)
=back
Searches the specified relationship, optionally specifying a condition and
attributes for matching records. See L</ATTRIBUTES> for more information.
+In list context, C<< ->all() >> is called implicitly on the resultset, thus
+returning a list of row objects instead. To avoid that, use L</search_related_rs>.
+
+See also L</search_related_rs>.
+
=cut
sub search_related {
=item Arguments: $cond?
-=item Return Value: $row_object?
+=item Return Value: $row_object | undef
=back
my $cd = $schema->resultset('CD')->single({ year => 2001 });
Inflates the first result without creating a cursor if the resultset has
-any records in it; if not returns nothing. Used by L</find> as a lean version of
-L</search>.
+any records in it; if not returns C<undef>. Used by L</find> as a lean version
+of L</search>.
While this method can take an optional search condition (just like L</search>)
being a fast-code-path it does not recognize search attributes. If you need to
}
}
-# XXX: Disabled since it doesn't infer uniqueness in all cases
-# unless ($self->_is_unique_query($attrs->{where})) {
-# carp "Query not guaranteed to return a single row"
-# . "; please declare your unique constraints or use search instead";
-# }
-
my @data = $self->result_source->storage->select_single(
$attrs->{from}, $attrs->{select},
$attrs->{where}, $attrs
}
-# _is_unique_query
-#
-# Try to determine if the specified query is guaranteed to be unique, based on
-# the declared unique constraints.
-
-sub _is_unique_query {
- my ($self, $query) = @_;
-
- my $collapsed = $self->_collapse_query($query);
- my $alias = $self->{attrs}{alias};
-
- foreach my $name ($self->result_source->unique_constraint_names) {
- my @unique_cols = map {
- "$alias.$_"
- } $self->result_source->unique_constraint_columns($name);
-
- # Count the values for each unique column
- my %seen = map { $_ => 0 } @unique_cols;
-
- foreach my $key (keys %$collapsed) {
- my $aliased = $key =~ /\./ ? $key : "$alias.$key";
- next unless exists $seen{$aliased}; # Additional constraints are okay
- $seen{$aliased} = scalar keys %{ $collapsed->{$key} };
- }
-
- # If we get 0 or more than 1 value for a column, it's not necessarily unique
- return 1 unless grep { $_ != 1 } values %seen;
- }
-
- return 0;
-}
-
# _collapse_query
#
# Recursively collapse the query, accumulating values for each column.
=item Arguments: $cond, \%attrs?
-=item Return Value: $resultset (scalar context), @row_objs (list context)
+=item Return Value: $resultset (scalar context) || @row_objs (list context)
=back
sub search_like {
my $class = shift;
- carp (
+ carp_unique (
'search_like() is deprecated and will be removed in DBIC version 0.09.'
.' Instead use ->search({ x => { -like => "y%" } })'
.' (note the outer pair of {}s - they are important!)'
=item Arguments: $first, $last
-=item Return Value: $resultset (scalar context), @row_objs (list context)
+=item Return Value: $resultset (scalar context) || @row_objs (list context)
=back
$attrs->{offset} = $self->{attrs}{offset} || 0;
$attrs->{offset} += $min;
$attrs->{rows} = ($max ? ($max - $min + 1) : 1);
- return $self->search(undef(), $attrs);
+ return $self->search(undef, $attrs);
#my $slice = (ref $self)->new($self->result_source, $attrs);
#return (wantarray ? $slice->all : $slice);
}
=item Arguments: none
-=item Return Value: $result?
+=item Return Value: $result | undef
=back
return $cache->[$self->{all_cache_position}++];
}
if ($self->{attrs}{cache}) {
+ delete $self->{pager};
$self->{all_cache_position} = 1;
return ($self->all)[0];
}
return undef;
}
-
sub _merge_result {
my ( $self, $result, $row, $register ) = @_;
return @$result = @$row if ( @$result == 0 ); # initialize with $row
my ( undef, $rels, $ids ) = @$result;
my ( undef, $new_rels, $new_ids ) = @$row;
- use List::MoreUtils;
- my @rels = List::MoreUtils::uniq( keys %$rels, keys %$new_rels );
+ my @rels = keys %{ { %{$rels||{} }, %{ $new_rels||{} } } };
foreach my $rel (@rels) {
$register = $register->{$rel} ||= {};
return 1;
}
-
-
-
=begin
# two arguments: $as_proto is an arrayref of column names,
sub result_class {
my ($self, $result_class) = @_;
if ($result_class) {
- $self->ensure_class_loaded($result_class);
+ unless (ref $result_class) { # don't fire this for an object
+ $self->ensure_class_loaded($result_class);
+ }
$self->_result_class($result_class);
- $self->{attrs}{result_class} = $result_class if ref $self;
+ # THIS LINE WOULD BE A BUG - this accessor specifically exists to
+ # permit the user to set result class on one result set only; it only
+ # chains if provided to search()
+ #$self->{attrs}{result_class} = $result_class if ref $self;
}
$self->_result_class;
}
$attrs ||= $self->_resolved_attrs;
my $tmp_attrs = { %$attrs };
-
- # take off any limits, record_filter is cdbi, and no point of ordering a count
- delete $tmp_attrs->{$_} for (qw/select as rows offset order_by record_filter/);
+ # take off any limits, record_filter is cdbi, and no point of ordering nor locking a count
+ delete @{$tmp_attrs}{qw/rows offset order_by record_filter for/};
# overwrite the selector (supplied by the storage)
- $tmp_attrs->{select} = $rsrc->storage->_count_select ($rsrc, $tmp_attrs);
+ $tmp_attrs->{select} = $rsrc->storage->_count_select ($rsrc, $attrs);
$tmp_attrs->{as} = 'count';
+ delete @{$tmp_attrs}{qw/columns/};
my $tmp_rs = $rsrc->resultset_class->new($rsrc, $tmp_attrs)->get_column ('count');
my ($self, $attrs) = @_;
my $rsrc = $self->result_source;
- $attrs ||= $self->_resolved_attrs_copy;
+ $attrs ||= $self->_resolved_attrs;
my $sub_attrs = { %$attrs };
+ # extra selectors do not go in the subquery and there is no point of ordering it, nor locking it
+ delete @{$sub_attrs}{qw/collapse columns as select _prefetch_selector_range order_by for/};
- # extra selectors do not go in the subquery and there is no point of ordering it
- delete $sub_attrs->{$_} for qw/collapse select _prefetch_select as order_by/;
-
- # if we multi-prefetch we group_by primary keys only as this is what we would
+ # if we multi-prefetch we group_by something unique, as this is what we would
# get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless
if ( $attrs->{collapse} ) {
- $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } ($rsrc->_pri_cols) ]
+ $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{
+ $rsrc->_identifying_column_set || $self->throw_exception(
+ 'Unable to construct a unique group_by criteria properly collapsing the '
+ . 'has_many prefetch before count()'
+ );
+ } ]
}
- $sub_attrs->{select} = $rsrc->storage->_subq_count_select ($rsrc, $attrs);
+ # Calculate subquery selector
+ if (my $g = $sub_attrs->{group_by}) {
- # this is so that the query can be simplified e.g.
- # * ordering can be thrown away in things like Top limit
- $sub_attrs->{-for_count_only} = 1;
+ my $sql_maker = $rsrc->storage->sql_maker;
- my $sub_rs = $rsrc->resultset_class->new ($rsrc, $sub_attrs);
+ # necessary as the group_by may refer to aliased functions
+ my $sel_index;
+ for my $sel (@{$attrs->{select}}) {
+ $sel_index->{$sel->{-as}} = $sel
+ if (ref $sel eq 'HASH' and $sel->{-as});
+ }
- $attrs->{from} = [{
- -alias => 'count_subq',
- -source_handle => $rsrc->handle,
- count_subq => $sub_rs->as_query,
- }];
+ # anything from the original select mentioned on the group-by needs to make it to the inner selector
+ # also look for named aggregates referred in the having clause
+ # having often contains scalarrefs - thus parse it out entirely
+ my @parts = @$g;
+ if ($attrs->{having}) {
+ local $sql_maker->{having_bind};
+ local $sql_maker->{quote_char} = $sql_maker->{quote_char};
+ local $sql_maker->{name_sep} = $sql_maker->{name_sep};
+ unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) {
+ $sql_maker->{quote_char} = [ "\x00", "\xFF" ];
+ # if we don't unset it we screw up retarded but unfortunately working
+ # 'MAX(foo.bar)' => { '>', 3 }
+ $sql_maker->{name_sep} = '';
+ }
- # the subquery replaces this
- delete $attrs->{$_} for qw/where bind collapse group_by having having_bind rows offset/;
+ my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
- return $self->_count_rs ($attrs);
+ my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} });
+
+ # search for both a proper quoted qualified string, for a naive unquoted scalarref
+ # and if all fails for an utterly naive quoted scalar-with-function
+ while ($sql =~ /
+ $rquote $sep $lquote (.+?) $rquote
+ |
+ [\s,] \w+ \. (\w+) [\s,]
+ |
+ [\s,] $lquote (.+?) $rquote [\s,]
+ /gx) {
+ push @parts, ($1 || $2 || $3); # one of them matched if we got here
+ }
+ }
+
+ for (@parts) {
+ my $colpiece = $sel_index->{$_} || $_;
+
+ # unqualify join-based group_by's. Arcane but possible query
+ # also horrible horrible hack to alias a column (not a func.)
+ # (probably need to introduce SQLA syntax)
+ if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) {
+ my $as = $colpiece;
+ $as =~ s/\./__/;
+ $colpiece = \ sprintf ('%s AS %s', map { $sql_maker->_quote ($_) } ($colpiece, $as) );
+ }
+ push @{$sub_attrs->{select}}, $colpiece;
+ }
+ }
+ else {
+ my @pcols = map { "$attrs->{alias}.$_" } ($rsrc->primary_columns);
+ $sub_attrs->{select} = @pcols ? \@pcols : [ 1 ];
+ }
+
+ return $rsrc->resultset_class
+ ->new ($rsrc, $sub_attrs)
+ ->as_subselect_rs
+ ->search ({}, { columns => { count => $rsrc->storage->_count_select ($rsrc, $attrs) } })
+ ->get_column ('count');
}
sub _bool {
=back
-Returns all elements in the resultset. Called implicitly if the resultset
-is returned in list context.
+Returns all elements in the resultset.
=cut
=item Arguments: none
-=item Return Value: $object?
+=item Return Value: $object | undef
=back
-Resets the resultset and returns an object for the first result (if the
-resultset returns anything).
+Resets the resultset and returns an object for the first result (or C<undef>
+if the resultset is empty).
=cut
sub _rs_update_delete {
my ($self, $op, $values) = @_;
+ my $cond = $self->{cond};
my $rsrc = $self->result_source;
+ my $storage = $rsrc->schema->storage;
- # if a condition exists we need to strip all table qualifiers
- # if this is not possible we'll force a subquery below
- my $cond = $rsrc->schema->storage->_strip_cond_qualifiers ($self->{cond});
+ my $attrs = { %{$self->_resolved_attrs} };
- my $needs_group_by_subq = $self->_has_resolved_attr (qw/collapse group_by -join/);
- my $needs_subq = $needs_group_by_subq || (not defined $cond) || $self->_has_resolved_attr(qw/row offset/);
+ # "needs" is a strong word here - if the subquery is part of an IN clause - no point of
+ # even adding the group_by. It will really be used only when composing a poor-man's
+ # multicolumn-IN equivalent OR set
+ my $needs_group_by_subq = defined $attrs->{group_by};
- if ($needs_group_by_subq or $needs_subq) {
+ # simplify the joinmap and maybe decide if a grouping (and thus subquery) is necessary
+ my $relation_classifications;
+ if (ref($attrs->{from}) eq 'ARRAY') {
+ $attrs->{from} = $storage->_prune_unused_joins ($attrs->{from}, $attrs->{select}, $cond, $attrs);
- # make a new $rs selecting only the PKs (that's all we really need)
- my $attrs = $self->_resolved_attrs_copy;
+ $relation_classifications = $storage->_resolve_aliastypes_from_select_args (
+ [ @{$attrs->{from}}[1 .. $#{$attrs->{from}}] ],
+ $attrs->{select},
+ $cond,
+ $attrs
+ ) unless $needs_group_by_subq; # we already know we need a group, no point of resolving them
+ }
+ else {
+ $needs_group_by_subq ||= 1; # if {from} is unparseable assume the worst
+ }
- delete $attrs->{$_} for qw/collapse select as/;
- $attrs->{columns} = [ map { "$attrs->{alias}.$_" } ($self->result_source->_pri_cols) ];
+ $needs_group_by_subq ||= exists $relation_classifications->{multiplying};
+ # if no subquery - life is easy-ish
+ unless (
+ $needs_group_by_subq
+ or
+ keys %$relation_classifications # if any joins at all - need to wrap a subq
+ or
+ $self->_has_resolved_attr(qw/rows offset/) # limits call for a subq
+ ) {
+ # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
+ # a condition containing 'me' or other table prefixes will not work
+ # at all. What this code tries to do (badly) is to generate a condition
+ # with the qualifiers removed, by exploiting the quote mechanism of sqla
+ #
+ # this is atrocious and should be replaced by normal sqla introspection
+ # one sunny day
+ my ($sql, @bind) = do {
+ my $sqla = $rsrc->storage->sql_maker;
+ local $sqla->{_dequalify_idents} = 1;
+ $sqla->_recurse_where($self->{cond});
+ } if $self->{cond};
+
+ return $rsrc->storage->$op(
+ $rsrc,
+ $op eq 'update' ? $values : (),
+ $self->{cond} ? \[$sql, @bind] : (),
+ );
+ }
+
+ # we got this far - means it is time to wrap a subquery
+ my $idcols = $rsrc->_identifying_column_set || $self->throw_exception(
+ sprintf(
+ "Unable to perform complex resultset %s() without an identifying set of columns on source '%s'",
+ $op,
+ $rsrc->source_name,
+ )
+ );
+ my $existing_group_by = delete $attrs->{group_by};
+
+ # make a new $rs selecting only the PKs (that's all we really need for the subq)
+ delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/;
+ $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ];
+ $attrs->{group_by} = \ ''; # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins
+ my $subrs = (ref $self)->new($rsrc, $attrs);
+
+ if (@$idcols == 1) {
+ return $storage->$op (
+ $rsrc,
+ $op eq 'update' ? $values : (),
+ { $idcols->[0] => { -in => $subrs->as_query } },
+ );
+ }
+ elsif ($storage->_use_multicolumn_in) {
+ # This is hideously ugly, but SQLA does not understand multicol IN expressions
+ my $sql_maker = $storage->sql_maker;
+ my ($sql, @bind) = @${$subrs->as_query};
+ $sql = sprintf ('(%s) IN %s', # the as_query already comes with a set of parenthesis
+ join (', ', map { $sql_maker->_quote ($_) } @$idcols),
+ $sql,
+ );
+
+ return $storage->$op (
+ $rsrc,
+ $op eq 'update' ? $values : (),
+ \[$sql, @bind],
+ );
+ }
+ else {
+ # if all else fails - get all primary keys and operate over a ORed set
+ # wrap in a transaction for consistency
+ # this is where the group_by starts to matter
+ my $subq_group_by;
if ($needs_group_by_subq) {
- # make sure no group_by was supplied, or if there is one - make sure it matches
- # the columns compiled above perfectly. Anything else can not be sanely executed
- # on most databases so croak right then and there
+ $subq_group_by = $attrs->{columns};
- if (my $g = $attrs->{group_by}) {
+ # make sure if there is a supplied group_by it matches the columns compiled above
+ # perfectly. Anything else can not be sanely executed on most databases so croak
+ # right then and there
+ if ($existing_group_by) {
my @current_group_by = map
{ $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
- @$g
+ @$existing_group_by
;
if (
join ("\x00", sort @current_group_by)
ne
- join ("\x00", sort @{$attrs->{columns}} )
+ join ("\x00", sort @$subq_group_by )
) {
$self->throw_exception (
"You have just attempted a $op operation on a resultset which does group_by"
);
}
}
- else {
- $attrs->{group_by} = $attrs->{columns};
- }
}
- my $subrs = (ref $self)->new($rsrc, $attrs);
+ my $guard = $storage->txn_scope_guard;
- return $self->result_source->storage->_subq_update_delete($subrs, $op, $values);
- }
- else {
- return $rsrc->storage->$op(
+ my @op_condition;
+ for my $row ($subrs->search({}, { group_by => $subq_group_by })->cursor->all) {
+ push @op_condition, { map
+ { $idcols->[$_] => $row->[$_] }
+ (0 .. $#$idcols)
+ };
+ }
+
+ my $res = $storage->$op (
$rsrc,
$op eq 'update' ? $values : (),
- $cond,
+ \@op_condition,
);
+
+ $guard->commit;
+
+ return $res;
}
}
=back
Sets the specified columns in the resultset to the supplied values in a
-single query. Return value will be true if the update succeeded or false
-if no records were updated; exact type of success value is storage-dependent.
+single query. Note that this will not run any accessor/set_column/update
+triggers, nor will it update any row object instances derived from this
+resultset (this includes the contents of the L<resultset cache|/set_cache>
+if any). See L</update_all> if you need to execute any on-update
+triggers or cascades defined either by you or a
+L<result component|DBIx::Class::Manual::Component/WHAT IS A COMPONENT>.
+
+The return value is a pass through of what the underlying
+storage backend returned, and may vary. See L<DBI/execute> for the most
+common case.
+
+=head3 CAVEAT
+
+Note that L</update> does not process/deflate any of the values passed in.
+This is unlike the corresponding L<DBIx::Class::Row/update>. The user must
+ensure manually that any value passed to this method will stringify to
+something the RDBMS knows how to deal with. A notable example is the
+handling of L<DateTime> objects, for more info see:
+L<DBIx::Class::Manual::Cookbook/Formatting DateTime objects in queries>.
=cut
=back
-Fetches all objects and updates them one at a time. Note that C<update_all>
-will run DBIC cascade triggers, while L</update> will not.
+Fetches all objects and updates them one at a time via
+L<DBIx::Class::Row/update>. Note that C<update_all> will run DBIC defined
+triggers, while L</update> will not.
=cut
my ($self, $values) = @_;
$self->throw_exception('Values for update_all must be a hash')
unless ref $values eq 'HASH';
- foreach my $obj ($self->all) {
- $obj->set_columns($values)->update;
- }
+
+ my $guard = $self->result_source->schema->txn_scope_guard;
+ $_->update({%$values}) for $self->all; # shallow copy - update will mangle it
+ $guard->commit;
return 1;
}
=back
-Deletes the contents of the resultset from its result source. Note that this
-will not run DBIC cascade triggers. See L</delete_all> if you need triggers
-to run. See also L<DBIx::Class::Row/delete>.
+Deletes the rows matching this resultset in a single query. Note that this
+will not run any delete triggers, nor will it alter the
+L<in_storage|DBIx::Class::Row/in_storage> status of any row object instances
+derived from this resultset (this includes the contents of the
+L<resultset cache|/set_cache> if any). See L</delete_all> if you need to
+execute any on-delete triggers or cascades defined either by you or a
+L<result component|DBIx::Class::Manual::Component/WHAT IS A COMPONENT>.
-Return value will be the amount of rows deleted; exact type of return value
-is storage-dependent.
+The return value is a pass through of what the underlying storage backend
+returned, and may vary. See L<DBI/execute> for the most common case.
=cut
=back
-Fetches all objects and deletes them one at a time. Note that C<delete_all>
-will run DBIC cascade triggers, while L</delete> will not.
+Fetches all objects and deletes them one at a time via
+L<DBIx::Class::Row/delete>. Note that C<delete_all> will run DBIC defined
+triggers, while L</delete> will not.
=cut
$self->throw_exception('delete_all does not accept any arguments')
if @_;
+ my $guard = $self->result_source->schema->txn_scope_guard;
$_->delete for $self->all;
+ $guard->commit;
return 1;
}
Accepts either an arrayref of hashrefs or alternatively an arrayref of arrayrefs.
For the arrayref of hashrefs style each hashref should be a structure suitable
-forsubmitting to a $resultset->create(...) method.
+for submitting to a $resultset->create(...) method.
In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
to insert the data, as this is a faster method.
# cruft placed in standalone method
my $data = $self->_normalize_populate_args(@_);
+ return unless @$data;
+
if(defined wantarray) {
my @created;
foreach my $item (@$data) {
push(@created, $self->create($item));
}
return wantarray ? @created : \@created;
- } else {
+ }
+ else {
my $first = $data->[0];
# if a column is a registered relationship, and is a non-blessed hash/array, consider
# it relationship data
my (@rels, @columns);
+ my $rsrc = $self->result_source;
+ my $rels = { map { $_ => $rsrc->relationship_info($_) } $rsrc->relationships };
for (keys %$first) {
my $ref = ref $first->{$_};
- $self->result_source->has_relationship($_) && ($ref eq 'ARRAY' or $ref eq 'HASH')
+ $rels->{$_} && ($ref eq 'ARRAY' or $ref eq 'HASH')
? push @rels, $_
: push @columns, $_
;
}
- my @pks = $self->result_source->primary_columns;
+ my @pks = $rsrc->primary_columns;
## do the belongs_to relationships
foreach my $index (0..$#$data) {
foreach my $rel (@rels) {
next unless ref $data->[$index]->{$rel} eq "HASH";
my $result = $self->related_resultset($rel)->create($data->[$index]->{$rel});
- my ($reverse) = keys %{$self->result_source->reverse_relationship_info($rel)};
+ my ($reverse_relname, $reverse_relinfo) = %{$rsrc->reverse_relationship_info($rel)};
my $related = $result->result_source->_resolve_condition(
- $result->result_source->relationship_info($reverse)->{cond},
+ $reverse_relinfo->{cond},
$self,
$result,
+ $rel,
);
delete $data->[$index]->{$rel};
}
## inherit the data locked in the conditions of the resultset
- my ($rs_data) = $self->_merge_cond_with_data({});
+ my ($rs_data) = $self->_merge_with_rscond({});
delete @{$rs_data}{@columns};
my @inherit_cols = keys %$rs_data;
my @inherit_data = values %$rs_data;
## do bulk insert on current row
- $self->result_source->storage->insert_bulk(
- $self->result_source,
+ $rsrc->storage->insert_bulk(
+ $rsrc,
[@columns, @inherit_cols],
[ map { [ @$_{@columns}, @inherit_data ] } @$data ],
);
## do the has_many relationships
foreach my $item (@$data) {
+ my $main_row;
+
foreach my $rel (@rels) {
- next unless $item->{$rel} && ref $item->{$rel} eq "ARRAY";
+ next unless ref $item->{$rel} eq "ARRAY" && @{ $item->{$rel} };
- my $parent = $self->find({map { $_ => $item->{$_} } @pks})
- || $self->throw_exception('Cannot find the relating object.');
+ $main_row ||= $self->new_result({map { $_ => $item->{$_} } @pks});
- my $child = $parent->$rel;
+ my $child = $main_row->$rel;
my $related = $child->result_source->_resolve_condition(
- $parent->result_source->relationship_info($rel)->{cond},
+ $rels->{$rel}{cond},
$child,
- $parent,
+ $main_row,
+ $rel,
);
my @rows_to_add = ref $item->{$rel} eq 'ARRAY' ? @{$item->{$rel}} : ($item->{$rel});
my ($self, $arg) = @_;
if (ref $arg eq 'ARRAY') {
- if (ref $arg->[0] eq 'HASH') {
+ if (!@$arg) {
+ return [];
+ }
+ elsif (ref $arg->[0] eq 'HASH') {
return $arg;
}
elsif (ref $arg->[0] eq 'ARRAY') {
return $self->{pager} if $self->{pager};
my $attrs = $self->{attrs};
- $self->throw_exception("Can't create pager for non-paged rs")
- unless $self->{attrs}{page};
+ if (!defined $attrs->{page}) {
+ $self->throw_exception("Can't create pager for non-paged rs");
+ }
+ elsif ($attrs->{page} <= 0) {
+ $self->throw_exception('Invalid page number (page-numbers are 1-based)');
+ }
$attrs->{rows} ||= 10;
# throw away the paging flags and re-run the count (possibly
# with a subselect) to get the real total count
my $count_attrs = { %$attrs };
delete $count_attrs->{$_} for qw/rows offset page pager/;
- my $total_count = (ref $self)->new($self->result_source, $count_attrs)->count;
- return $self->{pager} = Data::Page->new(
- $total_count,
+ my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
+
+ require DBIx::Class::ResultSet::Pager;
+ return $self->{pager} = DBIx::Class::ResultSet::Pager->new(
+ sub { $total_rs->count }, #lazy-get the total
$attrs->{rows},
- $self->{attrs}{page}
+ $self->{attrs}{page},
);
}
$self->throw_exception( "new_result needs a hash" )
unless (ref $values eq 'HASH');
- my ($merged_cond, $cols_from_relations) = $self->_merge_cond_with_data($values);
+ my ($merged_cond, $cols_from_relations) = $self->_merge_with_rscond($values);
my %new = (
%$merged_cond,
@$cols_from_relations
? (-cols_from_relations => $cols_from_relations)
: (),
- -source_handle => $self->_source_handle,
-result_source => $self->result_source, # DO NOT REMOVE THIS, REQUIRED
);
return $self->result_class->new(\%new);
}
-# _merge_cond_with_data
+# _merge_with_rscond
#
# Takes a simple hash of K/V data and returns its copy merged with the
# condition already present on the resultset. Additionally returns an
# arrayref of value/condition names, which were inferred from related
# objects (this is needed for in-memory related objects)
-sub _merge_cond_with_data {
+sub _merge_with_rscond {
my ($self, $data) = @_;
my (%new_data, @cols_from_relations);
my %implied = %{$self->_remove_alias($collapsed_cond, $alias)};
while ( my($col, $value) = each %implied ) {
- if (ref($value) eq 'HASH' && keys(%$value) && (keys %$value)[0] eq '=') {
+ my $vref = ref $value;
+ if (
+ $vref eq 'HASH'
+ and
+ keys(%$value) == 1
+ and
+ (keys %$value)[0] eq '='
+ ) {
$new_data{$col} = $value->{'='};
- next;
}
- $new_data{$col} = $value if $self->_is_deterministic_value($value);
+ elsif( !$vref or $vref eq 'SCALAR' or blessed($value) ) {
+ $new_data{$col} = $value;
+ }
}
}
return (\%new_data, \@cols_from_relations);
}
-# _is_deterministic_value
-#
-# Make an effor to strip non-deterministic values from the condition,
-# to make sure new_result chokes less
-
-sub _is_deterministic_value {
- my $self = shift;
- my $value = shift;
- my $ref_type = ref $value;
- return 1 if $ref_type eq '' || $ref_type eq 'SCALAR';
- return 1 if Scalar::Util::blessed($value);
- return 0;
-}
-
# _has_resolved_attr
#
# determines if the resultset defines at least one
$cd->cd_to_producer->find_or_new({ producer => $producer },
{ key => 'primary });
-Find an existing record from this resultset, based on its primary
-key, or a unique constraint. If none exists, instantiate a new result
-object and return it. The object will not be saved into your storage
-until you call L<DBIx::Class::Row/insert> on it.
+Find an existing record from this resultset using L</find>. if none exists,
+instantiate a new result object and return it. The object will not be saved
+into your storage until you call L<DBIx::Class::Row/insert> on it.
-You most likely want this method when looking for existing rows using
-a unique constraint that is not the primary key, or looking for
-related rows.
+You most likely want this method when looking for existing rows using a unique
+constraint that is not the primary key, or looking for related rows.
-If you want objects to be saved immediately, use L</find_or_create>
-instead.
+If you want objects to be saved immediately, use L</find_or_create> instead.
+
+B<Note>: Make sure to read the documentation of L</find> and understand the
+significance of the C<key> attribute, as its lack may skew your search, and
+subsequently result in spurious new objects.
B<Note>: Take care when using C<find_or_new> with a table having
columns with default values that you intend to be automatically
);
Example of creating a new row and also creating a row in a related
-C<belongs_to>resultset. Note Hashref.
+C<belongs_to> resultset. Note Hashref.
$cd_rs->create({
title=>"Music for Silly Walks",
{ key => 'cd_artist_title' }
);
+B<Note>: Make sure to read the documentation of L</find> and understand the
+significance of the C<key> attribute, as its lack may skew your search, and
+subsequently result in spurious row creation.
+
B<Note>: Because find_or_create() reads from the database and then
possibly inserts based on the result, this method is subject to a race
condition. Another process could create a record in the table after
See also L</find> and L</update_or_create>. For information on how to declare
unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
+If you need to know if an existing row was found or a new one created use
+L</find_or_new> and L<DBIx::Class::Row/in_storage> instead. Don't forget
+to call L<DBIx::Class::Row/insert> to save the newly created row to the
+database!
+
+ my $cd = $schema->resultset('CD')->find_or_new({
+ cdid => 5,
+ artist => 'Massive Attack',
+ title => 'Mezzanine',
+ year => 2005,
+ });
+
+ if( $cd->in_storage ) {
+ # do some stuff
+ $cd->insert;
+ }
+
=cut
sub find_or_create {
=item Arguments: \%col_values, { key => $unique_constraint }?
-=item Return Value: $rowobject
+=item Return Value: $row_object
=back
$resultset->update_or_create({ col => $val, ... });
-First, searches for an existing row matching one of the unique constraints
-(including the primary key) on the source of this resultset. If a row is
-found, updates it with the other given column values. Otherwise, creates a new
-row.
+Like L</find_or_create>, but if a row is found it is immediately updated via
+C<< $found_row->update (\%col_values) >>.
+
Takes an optional C<key> attribute to search on a specific unique constraint.
For example:
producer => $producer,
name => 'harry',
}, {
- key => 'primary,
+ key => 'primary',
});
-
-If no C<key> is specified, it searches on all unique constraints defined on the
-source, including the primary key.
-
-If the C<key> is specified as C<primary>, it searches only on the primary key.
-
-See also L</find> and L</find_or_create>. For information on how to declare
-unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
+B<Note>: Make sure to read the documentation of L</find> and understand the
+significance of the C<key> attribute, as its lack may skew your search, and
+subsequently result in spurious row creation.
B<Note>: Take care when using C<update_or_create> with a table having
columns with default values that you intend to be automatically
In normal usage, the value of such columns should NOT be included at
all in the call to C<update_or_create>, even when set to C<undef>.
+See also L</find> and L</find_or_create>. For information on how to declare
+unique constraints, see L<DBIx::Class::ResultSource/add_unique_constraint>.
+
+If you need to know if an existing row was updated or a new one created use
+L</update_or_new> and L<DBIx::Class::Row/in_storage> instead. Don't forget
+to call L<DBIx::Class::Row/insert> to save the newly created row to the
+database!
+
+ my $cd = $schema->resultset('CD')->update_or_new(
+ {
+ artist => 'Massive Attack',
+ title => 'Mezzanine',
+ year => 1998,
+ },
+ { key => 'cd_artist_title' }
+ );
+
+ if( $cd->in_storage ) {
+ # do some stuff
+ $cd->insert;
+ }
+
=cut
sub update_or_create {
$resultset->update_or_new({ col => $val, ... });
-First, searches for an existing row matching one of the unique constraints
-(including the primary key) on the source of this resultset. If a row is
-found, updates it with the other given column values. Otherwise, instantiate
-a new result object and return it. The object will not be saved into your storage
-until you call L<DBIx::Class::Row/insert> on it.
+Like L</find_or_new> but if a row is found it is immediately updated via
+C<< $found_row->update (\%col_values) >>.
-Takes an optional C<key> attribute to search on a specific unique constraint.
For example:
# In your application
$cd->insert;
}
+B<Note>: Make sure to read the documentation of L</find> and understand the
+significance of the C<key> attribute, as its lack may skew your search, and
+subsequently result in spurious new objects.
+
B<Note>: Take care when using C<update_or_new> with a table having
columns with default values that you intend to be automatically
supplied by the database (e.g. an auto_increment primary key column).
=item Arguments: none
-=item Return Value: \@cache_objects?
+=item Return Value: \@cache_objects | undef
=back
=item Arguments: none
-=item Return Value: []
+=item Return Value: undef
=back
sub is_ordered {
my ($self) = @_;
- return scalar $self->result_source->storage->_parse_order_by($self->{attrs}{order_by});
+ return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by});
}
=head2 related_resultset
# (the select/as attrs were deleted in the beginning), we need to flip all
# left joins to inner, so we get the expected results
# read the comment on top of the actual function to see what this does
- $attrs->{from} = $rsrc->schema->storage->_straight_join_to_node ($attrs->{from}, $alias);
+ $attrs->{from} = $rsrc->schema->storage->_inner_join_to_node ($attrs->{from}, $alias);
#XXX - temp fix for result_class bug. There likely is a more elegant fix -groditi
my $me = $self->current_source_alias;
- return $self->search(
+ return $self->search({
"$me.modified" => $user->id,
- );
+ });
}
=cut
=cut
sub as_subselect_rs {
- my $self = shift;
+ my $self = shift;
+
+ my $attrs = $self->_resolved_attrs;
- return $self->result_source->resultset->search( undef, {
- alias => $self->current_source_alias,
- from => [{
- $self->current_source_alias => $self->as_query,
- -alias => $self->current_source_alias,
- -source_handle => $self->result_source->handle,
- }]
- });
+ my $fresh_rs = (ref $self)->new (
+ $self->result_source
+ );
+
+ # these pieces will be locked in the subquery
+ delete $fresh_rs->{cond};
+ delete @{$fresh_rs->{attrs}}{qw/where bind/};
+
+ return $fresh_rs->search( {}, {
+ from => [{
+ $attrs->{alias} => $self->as_query,
+ -alias => $attrs->{alias},
+ -rsrc => $self->result_source,
+ }],
+ alias => $attrs->{alias},
+ });
}
# This code is called by search_related, and makes sure there
# we need to take the prefetch the attrs into account before we
# ->_resolve_join as otherwise they get lost - captainL
- my $join = $self->_merge_attr( $attrs->{join}, $attrs->{prefetch} );
+ my $join = $self->_merge_joinpref_attr( $attrs->{join}, $attrs->{prefetch} );
- delete @{$attrs}{qw/join prefetch collapse distinct select as columns +select +as +columns/};
+ delete @{$attrs}{qw/join prefetch collapse group_by distinct select as columns +select +as +columns/};
my $seen = { %{ (delete $attrs->{seen_join}) || {} } };
# are resolved (prefetch is useless - we are wrapping
# a subquery anyway).
my $rs_copy = $self->search;
- $rs_copy->{attrs}{join} = $self->_merge_attr (
+ $rs_copy->{attrs}{join} = $self->_merge_joinpref_attr (
$rs_copy->{attrs}{join},
delete $rs_copy->{attrs}{prefetch},
);
$from = [{
- -source_handle => $source->handle,
- -alias => $attrs->{alias},
+ -rsrc => $source,
+ -alias => $attrs->{alias},
$attrs->{alias} => $rs_copy->as_query,
}];
- delete @{$attrs}{@force_subq_attrs, 'where'};
+ delete @{$attrs}{@force_subq_attrs, qw/where bind/};
$seen->{-relation_chain_depth} = 0;
}
elsif ($attrs->{from}) { #shallow copy suffices
}
else {
$from = [{
- -source_handle => $source->handle,
+ -rsrc => $source,
-alias => $attrs->{alias},
$attrs->{alias} => $source->from,
}];
my $source = $self->result_source;
my $alias = $attrs->{alias};
- $attrs->{columns} ||= delete $attrs->{cols} if exists $attrs->{cols};
- my @colbits;
-
- # build columns (as long as select isn't set) into a set of as/select hashes
- unless ( $attrs->{select} ) {
-
- my @cols;
- if ( ref $attrs->{columns} eq 'ARRAY' ) {
- @cols = @{ delete $attrs->{columns}}
- } elsif ( defined $attrs->{columns} ) {
- @cols = delete $attrs->{columns}
- } else {
- @cols = $source->columns
- }
+ # default selection list
+ $attrs->{columns} = [ $source->columns ]
+ unless List::Util::first { exists $attrs->{$_} } qw/columns cols select as/;
- for (@cols) {
- if ( ref $_ eq 'HASH' ) {
- push @colbits, $_
- } else {
- my $key = /^\Q${alias}.\E(.+)$/
- ? "$1"
- : "$_";
- my $value = /\./
- ? "$_"
- : "${alias}.$_";
- push @colbits, { $key => $value };
- }
- }
+ # merge selectors together
+ for (qw/columns select as/) {
+ $attrs->{$_} = $self->_merge_attr($attrs->{$_}, delete $attrs->{"+$_"})
+ if $attrs->{$_} or $attrs->{"+$_"};
}
- # add the additional columns on
- foreach (qw{include_columns +columns}) {
- if ( $attrs->{$_} ) {
- my @list = ( ref($attrs->{$_}) eq 'ARRAY' )
- ? @{ delete $attrs->{$_} }
- : delete $attrs->{$_};
- for (@list) {
- if ( ref($_) eq 'HASH' ) {
- push @colbits, $_
- } else {
- my $key = ( split /\./, $_ )[-1];
- my $value = ( /\./ ? $_ : "$alias.$_" );
- push @colbits, { $key => $value };
+ # disassemble columns
+ my (@sel, @as);
+ if (my $cols = delete $attrs->{columns}) {
+ for my $c (ref $cols eq 'ARRAY' ? @$cols : $cols) {
+ if (ref $c eq 'HASH') {
+ for my $as (keys %$c) {
+ push @sel, $c->{$as};
+ push @as, $as;
}
}
+ else {
+ push @sel, $c;
+ push @as, $c;
+ }
}
}
- # start with initial select items
- if ( $attrs->{select} ) {
- $attrs->{select} =
- ( ref $attrs->{select} eq 'ARRAY' )
- ? [ @{ $attrs->{select} } ]
- : [ $attrs->{select} ];
+ # when trying to weed off duplicates later do not go past this point -
+ # everything added from here on is unbalanced "anyone's guess" stuff
+ my $dedup_stop_idx = $#as;
- if ( $attrs->{as} ) {
- $attrs->{as} =
- (
- ref $attrs->{as} eq 'ARRAY'
- ? [ @{ $attrs->{as} } ]
- : [ $attrs->{as} ]
- )
- } else {
- $attrs->{as} = [ map {
- m/^\Q${alias}.\E(.+)$/
- ? $1
- : $_
- } @{ $attrs->{select} }
- ]
- }
- }
- else {
- # otherwise we intialise select & as to empty
- $attrs->{select} = [];
- $attrs->{as} = [];
- }
+ push @as, @{ ref $attrs->{as} eq 'ARRAY' ? $attrs->{as} : [ $attrs->{as} ] }
+ if $attrs->{as};
+ push @sel, @{ ref $attrs->{select} eq 'ARRAY' ? $attrs->{select} : [ $attrs->{select} ] }
+ if $attrs->{select};
- # now add colbits to select/as
- push @{ $attrs->{select} }, map values %{$_}, @colbits;
- push @{ $attrs->{as} }, map keys %{$_}, @colbits;
+ # assume all unqualified selectors to apply to the current alias (legacy stuff)
+ for (@sel) {
+ $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_";
+ }
- if ( my $adds = delete $attrs->{'+select'} ) {
- $adds = [$adds] unless ref $adds eq 'ARRAY';
- push @{ $attrs->{select} },
- map { /\./ || ref $_ ? $_ : "$alias.$_" } @$adds;
+ # disqualify all $alias.col as-bits (collapser mandated)
+ for (@as) {
+ $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_;
}
- if ( my $adds = delete $attrs->{'+as'} ) {
- $adds = [$adds] unless ref $adds eq 'ARRAY';
- push @{ $attrs->{as} }, @$adds;
+
+ # de-duplicate the result (remove *identical* select/as pairs)
+ # and also die on duplicate {as} pointing to different {select}s
+ # not using a c-style for as the condition is prone to shrinkage
+ my $seen;
+ my $i = 0;
+ while ($i <= $dedup_stop_idx) {
+ if ($seen->{"$sel[$i] \x00\x00 $as[$i]"}++) {
+ splice @sel, $i, 1;
+ splice @as, $i, 1;
+ $dedup_stop_idx--;
+ }
+ elsif ($seen->{$as[$i]}++) {
+ $self->throw_exception(
+ "inflate_result() alias '$as[$i]' specified twice with different SQL-side {select}-ors"
+ );
+ }
+ else {
+ $i++;
+ }
}
+ $attrs->{select} = \@sel;
+ $attrs->{as} = \@as;
+
$attrs->{from} ||= [{
- -source_handle => $source->handle,
- -alias => $self->{attrs}{alias},
+ -rsrc => $source,
+ -alias => $self->{attrs}{alias},
$self->{attrs}{alias} => $source->from,
}];
$self->throw_exception ('join/prefetch can not be used with a custom {from}')
if ref $attrs->{from} ne 'ARRAY';
- my $join = delete $attrs->{join} || {};
+ my $join = (delete $attrs->{join}) || {};
if ( defined $attrs->{prefetch} ) {
- $join = $self->_merge_attr( $join, $attrs->{prefetch} );
+ $join = $self->_merge_joinpref_attr( $join, $attrs->{prefetch} );
}
$attrs->{from} = # have to copy here to avoid corrupting the original
# subquery (since a group_by is present)
if (delete $attrs->{distinct}) {
if ($attrs->{group_by}) {
- carp ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
+ carp_unique ("Useless use of distinct on a grouped resultset ('distinct' is ignored when a 'group_by' is present)");
}
else {
- $attrs->{group_by} = [ grep { !ref($_) || (ref($_) ne 'HASH') } @{$attrs->{select}} ];
-
- # add any order_by parts that are not already present in the group_by
- # we need to be careful not to add any named functions/aggregates
- # i.e. select => [ ... { count => 'foo', -as 'foocount' } ... ]
- my %already_grouped = map { $_ => 1 } (@{$attrs->{group_by}});
-
- my $storage = $self->result_source->schema->storage;
-
- my $rs_column_list = $storage->_resolve_column_info ($attrs->{from});
-
- for my $chunk ($storage->_parse_order_by($attrs->{order_by})) {
- if ($rs_column_list->{$chunk} && not $already_grouped{$chunk}++) {
- push @{$attrs->{group_by}}, $chunk;
- }
- }
+ # distinct affects only the main selection part, not what prefetch may
+ # add below.
+ $attrs->{group_by} = $source->storage->_group_over_selection (
+ $attrs->{from},
+ $attrs->{select},
+ $attrs->{order_by},
+ );
}
}
# generate selections based on the prefetch helper
- if ( my $prefetch = delete $attrs->{prefetch} ) {
+ my $prefetch;
+ $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} )
+ if defined $attrs->{prefetch};
+
+ if ($prefetch) {
+
+ $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}")
+ if $attrs->{_dark_selector};
+
$attrs->{collapse} = 1;
# this is a separate structure (we don't look in {from} directly)
my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map );
# we need to somehow mark which columns came from prefetch
- $attrs->{_prefetch_select} = [ map { $_->[0] } @prefetch ];
+ if (@prefetch) {
+ my $sel_end = $#{$attrs->{select}};
+ $attrs->{_prefetch_selector_range} = [ $sel_end + 1, $sel_end + @prefetch ];
+ }
- push @{ $attrs->{select} }, @{$attrs->{_prefetch_select}};
+ push @{ $attrs->{select} }, (map { $_->[0] } @prefetch);
push @{ $attrs->{as} }, (map { $_->[1] } @prefetch);
}
}
}
+
# if both page and offset are specified, produce a combined offset
# even though it doesn't make much sense, this is what pre 081xx has
# been doing
}
}
-sub _merge_attr {
+sub _merge_joinpref_attr {
my ($self, $orig, $import) = @_;
return $import unless defined($orig);
$position++;
}
my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
+ $import_key = '' if not defined $import_key;
if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
push( @{$orig}, $import_element );
$orig->[$best_candidate->{position}] = $import_element;
} elsif (ref $import_element eq 'HASH') {
my ($key) = keys %{$orig_best};
- $orig->[$best_candidate->{position}] = { $key => $self->_merge_attr($orig_best->{$key}, $import_element->{$key}) };
+ $orig->[$best_candidate->{position}] = { $key => $self->_merge_joinpref_attr($orig_best->{$key}, $import_element->{$key}) };
}
}
$seen_keys->{$import_key} = 1; # don't merge the same key twice
return $orig;
}
-sub result_source {
- my $self = shift;
+{
+ my $hm;
- if (@_) {
- $self->_source_handle($_[0]->handle);
- } else {
- $self->_source_handle->resolve;
- }
+ sub _merge_attr {
+ $hm ||= do {
+ require Hash::Merge;
+ my $hm = Hash::Merge->new;
+
+ $hm->specify_behavior({
+ SCALAR => {
+ SCALAR => sub {
+ my ($defl, $defr) = map { defined $_ } (@_[0,1]);
+
+ if ($defl xor $defr) {
+ return [ $defl ? $_[0] : $_[1] ];
+ }
+ elsif (! $defl) {
+ return [];
+ }
+ elsif (__HM_DEDUP and $_[0] eq $_[1]) {
+ return [ $_[0] ];
+ }
+ else {
+ return [$_[0], $_[1]];
+ }
+ },
+ ARRAY => sub {
+ return $_[1] if !defined $_[0];
+ return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
+ return [$_[0], @{$_[1]}]
+ },
+ HASH => sub {
+ return [] if !defined $_[0] and !keys %{$_[1]};
+ return [ $_[1] ] if !defined $_[0];
+ return [ $_[0] ] if !keys %{$_[1]};
+ return [$_[0], $_[1]]
+ },
+ },
+ ARRAY => {
+ SCALAR => sub {
+ return $_[0] if !defined $_[1];
+ return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
+ return [@{$_[0]}, $_[1]]
+ },
+ ARRAY => sub {
+ my @ret = @{$_[0]} or return $_[1];
+ return [ @ret, @{$_[1]} ] unless __HM_DEDUP;
+ my %idx = map { $_ => 1 } @ret;
+ push @ret, grep { ! defined $idx{$_} } (@{$_[1]});
+ \@ret;
+ },
+ HASH => sub {
+ return [ $_[1] ] if ! @{$_[0]};
+ return $_[0] if !keys %{$_[1]};
+ return $_[0] if __HM_DEDUP and List::Util::first { $_ eq $_[1] } @{$_[0]};
+ return [ @{$_[0]}, $_[1] ];
+ },
+ },
+ HASH => {
+ SCALAR => sub {
+ return [] if !keys %{$_[0]} and !defined $_[1];
+ return [ $_[0] ] if !defined $_[1];
+ return [ $_[1] ] if !keys %{$_[0]};
+ return [$_[0], $_[1]]
+ },
+ ARRAY => sub {
+ return [] if !keys %{$_[0]} and !@{$_[1]};
+ return [ $_[0] ] if !@{$_[1]};
+ return $_[1] if !keys %{$_[0]};
+ return $_[1] if __HM_DEDUP and List::Util::first { $_ eq $_[0] } @{$_[1]};
+ return [ $_[0], @{$_[1]} ];
+ },
+ HASH => sub {
+ return [] if !keys %{$_[0]} and !keys %{$_[1]};
+ return [ $_[0] ] if !keys %{$_[1]};
+ return [ $_[1] ] if !keys %{$_[0]};
+ return [ $_[0] ] if $_[0] eq $_[1];
+ return [ $_[0], $_[1] ];
+ },
+ }
+ } => 'DBIC_RS_ATTR_MERGER');
+ $hm;
+ };
+
+ return $hm->merge ($_[1], $_[2]);
+ }
+}
+
+sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ my $to_serialize = { %$self };
+
+ # A cursor in progress can't be serialized (and would make little sense anyway)
+ delete $to_serialize->{cursor};
+
+ # nor is it sensical to store a not-yet-fired-count pager
+ if ($to_serialize->{pager} and ref $to_serialize->{pager}{total_entries} eq 'CODE') {
+ delete $to_serialize->{pager};
+ }
+
+ Storable::nfreeze($to_serialize);
+}
+
+# need this hook for symmetry
+sub STORABLE_thaw {
+ my ($self, $cloning, $serialized) = @_;
+
+ %$self = %{ Storable::thaw($serialized) };
+
+ $self;
}
+
=head2 throw_exception
See L<DBIx::Class::Schema/throw_exception> for details.
sub throw_exception {
my $self=shift;
- if (ref $self && $self->_source_handle->schema) {
- $self->_source_handle->schema->throw_exception(@_)
+ if (ref $self and my $rsrc = $self->result_source) {
+ $rsrc->throw_exception(@_)
}
else {
DBIx::Class::Exception->throw(@_);
C<select> as normal. (You may also use the C<cols> attribute, as in
earlier versions of DBIC.)
+Essentially C<columns> does the same as L</select> and L</as>.
+
+ columns => [ 'foo', { bar => 'baz' } ]
+
+is the same as
+
+ select => [qw/foo baz/],
+ as => [qw/foo bar/]
+
=head2 +columns
=over 4
column (or relationship) accessor, and 'name' is the name of the column
accessor in the related table.
+B<NOTE:> You need to explicitly quote '+columns' when defining the attribute.
+Not doing so causes Perl to incorrectly interpret +columns as a bareword with a
+unary plus operator before it.
+
=head2 include_columns
=over 4
select => [
'name',
{ count => 'employeeid' },
- { sum => 'salary' }
+ { max => { length => 'name' }, -as => 'longest_name' }
]
});
-When you use function/stored procedure names and do not supply an C<as>
-attribute, the column names returned are storage-dependent. E.g. MySQL would
-return a column named C<count(employeeid)> in the above example.
+ # Equivalent SQL
+ SELECT name, COUNT( employeeid ), MAX( LENGTH( name ) ) AS longest_name FROM employee
-B<NOTE:> You will almost always need a corresponding 'as' entry when you use
-'select'.
+B<NOTE:> You will almost always need a corresponding L</as> attribute when you
+use L</select>, to instruct DBIx::Class how to store the result of the column.
+Also note that the L</as> attribute has nothing to do with the SQL-side 'AS'
+identifier aliasing. You can however alias a function, so you can use it in
+e.g. an C<ORDER BY> clause. This is done via the C<-as> B<select function
+attribute> supplied as shown in the example above.
+
+B<NOTE:> You need to explicitly quote '+select'/'+as' when defining the attributes.
+Not doing so causes Perl to incorrectly interpret them as a bareword with a
+unary plus operator before it.
=head2 +select
=over 4
Indicates additional columns to be selected from storage. Works the same as
-L</select> but adds columns to the selection.
+L</select> but adds columns to the default selection, instead of specifying
+an explicit list.
=back
=back
-Indicates column names for object inflation. That is, C<as>
-indicates the name that the column can be accessed as via the
-C<get_column> method (or via the object accessor, B<if one already
-exists>). It has nothing to do with the SQL code C<SELECT foo AS bar>.
-
-The C<as> attribute is used in conjunction with C<select>,
-usually when C<select> contains one or more function or stored
-procedure names:
+Indicates column names for object inflation. That is L</as> indicates the
+slot name in which the column value will be stored within the
+L<Row|DBIx::Class::Row> object. The value will then be accessible via this
+identifier by the C<get_column> method (or via the object accessor B<if one
+with the same name already exists>) as shown below. The L</as> attribute has
+B<nothing to do> with the SQL-side C<AS>. See L</select> for details.
$rs = $schema->resultset('Employee')->search(undef, {
select => [
'name',
- { count => 'employeeid' }
+ { count => 'employeeid' },
+ { max => { length => 'name' }, -as => 'longest_name' }
],
- as => ['name', 'employee_count'],
+ as => [qw/
+ name
+ employee_count
+ max_name_length
+ /],
});
- my $employee = $rs->first(); # get the first Employee
-
If the object against which the search is performed already has an accessor
matching a column name specified in C<as>, the value can be retrieved using
the accessor as normal:
You can create your own accessors if required - see
L<DBIx::Class::Manual::Cookbook> for details.
-Please note: This will NOT insert an C<AS employee_count> into the SQL
-statement produced, it is used for internal access only. Thus
-attempting to use the accessor in an C<order_by> clause or similar
-will fail miserably.
-
-To get around this limitation, you can supply literal SQL to your
-C<select> attribute that contains the C<AS alias> text, e.g.
-
- select => [\'myfield AS alias']
-
=head2 join
=over 4
Simple prefetches will be joined automatically, so there is no need
for a C<join> attribute in the above search.
-C<prefetch> can be used with the following relationship types: C<belongs_to>,
-C<has_one> (or if you're using C<add_relationship>, any relationship declared
-with an accessor type of 'single' or 'filter'). A more complex example that
-prefetches an artists cds, the tracks on those cds, and the tags associated
-with that artist is given below (assuming many-to-many from artists to tags):
+L</prefetch> can be used with the any of the relationship types and
+multiple prefetches can be specified together. Below is a more complex
+example that prefetches a CD's artist, its liner notes (if present),
+the cover image, the tracks on that cd, and the guests on those
+tracks.
- my $rs = $schema->resultset('Artist')->search(
+ # Assuming:
+ My::Schema::CD->belongs_to( artist => 'My::Schema::Artist' );
+ My::Schema::CD->might_have( liner_note => 'My::Schema::LinerNotes' );
+ My::Schema::CD->has_one( cover_image => 'My::Schema::Artwork' );
+ My::Schema::CD->has_many( tracks => 'My::Schema::Track' );
+
+ My::Schema::Artist->belongs_to( record_label => 'My::Schema::RecordLabel' );
+
+ My::Schema::Track->has_many( guests => 'My::Schema::Guest' );
+
+
+ my $rs = $schema->resultset('CD')->search(
+ undef,
+ {
+ prefetch => [
+ { artist => 'record_label'}, # belongs_to => belongs_to
+ 'liner_note', # might_have
+ 'cover_image', # has_one
+ { tracks => 'guests' }, # has_many => has_many
+ ]
+ }
+ );
+
+This will produce SQL like the following:
+
+ SELECT cd.*, artist.*, record_label.*, liner_note.*, cover_image.*,
+ tracks.*, guests.*
+ FROM cd me
+ JOIN artist artist
+ ON artist.artistid = me.artistid
+ JOIN record_label record_label
+ ON record_label.labelid = artist.labelid
+ LEFT JOIN track tracks
+ ON tracks.cdid = me.cdid
+ LEFT JOIN guest guests
+ ON guests.trackid = track.trackid
+ LEFT JOIN liner_notes liner_note
+ ON liner_note.cdid = me.cdid
+ JOIN cd_artwork cover_image
+ ON cover_image.cdid = me.cdid
+ ORDER BY tracks.cd
+
+Now the C<artist>, C<record_label>, C<liner_note>, C<cover_image>,
+C<tracks>, and C<guests> of the CD will all be available through the
+relationship accessors without the need for additional queries to the
+database.
+
+However, there is one caveat to be observed: it can be dangerous to
+prefetch more than one L<has_many|DBIx::Class::Relationship/has_many>
+relationship on a given level. e.g.:
+
+ my $rs = $schema->resultset('CD')->search(
undef,
{
prefetch => [
- { cds => 'tracks' },
- { artist_tags => 'tags' }
+ 'tracks', # has_many
+ { cd_to_producer => 'producer' }, # has_many => belongs_to (i.e. m2m)
]
}
);
+In fact, C<DBIx::Class> will emit the following warning:
-B<NOTE:> If you specify a C<prefetch> attribute, the C<join> and C<select>
-attributes will be ignored.
+ Prefetching multiple has_many rels tracks and cd_to_producer at top
+ level will explode the number of row objects retrievable via ->next
+ or ->all. Use at your own risk.
-B<CAVEATs>: Prefetch does a lot of deep magic. As such, it may not behave
-exactly as you might expect.
+The collapser currently can't identify duplicate tuples for multiple
+L<has_many|DBIx::Class::Relationship/has_many> relationships and as a
+result the second L<has_many|DBIx::Class::Relationship/has_many>
+relation could contain redundant objects.
+
+=head3 Using L</prefetch> with L</join>
+
+L</prefetch> implies a L</join> with the equivalent argument, and is
+properly merged with any existing L</join> specification. So the
+following:
+
+ my $rs = $schema->resultset('CD')->search(
+ {'record_label.name' => 'Music Product Ltd.'},
+ {
+ join => {artist => 'record_label'},
+ prefetch => 'artist',
+ }
+ );
+
+... will work, searching on the record label's name, but only
+prefetching the C<artist>.
+
+=head3 Using L</prefetch> with L</select> / L</+select> / L</as> / L</+as>
+
+L</prefetch> implies a L</+select>/L</+as> with the fields of the
+prefetched relations. So given:
+
+ my $rs = $schema->resultset('CD')->search(
+ undef,
+ {
+ select => ['cd.title'],
+ as => ['cd_title'],
+ prefetch => 'artist',
+ }
+ );
+
+The L</select> becomes: C<'cd.title', 'artist.*'> and the L</as>
+becomes: C<'cd_title', 'artist.*'>.
+
+=head3 CAVEATS
+
+Prefetch does a lot of deep magic. As such, it may not behave exactly
+as you might expect.
=over 4
identical to creating a non-pages resultset and then calling ->page($page)
on it.
-If L<rows> attribute is not specified it defaults to 10 rows per page.
+If L</rows> attribute is not specified it defaults to 10 rows per page.
When you have a paged resultset, L</count> will only return the number
of rows in the page. To get the total, use the L</pager> and call
Specifies the (zero-based) row number for the first row to be returned, or the
of the first row of the first page if paging is used.
+=head2 software_limit
+
+=over 4
+
+=item Value: (0 | 1)
+
+=back
+
+When combined with L</rows> and/or L</offset> the generated SQL will not
+include any limit dialect stanzas. Instead the entire result will be selected
+as if no limits were specified, and DBIC will perform the limit locally, by
+artificially advancing and finishing the resulting L</cursor>.
+
+This is the recommended way of performing resultset limiting when no sane RDBMS
+implementation is available (e.g.
+L<Sybase ASE|DBIx::Class::Storage::DBI::Sybase::ASE> using the
+L<Generic Sub Query|DBIx::Class::SQLMaker::LimitDialects/GenericSubQ> hack)
+
=head2 group_by
=over 4
ORDER BY. It is applied to the after the grouping calculations have been
done.
- having => { 'count(employee)' => { '>=', 100 } }
+ having => { 'count_employee' => { '>=', 100 } }
+
+or with an in-place function in which case literal SQL is required:
+
+ having => \[ 'count(employee) >= ?', [ count => 100 ] ]
=head2 distinct
Can be overridden by passing C<< { where => undef } >> as an attribute
to a resultset.
+For more complicated where clauses see L<SQL::Abstract/WHERE CLAUSES>.
+
=back
=head2 cache
--- /dev/null
+package # hide from pause
+ DBIx::Class::ResultSet::Pager;
+
+use warnings;
+use strict;
+
+use base 'Data::Page';
+use mro 'c3';
+
+# simple support for lazy totals
+sub _total_entries_accessor {
+ if (@_ == 1 and ref $_[0]->{total_entries} eq 'CODE') {
+ return $_[0]->{total_entries} = $_[0]->{total_entries}->();
+ }
+
+ return shift->next::method(@_);
+}
+
+sub _skip_namespace_frames { qr/^Data::Page/ }
+
+1;
use warnings;
use base 'DBIx::Class';
-
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use DBIx::Class::Exception;
-use List::Util;
+
+# not importing first() as it will clash with our own method
+use List::Util ();
=head1 NAME
my $orig_attrs = $rs->_resolved_attrs;
my $alias = $rs->current_source_alias;
+ my $rsrc = $rs->result_source;
# If $column can be found in the 'as' list of the parent resultset, use the
# corresponding element of its 'select' list (to keep any custom column
my $as_index = List::Util::first { ($as_list->[$_] || "") eq $column } 0..$#$as_list;
my $select = defined $as_index ? $select_list->[$as_index] : $column;
- my $new_parent_rs;
+ my ($new_parent_rs, $colmap);
+ for ($rsrc->columns, $column) {
+ if ($_ =~ /^ \Q$alias\E \. ([^\.]+) $ /x) {
+ $colmap->{$_} = $1;
+ }
+ elsif ($_ !~ /\./) {
+ $colmap->{"$alias.$_"} = $_;
+ $colmap->{$_} = $_;
+ }
+ }
+
# analyze the order_by, and see if it is done over a function/nonexistentcolumn
# if this is the case we will need to wrap a subquery since the result of RSC
# *must* be a single column select
- my %collist = map
- { $_ => 1, ($_ =~ /\./) ? () : ( "$alias.$_" => 1 ) }
- ($rs->result_source->columns, $column)
- ;
if (
scalar grep
- { ! $collist{$_} }
- ( $rs->result_source->schema->storage->_parse_order_by ($orig_attrs->{order_by} ) )
+ { ! exists $colmap->{$_->[0]} }
+ ( $rsrc->schema->storage->_extract_order_criteria ($orig_attrs->{order_by} ) )
) {
# nuke the prefetch before collapsing to sql
my $subq_rs = $rs->search;
- $subq_rs->{attrs}{join} = $subq_rs->_merge_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} );
+ $subq_rs->{attrs}{join} = $subq_rs->_merge_joinpref_attr( $subq_rs->{attrs}{join}, delete $subq_rs->{attrs}{prefetch} );
$new_parent_rs = $subq_rs->as_subselect_rs;
}
# rs via the _resolved_attrs trick - we need to retain the separation between
# +select/+as and select/as. At the same time we want to preserve any joins that the
# prefetch would otherwise generate.
- $new_attrs->{join} = $rs->_merge_attr( $new_attrs->{join}, delete $new_attrs->{prefetch} );
+ $new_attrs->{join} = $rs->_merge_joinpref_attr( $new_attrs->{join}, delete $new_attrs->{prefetch} );
# {collapse} would mean a has_many join was injected, which in turn means
# we need to group *IF WE CAN* (only if the column in question is unique)
if (!$orig_attrs->{group_by} && $orig_attrs->{collapse}) {
- # scan for a constraint that would contain our column only - that'd be proof
- # enough it is unique
- my $constraints = { $rs->result_source->unique_constraints };
- for my $constraint_columns ( values %$constraints ) {
-
- next unless @$constraint_columns == 1;
-
- my $col = $constraint_columns->[0];
- my $fqcol = join ('.', $new_attrs->{alias}, $col);
-
- if ($col eq $select or $fqcol eq $select) {
- $new_attrs->{group_by} = [ $select ];
- delete $new_attrs->{distinct}; # it is ignored when group_by is present
- last;
- }
+ if ($colmap->{$select} and $rsrc->_identifying_column_set([$colmap->{$select}])) {
+ $new_attrs->{group_by} = [ $select ];
+ delete $new_attrs->{distinct}; # it is ignored when group_by is present
}
-
- if (!$new_attrs->{group_by}) {
+ else {
carp (
"Attempting to retrieve non-unique column '$column' on a resultset containing "
. 'one-to-many joins will return duplicate results.'
Returns the next value of the column in the resultset (or C<undef> if
there is none).
-Much like L<DBIx::Class::ResultSet/next> but just returning the
+Much like L<DBIx::Class::ResultSet/next> but just returning the
one value.
=cut
See L<DBIx::Class::Schema/throw_exception> for details.
-=cut
+=cut
sub throw_exception {
my $self=shift;
package # hide from PAUSE
DBIx::Class::ResultSetProxy;
+unless ($INC{"DBIx/Class/DB.pm"}) {
+ warn "IMPORTANT: DBIx::Class::ResultSetProxy is DEPRECATED AND *WILL* BE REMOVED. DO NOT USE.\n";
+}
+
use strict;
use warnings;
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
-
-__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
- _columns _primaries _unique_constraints name resultset_attributes
- schema from _relationships column_info_from_storage source_info
- source_name sqlt_deploy_callback/);
-
-__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
- result_class/);
+use DBIx::Class::Carp;
+use DBIx::Class::GlobalDestruction;
+use Try::Tiny;
+use List::Util 'first';
+use Scalar::Util qw/blessed weaken isweak/;
+use namespace::clean;
+
+__PACKAGE__->mk_group_accessors(simple => qw/
+ source_name name source_info
+ _ordered_columns _columns _primaries _unique_constraints
+ _relationships resultset_attributes
+ column_info_from_storage
+/);
+
+__PACKAGE__->mk_group_accessors(component_class => qw/
+ resultset_class
+ result_class
+/);
+
+__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' );
=head1 NAME
# Create a table based result source, in a result class.
- package MyDB::Schema::Result::Artist;
+ package MyApp::Schema::Result::Artist;
use base qw/DBIx::Class::Core/;
__PACKAGE__->table('artist');
__PACKAGE__->add_columns(qw/ artistid name /);
__PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
+ __PACKAGE__->has_many(cds => 'MyApp::Schema::Result::CD');
1;
# Create a query (view) based result source, in a result class
- package MyDB::Schema::Result::Year2000CDs;
+ package MyApp::Schema::Result::Year2000CDs;
use base qw/DBIx::Class::Core/;
__PACKAGE__->load_components('InflateColumn::DateTime');
$new->{_relationships} = { %{$new->{_relationships}||{}} };
$new->{name} ||= "!!NAME NOT SET!!";
$new->{_columns_info_loaded} ||= 0;
- $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
return $new;
}
L<DBIx::Class::Row> objects. You can change the name of the accessor
by supplying an L</accessor> in the column_info hash.
+If a column name beginning with a plus sign ('+col1') is provided, the
+attributes provided will be merged with any existing attributes for the
+column, with the new attributes taking precedence in the case that an
+attribute already exists. Using this without a hashref
+(C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
+it does the same thing it would do without the plus.
+
The contents of the column_info are not set in stone. The following
keys are currently recognised/used by DBIx::Class:
This contains the column type. It is automatically filled if you use the
L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
-L<DBIx::Class::Schema::Loader> module.
+L<DBIx::Class::Schema::Loader> module.
Currently there is no standard set of values for the data_type. Use
whatever your database supports.
will attempt to retrieve the name of the sequence from the database
automatically.
+=item retrieve_on_insert
+
+ { retrieve_on_insert => 1 }
+
+For every column where this is set to true, DBIC will retrieve the RDBMS-side
+value upon a new row insertion (normally only the autoincrement PK is
+retrieved on insert). C<INSERT ... RETURNING> is used automatically if
+supported by the underlying storage, otherwise an extra SELECT statement is
+executed to retrieve the missing data.
+
=item auto_nextval
+ { auto_nextval => 1 }
+
Set this to a true value for a column whose value is retrieved automatically
from a sequence or function (if supported by your Storage driver.) For a
sequence, if you do not use a trigger to get the nextval, you have to set the
L</sequence> value as well.
Also set this for MSSQL columns with the 'uniqueidentifier'
-L<DBIx::Class::ResultSource/data_type> whose values you want to automatically
-generate using C<NEWID()>, unless they are a primary key in which case this will
-be done anyway.
+L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
+automatically generate using C<NEWID()>, unless they are a primary key in which
+case this will be done anyway.
=item extra
my @added;
my $columns = $self->_columns;
while (my $col = shift @cols) {
+ my $column_info = {};
+ if ($col =~ s/^\+//) {
+ $column_info = $self->column_info($col);
+ }
+
# If next entry is { ... } use that for the column info, if not
# use an empty hashref
- my $column_info = ref $cols[0] ? shift(@cols) : {};
+ if (ref $cols[0]) {
+ my $new_info = shift(@cols);
+ %$column_info = (%$column_info, %$new_info);
+ }
push(@added, $col) unless exists $columns->{$col};
$columns->{$col} = $column_info;
}
my ($self, $column) = @_;
$self->throw_exception("No such column $column")
unless exists $self->_columns->{$column};
- #warn $self->{_columns_info_loaded}, "\n";
+
if ( ! $self->_columns->{$column}{data_type}
- and $self->column_info_from_storage
and ! $self->{_columns_info_loaded}
- and $self->schema and $self->storage )
+ and $self->column_info_from_storage
+ and my $stor = try { $self->storage } )
{
$self->{_columns_info_loaded}++;
- my $info = {};
- my $lc_info = {};
- # eval for the case of storage without table
- eval { $info = $self->storage->columns_info_for( $self->from ) };
- unless ($@) {
- for my $realcol ( keys %{$info} ) {
- $lc_info->{lc $realcol} = $info->{$realcol};
- }
+
+ # try for the case of storage without table
+ try {
+ my $info = $stor->columns_info_for( $self->from );
+ my $lc_info = { map
+ { (lc $_) => $info->{$_} }
+ ( keys %$info )
+ };
+
foreach my $col ( keys %{$self->_columns} ) {
$self->_columns->{$col} = {
%{ $self->_columns->{$col} },
%{ $info->{$col} || $lc_info->{lc $col} || {} }
};
}
- }
+ };
}
+
return $self->_columns->{$column};
}
return @{$self->{_ordered_columns}||[]};
}
+=head2 columns_info
+
+=over
+
+=item Arguments: \@colnames ?
+
+=item Return value: Hashref of column name/info pairs
+
+=back
+
+ my $columns_info = $source->columns_info;
+
+Like L</column_info> but returns information for the requested columns. If
+the optional column-list arrayref is omitted it returns info on all columns
+currently defined on the ResultSource via L</add_columns>.
+
+=cut
+
+sub columns_info {
+ my ($self, $columns) = @_;
+
+ my $colinfo = $self->_columns;
+
+ if (
+ first { ! $_->{data_type} } values %$colinfo
+ and
+ ! $self->{_columns_info_loaded}
+ and
+ $self->column_info_from_storage
+ and
+ my $stor = try { $self->storage }
+ ) {
+ $self->{_columns_info_loaded}++;
+
+ # try for the case of storage without table
+ try {
+ my $info = $stor->columns_info_for( $self->from );
+ my $lc_info = { map
+ { (lc $_) => $info->{$_} }
+ ( keys %$info )
+ };
+
+ foreach my $col ( keys %$colinfo ) {
+ $colinfo->{$col} = {
+ %{ $colinfo->{$col} },
+ %{ $info->{$col} || $lc_info->{lc $col} || {} }
+ };
+ }
+ };
+ }
+
+ my %ret;
+
+ if ($columns) {
+ for (@$columns) {
+ if (my $inf = $colinfo->{$_}) {
+ $ret{$_} = $inf;
+ }
+ else {
+ $self->throw_exception( sprintf (
+ "No such column '%s' on source %s",
+ $_,
+ $self->source_name,
+ ));
+ }
+ }
+ }
+ else {
+ %ret = %$colinfo;
+ }
+
+ return \%ret;
+}
+
=head2 remove_columns
=over
Additionally, defines a L<unique constraint|add_unique_constraint>
named C<primary>.
-The primary key columns are used by L<DBIx::Class::PK::Auto> to
-retrieve automatically created values from the database. They are also
-used as default joining columns when specifying relationships, see
-L<DBIx::Class::Relationship>.
+Note: you normally do want to define a primary key on your sources
+B<even if the underlying database table does not have a primary key>.
+See
+L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
+for more info.
=cut
return @{shift->_primaries||[]};
}
+# a helper method that will automatically die with a descriptive message if
+# no pk is defined on the source in question. For internal use to save
+# on if @pks... boilerplate
sub _pri_cols {
my $self = shift;
my @pcols = $self->primary_columns
or $self->throw_exception (sprintf(
- 'Operation requires a primary key to be declared on %s via set_primary_key',
- $self->source_name,
+ "Operation requires a primary key to be declared on '%s' via set_primary_key",
+ # source_name is set only after schema-registration
+ $self->source_name || $self->result_class || $self->name || 'Unknown source...?',
));
return @pcols;
}
+=head2 sequence
+
+Manually define the correct sequence for your table, to avoid the overhead
+associated with looking up the sequence automatically. The supplied sequence
+will be applied to the L</column_info> of each L<primary_key|/set_primary_key>
+
+=over 4
+
+=item Arguments: $sequence_name
+
+=item Return value: undefined
+
+=back
+
+=cut
+
+sub sequence {
+ my ($self,$seq) = @_;
+
+ my @pks = $self->primary_columns
+ or return;
+
+ $_->{sequence} = $seq
+ for values %{ $self->columns_info (\@pks) };
+}
+
+
=head2 add_unique_constraint
=over 4
sub add_unique_constraint {
my $self = shift;
+
+ if (@_ > 2) {
+ $self->throw_exception(
+ 'add_unique_constraint() does not accept multiple constraints, use '
+ . 'add_unique_constraints() instead'
+ );
+ }
+
my $cols = pop @_;
- my $name = shift;
+ if (ref $cols ne 'ARRAY') {
+ $self->throw_exception (
+ 'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING')
+ );
+ }
+
+ my $name = shift @_;
$name ||= $self->name_unique_constraint($cols);
$self->_unique_constraints(\%unique_constraints);
}
+=head2 add_unique_constraints
+
+=over 4
+
+=item Arguments: @constraints
+
+=item Return value: undefined
+
+=back
+
+Declare multiple unique constraints on this source.
+
+ __PACKAGE__->add_unique_constraints(
+ constraint_name1 => [ qw/column1 column2/ ],
+ constraint_name2 => [ qw/column2 column3/ ],
+ );
+
+Alternatively, you can specify only the columns:
+
+ __PACKAGE__->add_unique_constraints(
+ [ qw/column1 column2/ ],
+ [ qw/column3 column4/ ]
+ );
+
+This will result in unique constraints named C<table_column1_column2> and
+C<table_column3_column4>, where C<table> is replaced with the table name.
+
+Throws an error if any of the given column names do not yet exist on
+the result source.
+
+See also L</add_unique_constraint>.
+
+=cut
+
+sub add_unique_constraints {
+ my $self = shift;
+ my @constraints = @_;
+
+ if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) {
+ # with constraint name
+ while (my ($name, $constraint) = splice @constraints, 0, 2) {
+ $self->add_unique_constraint($name => $constraint);
+ }
+ }
+ else {
+ # no constraint name
+ foreach my $constraint (@constraints) {
+ $self->add_unique_constraint($constraint);
+ }
+ }
+}
+
=head2 name_unique_constraint
=over 4
-=item Arguments: @colnames
+=item Arguments: \@colnames
=item Return value: Constraint name
=back
$source->table('mytable');
- $source->name_unique_constraint('col1', 'col2');
+ $source->name_unique_constraint(['col1', 'col2']);
# returns
'mytable_col1_col2'
=over
-=item Arguments: $callback
+=item Arguments: $callback_name | \&callback_code
+
+=item Return value: $callback_name | \&callback_code
=back
__PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
+ or
+
+ __PACKAGE__->sqlt_deploy_callback(sub {
+ my ($source_instance, $sqlt_table) = @_;
+ ...
+ } );
+
An accessor to set a callback to be called during deployment of
the schema via L<DBIx::Class::Schema/create_ddl_dir> or
L<DBIx::Class::Schema/deploy>.
The callback can be set as either a code reference or the name of a
method in the current result class.
-If not set, the L</default_sqlt_deploy_hook> is called.
+Defaults to L</default_sqlt_deploy_hook>.
Your callback will be passed the $source object representing the
ResultSource instance being deployed, and the
=head2 default_sqlt_deploy_hook
-=over
-
-=item Arguments: $source, $sqlt_table
-
-=item Return value: undefined
-
-=back
-
-This is the sensible default for L</sqlt_deploy_callback>.
-
-If a method named C<sqlt_deploy_hook> exists in your Result class, it
-will be called and passed the current C<$source> and the
-C<$sqlt_table> being deployed.
+This is the default deploy hook implementation which checks if your
+current Result class has a C<sqlt_deploy_hook> method, and if present
+invokes it B<on the Result class directly>. This is to preserve the
+semantics of C<sqlt_deploy_hook> which was originally designed to expect
+the Result class name and the
+L<$sqlt_table instance|SQL::Translator::Schema::Table> of the table being
+deployed.
=cut
'call it on the schema instead.'
) if scalar @_;
- return $self->resultset_class->new(
+ $self->resultset_class->new(
$self,
{
+ try { %{$self->schema->default_resultset_attributes} },
%{$self->{resultset_attributes}},
- %{$self->schema->default_resultset_attributes}
},
);
}
+=head2 name
+
+=over 4
+
+=item Arguments: None
+
+=item Result value: $name
+
+=back
+
+Returns the name of the result source, which will typically be the table
+name. This may be a scalar reference if the result source has a non-standard
+name.
+
=head2 source_name
=over 4
retrieval from this source. In the case of a database, the required FROM
clause contents.
+=cut
+
+sub from { die 'Virtual method!' }
+
=head2 schema
=over 4
-=item Arguments: None
+=item Arguments: $schema
=item Return value: A schema object
my $schema = $source->schema();
-Returns the L<DBIx::Class::Schema> object that this result source
-belongs to.
+Sets and/or returns the L<DBIx::Class::Schema> object to which this
+result source instance has been attached to.
+
+=cut
+
+sub schema {
+ if (@_ > 1) {
+ $_[0]->{schema} = $_[1];
+ }
+ else {
+ $_[0]->{schema} || do {
+ my $name = $_[0]->{source_name} || '_unnamed_';
+ my $err = 'Unable to perform storage-dependent operations with a detached result source '
+ . "(source '$name' is not associated with a schema).";
+
+ $err .= ' You need to use $schema->thaw() or manually set'
+ . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
+ if $_[0]->{_detached_thaw};
+
+ DBIx::Class::Exception->throw($err);
+ };
+ }
+}
=head2 storage
return $self;
- # XXX disabled. doesn't work properly currently. skip in tests.
+# XXX disabled. doesn't work properly currently. skip in tests.
my $f_source = $self->schema->source($f_source_name);
unless ($f_source) {
}
return unless $f_source; # Can't test rel without f_source
- eval { $self->_resolve_join($rel, 'me', {}, []) };
-
- if ($@) { # If the resolve failed, back out and re-throw the error
- delete $rels{$rel}; #
+ try { $self->_resolve_join($rel, 'me', {}, []) }
+ catch {
+ # If the resolve failed, back out and re-throw the error
+ delete $rels{$rel};
$self->_relationships(\%rels);
- $self->throw_exception("Error creating relationship $rel: $@");
- }
+ $self->throw_exception("Error creating relationship $rel: $_");
+ };
+
1;
}
sub reverse_relationship_info {
my ($self, $rel) = @_;
- my $rel_info = $self->relationship_info($rel);
+
+ my $rel_info = $self->relationship_info($rel)
+ or $self->throw_exception("No such relationship '$rel'");
+
my $ret = {};
return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
- my @cond = keys(%{$rel_info->{cond}});
- my @refkeys = map {/^\w+\.(\w+)$/} @cond;
- my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
+ my $stripped_cond = $self->__strip_relcond ($rel_info->{cond});
- # Get the related result source for this relationship
- my $othertable = $self->related_source($rel);
+ my $rsrc_schema_moniker = $self->source_name
+ if try { $self->schema };
+
+ # this may be a partial schema or something else equally esoteric
+ my $other_rsrc = try { $self->related_source($rel) }
+ or return $ret;
# Get all the relationships for that source that related to this source
# whose foreign column set are our self columns on $rel and whose self
- # columns are our foreign columns on $rel.
- my @otherrels = $othertable->relationships();
- my $otherrelationship;
- foreach my $otherrel (@otherrels) {
- my $otherrel_info = $othertable->relationship_info($otherrel);
+ # columns are our foreign columns on $rel
+ foreach my $other_rel ($other_rsrc->relationships) {
- my $back = $othertable->related_source($otherrel);
- next unless $back->source_name eq $self->source_name;
+ # only consider stuff that points back to us
+ # "us" here is tricky - if we are in a schema registration, we want
+ # to use the source_names, otherwise we will use the actual classes
- my @othertestconds;
+ # the schema may be partial
+ my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) }
+ or next;
- if (ref $otherrel_info->{cond} eq 'HASH') {
- @othertestconds = ($otherrel_info->{cond});
- }
- elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
- @othertestconds = @{$otherrel_info->{cond}};
+ if ($rsrc_schema_moniker and try { $roundtrip_rsrc->schema } ) {
+ next unless $rsrc_schema_moniker eq $roundtrip_rsrc->source_name;
}
else {
- next;
+ next unless $self->result_class eq $roundtrip_rsrc->result_class;
}
- foreach my $othercond (@othertestconds) {
- my @other_cond = keys(%$othercond);
- my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
- my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
- next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
- !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
- $ret->{$otherrel} = $otherrel_info;
- }
+ my $other_rel_info = $other_rsrc->relationship_info($other_rel);
+
+ # this can happen when we have a self-referential class
+ next if $other_rel_info eq $rel_info;
+
+ next unless ref $other_rel_info->{cond} eq 'HASH';
+ my $other_stripped_cond = $self->__strip_relcond($other_rel_info->{cond});
+
+ $ret->{$other_rel} = $other_rel_info if (
+ $self->_compare_relationship_keys (
+ [ keys %$stripped_cond ], [ values %$other_stripped_cond ]
+ )
+ and
+ $self->_compare_relationship_keys (
+ [ values %$stripped_cond ], [ keys %$other_stripped_cond ]
+ )
+ );
}
+
return $ret;
}
+# all this does is removes the foreign/self prefix from a condition
+sub __strip_relcond {
+ +{
+ map
+ { map { /^ (?:foreign|self) \. (\w+) $/x } ($_, $_[1]{$_}) }
+ keys %{$_[1]}
+ }
+}
+
sub compare_relationship_keys {
carp 'compare_relationship_keys is a private method, stop calling it';
my $self = shift;
# Returns true if both sets of keynames are the same, false otherwise.
sub _compare_relationship_keys {
- my ($self, $keys1, $keys2) = @_;
-
- # Make sure every keys1 is in keys2
- my $found;
- foreach my $key (@$keys1) {
- $found = 0;
- foreach my $prim (@$keys2) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
- }
+# my ($self, $keys1, $keys2) = @_;
+ return
+ join ("\x00", sort @{$_[1]})
+ eq
+ join ("\x00", sort @{$_[2]})
+ ;
+}
- # Make sure every key2 is in key1
- if ($found) {
- foreach my $prim (@$keys2) {
- $found = 0;
- foreach my $key (@$keys1) {
- if ($prim eq $key) {
- $found = 1;
- last;
- }
- }
- last unless $found;
+# optionally takes either an arrayref of column names, or a hashref of already
+# retrieved colinfos
+# returns an arrayref of column names of the shortest unique constraint
+# (matching some of the input if any), giving preference to the PK
+sub _identifying_column_set {
+ my ($self, $cols) = @_;
+
+ my %unique = $self->unique_constraints;
+ my $colinfos = ref $cols eq 'HASH' ? $cols : $self->columns_info($cols||());
+
+ # always prefer the PK first, and then shortest constraints first
+ USET:
+ for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) {
+ next unless $set && @$set;
+
+ for (@$set) {
+ next USET unless ($colinfos->{$_} && !$colinfos->{$_}{is_nullable} );
}
+
+ # copy so we can mangle it at will
+ return [ @$set ];
}
- return $found;
+ return undef;
}
# Returns the {from} structure used to express JOIN conditions
$jpath = [@$jpath]; # copy
- if (not defined $join) {
+ if (not defined $join or not length $join) {
return ();
}
elsif (ref $join eq 'ARRAY') {
for my $rel (keys %$join) {
my $rel_info = $self->relationship_info($rel)
- or $self->throw_exception("No such relationship ${rel}");
+ or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
my $force_left = $parent_force_left;
$force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
);
my $rel_info = $self->relationship_info($join)
- or $self->throw_exception("No such relationship ${join}");
+ or $self->throw_exception("No such relationship $join on " . $self->source_name);
my $rel_src = $self->related_source($join);
return [ { $as => $rel_src->from,
- -source_handle => $rel_src->handle,
+ -rsrc => $rel_src,
-join_type => $parent_force_left
? 'left'
: $rel_info->{attrs}{join_type}
-is_single => (
$rel_info->{attrs}{accessor}
&&
- List::Util::first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
+ first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
),
-alias => $as,
-relation_chain_depth => $seen->{-relation_chain_depth} || 0,
},
- $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
+ scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join)
+ ];
}
}
$self->_resolve_condition (@_);
}
-# Resolves the passed condition to a concrete query fragment. If given an alias,
-# returns a join condition; if given an object, inverts that object to produce
-# a related conditional from that object.
our $UNRESOLVABLE_CONDITION = \ '1 = 0';
+# Resolves the passed condition to a concrete query fragment and a flag
+# indicating whether this is a cross-table condition. Also an optional
+# list of non-triviail values (notmally conditions) returned as a part
+# of a joinfree condition hash
sub _resolve_condition {
- my ($self, $cond, $as, $for) = @_;
- if (ref $cond eq 'HASH') {
+ my ($self, $cond, $as, $for, $relname) = @_;
+
+ my $obj_rel = !!blessed $for;
+
+ if (ref $cond eq 'CODE') {
+ my $relalias = $obj_rel ? 'me' : $as;
+
+ my ($crosstable_cond, $joinfree_cond) = $cond->({
+ self_alias => $obj_rel ? $as : $for,
+ foreign_alias => $relalias,
+ self_resultsource => $self,
+ foreign_relname => $relname || ($obj_rel ? $as : $for),
+ self_rowobj => $obj_rel ? $for : undef
+ });
+
+ my $cond_cols;
+ if ($joinfree_cond) {
+
+ # FIXME sanity check until things stabilize, remove at some point
+ $self->throw_exception (
+ "A join-free condition returned for relationship '$relname' without a row-object to chain from"
+ ) unless $obj_rel;
+
+ # FIXME another sanity check
+ if (
+ ref $joinfree_cond ne 'HASH'
+ or
+ first { $_ !~ /^\Q$relalias.\E.+/ } keys %$joinfree_cond
+ ) {
+ $self->throw_exception (
+ "The join-free condition returned for relationship '$relname' must be a hash "
+ .'reference with all keys being valid columns on the related result source'
+ );
+ }
+
+ # normalize
+ for (values %$joinfree_cond) {
+ $_ = $_->{'='} if (
+ ref $_ eq 'HASH'
+ and
+ keys %$_ == 1
+ and
+ exists $_->{'='}
+ );
+ }
+
+ # see which parts of the joinfree cond are conditionals
+ my $relcol_list = { map { $_ => 1 } $self->related_source($relname)->columns };
+
+ for my $c (keys %$joinfree_cond) {
+ my ($colname) = $c =~ /^ (?: \Q$relalias.\E )? (.+)/x;
+
+ unless ($relcol_list->{$colname}) {
+ push @$cond_cols, $colname;
+ next;
+ }
+
+ if (
+ ref $joinfree_cond->{$c}
+ and
+ ref $joinfree_cond->{$c} ne 'SCALAR'
+ and
+ ref $joinfree_cond->{$c} ne 'REF'
+ ) {
+ push @$cond_cols, $colname;
+ next;
+ }
+ }
+
+ return wantarray ? ($joinfree_cond, 0, $cond_cols) : $joinfree_cond;
+ }
+ else {
+ return wantarray ? ($crosstable_cond, 1) : $crosstable_cond;
+ }
+ }
+ elsif (ref $cond eq 'HASH') {
my %ret;
foreach my $k (keys %{$cond}) {
my $v = $cond->{$k};
} elsif (!defined $as) { # undef, i.e. "no reverse object"
$ret{$v} = undef;
} else {
- $ret{"${as}.${k}"} = "${for}.${v}";
+ $ret{"${as}.${k}"} = { -ident => "${for}.${v}" };
}
}
- return \%ret;
- } elsif (ref $cond eq 'ARRAY') {
- return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
- } else {
- die("Can't handle condition $cond yet :(");
+
+ return wantarray
+ ? ( \%ret, ($obj_rel || !defined $as || ref $as) ? 0 : 1 )
+ : \%ret
+ ;
+ }
+ elsif (ref $cond eq 'ARRAY') {
+ my (@ret, $crosstable);
+ for (@$cond) {
+ my ($cond, $crosstab) = $self->_resolve_condition($_, $as, $for, $relname);
+ push @ret, $cond;
+ $crosstable ||= $crosstab;
+ }
+ return wantarray ? (\@ret, $crosstable) : \@ret;
+ }
+ else {
+ $self->throw_exception ("Can't handle condition $cond for relationship '$relname' yet :(");
}
}
-
# Accepts one or more relationships for the current source and returns an
# array of column names for each of those relationships. Column names are
# prefixed relative to the current source, in accordance with where they appear
# in the supplied relationships.
-
sub _resolve_prefetch {
my ($self, $pre, $alias, $alias_map, $order, $pref_path) = @_;
$pref_path ||= [];
- if (not defined $pre) {
+ if (not defined $pre or not length $pre) {
return ();
}
elsif( ref $pre eq 'ARRAY' ) {
my $as = shift @{$p->{-join_aliases}};
my $rel_info = $self->relationship_info( $pre );
- $self->throw_exception( $self->name . " has no such relationship '$pre'" )
+ $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
unless $rel_info;
my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
my $rel_source = $self->related_source($pre);
# values %{$rel_info->{cond}};
my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
keys %{$rel_info->{cond}};
- my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
- ? @{$rel_info->{attrs}{order_by}}
-
- : (defined $rel_info->{attrs}{order_by}
- ? ($rel_info->{attrs}{order_by})
- : ()
- ));
- push(@$order, map { "${as}.$_" } (@key, @ord));
+
+ push @$order, map { "${as}.$_" } @key;
+
+ if (my $rel_order = $rel_info->{attrs}{order_by}) {
+ # this is kludgy and incomplete, I am well aware
+ # but the parent method is going away entirely anyway
+ # so sod it
+ my $sql_maker = $self->storage->sql_maker;
+ my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
+ my $sep = $sql_maker->name_sep;
+
+ # install our own quoter, so we can catch unqualified stuff
+ local $sql_maker->{quote_char} = ["\x00", "\xFF"];
+
+ my $quoted_prefix = "\x00${as}\xFF";
+
+ for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
+ my @bind;
+ ($chunk, @bind) = @$chunk if ref $chunk;
+
+ $chunk = "${quoted_prefix}${sep}${chunk}"
+ unless $chunk =~ /\Q$sep/;
+
+ $chunk =~ s/\x00/$orig_ql/g;
+ $chunk =~ s/\xFF/$orig_qr/g;
+ push @$order, \[$chunk, @bind];
+ }
+ }
}
return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
if( !$self->has_relationship( $rel ) ) {
$self->throw_exception("No such relationship '$rel' on " . $self->source_name);
}
- return $self->schema->source($self->relationship_info($rel)->{source});
+
+ # if we are not registered with a schema - just use the prototype
+ # however if we do have a schema - ask for the source by name (and
+ # throw in the process if all fails)
+ if (my $schema = try { $self->schema }) {
+ $schema->source($self->relationship_info($rel)->{source});
+ }
+ else {
+ my $class = $self->relationship_info($rel)->{class};
+ $self->ensure_class_loaded($class);
+ $class->result_source_instance;
+ }
}
=head2 related_class
sub related_class {
my ($self, $rel) = @_;
if( !$self->has_relationship( $rel ) ) {
- $self->throw_exception("No such relationship '$rel'");
+ $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
}
return $self->schema->class($self->relationship_info($rel)->{source});
}
=head2 handle
-Obtain a new handle to this source. Returns an instance of a
-L<DBIx::Class::ResultSourceHandle>.
+=over 4
+
+=item Arguments: None
+
+=item Return value: $source_handle
+
+=back
+
+Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
+for this source. Used as a serializable pointer to this resultsource, as it is not
+easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
+relationship definitions.
=cut
sub handle {
- return DBIx::Class::ResultSourceHandle->new({
- schema => $_[0]->schema,
- source_moniker => $_[0]->source_name
- });
+ return DBIx::Class::ResultSourceHandle->new({
+ source_moniker => $_[0]->source_name,
+
+ # so that a detached thaw can be re-frozen
+ $_[0]->{_detached_thaw}
+ ? ( _detached_source => $_[0] )
+ : ( schema => $_[0]->schema )
+ ,
+ });
+}
+
+my $global_phase_destroy;
+sub DESTROY {
+ return if $global_phase_destroy ||= in_global_destruction;
+
+######
+# !!! ACHTUNG !!!!
+######
+#
+# Under no circumstances shall $_[0] be stored anywhere else (like copied to
+# a lexical variable, or shifted, or anything else). Doing so will mess up
+# the refcount of this particular result source, and will allow the $schema
+# we are trying to save to reattach back to the source we are destroying.
+# The relevant code checking refcounts is in ::Schema::DESTROY()
+
+ # if we are not a schema instance holder - we don't matter
+ return if(
+ ! ref $_[0]->{schema}
+ or
+ isweak $_[0]->{schema}
+ );
+
+ # weaken our schema hold forcing the schema to find somewhere else to live
+ # during global destruction (if we have not yet bailed out) this will throw
+ # which will serve as a signal to not try doing anything else
+ # however beware - on older perls the exception seems randomly untrappable
+ # due to some weird race condition during thread joining :(((
+ local $@;
+ eval {
+ weaken $_[0]->{schema};
+
+ # if schema is still there reintroduce ourselves with strong refs back to us
+ if ($_[0]->{schema}) {
+ my $srcregs = $_[0]->{schema}->source_registrations;
+ for (keys %$srcregs) {
+ next unless $srcregs->{$_};
+ $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
+ }
+ }
+
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ };
+
+ return;
+}
+
+sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $ice) = @_;
+ %$self = %{ (Storable::thaw($ice))->resolve };
}
=head2 throw_exception
sub throw_exception {
my $self = shift;
- if (defined $self->schema) {
- $self->schema->throw_exception(@_);
- }
- else {
- DBIx::Class::Exception->throw(@_);
- }
+ $self->{schema}
+ ? $self->{schema}->throw_exception(@_)
+ : DBIx::Class::Exception->throw(@_)
+ ;
}
=head2 source_info
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/ResultSource/);
__PACKAGE__->mk_group_accessors(
- 'simple' => qw(is_virtual view_definition)
-);
+ 'simple' => qw(is_virtual view_definition deploy_depends_on) );
=head1 NAME
=head1 SYNOPSIS
- package MyDB::Schema::Result::Year2000CDs;
+ package MyApp::Schema::Result::Year2000CDs;
use base qw/DBIx::Class::Core/;
=head1 EXAMPLES
-Having created the MyDB::Schema::Year2000CDs schema as shown in the SYNOPSIS
+Having created the MyApp::Schema::Year2000CDs schema as shown in the SYNOPSIS
above, you can then:
$2000_cds = $schema->resultset('Year2000CDs')
If you modified the schema to include a placeholder
__PACKAGE__->result_source_instance->view_definition(
- "SELECT cdid, artist, title FROM cd WHERE year ='?'"
+ "SELECT cdid, artist, title FROM cd WHERE year = ?"
);
and ensuring you have is_virtual set to true:
$schema->resultset('Year2000CDs')->all();
- SELECT cdid, artist, title FROM
+ SELECT cdid, artist, title FROM
(SELECT cdid, artist, title FROM cd WHERE year ='2000') me
=back
An SQL query for your view. Will not be translated across database
syntaxes.
+=head2 deploy_depends_on
+
+ __PACKAGE__->result_source_instance->deploy_depends_on(
+ ["MyApp::Schema::Result::Year","MyApp::Schema::Result::CD"]
+ );
+
+Specify the views (and only the views) that this view depends on.
+Pass this an array reference of fully qualified result classes.
=head1 OVERRIDDEN METHODS
=cut
sub from {
- my $self = shift;
- return \"(${\$self->view_definition})" if $self->is_virtual;
- return $self->name;
+ my $self = shift;
+ return \"(${\$self->view_definition})" if $self->is_virtual;
+ return $self->name;
}
-1;
+=head1 OTHER METHODS
-=head1 AUTHORS
+=head2 new
-Matt S. Trout <mst@shadowcatsystems.co.uk>
+The constructor.
-With Contributions from:
+=cut
-Guillermo Roditi E<lt>groditi@cpan.orgE<gt>
+sub new {
+ my ( $self, @args ) = @_;
+ my $new = $self->next::method(@args);
+ $new->{deploy_depends_on} =
+ { map { $_ => 1 }
+ @{ $new->{deploy_depends_on} || [] } }
+ unless ref $new->{deploy_depends_on} eq 'HASH';
+ return $new;
+}
-Jess Robinson <castaway@desert-island.me.uk>
+1;
+
+=head1 AUTHORS
-Wallace Reis <wreis@cpan.org>
+See L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
use strict;
use warnings;
-use Storable;
-use Carp;
use base qw/DBIx::Class/;
+use DBIx::Class::Exception;
+use Try::Tiny;
+
+use namespace::clean;
+
use overload
- # on some RH perls the following line causes serious performance problem
- # see https://bugzilla.redhat.com/show_bug.cgi?id=196836
q/""/ => sub { __PACKAGE__ . ":" . shift->source_moniker; },
fallback => 1;
-__PACKAGE__->mk_group_accessors('simple' => qw/schema source_moniker/);
+__PACKAGE__->mk_group_accessors('simple' => qw/schema source_moniker _detached_source/);
# Schema to use when thawing.
our $thaw_schema;
=head1 NAME
-DBIx::Class::ResultSourceHandle - Decouple Rows/ResultSets objects from their Source objects
+DBIx::Class::ResultSourceHandle - Serializable pointers to ResultSource instances
=head1 DESCRIPTION
-This module removes fixed link between Rows/ResultSets and the actual source
-objects, which gets round the following problems
-
-=over 4
-
-=item *
-
-Needing to keep C<$schema> in scope, since any objects/result_sets
-will have a C<$schema> object through their source handle
-
-=item *
-
-Large output when using Data::Dump(er) since this class can be set to
-stringify to almost nothing
+Currently instances of this class are used to allow proper serialization of
+L<ResultSources|DBIx::Class::ResultSource> (which may contain unserializable
+elements like C<CODE> references).
-=item *
-
-Closer to being able to do a Serialize::Storable that doesn't require class-based connections
-
-=back
+Originally this module was used to remove the fixed link between
+L<Rows|DBIx::Class::Row>/L<ResultSets|DBIx::Class::ResultSet> and the actual
+L<result source objects|DBIx::Class::ResultSource> in order to obviate the need
+of keeping a L<schema instance|DBIx::Class::Schema> constantly in scope, while
+at the same time avoiding leaks due to circular dependencies. This is however
+no longer needed after introduction of a proper mutual-assured-destruction
+contract between a C<Schema> instance and its C<ResultSource> registrants.
=head1 METHODS
=cut
sub new {
- my ($class, $data) = @_;
+ my ($class, $args) = @_;
+ my $self = bless $args, ref $class || $class;
- $class = ref $class if ref $class;
+ unless( ($self->{schema} || $self->{_detached_source}) && $self->{source_moniker} ) {
+ my $err = 'Expecting a schema instance and a source moniker';
+ $self->{schema}
+ ? $self->{schema}->throw_exception($err)
+ : DBIx::Class::Exception->throw($err)
+ }
- bless $data, $class;
+ $self;
}
=head2 resolve
=cut
-sub resolve { return $_[0]->schema->source($_[0]->source_moniker) }
+sub resolve {
+ return $_[0]->{schema}->source($_[0]->source_moniker) if $_[0]->{schema};
+
+ $_[0]->_detached_source || DBIx::Class::Exception->throw( sprintf (
+ # vague error message as this is never supposed to happen
+ "Unable to resolve moniker '%s' - please contact the dev team at %s",
+ $_[0]->source_moniker,
+ 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT',
+ ), 'full_stacktrace');
+}
=head2 STORABLE_freeze
=cut
sub STORABLE_freeze {
- my ($self, $cloning) = @_;
+ my ($self, $cloning) = @_;
- my $to_serialize = { %$self };
+ my $to_serialize = { %$self };
- delete $to_serialize->{schema};
- $to_serialize->{_frozen_from_class} = $self->schema->class($self->source_moniker);
+ delete $to_serialize->{schema};
+ delete $to_serialize->{_detached_source};
+ $to_serialize->{_frozen_from_class} = $self->{schema}
+ ? $self->{schema}->class($self->source_moniker)
+ : $self->{_detached_source}->result_class
+ ;
- return (Storable::freeze($to_serialize));
+ Storable::nfreeze($to_serialize);
}
=head2 STORABLE_thaw
Thaws frozen handle. Resets the internal schema reference to the package
-variable C<$thaw_schema>. The recommended way of setting this is to use
+variable C<$thaw_schema>. The recommended way of setting this is to use
C<< $schema->thaw($ice) >> which handles this for you.
=cut
-
sub STORABLE_thaw {
- my ($self, $cloning, $ice) = @_;
- %$self = %{ Storable::thaw($ice) };
-
- my $class = delete $self->{_frozen_from_class};
- if( $thaw_schema ) {
- $self->{schema} = $thaw_schema;
+ my ($self, $cloning, $ice) = @_;
+ %$self = %{ Storable::thaw($ice) };
+
+ my $from_class = delete $self->{_frozen_from_class};
+
+ if( $thaw_schema ) {
+ $self->schema( $thaw_schema );
+ }
+ elsif( my $rs = $from_class->result_source_instance ) {
+ # in the off-chance we are using CDBI-compat and have leaked $schema already
+ if( my $s = try { $rs->schema } ) {
+ $self->schema( $s );
}
else {
- my $rs = $class->result_source_instance;
- $self->{schema} = $rs->schema if $rs;
+ $rs->source_name( $self->source_moniker );
+ $rs->{_detached_thaw} = 1;
+ $self->_detached_source( $rs );
}
-
- carp "Unable to restore schema. Look at 'freeze' and 'thaw' methods in DBIx::Class::Schema."
- unless $self->{schema};
+ }
+ else {
+ DBIx::Class::Exception->throw(
+ "Thaw failed - original result class '$from_class' does not exist on this system"
+ );
+ }
}
=head1 AUTHOR
use base qw/DBIx::Class/;
use Scalar::Util qw/blessed/;
-use Carp::Clan qw/^DBIx::Class/;
+use Sub::Name qw/subname/;
+use namespace::clean;
-sub iterator_class { shift->result_source_instance->resultset_class(@_) }
-sub resultset_class { shift->result_source_instance->resultset_class(@_) }
-sub result_class { shift->result_source_instance->result_class(@_) }
-sub source_info { shift->result_source_instance->source_info(@_) }
+__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name');
+
+sub get_inherited_ro_instance { shift->get_inherited(@_) }
sub set_inherited_ro_instance {
- my $self = shift;
+ my $self = shift;
- croak "Cannot set @{[shift]} on an instance" if blessed $self;
+ $self->throw_exception ("Cannot set @{[shift]} on an instance")
+ if blessed $self;
- return $self->set_inherited(@_);
+ $self->set_inherited(@_);
}
-sub get_inherited_ro_instance {
- return shift->get_inherited(@_);
-}
-
-__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name');
-
-
-sub resultset_attributes {
- shift->result_source_instance->resultset_attributes(@_);
-}
sub add_columns {
my ($class, @cols) = @_;
my $source = $class->result_source_instance;
$source->add_columns(@cols);
foreach my $c (grep { !ref } @cols) {
+ # If this is an augment definition get the real colname.
+ $c =~ s/^\+//;
+
$class->register_column($c => $source->column_info($c));
}
}
-sub add_column {
- shift->add_columns(@_);
-}
+sub add_column { shift->add_columns(@_) }
-sub has_column {
- shift->result_source_instance->has_column(@_);
-}
-
-sub column_info {
- shift->result_source_instance->column_info(@_);
-}
-
-sub column_info_from_storage {
- shift->result_source_instance->column_info_from_storage(@_);
-}
-sub columns {
- shift->result_source_instance->columns(@_);
-}
-
-sub remove_columns {
- shift->result_source_instance->remove_columns(@_);
+sub add_relationship {
+ my ($class, $rel, @rest) = @_;
+ my $source = $class->result_source_instance;
+ $source->add_relationship($rel => @rest);
+ $class->register_relationship($rel => $source->relationship_info($rel));
}
-*remove_column = \&remove_columns;
-sub set_primary_key {
- shift->result_source_instance->set_primary_key(@_);
-}
+# legacy resultset_class accessor, seems to be used by cdbi only
+sub iterator_class { shift->result_source_instance->resultset_class(@_) }
-sub primary_columns {
- shift->result_source_instance->primary_columns(@_);
-}
+for my $method_to_proxy (qw/
+ source_info
+ result_class
+ resultset_class
+ resultset_attributes
-sub _pri_cols {
- shift->result_source_instance->_pri_cols(@_);
-}
-
-sub add_unique_constraint {
- shift->result_source_instance->add_unique_constraint(@_);
-}
+ columns
+ has_column
-sub unique_constraints {
- shift->result_source_instance->unique_constraints(@_);
-}
+ remove_column
+ remove_columns
-sub unique_constraint_names {
- shift->result_source_instance->unique_constraint_names(@_);
-}
+ column_info
+ columns_info
+ column_info_from_storage
-sub unique_constraint_columns {
- shift->result_source_instance->unique_constraint_columns(@_);
-}
+ set_primary_key
+ primary_columns
+ _pri_cols
+ sequence
-sub add_relationship {
- my ($class, $rel, @rest) = @_;
- my $source = $class->result_source_instance;
- $source->add_relationship($rel => @rest);
- $class->register_relationship($rel => $source->relationship_info($rel));
-}
+ add_unique_constraint
+ add_unique_constraints
-sub relationships {
- shift->result_source_instance->relationships(@_);
-}
+ unique_constraints
+ unique_constraint_names
+ unique_constraint_columns
-sub relationship_info {
- shift->result_source_instance->relationship_info(@_);
+ relationships
+ relationship_info
+ has_relationship
+/) {
+ no strict qw/refs/;
+ *{__PACKAGE__."::$method_to_proxy"} = subname $method_to_proxy => sub {
+ shift->result_source_instance->$method_to_proxy (@_);
+ };
}
1;
use base qw/DBIx::Class::ResultSourceProxy/;
use DBIx::Class::ResultSource::Table;
-use Scalar::Util ();
+use Scalar::Util 'blessed';
+use namespace::clean;
__PACKAGE__->mk_classdata(table_class => 'DBIx::Class::ResultSource::Table');
my ($class, $table) = @_;
return $class->result_source_instance->name unless $table;
- unless (Scalar::Util::blessed($table) && $table->isa($class->table_class)) {
+ unless (blessed $table && $table->isa($class->table_class)) {
my $table_class = $class->table_class;
$class->ensure_class_loaded($table_class);
$table = $table_class->new({
- $class->can('result_source_instance') ?
- %{$class->result_source_instance||{}} : (),
+ $class->can('result_source_instance')
+ ? %{$class->result_source_instance||{}}
+ : ()
+ ,
name => $table,
result_class => $class,
- source_name => undef,
});
}
use base qw/DBIx::Class/;
use DBIx::Class::Exception;
-use Scalar::Util ();
+use Scalar::Util 'blessed';
+use List::Util 'first';
+use Try::Tiny;
###
### Internal method
: sub () { 0 };
}
-__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
+use namespace::clean;
=head1 NAME
L<DBIx::Class::ResultSet> object.
When calling it directly, you will not get a complete, usable row
-object until you pass or set the C<source_handle> attribute, to a
+object until you pass or set the C<result_source> attribute, to a
L<DBIx::Class::ResultSource> instance that is attached to a
L<DBIx::Class::Schema> with a valid connection.
C<$attrs> is a hashref of column name, value data. It can also contain
-some other attributes such as the C<source_handle>.
+some other attributes such as the C<result_source>.
Passing an object, or an arrayref of objects as a value will call
L<DBIx::Class::Relationship::Base/set_from_related> for you. When
sub __new_related_find_or_new_helper {
my ($self, $relname, $data) = @_;
- if ($self->__their_pk_needs_us($relname, $data)) {
+
+ my $rsrc = $self->result_source;
+
+ # create a mock-object so all new/set_column component overrides will run:
+ my $rel_rs = $rsrc->related_source($relname)->resultset;
+ my $new_rel_obj = $rel_rs->new_result($data);
+ my $proc_data = { $new_rel_obj->get_columns };
+
+ if ($self->__their_pk_needs_us($relname)) {
MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
- return $self->result_source
- ->related_source($relname)
- ->resultset
- ->new_result($data);
+ return $new_rel_obj;
}
- if ($self->result_source->_pk_depends_on($relname, $data)) {
- MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
- return $self->result_source
- ->related_source($relname)
- ->resultset
- ->find_or_new($data);
+ elsif ($rsrc->_pk_depends_on($relname, $proc_data )) {
+ if (! keys %$proc_data) {
+ # there is nothing to search for - blind create
+ MULTICREATE_DEBUG and warn "MC $self constructing default-insert $relname";
+ }
+ else {
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
+ # this is not *really* find or new, as we don't want to double-new the
+ # data (thus potentially double encoding or whatever)
+ my $exists = $rel_rs->find ($proc_data);
+ return $exists if $exists;
+ }
+ return $new_rel_obj;
+ }
+ else {
+ my $us = $rsrc->source_name;
+ $self->throw_exception (
+ "Unable to determine relationship '$relname' direction from '$us', "
+ . "possibly due to a missing reverse-relationship on '$relname' to '$us'."
+ );
}
- MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
- return $self->find_or_new_related($relname, $data);
}
sub __their_pk_needs_us { # this should maybe be in resultsource.
- my ($self, $relname, $data) = @_;
+ my ($self, $relname) = @_;
my $source = $self->result_source;
my $reverse = $source->reverse_relationship_info($relname);
my $rel_source = $source->related_source($relname);
my ($class, $attrs) = @_;
$class = ref $class if ref $class;
- my $new = {
- _column_data => {},
- };
- bless $new, $class;
-
- if (my $handle = delete $attrs->{-source_handle}) {
- $new->_source_handle($handle);
- }
-
- my $source;
- if ($source = delete $attrs->{-result_source}) {
- $new->result_source($source);
- }
-
- if (my $related = delete $attrs->{-cols_from_relations}) {
- @{$new->{_ignore_at_insert}={}}{@$related} = ();
- }
+ my $new = bless { _column_data => {} }, $class;
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
+ my $source = delete $attrs->{-result_source};
+ if ( my $h = delete $attrs->{-source_handle} ) {
+ $source ||= $h->resolve;
+ }
+
+ $new->result_source($source) if $source;
+
+ if (my $col_from_rel = delete $attrs->{-cols_from_relations}) {
+ @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = ();
+ }
+
my ($related,$inflated);
foreach my $key (keys %$attrs) {
my $acc_type = $info->{attrs}{accessor} || '';
if ($acc_type eq 'single') {
my $rel_obj = delete $attrs->{$key};
- if(!Scalar::Util::blessed($rel_obj)) {
+ if(!blessed $rel_obj) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
my @objects;
foreach my $idx (0 .. $#$others) {
my $rel_obj = $others->[$idx];
- if(!Scalar::Util::blessed($rel_obj)) {
+ if(!blessed $rel_obj) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
elsif ($acc_type eq 'filter') {
## 'filter' should disappear and get merged in with 'single' above!
my $rel_obj = delete $attrs->{$key};
- if(!Scalar::Util::blessed($rel_obj)) {
+ if(!blessed $rel_obj) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
if ($rel_obj->in_storage) {
=back
Inserts an object previously created by L</new> into the database if
-it isn't already in there. Returns the object itself. Requires the
-object's result source to be set, or the class to have a
-result_source_instance method. To insert an entirely new row into
-the database, use C<create> (see L<DBIx::Class::ResultSet/create>).
+it isn't already in there. Returns the object itself. To insert an
+entirely new row into the database, use L<DBIx::Class::ResultSet/create>.
To fetch an uninserted row object, call
L<new|DBIx::Class::ResultSet/new> on a resultset.
my ($self) = @_;
return $self if $self->in_storage;
my $source = $self->result_source;
- $source ||= $self->result_source($self->result_source_instance)
- if $self->can('result_source_instance');
$self->throw_exception("No result_source set on this object; can't insert")
unless $source;
+ my $storage = $source->storage;
+
my $rollback_guard;
# Check if we stored uninserted relobjs here in new()
my $rel_obj = $related_stuff{$relname};
if (! $self->{_rel_in_storage}{$relname}) {
- next unless (Scalar::Util::blessed($rel_obj)
- && $rel_obj->isa('DBIx::Class::Row'));
+ next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row'));
next unless $source->_pk_depends_on(
$relname, { $rel_obj->get_columns }
);
# The guard will save us if we blow out of this scope via die
- $rollback_guard ||= $source->storage->txn_scope_guard;
+ $rollback_guard ||= $storage->txn_scope_guard;
MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
- my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
- my $re = $self->result_source
- ->related_source($relname)
- ->resultset
- ->find_or_create($them);
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
+ my $existing;
+
+ # if there are no keys - nothing to search for
+ if (keys %$them and $existing = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find($them)
+ ) {
+ %{$rel_obj} = %{$existing};
+ }
+ else {
+ $rel_obj->insert;
+ }
- %{$rel_obj} = %{$re};
$self->{_rel_in_storage}{$relname} = 1;
}
# start a transaction here if not started yet and there is more stuff
# to insert after us
if (keys %related_stuff) {
- $rollback_guard ||= $source->storage->txn_scope_guard
+ $rollback_guard ||= $storage->txn_scope_guard
}
MULTICREATE_DEBUG and do {
no warnings 'uninitialized';
warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
};
- my $updated_cols = $source->storage->insert($source, { $self->get_columns });
- foreach my $col (keys %$updated_cols) {
- $self->store_column($col, $updated_cols->{$col});
- }
- ## PK::Auto
- my @auto_pri = grep {
- (not defined $self->get_column($_))
- ||
- (ref($self->get_column($_)) eq 'SCALAR')
- } $self->primary_columns;
-
- if (@auto_pri) {
- MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\n";
- my $storage = $self->result_source->storage;
- $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
- unless $storage->can('last_insert_id');
- my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
- $self->throw_exception( "Can't get last insert id" )
- unless (@ids == @auto_pri);
- $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
+ # perform the insert - the storage will return everything it is asked to
+ # (autoinc primary columns and any retrieve_on_insert columns)
+ my %current_rowdata = $self->get_columns;
+ my $returned_cols = $storage->insert(
+ $source,
+ { %current_rowdata }, # what to insert, copy because the storage *will* change it
+ );
+
+ for (keys %$returned_cols) {
+ $self->store_column($_, $returned_cols->{$_})
+ # this ensures we fire store_column only once
+ # (some asshats like overriding it)
+ if (
+ (!exists $current_rowdata{$_})
+ or
+ (defined $current_rowdata{$_} xor defined $returned_cols->{$_})
+ or
+ (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_})
+ );
}
+ delete $self->{_column_data_in_storage};
+ $self->in_storage(1);
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
: $related_stuff{$relname}
;
- if (@cands
- && Scalar::Util::blessed($cands[0])
- && $cands[0]->isa('DBIx::Class::Row')
+ if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row')
) {
my $reverse = $source->reverse_relationship_info($relname);
foreach my $obj (@cands) {
$obj->set_from_related($_, $self) for keys %$reverse;
- my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
- if ($self->__their_pk_needs_us($relname, $them)) {
+ if ($self->__their_pk_needs_us($relname)) {
if (exists $self->{_ignore_at_insert}{$relname}) {
MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
- } else {
- MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj";
- my $re = $self->result_source
- ->related_source($relname)
- ->resultset
- ->create($them);
- %{$obj} = %{$re};
- MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
+ }
+ else {
+ MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj";
+ $obj->insert;
}
} else {
MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
}
}
- $self->in_storage(1);
- delete $self->{_orig_ident};
delete $self->{_ignore_at_insert};
+
$rollback_guard->commit if $rollback_guard;
return $self;
according to L</in_storage>.
This method issues an SQL UPDATE query to commit any changes to the
-object to the database if required.
+object to the database if required (see L</get_dirty_columns>).
+It throws an exception if a proper WHERE clause uniquely identifying
+the database row can not be constructed (see
+L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
+for more details).
-Also takes an optional hashref of C<< column_name => value> >> pairs
+Also takes an optional hashref of C<< column_name => value >> pairs
to update on the object first. Be aware that the hashref will be
passed to C<set_inflated_columns>, which might edit it in place, so
don't rely on it being the same after a call to C<update>. If you
If the values passed or any of the column values set on the object
contain scalar references, e.g.:
- $row->last_modified(\'NOW()');
+ $row->last_modified(\'NOW()')->update();
# OR
$row->update({ last_modified => \'NOW()' });
sub update {
my ($self, $upd) = @_;
- $self->throw_exception( "Not in database" ) unless $self->in_storage;
- my $ident_cond = $self->ident_condition;
- $self->throw_exception("Cannot safely update a row in a PK-less table")
- if ! keys %$ident_cond;
$self->set_inflated_columns($upd) if $upd;
- my %to_update = $self->get_dirty_columns;
- return $self unless keys %to_update;
+
+ my %to_update = $self->get_dirty_columns
+ or return $self;
+
+ $self->throw_exception( "Not in database" ) unless $self->in_storage;
+
my $rows = $self->result_source->storage->update(
- $self->result_source, \%to_update,
- $self->{_orig_ident} || $ident_cond
- );
+ $self->result_source, \%to_update, $self->_storage_ident_condition
+ );
if ($rows == 0) {
$self->throw_exception( "Can't update ${self}: row not found" );
} elsif ($rows > 1) {
}
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
- undef $self->{_orig_ident};
+ delete $self->{_column_data_in_storage};
return $self;
}
=back
Throws an exception if the object is not in the database according to
-L</in_storage>. Runs an SQL DELETE statement using the primary key
-values to locate the row.
+L</in_storage>. Also throws an exception if a proper WHERE clause
+uniquely identifying the database row can not be constructed (see
+L<significance of primary keys|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
+for more details).
The object is still perfectly usable, but L</in_storage> will
now return 0 and the object must be reinserted using L</insert>
my $self = shift;
if (ref $self) {
$self->throw_exception( "Not in database" ) unless $self->in_storage;
- my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
- $self->throw_exception("Cannot safely delete a row in a PK-less table")
- if ! keys %$ident_cond;
- foreach my $column (keys %$ident_cond) {
- $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
- unless exists $self->{_column_data}{$column};
- }
+
$self->result_source->storage->delete(
- $self->result_source, $ident_cond);
+ $self->result_source, $self->_storage_ident_condition
+ );
+
+ delete $self->{_column_data_in_storage};
$self->in_storage(undef);
- } else {
- $self->throw_exception("Can't do class delete without a ResultSource instance")
- unless $self->can('result_source_instance');
+ }
+ else {
+ my $rsrc = try { $self->result_source_instance }
+ or $self->throw_exception("Can't do class delete without a ResultSource instance");
+
my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
- $self->result_source_instance->resultset->search(@_)->delete;
+ $rsrc->resultset->search(@_)->delete;
}
return $self;
}
=back
Throws an exception if the column name given doesn't exist according
-to L</has_column>.
+to L<has_column|DBIx::Class::ResultSource/has_column>.
Returns a raw column value from the row object, if it has already
been fetched from the database or set by an accessor.
sub get_inflated_columns {
my $self = shift;
- my %loaded_colinfo = (map
- { $_ => $self->column_info($_) }
- (grep { $self->has_column_loaded($_) } $self->columns)
- );
+ my $loaded_colinfo = $self->columns_info ([
+ grep { $self->has_column_loaded($_) } $self->columns
+ ]);
my %inflated;
- for my $col (keys %loaded_colinfo) {
- if (exists $loaded_colinfo{$col}{accessor}) {
- my $acc = $loaded_colinfo{$col}{accessor};
+ for my $col (keys %$loaded_colinfo) {
+ if (exists $loaded_colinfo->{$col}{accessor}) {
+ my $acc = $loaded_colinfo->{$col}{accessor};
$inflated{$col} = $self->$acc if defined $acc;
}
else {
}
# return all loaded columns with the inflations overlayed on top
- return ($self->get_columns, %inflated);
+ return %{ { $self->get_columns, %inflated } };
}
sub _is_column_numeric {
my $colinfo = $self->column_info ($column);
# cache for speed (the object may *not* have a resultsource instance)
- if (not defined $colinfo->{is_numeric} && $self->_source_handle) {
+ if (
+ ! defined $colinfo->{is_numeric}
+ and
+ my $storage = try { $self->result_source->schema->storage }
+ ) {
$colinfo->{is_numeric} =
- $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type})
+ $storage->is_datatype_numeric ($colinfo->{data_type})
? 1
: 0
;
sub set_column {
my ($self, $column, $new_value) = @_;
- $self->{_orig_ident} ||= $self->ident_condition;
- my $old_value = $self->get_column($column);
+ my $had_value = $self->has_column_loaded($column);
+ my ($old_value, $in_storage) = ($self->get_column($column), $self->in_storage)
+ if $had_value;
$new_value = $self->store_column($column, $new_value);
- my $dirty;
- if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
- $dirty = 1;
- }
- elsif (defined $old_value xor defined $new_value) {
- $dirty = 1;
- }
- elsif (not defined $old_value) { # both undef
- $dirty = 0;
- }
- elsif ($old_value eq $new_value) {
- $dirty = 0;
- }
- else { # do a numeric comparison if datatype allows it
- if ($self->_is_column_numeric($column)) {
- $dirty = $old_value != $new_value;
+ my $dirty =
+ $self->{_dirty_columns}{$column}
+ ||
+ $in_storage # no point tracking dirtyness on uninserted data
+ ? ! $self->_eq_column_values ($column, $old_value, $new_value)
+ : 1
+ ;
+
+ if ($dirty) {
+ # FIXME sadly the update code just checks for keys, not for their value
+ $self->{_dirty_columns}{$column} = 1;
+
+ # Clear out the relation/inflation cache related to this column
+ #
+ # FIXME - this is a quick *largely incorrect* hack, pending a more
+ # serious rework during the merge of single and filter rels
+ my $rels = $self->result_source->{_relationships};
+ for my $rel (keys %$rels) {
+
+ my $acc = $rels->{$rel}{attrs}{accessor} || '';
+
+ if ( $acc eq 'single' and $rels->{$rel}{attrs}{fk_columns}{$column} ) {
+ delete $self->{related_resultsets}{$rel};
+ delete $self->{_relationship_data}{$rel};
+ #delete $self->{_inflated_column}{$rel};
+ }
+ elsif ( $acc eq 'filter' and $rel eq $column) {
+ delete $self->{related_resultsets}{$rel};
+ #delete $self->{_relationship_data}{$rel};
+ delete $self->{_inflated_column}{$rel};
+ }
}
- else {
- $dirty = 1;
+
+ if (
+ # value change from something (even if NULL)
+ $had_value
+ and
+ # no storage - no storage-value
+ $in_storage
+ and
+ # no value already stored (multiple changes before commit to storage)
+ ! exists $self->{_column_data_in_storage}{$column}
+ and
+ $self->_track_storage_value($column)
+ ) {
+ $self->{_column_data_in_storage}{$column} = $old_value;
}
}
- # sadly the update code just checks for keys, not for their value
- $self->{_dirty_columns}{$column} = 1 if $dirty;
+ return $new_value;
+}
- # XXX clear out the relation cache for this column
- delete $self->{related_resultsets}{$column};
+sub _eq_column_values {
+ my ($self, $col, $old, $new) = @_;
- return $new_value;
+ if (defined $old xor defined $new) {
+ return 0;
+ }
+ elsif (not defined $old) { # both undef
+ return 1;
+ }
+ elsif ($old eq $new) {
+ return 1;
+ }
+ elsif ($self->_is_column_numeric($col)) { # do a numeric comparison if datatype allows it
+ return $old == $new;
+ }
+ else {
+ return 0;
+ }
+}
+
+# returns a boolean indicating if the passed column should have its original
+# value tracked between column changes and commitment to storage
+sub _track_storage_value {
+ my ($self, $col) = @_;
+ return defined first { $col eq $_ } ($self->primary_columns);
}
=head2 set_columns
my ($self, $changes) = @_;
$changes ||= {};
my $col_data = { %{$self->{_column_data}} };
+
+ my $colinfo = $self->columns_info([ keys %$col_data ]);
foreach my $col (keys %$col_data) {
delete $col_data->{$col}
- if $self->result_source->column_info($col)->{is_auto_increment};
+ if $colinfo->{$col}{is_auto_increment};
}
my $new = { _column_data => $col_data };
next unless $rel_info->{attrs}{cascade_copy};
my $resolved = $self->result_source->_resolve_condition(
- $rel_info->{cond}, $rel, $new
+ $rel_info->{cond}, $rel, $new, $rel
);
my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
sub inflate_result {
my ($class, $source, $me, $prefetch) = @_;
- my ($source_handle) = $source;
+ $source = $source->resolve
+ if $source->isa('DBIx::Class::ResultSourceHandle');
- if ($source->isa('DBIx::Class::ResultSourceHandle')) {
- $source = $source_handle->resolve
- }
- else {
- $source_handle = $source->handle
- }
-
- my $new = {
- _source_handle => $source_handle,
- _column_data => $me,
- };
- bless $new, (ref $class || $class);
+ my $new = bless
+ { _column_data => $me, _result_source => $source },
+ ref $class || $class
+ ;
foreach my $pre (keys %{$prefetch||{}}) {
- my $pre_source = $source->related_source($pre)
- or $class->throw_exception("Can't prefetch non-existent relationship ${pre}");
-
- my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
- or $class->throw_exception("No accessor for prefetched $pre");
-
- my @pre_vals;
+ my (@pre_vals, $is_multi);
if (ref $prefetch->{$pre}[0] eq 'ARRAY') {
+ $is_multi = 1;
@pre_vals = @{$prefetch->{$pre}};
}
else {
@pre_vals = $prefetch->{$pre};
}
+ my $pre_source = try {
+ $source->related_source($pre)
+ }
+ catch {
+ $class->throw_exception(sprintf
+
+ "Can't inflate manual prefetch into non-existent relationship '%s' from '%s', "
+ . "check the inflation specification (columns/as) ending in '%s.%s'.",
+
+ $pre,
+ $source->source_name,
+ $pre,
+ (keys %{$pre_vals[0][0]})[0] || 'something.something...',
+ );
+ };
+
+ my $accessor = $source->relationship_info($pre)->{attrs}{accessor}
+ or $class->throw_exception("No accessor type declared for prefetched $pre");
+
+ if (! $is_multi and $accessor eq 'multi') {
+ $class->throw_exception("Manual prefetch (via select/columns) not supported with accessor 'multi'");
+ }
+
my @pre_objects;
for my $me_pref (@pre_vals) {
push @pre_objects, $pre_source->result_class->inflate_result(
=over
-=item Arguments: none
+=item Arguments: $result_source_instance
=item Returns: a ResultSource instance
=cut
sub result_source {
- my $self = shift;
-
- if (@_) {
- $self->_source_handle($_[0]->handle);
- } else {
- $self->_source_handle->resolve;
- }
+ $_[0]->throw_exception( 'result_source can be called on instances only' )
+ unless ref $_[0];
+
+ @_ > 1
+ ? $_[0]->{_result_source} = $_[1]
+
+ # note this is a || not a ||=, the difference is important
+ : $_[0]->{_result_source} || do {
+ my $class = ref $_[0];
+ $_[0]->can('result_source_instance')
+ ? $_[0]->result_source_instance
+ : $_[0]->throw_exception(
+ "No result source instance registered for $class, did you forget to call $class->table(...) ?"
+ )
+ }
+ ;
}
=head2 register_column
=back
Fetches a fresh copy of the Row object from the database and returns it.
-
-If passed the \%attrs argument, will first apply these attributes to
+Throws an exception if a proper WHERE clause identifying the database row
+can not be constructed (i.e. if the original object does not contain its
+entire
+ L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
+). If passed the \%attrs argument, will first apply these attributes to
the resultset used to find the row.
This copy can then be used to compare to an existing row object, to
$resultset = $resultset->search(undef, $attrs);
}
- return $resultset->find($self->{_orig_ident} || $self->ident_condition);
+ return $resultset->find($self->_storage_ident_condition);
}
-=head2 discard_changes ($attrs)
+=head2 discard_changes ($attrs?)
+
+ $row->discard_changes
+
+=over
+
+=item Arguments: none or $attrs
+
+=item Returns: self (updates object in-place)
+
+=back
Re-selects the row from the database, losing any changes that had
-been made.
+been made. Throws an exception if a proper C<WHERE> clause identifying
+the database row can not be constructed (i.e. if the original object
+does not contain its entire
+L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>).
This method can also be used to refresh from storage, retrieving any
changes made since the row was last read from storage.
-$attrs is expected to be a hashref of attributes suitable for passing as the
-second argument to $resultset->search($cond, $attrs);
+$attrs, if supplied, is expected to be a hashref of attributes suitable for passing as the
+second argument to C<< $resultset->search($cond, $attrs) >>;
+
+Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
+storage, please kept in mind that if you L</discard_changes> on a row that you
+just updated or created, you should wrap the entire bit inside a transaction.
+Otherwise you run the risk that you insert or update to the master database
+but read from a replicant database that has not yet been updated from the
+master. This will result in unexpected results.
=cut
sub discard_changes {
my ($self, $attrs) = @_;
- delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
# add a replication default to read from the master only
}
}
-
=head2 throw_exception
See L<DBIx::Class::Schema/throw_exception>.
sub throw_exception {
my $self=shift;
- if (ref $self && ref $self->result_source && $self->result_source->schema) {
- $self->result_source->schema->throw_exception(@_)
+ if (ref $self && ref $self->result_source ) {
+ $self->result_source->throw_exception(@_)
}
else {
DBIx::Class::Exception->throw(@_);
Returns the primary key(s) for a row. Can't be called as a class method.
Actually implemented in L<DBIx::Class::PK>
-=head2 discard_changes
-
- $row->discard_changes
-
-=over
-
-=item Arguments: none
-
-=item Returns: nothing (updates object in-place)
-
-=back
-
-Retrieves and sets the row object data from the database, losing any
-local changes made.
-
-This method can also be used to refresh from storage, retrieving any
-changes made since the row was last read from storage. Actually
-implemented in L<DBIx::Class::PK>
-
-Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
-storage, please kept in mind that if you L</discard_changes> on a row that you
-just updated or created, you should wrap the entire bit inside a transaction.
-Otherwise you run the risk that you insert or update to the master database
-but read from a replicant database that has not yet been updated from the
-master. This will result in unexpected results.
-
-=cut
-
-1;
-
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
You may distribute this code under the same terms as Perl itself.
=cut
+
+1;
package # Hide from PAUSE
DBIx::Class::SQLAHacks;
-# This module is a subclass of SQL::Abstract::Limit and includes a number
-# of DBIC-specific workarounds, not yet suitable for inclusion into the
-# SQLA core
-
-use base qw/SQL::Abstract::Limit/;
-use strict;
-use warnings;
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-use Sub::Name();
-
-BEGIN {
- # reinstall the carp()/croak() functions imported into SQL::Abstract
- # as Carp and Carp::Clan do not like each other much
- no warnings qw/redefine/;
- no strict qw/refs/;
- for my $f (qw/carp croak/) {
-
- my $orig = \&{"SQL::Abstract::$f"};
- *{"SQL::Abstract::$f"} = Sub::Name::subname "SQL::Abstract::$f" =>
- sub {
- if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
- __PACKAGE__->can($f)->(@_);
- }
- else {
- goto $orig;
- }
- };
- }
-}
-
-
-# Tries to determine limit dialect.
-#
-sub new {
- my $self = shift->SUPER::new(@_);
-
- # This prevents the caching of $dbh in S::A::L, I believe
- # If limit_dialect is a ref (like a $dbh), go ahead and replace
- # it with what it resolves to:
- $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
- if ref $self->{limit_dialect};
-
- $self;
-}
-
-
-# ANSI standard Limit/Offset implementation. DB2 and MSSQL use this
-sub _RowNumberOver {
- my ($self, $sql, $order, $rows, $offset ) = @_;
-
- # get the select to make the final amount of columns equal the original one
- my ($select) = $sql =~ /^ \s* SELECT \s+ (.+?) \s+ FROM/ix
- or croak "Unrecognizable SELECT: $sql";
-
- # get the order_by only (or make up an order if none exists)
- my $order_by = $self->_order_by(
- (delete $order->{order_by}) || $self->_rno_default_order
- );
-
- # whatever is left of the order_by
- my $group_having = $self->_order_by($order);
-
- my $qalias = $self->_quote ($self->{_dbic_rs_attrs}{alias});
-
- $sql = sprintf (<<EOS, $offset + 1, $offset + $rows, );
-
-SELECT $select FROM (
- SELECT $qalias.*, ROW_NUMBER() OVER($order_by ) AS rno__row__index FROM (
- ${sql}${group_having}
- ) $qalias
-) $qalias WHERE rno__row__index BETWEEN %d AND %d
-
-EOS
-
- $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
- return $sql;
-}
-
-# some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) )
-sub _rno_default_order {
- return undef;
-}
-
-# Informix specific limit, almost like LIMIT/OFFSET
-sub _SkipFirst {
- my ($self, $sql, $order, $rows, $offset) = @_;
-
- $sql =~ s/^ \s* SELECT \s+ //ix
- or croak "Unrecognizable SELECT: $sql";
-
- return sprintf ('SELECT %s%s%s%s',
- $offset
- ? sprintf ('SKIP %d ', $offset)
- : ''
- ,
- sprintf ('FIRST %d ', $rows),
- $sql,
- $self->_order_by ($order),
- );
-}
-
-# Crappy Top based Limit/Offset support. Legacy from MSSQL.
-sub _Top {
- my ( $self, $sql, $order, $rows, $offset ) = @_;
-
- # mangle the input sql so it can be properly aliased in the outer queries
- $sql =~ s/^ \s* SELECT \s+ (.+?) \s+ (?=FROM)//ix
- or croak "Unrecognizable SELECT: $sql";
- my $sql_select = $1;
- my @sql_select = split (/\s*,\s*/, $sql_select);
-
- # we can't support subqueries (in fact MSSQL can't) - croak
- if (@sql_select != @{$self->{_dbic_rs_attrs}{select}}) {
- croak (sprintf (
- 'SQL SELECT did not parse cleanly - retrieved %d comma separated elements, while '
- . 'the resultset select attribure contains %d elements: %s',
- scalar @sql_select,
- scalar @{$self->{_dbic_rs_attrs}{select}},
- $sql_select,
- ));
- }
-
- my $name_sep = $self->name_sep || '.';
- my $esc_name_sep = "\Q$name_sep\E";
- my $col_re = qr/ ^ (?: (.+) $esc_name_sep )? ([^$esc_name_sep]+) $ /x;
-
- my $rs_alias = $self->{_dbic_rs_attrs}{alias};
- my $quoted_rs_alias = $self->_quote ($rs_alias);
-
- # construct the new select lists, rename(alias) some columns if necessary
- my (@outer_select, @inner_select, %seen_names, %col_aliases, %outer_col_aliases);
-
- for (@{$self->{_dbic_rs_attrs}{select}}) {
- next if ref $_;
- my ($table, $orig_colname) = ( $_ =~ $col_re );
- next unless $table;
- $seen_names{$orig_colname}++;
- }
-
- for my $i (0 .. $#sql_select) {
-
- my $colsel_arg = $self->{_dbic_rs_attrs}{select}[$i];
- my $colsel_sql = $sql_select[$i];
-
- # this may or may not work (in case of a scalarref or something)
- my ($table, $orig_colname) = ( $colsel_arg =~ $col_re );
-
- my $quoted_alias;
- # do not attempt to understand non-scalar selects - alias numerically
- if (ref $colsel_arg) {
- $quoted_alias = $self->_quote ('column_' . (@inner_select + 1) );
- }
- # column name seen more than once - alias it
- elsif ($orig_colname &&
- ($seen_names{$orig_colname} && $seen_names{$orig_colname} > 1) ) {
- $quoted_alias = $self->_quote ("${table}__${orig_colname}");
- }
-
- # we did rename - make a record and adjust
- if ($quoted_alias) {
- # alias inner
- push @inner_select, "$colsel_sql AS $quoted_alias";
-
- # push alias to outer
- push @outer_select, $quoted_alias;
-
- # Any aliasing accumulated here will be considered
- # both for inner and outer adjustments of ORDER BY
- $self->__record_alias (
- \%col_aliases,
- $quoted_alias,
- $colsel_arg,
- $table ? $orig_colname : undef,
- );
- }
-
- # otherwise just leave things intact inside, and use the abbreviated one outside
- # (as we do not have table names anymore)
- else {
- push @inner_select, $colsel_sql;
-
- my $outer_quoted = $self->_quote ($orig_colname); # it was not a duplicate so should just work
- push @outer_select, $outer_quoted;
- $self->__record_alias (
- \%outer_col_aliases,
- $outer_quoted,
- $colsel_arg,
- $table ? $orig_colname : undef,
- );
- }
- }
-
- my $outer_select = join (', ', @outer_select );
- my $inner_select = join (', ', @inner_select );
-
- %outer_col_aliases = (%outer_col_aliases, %col_aliases);
-
- # deal with order
- croak '$order supplied to SQLAHacks limit emulators must be a hash'
- if (ref $order ne 'HASH');
-
- $order = { %$order }; #copy
-
- my $req_order = $order->{order_by};
-
- # examine normalized version, collapses nesting
- my $limit_order;
- if (scalar $self->_order_by_chunks ($req_order)) {
- $limit_order = $req_order;
- }
- else {
- $limit_order = [ map
- { join ('', $rs_alias, $name_sep, $_ ) }
- ( $self->{_dbic_rs_attrs}{_source_handle}->resolve->primary_columns )
- ];
- }
-
- my ( $order_by_inner, $order_by_outer ) = $self->_order_directions($limit_order);
- my $order_by_requested = $self->_order_by ($req_order);
-
- # generate the rest
- delete $order->{order_by};
- my $grpby_having = $self->_order_by ($order);
-
- # short circuit for counts - the ordering complexity is needless
- if ($self->{_dbic_rs_attrs}{-for_count_only}) {
- return "SELECT TOP $rows $inner_select $sql $grpby_having $order_by_outer";
- }
-
- # we can't really adjust the order_by columns, as introspection is lacking
- # resort to simple substitution
- for my $col (keys %outer_col_aliases) {
- for ($order_by_requested, $order_by_outer) {
- $_ =~ s/\s+$col\s+/ $outer_col_aliases{$col} /g;
- }
- }
- for my $col (keys %col_aliases) {
- $order_by_inner =~ s/\s+$col\s+/ $col_aliases{$col} /g;
- }
-
-
- my $inner_lim = $rows + $offset;
-
- $sql = "SELECT TOP $inner_lim $inner_select $sql $grpby_having $order_by_inner";
-
- if ($offset) {
- $sql = <<"SQL";
-
- SELECT TOP $rows $outer_select FROM
- (
- $sql
- ) $quoted_rs_alias
- $order_by_outer
-SQL
-
- }
-
- if ($order_by_requested) {
- $sql = <<"SQL";
-
- SELECT $outer_select FROM
- ( $sql ) $quoted_rs_alias
- $order_by_requested
-SQL
-
- }
-
- $sql =~ s/\s*\n\s*/ /g; # parsing out multiline statements is harder than a single line
- return $sql;
-}
-
-# action at a distance to shorten Top code above
-sub __record_alias {
- my ($self, $register, $alias, $fqcol, $col) = @_;
-
- # record qualified name
- $register->{$fqcol} = $alias;
- $register->{$self->_quote($fqcol)} = $alias;
-
- return unless $col;
-
- # record unqualified name, undef (no adjustment) if a duplicate is found
- if (exists $register->{$col}) {
- $register->{$col} = undef;
- }
- else {
- $register->{$col} = $alias;
- }
-
- $register->{$self->_quote($col)} = $register->{$col};
-}
-
-
-
-# While we're at it, this should make LIMIT queries more efficient,
-# without digging into things too deeply
-sub _find_syntax {
- my ($self, $syntax) = @_;
- return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
-}
-
-my $for_syntax = {
- update => 'FOR UPDATE',
- shared => 'FOR SHARE',
-};
-# Quotes table names, handles "limit" dialects (e.g. where rownum between x and
-# y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
-sub select {
- my ($self, $table, $fields, $where, $order, @rest) = @_;
-
- $self->{"${_}_bind"} = [] for (qw/having from order/);
-
- if (not ref($table) or ref($table) eq 'SCALAR') {
- $table = $self->_quote($table);
- }
-
- local $self->{rownum_hack_count} = 1
- if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
- @rest = (-1) unless defined $rest[0];
- croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
- # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
- my ($sql, @where_bind) = $self->SUPER::select(
- $table, $self->_recurse_fields($fields), $where, $order, @rest
- );
- if (my $for = delete $self->{_dbic_rs_attrs}{for}) {
- $sql .= " $for_syntax->{$for}" if $for_syntax->{$for};
- }
-
- return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
-}
-
-# Quotes table names, and handles default inserts
-sub insert {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
-
- # SQLA will emit INSERT INTO $table ( ) VALUES ( )
- # which is sadly understood only by MySQL. Change default behavior here,
- # until SQLA2 comes with proper dialect support
- if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
- return "INSERT INTO ${table} DEFAULT VALUES"
- }
-
- $self->SUPER::insert($table, @_);
-}
-
-# Just quotes table names.
-sub update {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
- $self->SUPER::update($table, @_);
-}
-
-# Just quotes table names.
-sub delete {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
- $self->SUPER::delete($table, @_);
-}
-
-sub _emulate_limit {
- my $self = shift;
- if ($_[3] == -1) {
- return $_[1].$self->_order_by($_[2]);
- } else {
- return $self->SUPER::_emulate_limit(@_);
- }
-}
-
-sub _recurse_fields {
- my ($self, $fields, $params) = @_;
- my $ref = ref $fields;
- return $self->_quote($fields) unless $ref;
- return $$fields if $ref eq 'SCALAR';
-
- if ($ref eq 'ARRAY') {
- return join(', ', map {
- $self->_recurse_fields($_)
- .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
- ? ' AS col'.$self->{rownum_hack_count}++
- : '')
- } @$fields);
- }
- elsif ($ref eq 'HASH') {
- my %hash = %$fields;
-
- my $as = delete $hash{-as}; # if supplied
-
- my ($func, $args) = each %hash;
- delete $hash{$func};
-
- if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
- croak (
- 'The select => { distinct => ... } syntax is not supported for multiple columns.'
- .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
- .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
- );
- }
-
- my $select = sprintf ('%s( %s )%s',
- $self->_sqlcase($func),
- $self->_recurse_fields($args),
- $as
- ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
- : ''
- );
-
- # there should be nothing left
- if (keys %hash) {
- croak "Malformed select argument - too many keys in hash: " . join (',', keys %$fields );
- }
-
- return $select;
- }
- # Is the second check absolutely necessary?
- elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
- return $self->_fold_sqlbind( $fields );
- }
- else {
- croak($ref . qq{ unexpected in _recurse_fields()})
- }
-}
-
-sub _order_by {
- my ($self, $arg) = @_;
-
- if (ref $arg eq 'HASH' and keys %$arg and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
-
- my $ret = '';
-
- if (my $g = $self->_recurse_fields($arg->{group_by}, { no_rownum_hack => 1 }) ) {
- $ret = $self->_sqlcase(' group by ') . $g;
- }
-
- if (defined $arg->{having}) {
- my ($frag, @bind) = $self->_recurse_where($arg->{having});
- push(@{$self->{having_bind}}, @bind);
- $ret .= $self->_sqlcase(' having ').$frag;
- }
-
- if (defined $arg->{order_by}) {
- my ($frag, @bind) = $self->SUPER::_order_by($arg->{order_by});
- push(@{$self->{order_bind}}, @bind);
- $ret .= $frag;
- }
-
- return $ret;
- }
- else {
- my ($sql, @bind) = $self->SUPER::_order_by ($arg);
- push(@{$self->{order_bind}}, @bind);
- return $sql;
- }
-}
-
-sub _order_directions {
- my ($self, $order) = @_;
-
- # strip bind values - none of the current _order_directions users support them
- return $self->SUPER::_order_directions( [ map
- { ref $_ ? $_->[0] : $_ }
- $self->_order_by_chunks ($order)
- ]);
-}
-
-sub _table {
- my ($self, $from) = @_;
- if (ref $from eq 'ARRAY') {
- return $self->_recurse_from(@$from);
- } elsif (ref $from eq 'HASH') {
- return $self->_make_as($from);
- } else {
- return $from; # would love to quote here but _table ends up getting called
- # twice during an ->select without a limit clause due to
- # the way S::A::Limit->select works. should maybe consider
- # bypassing this and doing S::A::select($self, ...) in
- # our select method above. meantime, quoting shims have
- # been added to select/insert/update/delete here
- }
-}
-
-sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push(@sqlf, $self->_make_as($from));
- foreach my $j (@join) {
- my ($to, $on) = @$j;
-
-
- # check whether a join type exists
- my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
- my $join_type;
- if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
- $join_type = $to_jt->{-join_type};
- $join_type =~ s/^\s+ | \s+$//xg;
- }
-
- $join_type = $self->{_default_jointype} if not defined $join_type;
-
- my $join_clause = sprintf ('%s JOIN ',
- $join_type ? ' ' . uc($join_type) : ''
- );
- push @sqlf, $join_clause;
-
- if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_make_as($to));
- }
- push(@sqlf, ' ON ', $self->_join_condition($on));
- }
- return join('', @sqlf);
-}
-
-sub _fold_sqlbind {
- my ($self, $sqlbind) = @_;
-
- my @sqlbind = @$$sqlbind; # copy
- my $sql = shift @sqlbind;
- push @{$self->{from_bind}}, @sqlbind;
-
- return $sql;
-}
-
-sub _make_as {
- my ($self, $from) = @_;
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
- : ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
- : $self->_quote($_))
- } reverse each %{$self->_skip_options($from)});
-}
-
-sub _skip_options {
- my ($self, $hash) = @_;
- my $clean_hash = {};
- $clean_hash->{$_} = $hash->{$_}
- for grep {!/^-/} keys %$hash;
- return $clean_hash;
-}
-
-sub _join_condition {
- my ($self, $cond) = @_;
- if (ref $cond eq 'HASH') {
- my %j;
- for (keys %$cond) {
- my $v = $cond->{$_};
- if (ref $v) {
- croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
- if ref($v) ne 'SCALAR';
- $j{$_} = $v;
- }
- else {
- my $x = '= '.$self->_quote($v); $j{$_} = \$x;
- }
- };
- return scalar($self->_recurse_where(\%j));
- } elsif (ref $cond eq 'ARRAY') {
- return join(' OR ', map { $self->_join_condition($_) } @$cond);
- } else {
- die "Can't handle this yet!";
- }
-}
-
-sub _quote {
- my ($self, $label) = @_;
- return '' unless defined $label;
- return $$label if ref($label) eq 'SCALAR';
- return "*" if $label eq '*';
- return $label unless $self->{quote_char};
- if(ref $self->{quote_char} eq "ARRAY"){
- return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
- if !defined $self->{name_sep};
- my $sep = $self->{name_sep};
- return join($self->{name_sep},
- map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
- split(/\Q$sep\E/,$label));
- }
- return $self->SUPER::_quote($label);
-}
-
-sub limit_dialect {
- my $self = shift;
- $self->{limit_dialect} = shift if @_;
- return $self->{limit_dialect};
-}
-
-# Set to an array-ref to specify separate left and right quotes for table names.
-# A single scalar is equivalen to [ $char, $char ]
-sub quote_char {
- my $self = shift;
- $self->{quote_char} = shift if @_;
- return $self->{quote_char};
-}
-
-# Character separating quoted table names.
-sub name_sep {
- my $self = shift;
- $self->{name_sep} = shift if @_;
- return $self->{name_sep};
-}
+use base qw/DBIx::Class::SQLMaker/;
1;
package # Hide from PAUSE
DBIx::Class::SQLAHacks::MSSQL;
-use base qw( DBIx::Class::SQLAHacks );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-
-#
-# MSSQL does not support ... OVER() ... RNO limits
-#
-sub _rno_default_order {
- return \ '(SELECT(1))';
-}
+use base qw( DBIx::Class::SQLMaker::MSSQL );
1;
package # Hide from PAUSE
DBIx::Class::SQLAHacks::MySQL;
-use base qw( DBIx::Class::SQLAHacks );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-
-#
-# MySQL does not understand the standard INSERT INTO $table DEFAULT VALUES
-# Adjust SQL here instead
-#
-sub insert {
- my $self = shift;
-
- my $table = $_[0];
- $table = $self->_quote($table);
-
- if (! $_[1] or (ref $_[1] eq 'HASH' and !keys %{$_[1]} ) ) {
- return "INSERT INTO ${table} () VALUES ()"
- }
-
- return $self->SUPER::insert (@_);
-}
+use base qw( DBIx::Class::SQLMaker::MySQL );
1;
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLAHacks::Oracle;
+
+use base qw( DBIx::Class::SQLMaker::Oracle );
+
+1;
package # Hide from PAUSE
DBIx::Class::SQLAHacks::OracleJoins;
-use base qw( DBIx::Class::SQLAHacks );
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-
-sub select {
- my ($self, $table, $fields, $where, $order, @rest) = @_;
-
- if (ref($table) eq 'ARRAY') {
- $where = $self->_oracle_joins($where, @{ $table });
- }
-
- return $self->SUPER::select($table, $fields, $where, $order, @rest);
-}
-
-sub _recurse_from {
- my ($self, $from, @join) = @_;
-
- my @sqlf = $self->_make_as($from);
-
- foreach my $j (@join) {
- my ($to, $on) = @{ $j };
-
- if (ref $to eq 'ARRAY') {
- push (@sqlf, $self->_recurse_from(@{ $to }));
- }
- else {
- push (@sqlf, $self->_make_as($to));
- }
- }
-
- return join q{, }, @sqlf;
-}
-
-sub _oracle_joins {
- my ($self, $where, $from, @join) = @_;
- my $join_where = {};
- $self->_recurse_oracle_joins($join_where, $from, @join);
- if (keys %$join_where) {
- if (!defined($where)) {
- $where = $join_where;
- } else {
- if (ref($where) eq 'ARRAY') {
- $where = { -or => $where };
- }
- $where = { -and => [ $join_where, $where ] };
- }
- }
- return $where;
-}
-
-sub _recurse_oracle_joins {
- my ($self, $where, $from, @join) = @_;
-
- foreach my $j (@join) {
- my ($to, $on) = @{ $j };
-
- if (ref $to eq 'ARRAY') {
- $self->_recurse_oracle_joins($where, @{ $to });
- }
-
- my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
- my $left_join = q{};
- my $right_join = q{};
-
- if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
- #TODO: Support full outer joins -- this would happen much earlier in
- #the sequence since oracle 8's full outer join syntax is best
- #described as INSANE.
- croak "Can't handle full outer joins in Oracle 8 yet!\n"
- if $to_jt->{-join_type} =~ /full/i;
-
- $left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
- && $to_jt->{-join_type} !~ /inner/i;
-
- $right_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
- && $to_jt->{-join_type} !~ /inner/i;
- }
-
- foreach my $lhs (keys %{ $on }) {
- $where->{$lhs . $left_join} = \"= $on->{ $lhs }$right_join";
- }
- }
-}
+use base qw( DBIx::Class::SQLMaker::OracleJoins );
1;
-
-=pod
-
-=head1 NAME
-
-DBIx::Class::SQLAHacks::OracleJoins - Pre-ANSI Joins-via-Where-Clause Syntax
-
-=head1 PURPOSE
-
-This module was originally written to support Oracle < 9i where ANSI joins
-weren't supported at all, but became the module for Oracle >= 8 because
-Oracle's optimising of ANSI joins is horrible.
-
-=head1 SYNOPSIS
-
-Not intended for use directly; used as the sql_maker_class for schemas and components.
-
-=head1 DESCRIPTION
-
-Implements pre-ANSI joins specified in the where clause. Instead of:
-
- SELECT x FROM y JOIN z ON y.id = z.id
-
-It will write:
-
- SELECT x FROM y, z WHERE y.id = z.id
-
-It should properly support left joins, and right joins. Full outer joins are
-not possible due to the fact that Oracle requires the entire query be written
-to union the results of a left and right join, and by the time this module is
-called to create the where query and table definition part of the sql query,
-it's already too late.
-
-=head1 METHODS
-
-=over
-
-=item select ($\@$;$$@)
-
-Replaces DBIx::Class::SQLAHacks's select() method, which calls _oracle_joins()
-to modify the column and table list before calling SUPER::select().
-
-=item _recurse_from ($$\@)
-
-Recursive subroutine that builds the table list.
-
-=item _oracle_joins ($$$@)
-
-Creates the left/right relationship in the where query.
-
-=back
-
-=head1 BUGS
-
-Does not support full outer joins.
-Probably lots more.
-
-=head1 SEE ALSO
-
-=over
-
-=item L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> - Storage class using this
-
-=item L<DBIx::Class::SQLAHacks> - Parent module
-
-=item L<DBIx::Class> - Duh
-
-=back
-
-=head1 AUTHOR
-
-Justin Wheeler C<< <jwheeler@datademons.com> >>
-
-=head1 CONTRIBUTORS
-
-David Jack Olrik C<< <djo@cpan.org> >>
-
-=head1 LICENSE
-
-This module is licensed under the same terms as Perl itself.
-
-=cut
-
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLAHacks::SQLite;
+
+use base qw( DBIx::Class::SQLMaker::SQLite );
+
+1;
--- /dev/null
+package DBIx::Class::SQLMaker;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+DBIx::Class::SQLMaker - An SQL::Abstract-based SQL maker class
+
+=head1 DESCRIPTION
+
+This module is a subclass of L<SQL::Abstract> and includes a number of
+DBIC-specific workarounds, not yet suitable for inclusion into the
+L<SQL::Abstract> core. It also provides all (and more than) the functionality
+of L<SQL::Abstract::Limit>, see L<DBIx::Class::SQLMaker::LimitDialects> for
+more info.
+
+Currently the enhancements to L<SQL::Abstract> are:
+
+=over
+
+=item * Support for C<JOIN> statements (via extended C<table/from> support)
+
+=item * Support of functions in C<SELECT> lists
+
+=item * C<GROUP BY>/C<HAVING> support (via extensions to the order_by parameter)
+
+=item * Support of C<...FOR UPDATE> type of select statement modifiers
+
+=item * The L</-ident> operator
+
+=item * The L</-value> operator
+
+=back
+
+=cut
+
+use base qw/
+ DBIx::Class::SQLMaker::LimitDialects
+ SQL::Abstract
+ DBIx::Class
+/;
+use mro 'c3';
+
+use Sub::Name 'subname';
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
+use namespace::clean;
+
+__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
+
+# for when I need a normalized l/r pair
+sub _quote_chars {
+ map
+ { defined $_ ? $_ : '' }
+ ( ref $_[0]->{quote_char} ? (@{$_[0]->{quote_char}}) : ( ($_[0]->{quote_char}) x 2 ) )
+ ;
+}
+
+# FIXME when we bring in the storage weaklink, check its schema
+# weaklink and channel through $schema->throw_exception
+sub throw_exception { DBIx::Class::Exception->throw($_[1]) }
+
+BEGIN {
+ # reinstall the belch()/puke() functions of SQL::Abstract with custom versions
+ # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
+ no warnings qw/redefine/;
+
+ *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
+ my($func) = (caller(1))[3];
+ carp "[$func] Warning: ", @_;
+ };
+
+ *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
+ my($func) = (caller(1))[3];
+ __PACKAGE__->throw_exception("[$func] Fatal: " . join ('', @_));
+ };
+
+ # Current SQLA pollutes its namespace - clean for the time being
+ namespace::clean->clean_subroutines(qw/SQL::Abstract carp croak confess/);
+}
+
+# the "oh noes offset/top without limit" constant
+# limited to 31 bits for sanity (and consistency,
+# since it may be handed to the like of sprintf %u)
+#
+# Also *some* builds of SQLite fail the test
+# some_column BETWEEN ? AND ?: 1, 4294967295
+# with the proper integer bind attrs
+#
+# Implemented as a method, since ::Storage::DBI also
+# refers to it (i.e. for the case of software_limit or
+# as the value to abuse with MSSQL ordered subqueries)
+sub __max_int () { 0x7FFFFFFF };
+
+# poor man's de-qualifier
+sub _quote {
+ $_[0]->next::method( ( $_[0]{_dequalify_idents} and ! ref $_[1] )
+ ? $_[1] =~ / ([^\.]+) $ /x
+ : $_[1]
+ );
+}
+
+sub new {
+ my $self = shift->next::method(@_);
+
+ # use the same coderefs, they are prepared to handle both cases
+ my @extra_dbic_syntax = (
+ { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
+ { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
+ );
+
+ push @{$self->{special_ops}}, @extra_dbic_syntax;
+ push @{$self->{unary_ops}}, @extra_dbic_syntax;
+
+ $self;
+}
+
+sub _where_op_IDENT {
+ my $self = shift;
+ my ($op, $rhs) = splice @_, -2;
+ if (ref $rhs) {
+ $self->throw_exception("-$op takes a single scalar argument (a quotable identifier)");
+ }
+
+ # in case we are called as a top level special op (no '=')
+ my $lhs = shift;
+
+ $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
+
+ return $lhs
+ ? "$lhs = $rhs"
+ : $rhs
+ ;
+}
+
+sub _where_op_VALUE {
+ my $self = shift;
+ my ($op, $rhs) = splice @_, -2;
+
+ # in case we are called as a top level special op (no '=')
+ my $lhs = shift;
+
+ my @bind = [
+ ($lhs || $self->{_nested_func_lhs} || $self->throw_exception("Unable to find bindtype for -value $rhs") ),
+ $rhs
+ ];
+
+ return $lhs
+ ? (
+ $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
+ @bind
+ )
+ : (
+ $self->_convert('?'),
+ @bind,
+ )
+ ;
+}
+
+sub _where_op_NEST {
+ carp_unique ("-nest in search conditions is deprecated, you most probably wanted:\n"
+ .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
+ );
+
+ shift->next::method(@_);
+}
+
+# Handle limit-dialect selection
+sub select {
+ my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
+
+
+ $fields = $self->_recurse_fields($fields);
+
+ if (defined $offset) {
+ $self->throw_exception('A supplied offset must be a non-negative integer')
+ if ( $offset =~ /\D/ or $offset < 0 );
+ }
+ $offset ||= 0;
+
+ if (defined $limit) {
+ $self->throw_exception('A supplied limit must be a positive integer')
+ if ( $limit =~ /\D/ or $limit <= 0 );
+ }
+ elsif ($offset) {
+ $limit = $self->__max_int;
+ }
+
+
+ my ($sql, @bind);
+ if ($limit) {
+ # this is legacy code-flow from SQLA::Limit, it is not set in stone
+
+ ($sql, @bind) = $self->next::method ($table, $fields, $where);
+
+ my $limiter =
+ $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit
+ ||
+ do {
+ my $dialect = $self->limit_dialect
+ or $self->throw_exception( "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found" );
+ $self->can ("_$dialect")
+ or $self->throw_exception(__PACKAGE__ . " does not implement the requested dialect '$dialect'");
+ }
+ ;
+
+ $sql = $self->$limiter (
+ $sql,
+ { %{$rs_attrs||{}}, _selector_sql => $fields },
+ $limit,
+ $offset
+ );
+ }
+ else {
+ ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
+ }
+
+ push @{$self->{where_bind}}, @bind;
+
+# this *must* be called, otherwise extra binds will remain in the sql-maker
+ my @all_bind = $self->_assemble_binds;
+
+ $sql .= $self->_lock_select ($rs_attrs->{for})
+ if $rs_attrs->{for};
+
+ return wantarray ? ($sql, @all_bind) : $sql;
+}
+
+sub _assemble_binds {
+ my $self = shift;
+ return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where group having order limit/);
+}
+
+my $for_syntax = {
+ update => 'FOR UPDATE',
+ shared => 'FOR SHARE',
+};
+sub _lock_select {
+ my ($self, $type) = @_;
+ my $sql = $for_syntax->{$type} || $self->throw_exception( "Unknown SELECT .. FOR type '$type' requested" );
+ return " $sql";
+}
+
+# Handle default inserts
+sub insert {
+# optimized due to hotttnesss
+# my ($self, $table, $data, $options) = @_;
+
+ # SQLA will emit INSERT INTO $table ( ) VALUES ( )
+ # which is sadly understood only by MySQL. Change default behavior here,
+ # until SQLA2 comes with proper dialect support
+ if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
+ my @bind;
+ my $sql = sprintf(
+ 'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
+ );
+
+ if ( ($_[3]||{})->{returning} ) {
+ my $s;
+ ($s, @bind) = $_[0]->_insert_returning ($_[3]);
+ $sql .= $s;
+ }
+
+ return ($sql, @bind);
+ }
+
+ next::method(@_);
+}
+
+sub _recurse_fields {
+ my ($self, $fields) = @_;
+ my $ref = ref $fields;
+ return $self->_quote($fields) unless $ref;
+ return $$fields if $ref eq 'SCALAR';
+
+ if ($ref eq 'ARRAY') {
+ return join(', ', map { $self->_recurse_fields($_) } @$fields);
+ }
+ elsif ($ref eq 'HASH') {
+ my %hash = %$fields; # shallow copy
+
+ my $as = delete $hash{-as}; # if supplied
+
+ my ($func, $args, @toomany) = %hash;
+
+ # there should be only one pair
+ if (@toomany) {
+ $self->throw_exception( "Malformed select argument - too many keys in hash: " . join (',', keys %$fields ) );
+ }
+
+ if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
+ $self->throw_exception (
+ 'The select => { distinct => ... } syntax is not supported for multiple columns.'
+ .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
+ .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
+ );
+ }
+
+ my $select = sprintf ('%s( %s )%s',
+ $self->_sqlcase($func),
+ $self->_recurse_fields($args),
+ $as
+ ? sprintf (' %s %s', $self->_sqlcase('as'), $self->_quote ($as) )
+ : ''
+ );
+
+ return $select;
+ }
+ # Is the second check absolutely necessary?
+ elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
+ push @{$self->{select_bind}}, @{$$fields}[1..$#$$fields];
+ return $$fields->[0];
+ }
+ else {
+ $self->throw_exception( $ref . qq{ unexpected in _recurse_fields()} );
+ }
+}
+
+
+# this used to be a part of _order_by but is broken out for clarity.
+# What we have been doing forever is hijacking the $order arg of
+# SQLA::select to pass in arbitrary pieces of data (first the group_by,
+# then pretty much the entire resultset attr-hash, as more and more
+# things in the SQLA space need to have mopre info about the $rs they
+# create SQL for. The alternative would be to keep expanding the
+# signature of _select with more and more positional parameters, which
+# is just gross. All hail SQLA2!
+sub _parse_rs_attrs {
+ my ($self, $arg) = @_;
+
+ my $sql = '';
+
+ if ($arg->{group_by}) {
+ # horible horrible, waiting for refactor
+ local $self->{select_bind};
+ if (my $g = $self->_recurse_fields($arg->{group_by}) ) {
+ $sql .= $self->_sqlcase(' group by ') . $g;
+ push @{$self->{group_bind} ||= []}, @{$self->{select_bind}||[]};
+ }
+ }
+
+ if (defined $arg->{having}) {
+ my ($frag, @bind) = $self->_recurse_where($arg->{having});
+ push(@{$self->{having_bind}}, @bind);
+ $sql .= $self->_sqlcase(' having ') . $frag;
+ }
+
+ if (defined $arg->{order_by}) {
+ $sql .= $self->_order_by ($arg->{order_by});
+ }
+
+ return $sql;
+}
+
+sub _order_by {
+ my ($self, $arg) = @_;
+
+ # check that we are not called in legacy mode (order_by as 4th argument)
+ if (ref $arg eq 'HASH' and not grep { $_ =~ /^-(?:desc|asc)/i } keys %$arg ) {
+ return $self->_parse_rs_attrs ($arg);
+ }
+ else {
+ my ($sql, @bind) = $self->next::method($arg);
+ push @{$self->{order_bind}}, @bind;
+ return $sql;
+ }
+}
+
+sub _table {
+# optimized due to hotttnesss
+# my ($self, $from) = @_;
+ if (my $ref = ref $_[1] ) {
+ if ($ref eq 'ARRAY') {
+ return $_[0]->_recurse_from(@{$_[1]});
+ }
+ elsif ($ref eq 'HASH') {
+ return $_[0]->_recurse_from($_[1]);
+ }
+ elsif ($ref eq 'REF' && ref ${$_[1]} eq 'ARRAY') {
+ my ($sql, @bind) = @{ ${$_[1]} };
+ push @{$_[0]->{from_bind}}, @bind;
+ return $sql
+ }
+ }
+ return $_[0]->next::method ($_[1]);
+}
+
+sub _generate_join_clause {
+ my ($self, $join_type) = @_;
+
+ $join_type = $self->{_default_jointype}
+ if ! defined $join_type;
+
+ return sprintf ('%s JOIN ',
+ $join_type ? $self->_sqlcase($join_type) : ''
+ );
+}
+
+sub _recurse_from {
+ my $self = shift;
+
+ return join (' ', $self->_gen_from_blocks(@_) );
+}
+
+sub _gen_from_blocks {
+ my ($self, $from, @joins) = @_;
+
+ my @fchunks = $self->_from_chunk_to_sql($from);
+
+ for (@joins) {
+ my ($to, $on) = @$_;
+
+ # check whether a join type exists
+ my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
+ my $join_type;
+ if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
+ $join_type = $to_jt->{-join_type};
+ $join_type =~ s/^\s+ | \s+$//xg;
+ }
+
+ my @j = $self->_generate_join_clause( $join_type );
+
+ if (ref $to eq 'ARRAY') {
+ push(@j, '(', $self->_recurse_from(@$to), ')');
+ }
+ else {
+ push(@j, $self->_from_chunk_to_sql($to));
+ }
+
+ my ($sql, @bind) = $self->_join_condition($on);
+ push(@j, ' ON ', $sql);
+ push @{$self->{from_bind}}, @bind;
+
+ push @fchunks, join '', @j;
+ }
+
+ return @fchunks;
+}
+
+sub _from_chunk_to_sql {
+ my ($self, $fromspec) = @_;
+
+ return join (' ', do {
+ if (! ref $fromspec) {
+ $self->_quote($fromspec);
+ }
+ elsif (ref $fromspec eq 'SCALAR') {
+ $$fromspec;
+ }
+ elsif (ref $fromspec eq 'REF' and ref $$fromspec eq 'ARRAY') {
+ push @{$self->{from_bind}}, @{$$fromspec}[1..$#$$fromspec];
+ $$fromspec->[0];
+ }
+ elsif (ref $fromspec eq 'HASH') {
+ my ($as, $table, $toomuch) = ( map
+ { $_ => $fromspec->{$_} }
+ ( grep { $_ !~ /^\-/ } keys %$fromspec )
+ );
+
+ $self->throw_exception( "Only one table/as pair expected in from-spec but an exra '$toomuch' key present" )
+ if defined $toomuch;
+
+ ($self->_from_chunk_to_sql($table), $self->_quote($as) );
+ }
+ else {
+ $self->throw_exception('Unsupported from refkind: ' . ref $fromspec );
+ }
+ });
+}
+
+sub _join_condition {
+ my ($self, $cond) = @_;
+
+ # Backcompat for the old days when a plain hashref
+ # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
+ # Once things settle we should start warning here so that
+ # folks unroll their hacks
+ if (
+ ref $cond eq 'HASH'
+ and
+ keys %$cond == 1
+ and
+ (keys %$cond)[0] =~ /\./
+ and
+ ! ref ( (values %$cond)[0] )
+ ) {
+ $cond = { keys %$cond => { -ident => values %$cond } }
+ }
+ elsif ( ref $cond eq 'ARRAY' ) {
+ # do our own ORing so that the hashref-shim above is invoked
+ my @parts;
+ my @binds;
+ foreach my $c (@$cond) {
+ my ($sql, @bind) = $self->_join_condition($c);
+ push @binds, @bind;
+ push @parts, $sql;
+ }
+ return join(' OR ', @parts), @binds;
+ }
+
+ return $self->_recurse_where($cond);
+}
+
+1;
+
+=head1 OPERATORS
+
+=head2 -ident
+
+Used to explicitly specify an SQL identifier. Takes a plain string as value
+which is then invariably treated as a column name (and is being properly
+quoted if quoting has been requested). Most useful for comparison of two
+columns:
+
+ my %where = (
+ priority => { '<', 2 },
+ requestor => { -ident => 'submitter' }
+ );
+
+which results in:
+
+ $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
+ @bind = ('2');
+
+=head2 -value
+
+The -value operator signals that the argument to the right is a raw bind value.
+It will be passed straight to DBI, without invoking any of the SQL::Abstract
+condition-parsing logic. This allows you to, for example, pass an array as a
+column value for databases that support array datatypes, e.g.:
+
+ my %where = (
+ array => { -value => [1, 2, 3] }
+ );
+
+which results in:
+
+ $stmt = 'WHERE array = ?';
+ @bind = ([1, 2, 3]);
+
+=head1 AUTHORS
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::ACCESS;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::SQLMaker';
+
+# inner joins must be prefixed with 'INNER '
+sub new {
+ my $class = shift;
+ my $self = $class->next::method(@_);
+
+ $self->{_default_jointype} = 'INNER';
+
+ return $self;
+}
+
+# MSAccess is retarded wrt multiple joins in FROM - it requires a certain
+# way of parenthesizing each left part before each next right part
+sub _recurse_from {
+ my @j = shift->_gen_from_blocks(@_);
+
+ # first 2 steps need no parenthesis
+ my $fin_join = join (' ', splice @j, 0, 2);
+
+ while (@j) {
+ $fin_join = sprintf '( %s ) %s', $fin_join, (shift @j);
+ }
+
+ # the entire FROM is *ALSO* expected aprenthesized
+ "( $fin_join )";
+}
+
+1;
--- /dev/null
+package DBIx::Class::SQLMaker::LimitDialects;
+
+use warnings;
+use strict;
+
+use List::Util 'first';
+use namespace::clean;
+
+# constants are used not only here, but also in comparison tests
+sub __rows_bindtype () {
+ +{ sqlt_datatype => 'integer' }
+}
+sub __offset_bindtype () {
+ +{ sqlt_datatype => 'integer' }
+}
+sub __total_bindtype () {
+ +{ sqlt_datatype => 'integer' }
+}
+
+=head1 NAME
+
+DBIx::Class::SQLMaker::LimitDialects - SQL::Abstract::Limit-like functionality for DBIx::Class::SQLMaker
+
+=head1 DESCRIPTION
+
+This module replicates a lot of the functionality originally found in
+L<SQL::Abstract::Limit>. While simple limits would work as-is, the more
+complex dialects that require e.g. subqueries could not be reliably
+implemented without taking full advantage of the metadata locked within
+L<DBIx::Class::ResultSource> classes. After reimplementation of close to
+80% of the L<SQL::Abstract::Limit> functionality it was deemed more
+practical to simply make an independent DBIx::Class-specific limit-dialect
+provider.
+
+=head1 SQL LIMIT DIALECTS
+
+Note that the actual implementations listed below never use C<*> literally.
+Instead proper re-aliasing of selectors and order criteria is done, so that
+the limit dialect are safe to use on joined resultsets with clashing column
+names.
+
+Currently the provided dialects are:
+
+=head2 LimitOffset
+
+ SELECT ... LIMIT $limit OFFSET $offset
+
+Supported by B<PostgreSQL> and B<SQLite>
+
+=cut
+sub _LimitOffset {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+ $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT ?";
+ push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
+ if ($offset) {
+ $sql .= " OFFSET ?";
+ push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ];
+ }
+ return $sql;
+}
+
+=head2 LimitXY
+
+ SELECT ... LIMIT $offset $limit
+
+Supported by B<MySQL> and any L<SQL::Statement> based DBD
+
+=cut
+sub _LimitXY {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+ $sql .= $self->_parse_rs_attrs( $rs_attrs ) . " LIMIT ";
+ if ($offset) {
+ $sql .= '?, ';
+ push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset ];
+ }
+ $sql .= '?';
+ push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
+
+ return $sql;
+}
+
+=head2 RowNumberOver
+
+ SELECT * FROM (
+ SELECT *, ROW_NUMBER() OVER( ORDER BY ... ) AS RNO__ROW__INDEX FROM (
+ SELECT ...
+ )
+ ) WHERE RNO__ROW__INDEX BETWEEN ($offset+1) AND ($limit+$offset)
+
+
+ANSI standard Limit/Offset implementation. Supported by B<DB2> and
+B<< MSSQL >= 2005 >>.
+
+=cut
+sub _RowNumberOver {
+ my ($self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ # get selectors, and scan the order_by (if any)
+ my $sq_attrs = $self->_subqueried_limit_attrs ( $sql, $rs_attrs );
+
+ # make up an order if none exists
+ my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order;
+
+ # the order binds (if any) will need to go at the end of the entire inner select
+ local $self->{order_bind};
+ my $rno_ord = $self->_order_by ($requested_order);
+ push @{$self->{select_bind}}, @{$self->{order_bind}};
+
+ # this is the order supplement magic
+ my $mid_sel = $sq_attrs->{selection_outer};
+ if (my $extra_order_sel = $sq_attrs->{order_supplement}) {
+ for my $extra_col (sort
+ { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
+ keys %$extra_order_sel
+ ) {
+ $sq_attrs->{selection_inner} .= sprintf (', %s AS %s',
+ $extra_col,
+ $extra_order_sel->{$extra_col},
+ );
+ }
+ }
+
+ # and this is order re-alias magic
+ for my $map ($sq_attrs->{order_supplement}, $sq_attrs->{outer_renames}) {
+ for my $col (sort { (length $b) <=> (length $a) } keys %{$map||{}} ) {
+ my $re_col = quotemeta ($col);
+ $rno_ord =~ s/$re_col/$map->{$col}/;
+ }
+ }
+
+ # whatever is left of the order_by (only where is processed at this point)
+ my $group_having = $self->_parse_rs_attrs($rs_attrs);
+
+ my $qalias = $self->_quote ($rs_attrs->{alias});
+ my $idx_name = $self->_quote ('rno__row__index');
+
+ push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1], [ $self->__total_bindtype => $offset + $rows ];
+
+ return <<EOS;
+
+SELECT $sq_attrs->{selection_outer} FROM (
+ SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM (
+ SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${group_having}
+ ) $qalias
+) $qalias WHERE $idx_name >= ? AND $idx_name <= ?
+
+EOS
+
+}
+
+# some databases are happy with OVER (), some need OVER (ORDER BY (SELECT (1)) )
+sub _rno_default_order {
+ return undef;
+}
+
+=head2 SkipFirst
+
+ SELECT SKIP $offset FIRST $limit * FROM ...
+
+Suported by B<Informix>, almost like LimitOffset. According to
+L<SQL::Abstract::Limit> C<... SKIP $offset LIMIT $limit ...> is also supported.
+
+=cut
+sub _SkipFirst {
+ my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
+
+ $sql =~ s/^ \s* SELECT \s+ //ix
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
+
+ return sprintf ('SELECT %s%s%s%s',
+ $offset
+ ? do {
+ push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset];
+ 'SKIP ? '
+ }
+ : ''
+ ,
+ do {
+ push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ];
+ 'FIRST ? '
+ },
+ $sql,
+ $self->_parse_rs_attrs ($rs_attrs),
+ );
+}
+
+=head2 FirstSkip
+
+ SELECT FIRST $limit SKIP $offset * FROM ...
+
+Supported by B<Firebird/Interbase>, reverse of SkipFirst. According to
+L<SQL::Abstract::Limit> C<... ROWS $limit TO $offset ...> is also supported.
+
+=cut
+sub _FirstSkip {
+ my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
+
+ $sql =~ s/^ \s* SELECT \s+ //ix
+ or $self->throw_exception("Unrecognizable SELECT: $sql");
+
+ return sprintf ('SELECT %s%s%s%s',
+ do {
+ push @{$self->{pre_select_bind}}, [ $self->__rows_bindtype => $rows ];
+ 'FIRST ? '
+ },
+ $offset
+ ? do {
+ push @{$self->{pre_select_bind}}, [ $self->__offset_bindtype => $offset];
+ 'SKIP ? '
+ }
+ : ''
+ ,
+ $sql,
+ $self->_parse_rs_attrs ($rs_attrs),
+ );
+}
+
+
+=head2 RowNum
+
+Depending on the resultset attributes one of:
+
+ SELECT * FROM (
+ SELECT *, ROWNUM rownum__index FROM (
+ SELECT ...
+ ) WHERE ROWNUM <= ($limit+$offset)
+ ) WHERE rownum__index >= ($offset+1)
+
+or
+
+ SELECT * FROM (
+ SELECT *, ROWNUM rownum__index FROM (
+ SELECT ...
+ )
+ ) WHERE rownum__index BETWEEN ($offset+1) AND ($limit+$offset)
+
+or
+
+ SELECT * FROM (
+ SELECT ...
+ ) WHERE ROWNUM <= ($limit+1)
+
+Supported by B<Oracle>.
+
+=cut
+sub _RowNum {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ my $sq_attrs = $self->_subqueried_limit_attrs ($sql, $rs_attrs);
+
+ my $qalias = $self->_quote ($rs_attrs->{alias});
+ my $idx_name = $self->_quote ('rownum__index');
+ my $order_group_having = $self->_parse_rs_attrs($rs_attrs);
+
+
+ # if no offset (e.g. first page) - we can skip one of the subqueries
+ if (! $offset) {
+ push @{$self->{limit_bind}}, [ $self->__rows_bindtype => $rows ];
+
+ return <<EOS;
+SELECT $sq_attrs->{selection_outer} FROM (
+ SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having}
+) $qalias WHERE ROWNUM <= ?
+EOS
+ }
+
+ #
+ # There are two ways to limit in Oracle, one vastly faster than the other
+ # on large resultsets: https://decipherinfosys.wordpress.com/2007/08/09/paging-and-countstopkey-optimization/
+ # However Oracle is retarded and does not preserve stable ROWNUM() values
+ # when called twice in the same scope. Therefore unless the resultset is
+ # ordered by a unique set of columns, it is not safe to use the faster
+ # method, and the slower BETWEEN query is used instead
+ #
+ # FIXME - this is quite expensive, and does not perform caching of any sort
+ # as soon as some of the DQ work becomes viable consider switching this
+ # over
+ if (
+ $rs_attrs->{order_by}
+ and
+ $rs_attrs->{_rsroot_rsrc}->storage->_order_by_is_stable(
+ @{$rs_attrs}{qw/from order_by where/}
+ )
+ ) {
+ push @{$self->{limit_bind}}, [ $self->__total_bindtype => $offset + $rows ], [ $self->__offset_bindtype => $offset + 1 ];
+
+ return <<EOS;
+SELECT $sq_attrs->{selection_outer} FROM (
+ SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM (
+ SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having}
+ ) $qalias WHERE ROWNUM <= ?
+) $qalias WHERE $idx_name >= ?
+EOS
+ }
+ else {
+ push @{$self->{limit_bind}}, [ $self->__offset_bindtype => $offset + 1 ], [ $self->__total_bindtype => $offset + $rows ];
+
+ return <<EOS;
+SELECT $sq_attrs->{selection_outer} FROM (
+ SELECT $sq_attrs->{selection_outer}, ROWNUM $idx_name FROM (
+ SELECT $sq_attrs->{selection_inner} $sq_attrs->{query_leftover}${order_group_having}
+ ) $qalias
+) $qalias WHERE $idx_name BETWEEN ? AND ?
+EOS
+ }
+}
+
+# used by _Top and _FetchFirst below
+sub _prep_for_skimming_limit {
+ my ( $self, $sql, $rs_attrs ) = @_;
+
+ # get selectors
+ my $sq_attrs = $self->_subqueried_limit_attrs ($sql, $rs_attrs);
+
+ my $requested_order = delete $rs_attrs->{order_by};
+ $sq_attrs->{order_by_requested} = $self->_order_by ($requested_order);
+ $sq_attrs->{grpby_having} = $self->_parse_rs_attrs ($rs_attrs);
+
+ # without an offset things are easy
+ if (! $rs_attrs->{offset}) {
+ $sq_attrs->{order_by_inner} = $sq_attrs->{order_by_requested};
+ }
+ else {
+ $sq_attrs->{quoted_rs_alias} = $self->_quote ($rs_attrs->{alias});
+
+ # localise as we already have all the bind values we need
+ local $self->{order_bind};
+
+ # make up an order unless supplied or sanity check what we are given
+ my $inner_order;
+ if ($sq_attrs->{order_by_requested}) {
+ $self->throw_exception (
+ 'Unable to safely perform "skimming type" limit with supplied unstable order criteria'
+ ) unless ($rs_attrs->{_rsroot_rsrc}->schema->storage->_order_by_is_stable(
+ $rs_attrs->{from},
+ $requested_order,
+ $rs_attrs->{where},
+ ));
+
+ $inner_order = $requested_order;
+ }
+ else {
+ $inner_order = [ map
+ { "$rs_attrs->{alias}.$_" }
+ ( @{
+ $rs_attrs->{_rsroot_rsrc}->_identifying_column_set
+ ||
+ $self->throw_exception(sprintf(
+ 'Unable to auto-construct stable order criteria for "skimming type" limit '
+ . "dialect based on source '%s'", $rs_attrs->{_rsroot_rsrc}->name) );
+ } )
+ ];
+ }
+
+ $sq_attrs->{order_by_inner} = $self->_order_by ($inner_order);
+
+ my @out_chunks;
+ for my $ch ($self->_order_by_chunks ($inner_order)) {
+ $ch = $ch->[0] if ref $ch eq 'ARRAY';
+
+ $ch =~ s/\s+ ( ASC|DESC ) \s* $//ix;
+ my $dir = uc ($1||'ASC');
+ push @out_chunks, \join (' ', $ch, $dir eq 'ASC' ? 'DESC' : 'ASC' );
+ }
+
+ $sq_attrs->{order_by_middle} = $self->_order_by (\@out_chunks);
+
+ # this is the order supplement magic
+ $sq_attrs->{selection_middle} = $sq_attrs->{selection_outer};
+ if (my $extra_order_sel = $sq_attrs->{order_supplement}) {
+ for my $extra_col (sort
+ { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
+ keys %$extra_order_sel
+ ) {
+ $sq_attrs->{selection_inner} .= sprintf (', %s AS %s',
+ $extra_col,
+ $extra_order_sel->{$extra_col},
+ );
+
+ $sq_attrs->{selection_middle} .= ', ' . $extra_order_sel->{$extra_col};
+ }
+
+ # Whatever order bindvals there are, they will be realiased and
+ # reselected, and need to show up at end of the initial inner select
+ push @{$self->{select_bind}}, @{$self->{order_bind}};
+
+ # if this is a part of something bigger, we need to add back all
+ # the extra order_by's, as they may be relied upon by the outside
+ # of a prefetch or something
+ if ($rs_attrs->{_is_internal_subuery}) {
+ $sq_attrs->{selection_outer} .= sprintf ", $extra_order_sel->{$_} AS $_"
+ for sort
+ { $extra_order_sel->{$a} cmp $extra_order_sel->{$b} }
+ grep { $_ !~ /[^\w\-]/ } # ignore functions
+ keys %$extra_order_sel
+ ;
+ }
+ }
+
+ # and this is order re-alias magic
+ for my $map ($sq_attrs->{order_supplement}, $sq_attrs->{outer_renames}) {
+ for my $col (sort { (length $b) <=> (length $a) } keys %{$map||{}}) {
+ my $re_col = quotemeta ($col);
+ $_ =~ s/$re_col/$map->{$col}/
+ for ($sq_attrs->{order_by_middle}, $sq_attrs->{order_by_requested});
+ }
+ }
+ }
+
+ $sq_attrs;
+}
+
+=head2 Top
+
+ SELECT * FROM
+
+ SELECT TOP $limit FROM (
+ SELECT TOP $limit FROM (
+ SELECT TOP ($limit+$offset) ...
+ ) ORDER BY $reversed_original_order
+ ) ORDER BY $original_order
+
+Unreliable Top-based implementation, supported by B<< MSSQL < 2005 >>.
+
+=head3 CAVEAT
+
+Due to its implementation, this limit dialect returns B<incorrect results>
+when $limit+$offset > total amount of rows in the resultset.
+
+=cut
+
+sub _Top {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ my $lim = $self->_prep_for_skimming_limit($sql, $rs_attrs);
+
+ $sql = sprintf ('SELECT TOP %u %s %s %s %s',
+ $rows + ($offset||0),
+ $offset ? $lim->{selection_inner} : $lim->{selection_original},
+ $lim->{query_leftover},
+ $lim->{grpby_having},
+ $lim->{order_by_inner},
+ );
+
+ $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
+ $rows,
+ $lim->{selection_middle},
+ $sql,
+ $lim->{quoted_rs_alias},
+ $lim->{order_by_middle},
+ ) if $offset;
+
+ $sql = sprintf ('SELECT %s FROM ( %s ) %s %s',
+ $lim->{selection_outer},
+ $sql,
+ $lim->{quoted_rs_alias},
+ $lim->{order_by_requested},
+ ) if $offset and (
+ $lim->{order_by_requested} or $lim->{selection_middle} ne $lim->{selection_outer}
+ );
+
+ return $sql;
+}
+
+=head2 FetchFirst
+
+ SELECT * FROM
+ (
+ SELECT * FROM (
+ SELECT * FROM (
+ SELECT * FROM ...
+ ) ORDER BY $reversed_original_order
+ FETCH FIRST $limit ROWS ONLY
+ ) ORDER BY $original_order
+ FETCH FIRST $limit ROWS ONLY
+ )
+
+Unreliable FetchFirst-based implementation, supported by B<< IBM DB2 <= V5R3 >>.
+
+=head3 CAVEAT
+
+Due to its implementation, this limit dialect returns B<incorrect results>
+when $limit+$offset > total amount of rows in the resultset.
+
+=cut
+
+sub _FetchFirst {
+ my ( $self, $sql, $rs_attrs, $rows, $offset ) = @_;
+
+ my $lim = $self->_prep_for_skimming_limit($sql, $rs_attrs);
+
+ $sql = sprintf ('SELECT %s %s %s %s FETCH FIRST %u ROWS ONLY',
+ $offset ? $lim->{selection_inner} : $lim->{selection_original},
+ $lim->{query_leftover},
+ $lim->{grpby_having},
+ $lim->{order_by_inner},
+ $rows + ($offset||0),
+ );
+
+ $sql = sprintf ('SELECT %s FROM ( %s ) %s %s FETCH FIRST %u ROWS ONLY',
+ $lim->{selection_middle},
+ $sql,
+ $lim->{quoted_rs_alias},
+ $lim->{order_by_middle},
+ $rows,
+ ) if $offset;
+
+
+ $sql = sprintf ('SELECT %s FROM ( %s ) %s %s',
+ $lim->{selection_outer},
+ $sql,
+ $lim->{quoted_rs_alias},
+ $lim->{order_by_requested},
+ ) if $offset and (
+ $lim->{order_by_requested} or $lim->{selection_middle} ne $lim->{selection_outer}
+ );
+
+ return $sql;
+}
+
+=head2 RowCountOrGenericSubQ
+
+This is not exactly a limit dialect, but more of a proxy for B<Sybase ASE>.
+If no $offset is supplied the limit is simply performed as:
+
+ SET ROWCOUNT $limit
+ SELECT ...
+ SET ROWCOUNT 0
+
+Otherwise we fall back to L</GenericSubQ>
+
+=cut
+
+sub _RowCountOrGenericSubQ {
+ my $self = shift;
+ my ($sql, $rs_attrs, $rows, $offset) = @_;
+
+ return $self->_GenericSubQ(@_) if $offset;
+
+ return sprintf <<"EOF", $rows, $sql, $self->_parse_rs_attrs( $rs_attrs );
+SET ROWCOUNT %d
+%s %s
+SET ROWCOUNT 0
+EOF
+}
+
+=head2 GenericSubQ
+
+ SELECT * FROM (
+ SELECT ...
+ )
+ WHERE (
+ SELECT COUNT(*) FROM $original_table cnt WHERE cnt.id < $original_table.id
+ ) BETWEEN $offset AND ($offset+$rows-1)
+
+This is the most evil limit "dialect" (more of a hack) for I<really> stupid
+databases. It works by ordering the set by some unique column, and calculating
+the amount of rows that have a less-er value (thus emulating a L</RowNum>-like
+index). Of course this implies the set can only be ordered by a single unique
+column.
+
+Also note that this technique can be and often is B<excruciatingly slow>. You
+may have much better luck using L<DBIx::Class::ResultSet/software_limit>
+instead.
+
+Currently used by B<Sybase ASE>, due to lack of any other option.
+
+=cut
+sub _GenericSubQ {
+ my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
+
+ my $root_rsrc = $rs_attrs->{_rsroot_rsrc};
+ my $root_tbl_name = $root_rsrc->name;
+
+ my ($first_order_by) = do {
+ local $self->{quote_char};
+ local $self->{order_bind};
+ map { ref $_ ? $_->[0] : $_ } $self->_order_by_chunks ($rs_attrs->{order_by})
+ } or $self->throw_exception (
+ 'Generic Subquery Limit does not work on resultsets without an order. Provide a single, '
+ . 'unique-column order criteria.'
+ );
+
+ $first_order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix;
+ my $direction = lc ($1 || 'asc');
+
+ my ($first_ord_alias, $first_ord_col) = $first_order_by =~ /^ (?: ([^\.]+) \. )? ([^\.]+) $/x;
+
+ $self->throw_exception(sprintf
+ "Generic Subquery Limit order criteria can be only based on the root-source '%s'"
+ . " (aliased as '%s')", $root_rsrc->source_name, $rs_attrs->{alias},
+ ) if ($first_ord_alias and $first_ord_alias ne $rs_attrs->{alias});
+
+ $first_ord_alias ||= $rs_attrs->{alias};
+
+ $self->throw_exception(
+ "Generic Subquery Limit first order criteria '$first_ord_col' must be unique"
+ ) unless $root_rsrc->_identifying_column_set([$first_ord_col]);
+
+ my $sq_attrs = do {
+ # perform the mangling only using the very first order crietria
+ # (the one we care about)
+ local $rs_attrs->{order_by} = $first_order_by;
+ $self->_subqueried_limit_attrs ($sql, $rs_attrs);
+ };
+
+ my $cmp_op = $direction eq 'desc' ? '>' : '<';
+ my $count_tbl_alias = 'rownum__emulation';
+
+ my ($order_sql, @order_bind) = do {
+ local $self->{order_bind};
+ my $s = $self->_order_by (delete $rs_attrs->{order_by});
+ ($s, @{$self->{order_bind}});
+ };
+ my $group_having_sql = $self->_parse_rs_attrs($rs_attrs);
+
+ my $in_sel = $sq_attrs->{selection_inner};
+
+ # add the order supplement (if any) as this is what will be used for the outer WHERE
+ $in_sel .= ", $_" for keys %{$sq_attrs->{order_supplement}};
+
+ my $rownum_cond;
+ if ($offset) {
+ $rownum_cond = 'BETWEEN ? AND ?';
+
+ push @{$self->{limit_bind}},
+ [ $self->__offset_bindtype => $offset ],
+ [ $self->__total_bindtype => $offset + $rows - 1]
+ ;
+ }
+ else {
+ $rownum_cond = '< ?';
+
+ push @{$self->{limit_bind}},
+ [ $self->__rows_bindtype => $rows ]
+ ;
+ }
+
+ # even though binds in order_by make no sense here (the rs needs to be
+ # ordered by a unique column first) - pass whatever there may be through
+ # anyway
+ push @{$self->{limit_bind}}, @order_bind;
+
+ return sprintf ("
+SELECT $sq_attrs->{selection_outer}
+ FROM (
+ SELECT $in_sel $sq_attrs->{query_leftover}${group_having_sql}
+ ) %s
+WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) $rownum_cond
+$order_sql
+ ", map { $self->_quote ($_) } (
+ $rs_attrs->{alias},
+ $root_tbl_name,
+ $count_tbl_alias,
+ "$count_tbl_alias.$first_ord_col",
+ "$first_ord_alias.$first_ord_col",
+ ));
+}
+
+
+# !!! THIS IS ALSO HORRIFIC !!! /me ashamed
+#
+# Generates inner/outer select lists for various limit dialects
+# which result in one or more subqueries (e.g. RNO, Top, RowNum)
+# Any non-root-table columns need to have their table qualifier
+# turned into a column alias (otherwise names in subqueries clash
+# and/or lose their source table)
+#
+# Returns mangled proto-sql, inner/outer strings of SQL QUOTED selectors
+# with aliases (to be used in whatever select statement), and an alias
+# index hashref of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used
+# for string-subst higher up).
+# If an order_by is supplied, the inner select needs to bring out columns
+# used in implicit (non-selected) orders, and the order condition itself
+# needs to be realiased to the proper names in the outer query. Thus we
+# also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL =>
+# QUOTED ALIAS pairs, which is a list of extra selectors that do *not*
+# exist in the original select list
+sub _subqueried_limit_attrs {
+ my ($self, $proto_sql, $rs_attrs) = @_;
+
+ $self->throw_exception(
+ 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
+ ) unless ref ($rs_attrs) eq 'HASH';
+
+ # mangle the input sql as we will be replacing the selector entirely
+ unless (
+ $rs_attrs->{_selector_sql}
+ and
+ $proto_sql =~ s/^ \s* SELECT \s* \Q$rs_attrs->{_selector_sql}//ix
+ ) {
+ $self->throw_exception("Unrecognizable SELECT: $proto_sql");
+ }
+
+ my ($re_sep, $re_alias) = map { quotemeta $_ } ( $self->{name_sep}, $rs_attrs->{alias} );
+
+ # insulate from the multiple _recurse_fields calls below
+ local $self->{select_bind};
+
+ # correlate select and as, build selection index
+ my (@sel, $in_sel_index);
+ for my $i (0 .. $#{$rs_attrs->{select}}) {
+
+ my $s = $rs_attrs->{select}[$i];
+ my $sql_sel = $self->_recurse_fields ($s);
+ my $sql_alias = (ref $s) eq 'HASH' ? $s->{-as} : undef;
+
+ push @sel, {
+ arg => $s,
+ sql => $sql_sel,
+ unquoted_sql => do {
+ local $self->{quote_char};
+ $self->_recurse_fields ($s);
+ },
+ as =>
+ $sql_alias
+ ||
+ $rs_attrs->{as}[$i]
+ ||
+ $self->throw_exception("Select argument $i ($s) without corresponding 'as'")
+ ,
+ };
+
+ # anything with a placeholder in it needs re-selection
+ $in_sel_index->{$sql_sel}++ unless $sql_sel =~ / (?: ^ | \W ) \? (?: \W | $ ) /x;
+
+ $in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias;
+
+ # record unqualified versions too, so we do not have
+ # to reselect the same column twice (in qualified and
+ # unqualified form)
+ if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) {
+ $in_sel_index->{$1}++;
+ }
+ }
+
+
+ # re-alias and remove any name separators from aliases,
+ # unless we are dealing with the current source alias
+ # (which will transcend the subqueries as it is necessary
+ # for possible further chaining)
+ # same for anything we do not recognize
+ my ($sel, $renamed);
+ for my $node (@sel) {
+ push @{$sel->{original}}, $node->{sql};
+
+ if (
+ ! $in_sel_index->{$node->{sql}}
+ or
+ $node->{as} =~ / (?<! ^ $re_alias ) \. /x
+ or
+ $node->{unquoted_sql} =~ / (?<! ^ $re_alias ) $re_sep /x
+ ) {
+ $node->{as} = $self->_unqualify_colname($node->{as});
+ my $quoted_as = $self->_quote($node->{as});
+ push @{$sel->{inner}}, sprintf '%s AS %s', $node->{sql}, $quoted_as;
+ push @{$sel->{outer}}, $quoted_as;
+ $renamed->{$node->{sql}} = $quoted_as;
+ }
+ else {
+ push @{$sel->{inner}}, $node->{sql};
+ push @{$sel->{outer}}, $self->_quote (ref $node->{arg} ? $node->{as} : $node->{arg});
+ }
+ }
+
+ # see if the order gives us anything
+ my $extra_order_sel;
+ for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
+ # order with bind
+ $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+
+ next if $in_sel_index->{$chunk};
+
+ $extra_order_sel->{$chunk} ||= $self->_quote (
+ 'ORDER__BY__' . scalar keys %{$extra_order_sel||{}}
+ );
+ }
+
+ return {
+ query_leftover => $proto_sql,
+ (map {( "selection_$_" => join (', ', @{$sel->{$_}} ) )} keys %$sel ),
+ outer_renames => $renamed,
+ order_supplement => $extra_order_sel,
+ };
+}
+
+sub _unqualify_colname {
+ my ($self, $fqcn) = @_;
+ $fqcn =~ s/ \. /__/xg;
+ return $fqcn;
+}
+
+1;
+
+=head1 AUTHORS
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::MSSQL;
+
+use base qw( DBIx::Class::SQLMaker );
+
+#
+# MSSQL does not support ... OVER() ... RNO limits
+#
+sub _rno_default_order {
+ return \ '(SELECT(1))';
+}
+
+1;
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::MySQL;
+
+use base qw( DBIx::Class::SQLMaker );
+
+#
+# MySQL does not understand the standard INSERT INTO $table DEFAULT VALUES
+# Adjust SQL here instead
+#
+sub insert {
+ my $self = shift;
+
+ if (! $_[1] or (ref $_[1] eq 'HASH' and !keys %{$_[1]} ) ) {
+ my $table = $self->_quote($_[0]);
+ return "INSERT INTO ${table} () VALUES ()"
+ }
+
+ return $self->next::method (@_);
+}
+
+# Allow STRAIGHT_JOIN's
+sub _generate_join_clause {
+ my ($self, $join_type) = @_;
+
+ if( $join_type && $join_type =~ /^STRAIGHT\z/i ) {
+ return ' STRAIGHT_JOIN '
+ }
+
+ return $self->next::method($join_type);
+}
+
+# LOCK IN SHARE MODE
+my $for_syntax = {
+ update => 'FOR UPDATE',
+ shared => 'LOCK IN SHARE MODE'
+};
+
+sub _lock_select {
+ my ($self, $type) = @_;
+
+ my $sql = $for_syntax->{$type}
+ || $self->throw_exception("Unknown SELECT .. FOR type '$type' requested");
+
+ return " $sql";
+}
+
+1;
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::Oracle;
+
+use warnings;
+use strict;
+
+use base qw( DBIx::Class::SQLMaker );
+
+BEGIN {
+ use DBIx::Class::Optional::Dependencies;
+ die('The following extra modules are required for Oracle-based Storages ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener') . "\n" )
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
+}
+
+sub new {
+ my $self = shift;
+ my %opts = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
+ push @{$opts{special_ops}}, {
+ regex => qr/^prior$/i,
+ handler => '_where_field_PRIOR',
+ };
+
+ $self->next::method(\%opts);
+}
+
+sub _assemble_binds {
+ my $self = shift;
+ return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/pre_select select from where oracle_connect_by group having order limit/);
+}
+
+
+sub _parse_rs_attrs {
+ my $self = shift;
+ my ($rs_attrs) = @_;
+
+ my ($cb_sql, @cb_bind) = $self->_connect_by($rs_attrs);
+ push @{$self->{oracle_connect_by_bind}}, @cb_bind;
+
+ my $sql = $self->next::method(@_);
+
+ return "$cb_sql $sql";
+}
+
+sub _connect_by {
+ my ($self, $attrs) = @_;
+
+ my $sql = '';
+ my @bind;
+
+ if ( ref($attrs) eq 'HASH' ) {
+ if ( $attrs->{'start_with'} ) {
+ my ($ws, @wb) = $self->_recurse_where( $attrs->{'start_with'} );
+ $sql .= $self->_sqlcase(' start with ') . $ws;
+ push @bind, @wb;
+ }
+ if ( my $connect_by = $attrs->{'connect_by'} || $attrs->{'connect_by_nocycle'} ) {
+ my ($connect_by_sql, @connect_by_sql_bind) = $self->_recurse_where( $connect_by );
+ $sql .= sprintf(" %s %s",
+ ( $attrs->{'connect_by_nocycle'} ) ? $self->_sqlcase('connect by nocycle')
+ : $self->_sqlcase('connect by'),
+ $connect_by_sql,
+ );
+ push @bind, @connect_by_sql_bind;
+ }
+ if ( $attrs->{'order_siblings_by'} ) {
+ $sql .= $self->_order_siblings_by( $attrs->{'order_siblings_by'} );
+ }
+ }
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+sub _order_siblings_by {
+ my ( $self, $arg ) = @_;
+
+ my ( @sql, @bind );
+ for my $c ( $self->_order_by_chunks($arg) ) {
+ if (ref $c) {
+ push @sql, shift @$c;
+ push @bind, @$c;
+ }
+ else {
+ push @sql, $c;
+ }
+ }
+
+ my $sql =
+ @sql
+ ? sprintf( '%s %s', $self->_sqlcase(' order siblings by'), join( ', ', @sql ) )
+ : '';
+
+ return wantarray ? ( $sql, @bind ) : $sql;
+}
+
+# we need to add a '=' only when PRIOR is used against a column diretly
+# i.e. when it is invoked by a special_op callback
+sub _where_field_PRIOR {
+ my ($self, $lhs, $op, $rhs) = @_;
+ my ($sql, @bind) = $self->_recurse_where ($rhs);
+
+ $sql = sprintf ('%s = %s %s ',
+ $self->_convert($self->_quote($lhs)),
+ $self->_sqlcase ($op),
+ $sql
+ );
+
+ return ($sql, @bind);
+}
+
+# use this codepath to hook all identifiers and mangle them if necessary
+# this is invoked regardless of quoting being on or off
+sub _quote {
+ my ($self, $label) = @_;
+
+ return '' unless defined $label;
+ return ${$label} if ref($label) eq 'SCALAR';
+
+ $label =~ s/ ( [^\.]{31,} ) /$self->_shorten_identifier($1)/gxe;
+
+ $self->next::method($label);
+}
+
+# this takes an identifier and shortens it if necessary
+# optionally keywords can be passed as an arrayref to generate useful
+# identifiers
+sub _shorten_identifier {
+ my ($self, $to_shorten, $keywords) = @_;
+
+ # 30 characters is the identifier limit for Oracle
+ my $max_len = 30;
+ # we want at least 10 characters of the base36 md5
+ my $min_entropy = 10;
+
+ my $max_trunc = $max_len - $min_entropy - 1;
+
+ return $to_shorten
+ if length($to_shorten) <= $max_len;
+
+ $self->throw_exception("'keywords' needs to be an arrayref")
+ if defined $keywords && ref $keywords ne 'ARRAY';
+
+ # if no keywords are passed use the identifier as one
+ my @keywords = @{$keywords || []};
+ @keywords = $to_shorten unless @keywords;
+
+ # get a base36 md5 of the identifier
+ require Digest::MD5;
+ require Math::BigInt;
+ require Math::Base36;
+ my $b36sum = Math::Base36::encode_base36(
+ Math::BigInt->from_hex (
+ '0x' . Digest::MD5::md5_hex ($to_shorten)
+ )
+ );
+
+ # switch from perl to java
+ # get run-length
+ my ($concat_len, @lengths);
+ for (@keywords) {
+ $_ = ucfirst (lc ($_));
+ $_ =~ s/\_+(\w)/uc ($1)/eg;
+
+ push @lengths, length ($_);
+ $concat_len += $lengths[-1];
+ }
+
+ # if we are still too long - try to disemvowel non-capitals (not keyword starts)
+ if ($concat_len > $max_trunc) {
+ $concat_len = 0;
+ @lengths = ();
+
+ for (@keywords) {
+ $_ =~ s/[aeiou]//g;
+
+ push @lengths, length ($_);
+ $concat_len += $lengths[-1];
+ }
+ }
+
+ # still too long - just start cuting proportionally
+ if ($concat_len > $max_trunc) {
+ my $trim_ratio = $max_trunc / $concat_len;
+
+ for my $i (0 .. $#keywords) {
+ $keywords[$i] = substr ($keywords[$i], 0, int ($trim_ratio * $lengths[$i] ) );
+ }
+ }
+
+ my $fin = join ('', @keywords);
+ my $fin_len = length $fin;
+
+ return sprintf ('%s_%s',
+ $fin,
+ substr ($b36sum, 0, $max_len - $fin_len - 1),
+ );
+}
+
+sub _unqualify_colname {
+ my ($self, $fqcn) = @_;
+
+ return $self->_shorten_identifier($self->next::method($fqcn));
+}
+
+#
+# Oracle has a different INSERT...RETURNING syntax
+#
+
+sub _insert_returning {
+ my ($self, $options) = @_;
+
+ my $f = $options->{returning};
+
+ my ($f_list, @f_names) = do {
+ if (! ref $f) {
+ (
+ $self->_quote($f),
+ $f,
+ )
+ }
+ elsif (ref $f eq 'ARRAY') {
+ (
+ (join ', ', map { $self->_quote($_) } @$f),
+ @$f,
+ )
+ }
+ elsif (ref $f eq 'SCALAR') {
+ (
+ $$f,
+ $$f,
+ )
+ }
+ else {
+ $self->throw_exception("Unsupported INSERT RETURNING option $f");
+ }
+ };
+
+ my $rc_ref = $options->{returning_container}
+ or $self->throw_exception('No returning container supplied for IR values');
+
+ @$rc_ref = (undef) x @f_names;
+
+ return (
+ ( join (' ',
+ $self->_sqlcase(' returning'),
+ $f_list,
+ $self->_sqlcase('into'),
+ join (', ', ('?') x @f_names ),
+ )),
+ map {
+ $self->{bindtype} eq 'columns'
+ ? [ $f_names[$_] => \$rc_ref->[$_] ]
+ : \$rc_ref->[$_]
+ } (0 .. $#f_names),
+ );
+}
+
+1;
--- /dev/null
+package DBIx::Class::SQLMaker::OracleJoins;
+
+use warnings;
+use strict;
+
+use base qw( DBIx::Class::SQLMaker::Oracle );
+
+sub select {
+ my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
+
+ # pull out all join conds as regular WHEREs from all extra tables
+ if (ref($table) eq 'ARRAY') {
+ $where = $self->_oracle_joins($where, @{ $table }[ 1 .. $#$table ]);
+ }
+
+ return $self->next::method($table, $fields, $where, $rs_attrs, @rest);
+}
+
+sub _recurse_from {
+ my ($self, $from, @join) = @_;
+
+ my @sqlf = $self->_from_chunk_to_sql($from);
+
+ for (@join) {
+ my ($to, $on) = @$_;
+
+ if (ref $to eq 'ARRAY') {
+ push (@sqlf, $self->_recurse_from(@{ $to }));
+ }
+ else {
+ push (@sqlf, $self->_from_chunk_to_sql($to));
+ }
+ }
+
+ return join q{, }, @sqlf;
+}
+
+sub _oracle_joins {
+ my ($self, $where, @join) = @_;
+ my $join_where = $self->_recurse_oracle_joins(@join);
+
+ if (keys %$join_where) {
+ if (!defined($where)) {
+ $where = $join_where;
+ } else {
+ if (ref($where) eq 'ARRAY') {
+ $where = { -or => $where };
+ }
+ $where = { -and => [ $join_where, $where ] };
+ }
+ }
+ return $where;
+}
+
+sub _recurse_oracle_joins {
+ my $self = shift;
+
+ my @where;
+ for my $j (@_) {
+ my ($to, $on) = @{ $j };
+
+ push @where, $self->_recurse_oracle_joins(@{ $to })
+ if (ref $to eq 'ARRAY');
+
+ my $join_opts = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $left_join = q{};
+ my $right_join = q{};
+
+ if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) {
+ #TODO: Support full outer joins -- this would happen much earlier in
+ #the sequence since oracle 8's full outer join syntax is best
+ #described as INSANE.
+ $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n")
+ if $jt =~ /full/i;
+
+ $left_join = q{(+)} if $jt =~ /left/i
+ && $jt !~ /inner/i;
+
+ $right_join = q{(+)} if $jt =~ /right/i
+ && $jt !~ /inner/i;
+ }
+
+ # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops
+ push @where, map { \sprintf ('%s%s = %s%s',
+ ref $_ ? $self->_recurse_where($_) : $self->_quote($_),
+ $left_join,
+ ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}),
+ $right_join,
+ )} keys %$on;
+ }
+
+ return { -and => \@where };
+}
+
+1;
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::SQLMaker::OracleJoins - Pre-ANSI Joins-via-Where-Clause Syntax
+
+=head1 PURPOSE
+
+This module is used with Oracle < 9.0 due to lack of support for standard
+ANSI join syntax.
+
+=head1 SYNOPSIS
+
+Not intended for use directly; used as the sql_maker_class for schemas and components.
+
+=head1 DESCRIPTION
+
+Implements pre-ANSI joins specified in the where clause. Instead of:
+
+ SELECT x FROM y JOIN z ON y.id = z.id
+
+It will write:
+
+ SELECT x FROM y, z WHERE y.id = z.id
+
+It should properly support left joins, and right joins. Full outer joins are
+not possible due to the fact that Oracle requires the entire query be written
+to union the results of a left and right join, and by the time this module is
+called to create the where query and table definition part of the sql query,
+it's already too late.
+
+=head1 METHODS
+
+=over
+
+=item select
+
+Overrides DBIx::Class::SQLMaker's select() method, which calls _oracle_joins()
+to modify the column and table list before calling next::method().
+
+=back
+
+=head1 BUGS
+
+Does not support full outer joins (however neither really does DBIC itself)
+
+=head1 SEE ALSO
+
+=over
+
+=item L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> - Storage class using this
+
+=item L<DBIx::Class::SQLMaker> - Parent module
+
+=item L<DBIx::Class> - Duh
+
+=back
+
+=head1 AUTHOR
+
+Justin Wheeler C<< <jwheeler@datademons.com> >>
+
+=head1 CONTRIBUTORS
+
+David Jack Olrik C<< <djo@cpan.org> >>
+
+=head1 LICENSE
+
+This module is licensed under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package # Hide from PAUSE
+ DBIx::Class::SQLMaker::SQLite;
+
+use base qw( DBIx::Class::SQLMaker );
+
+#
+# SQLite does not understand SELECT ... FOR UPDATE
+# Disable it here
+sub _lock_select () { '' };
+
+1;
use warnings;
use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util ();
-use File::Spec;
-use Sub::Name ();
-use Module::Find();
+use DBIx::Class::Carp;
+use Try::Tiny;
+use Scalar::Util qw/weaken blessed/;
+use Sub::Name 'subname';
+use B 'svref_2object';
+use DBIx::Class::GlobalDestruction;
+use namespace::clean;
use base qw/DBIx::Class/;
__PACKAGE__->load_namespaces();
__PACKAGE__->load_namespaces(
- result_namespace => 'Res',
- resultset_namespace => 'RSet',
- default_resultset_class => '+MyDB::Othernamespace::RSet',
- );
+ result_namespace => 'Res',
+ resultset_namespace => 'RSet',
+ default_resultset_class => '+MyDB::Othernamespace::RSet',
+ );
+
+With no arguments, this method uses L<Module::Find> to load all of the
+Result and ResultSet classes under the namespace of the schema from
+which it is called. For example, C<My::Schema> will by default find
+and load Result classes named C<My::Schema::Result::*> and ResultSet
+classes named C<My::Schema::ResultSet::*>.
+
+ResultSet classes are associated with Result class of the same name.
+For example, C<My::Schema::Result::CD> will get the ResultSet class
+C<My::Schema::ResultSet::CD> if it is present.
+
+Both Result and ResultSet namespaces are configurable via the
+C<result_namespace> and C<resultset_namespace> options.
-With no arguments, this method uses L<Module::Find> to load all your
-Result classes from a sub-namespace F<Result> under your Schema class'
-namespace, i.e. with a Schema of I<MyDB::Schema> all files in
-I<MyDB::Schema::Result> are assumed to be Result classes.
+Another option, C<default_resultset_class> specifies a custom default
+ResultSet class for Result classes with no corresponding ResultSet.
-It also finds all ResultSet classes in the namespace F<ResultSet> and
-loads them into the appropriate Result classes using for you. The
-matching is done by assuming the package name of the ResultSet class
-is the same as that of the Result class.
+All of the namespace and classname options are by default relative to
+the schema classname. To specify a fully-qualified name, prefix it
+with a literal C<+>. For example, C<+Other::NameSpace::Result>.
+
+=head3 Warnings
You will be warned if ResultSet classes are discovered for which there
are no matching Result classes like this:
If a Result class is found to already have a ResultSet class set using
L</resultset_class> to some other class, you will be warned like this:
- We found ResultSet class '$rs_class' for '$result', but it seems
+ We found ResultSet class '$rs_class' for '$result', but it seems
that you had already set '$result' to use '$rs_set' instead
-Both of the sub-namespaces are configurable if you don't like the defaults,
-via the options C<result_namespace> and C<resultset_namespace>.
-
-If (and only if) you specify the option C<default_resultset_class>, any found
-Result classes for which we do not find a corresponding
-ResultSet class will have their C<resultset_class> set to
-C<default_resultset_class>.
-
-All of the namespace and classname options to this method are relative to
-the schema classname by default. To specify a fully-qualified name, prefix
-it with a literal C<+>.
-
-Examples:
+=head3 Examples
# load My::Schema::Result::CD, My::Schema::Result::Artist,
# My::Schema::ResultSet::CD, etc...
resultset_namespace => '+Another::Place::RSets',
);
-If you'd like to use multiple namespaces of each type, simply use an arrayref
-of namespaces for that option. In the case that the same result
-(or resultset) class exists in multiple namespaces, the latter entries in
-your list of namespaces will override earlier ones.
+To search multiple namespaces for either Result or ResultSet classes,
+use an arrayref of namespaces for that option. In the case that the
+same result (or resultset) class exists in multiple namespaces, later
+entries in the list of namespaces will override earlier ones.
My::Schema->load_namespaces(
# My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
my $proto = shift;
my $ns = shift || ref $proto || $proto;
+ require Module::Find;
my @mods = Module::Find::findallmod($ns);
# try to untaint module names. mods where this fails
# returns the result_source_instance for the passed class/object,
# or dies with an informative message (used by load_namespaces)
sub _ns_get_rsrc_instance {
- my $class = shift;
- my $rs = ref ($_[0]) || $_[0];
-
- if ($rs->can ('result_source_instance') ) {
- return $rs->result_source_instance;
- }
- else {
- $class->throw_exception (
- "Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?"
+ my $me = shift;
+ my $rs_class = ref ($_[0]) || $_[0];
+
+ return try {
+ $rs_class->result_source_instance
+ } catch {
+ $me->throw_exception (
+ "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_"
);
- }
+ };
}
sub load_namespaces {
my @to_register;
{
- no warnings 'redefine';
- local *Class::C3::reinitialize = sub { };
- use warnings 'redefine';
+ no warnings qw/redefine/;
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
# ensure classes are loaded and attached in inheritance order
- $class->ensure_class_loaded($_) foreach(values %results);
+ for my $res (values %results) {
+ $class->ensure_class_loaded($res);
+ }
my %inh_idx;
my @subclass_last = sort {
}
elsif($rs_class ||= $default_resultset_class) {
$class->ensure_class_loaded($rs_class);
+ if(!$rs_class->isa("DBIx::Class::ResultSet")) {
+ carp "load_namespaces found ResultSet class $rs_class that does not subclass DBIx::Class::ResultSet";
+ }
+
$class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class);
}
. 'corresponding Result class';
}
- Class::C3->reinitialize;
+ Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
+
$class->register_class(@$_) for (@to_register);
return;
If any classes found do not appear to be Result class files, you will
get the following warning:
- Failed to load $comp_class. Can't find source_name method. Is
+ Failed to load $comp_class. Can't find source_name method. Is
$comp_class really a full DBIC result class? Fix it, move it elsewhere,
or make your load_classes call more specific.
my @to_register;
{
no warnings qw/redefine/;
- local *Class::C3::reinitialize = sub { };
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
+
foreach my $prefix (keys %comps_for) {
foreach my $comp (@{$comps_for{$prefix}||[]}) {
my $comp_class = "${prefix}::${comp}";
}
}
}
- Class::C3->reinitialize;
+ Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
foreach my $to (@to_register) {
$class->register_class(@$to);
- # if $class->can('result_source_instance');
}
}
=back
-If C<exception_action> is set for this class/object, L</throw_exception>
-will prefer to call this code reference with the exception as an argument,
-rather than L<DBIx::Class::Exception/throw>.
+When L</throw_exception> is invoked and L</exception_action> is set to a code
+reference, this reference will be called instead of
+L<DBIx::Class::Exception/throw>, with the exception message passed as the only
+argument.
-Your subroutine should probably just wrap the error in the exception
-object/class of your choosing and rethrow. If, against all sage advice,
-you'd like your C<exception_action> to suppress a particular exception
-completely, simply have it return true.
+Your custom throw code B<must> rethrow the exception, as L</throw_exception> is
+an integral part of DBIC's internal execution control flow.
Example:
my $schema_obj = My::Schema->connect( .... );
$schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
- # suppress all exceptions, like a moron:
- $schema_obj->exception_action(sub { 1 });
-
=head2 stacktrace
=over 4
=back
-An optional sub which you can declare in your own Schema class that will get
+An optional sub which you can declare in your own Schema class that will get
passed the L<SQL::Translator::Schema> object when you deploy the schema via
L</create_ddl_dir> or L</deploy>.
-For an example of what you can do with this, see
+For an example of what you can do with this, see
L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
=cut
sub source {
- my ($self, $moniker) = @_;
+ my $self = shift;
+
+ $self->throw_exception("source() expects a source name")
+ unless @_;
+
+ my $moniker = shift;
+
my $sreg = $self->source_registrations;
return $sreg->{$moniker} if exists $sreg->{$moniker};
=head2 txn_scope_guard
-Runs C<txn_scope_guard> on the schema's storage. See
+Runs C<txn_scope_guard> on the schema's storage. See
L<DBIx::Class::Storage/txn_scope_guard>.
=cut
Begins a transaction (does nothing if AutoCommit is off). Equivalent to
calling $schema->storage->txn_begin. See
-L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
+L<DBIx::Class::Storage/"txn_begin"> for more information.
=cut
=head2 txn_commit
Commits the current transaction. Equivalent to calling
-$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+$schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
for more information.
=cut
Rolls back the current transaction. Equivalent to calling
$schema->storage->txn_rollback. See
-L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
+L<DBIx::Class::Storage/"txn_rollback"> for more information.
=cut
Pass this method a resultsource name, and an arrayref of
arrayrefs. The arrayrefs should contain a list of column names,
-followed by one or many sets of matching data for the given columns.
+followed by one or many sets of matching data for the given columns.
In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
to insert the data, as this is a fast method. However, insert_bulk currently
...
]);
-Since wantarray context is basically the same as looping over $rs->create(...)
+Since wantarray context is basically the same as looping over $rs->create(...)
you won't see any performance benefits and in this case the method is more for
convenience. Void context sends the column information directly to storage
-using <DBI>s bulk insert method. So the performance will be much better for
+using <DBI>s bulk insert method. So the performance will be much better for
storages that support this method.
-Because of this difference in the way void context inserts rows into your
+Because of this difference in the way void context inserts rows into your
database you need to note how this will effect any loaded components that
-override or augment insert. For example if you are using a component such
-as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
+override or augment insert. For example if you are using a component such
+as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
wantarray context if you want the PKs automatically created.
=cut
$rs->populate($data);
}
} else {
- $self->throw_exception("$name is not a resultset");
+ $self->throw_exception("$name is not a resultset");
}
}
my ($self, @info) = @_;
return $self if !@info && $self->storage;
- my ($storage_class, $args) = ref $self->storage_type ?
+ my ($storage_class, $args) = ref $self->storage_type ?
($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
$storage_class = 'DBIx::Class::Storage'.$storage_class
if $storage_class =~ m/^::/;
- eval { $self->ensure_class_loaded ($storage_class) };
- $self->throw_exception(
- "No arguments to load_classes and couldn't load ${storage_class} ($@)"
- ) if $@;
+ try {
+ $self->ensure_class_loaded ($storage_class);
+ }
+ catch {
+ $self->throw_exception(
+ "Unable to load storage class ${storage_class}: $_"
+ );
+ };
my $storage = $storage_class->new($self=>$args);
$storage->connect_info(\@info);
$self->storage($storage);
sub compose_namespace {
my ($self, $target, $base) = @_;
+
my $schema = $self->clone;
+
+ $schema->source_registrations({});
+
+ # the original class-mappings must remain - otherwise
+ # reverse_relationship_info will not work
+ #$schema->class_mappings({});
+
{
no warnings qw/redefine/;
-# local *Class::C3::reinitialize = sub { };
- foreach my $moniker ($schema->sources) {
- my $source = $schema->source($moniker);
+ local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+ use warnings qw/redefine/;
+
+ no strict qw/refs/;
+ foreach my $moniker ($self->sources) {
+ my $orig_source = $self->source($moniker);
+
my $target_class = "${target}::${moniker}";
- $self->inject_base(
- $target_class => $source->result_class, ($base ? $base : ())
+ $self->inject_base($target_class, $orig_source->result_class, ($base || ()) );
+
+ # register_source examines result_class, and then returns us a clone
+ my $new_source = $schema->register_source($moniker, bless
+ { %$orig_source, result_class => $target_class },
+ ref $orig_source,
);
- $source->result_class($target_class);
- $target_class->result_source_instance($source)
- if $target_class->can('result_source_instance');
- $schema->register_source($moniker, $source);
+
+ if ($target_class->can('result_source_instance')) {
+ # give the class a schema-less source copy
+ $target_class->result_source_instance( bless
+ { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} },
+ ref $new_source,
+ );
+ }
}
- }
-# Class::C3->reinitialize();
- {
- no strict 'refs';
- no warnings 'redefine';
+
foreach my $meth (qw/class source resultset/) {
- *{"${target}::${meth}"} = Sub::Name::subname "${target}::${meth}" =>
+ no warnings 'redefine';
+ *{"${target}::${meth}"} = subname "${target}::${meth}" =>
sub { shift->schema->$meth(@_) };
}
}
+
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
return $schema;
}
=head2 svp_begin
-Creates a new savepoint (does nothing outside a transaction).
+Creates a new savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_begin. See
-L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
+L<DBIx::Class::Storage/"svp_begin"> for more information.
=cut
=head2 svp_release
-Releases a savepoint (does nothing outside a transaction).
+Releases a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_release. See
-L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
+L<DBIx::Class::Storage/"svp_release"> for more information.
=cut
=head2 svp_rollback
-Rollback to a savepoint (does nothing outside a transaction).
+Rollback to a savepoint (does nothing outside a transaction).
Equivalent to calling $schema->storage->svp_rollback. See
-L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
+L<DBIx::Class::Storage/"svp_rollback"> for more information.
=cut
=over 4
+=item Arguments: %attrs?
+
=item Return Value: $new_schema
=back
Clones the schema and its associated result_source objects and returns the
-copy.
+copy. The resulting copy will have the same attributes as the source schema,
+except for those attributes explicitly overriden by the provided C<%attrs>.
=cut
sub clone {
- my ($self) = @_;
- my $clone = { (ref $self ? %$self : ()) };
+ my $self = shift;
+
+ my $clone = {
+ (ref $self ? %$self : ()),
+ (@_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_),
+ };
bless $clone, (ref $self || $self);
- $clone->class_mappings({ %{$clone->class_mappings} });
- $clone->source_registrations({ %{$clone->source_registrations} });
- foreach my $moniker ($self->sources) {
- my $source = $self->source($moniker);
+ $clone->$_(undef) for qw/class_mappings source_registrations storage/;
+
+ $clone->_copy_state_from($self);
+
+ return $clone;
+}
+
+# Needed in Schema::Loader - if you refactor, please make a compatibility shim
+# -- Caelum
+sub _copy_state_from {
+ my ($self, $from) = @_;
+
+ $self->class_mappings({ %{$from->class_mappings} });
+ $self->source_registrations({ %{$from->source_registrations} });
+
+ foreach my $moniker ($from->sources) {
+ my $source = $from->source($moniker);
my $new = $source->new($source);
# we use extra here as we want to leave the class_mappings as they are
# but overwrite the source_registrations entry with the new source
- $clone->register_extra_source($moniker => $new);
+ $self->register_extra_source($moniker => $new);
+ }
+
+ if ($from->storage) {
+ $self->storage($from->storage);
+ $self->storage->set_schema($self);
}
- $clone->storage->set_schema($clone) if $clone->storage;
- return $clone;
}
=head2 throw_exception
=back
-Throws an exception. Defaults to using L<Carp::Clan> to report errors from
-user's perspective. See L</exception_action> for details on overriding
+Throws an exception. Obeys the exemption rules of L<DBIx::Class::Carp> to report
+errors from outer-user's perspective. See L</exception_action> for details on overriding
this method's behavior. If L</stacktrace> is turned on, C<throw_exception>'s
default behavior will provide a detailed stack trace.
=cut
+my $false_exception_action_warned;
sub throw_exception {
my $self = shift;
- DBIx::Class::Exception->throw($_[0], $self->stacktrace)
- if !$self->exception_action || !$self->exception_action->(@_);
+ if (my $act = $self->exception_action) {
+ if ($act->(@_)) {
+ DBIx::Class::Exception->throw(
+ "Invocation of the exception_action handler installed on $self did *not*"
+ .' result in an exception. DBIx::Class is unable to function without a reliable'
+ .' exception mechanism, ensure that exception_action does not hide exceptions'
+ ." (original error: $_[0])"
+ );
+ }
+ elsif(! $false_exception_action_warned++) {
+ carp (
+ "The exception_action handler installed on $self returned false instead"
+ .' of throwing an exception. This behavior has been deprecated, adjust your'
+ .' handler to always rethrow the supplied error.'
+ );
+ }
+ }
+
+ DBIx::Class::Exception->throw($_[0], $self->stacktrace);
}
=head2 deploy
created. For quoting purposes supply C<quote_table_names> and
C<quote_field_names>.
-Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
-ref or an array ref, containing a list of source to deploy. If present, then
+Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
+ref or an array ref, containing a list of source to deploy. If present, then
only the sources listed will get deployed. Furthermore, you can use the
C<add_fk_index> parser parameter to prevent the parser from creating an index for each
FK.
=back
-A convenient shortcut to
+A convenient shortcut to
C<< $self->storage->create_ddl_dir($self, @args) >>.
Creates an SQL file based on the Schema, for each of the specified
my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
In recent versions variables $dir and $version were reversed in order to
- bring the signature in line with other Schema/Storage methods. If you
+ bring the signature in line with other Schema/Storage methods. If you
really need to maintain backward compatibility, you can do the following
in any overriding methods:
sub ddl_filename {
my ($self, $type, $version, $dir, $preversion) = @_;
- my $filename = ref($self);
- $filename =~ s/::/-/g;
- $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
- $filename =~ s/$version/$preversion-$version/ if($preversion);
+ require File::Spec;
+
+ $version = "$preversion-$version" if $preversion;
+
+ my $class = blessed($self) || $self;
+ $class =~ s/::/-/g;
- return $filename;
+ return File::Spec->catfile($dir, "$class-$version-$type.sql");
}
=head2 thaw
-Provided as the recommended way of thawing schema objects. You can call
+Provided as the recommended way of thawing schema objects. You can call
C<Storable::thaw> directly if you wish, but the thawed objects will not have a
reference to any schema, so are rather useless.
sub thaw {
my ($self, $obj) = @_;
local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ require Storable;
return Storable::thaw($obj);
}
=head2 freeze
-This doesn't actually do anything more than call L<Storable/freeze>, it is just
+This doesn't actually do anything more than call L<Storable/nfreeze>, it is just
provided here for symmetry.
=cut
sub freeze {
- return Storable::freeze($_[1]);
+ require Storable;
+ return Storable::nfreeze($_[1]);
}
=head2 dclone
sub dclone {
my ($self, $obj) = @_;
local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+ require Storable;
return Storable::dclone($obj);
}
=back
-This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
+This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
You will only need this method if you have your Result classes in
files which are not named after the packages (or all in the same
=cut
-sub register_source {
- my $self = shift;
-
- $self->_register_source(@_);
-}
+sub register_source { shift->_register_source(@_) }
=head2 unregister_source
=cut
-sub unregister_source {
- my $self = shift;
-
- $self->_unregister_source(@_);
-}
+sub unregister_source { shift->_unregister_source(@_) }
=head2 register_extra_source
=back
-As L</register_source> but should be used if the result class already
+As L</register_source> but should be used if the result class already
has a source and you want to register an extra one.
=cut
-sub register_extra_source {
- my $self = shift;
-
- $self->_register_source(@_, { extra => 1 });
-}
+sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
sub _register_source {
my ($self, $moniker, $source, $params) = @_;
- my $orig_source = $source;
-
$source = $source->new({ %$source, source_name => $moniker });
- $source->schema($self);
- Scalar::Util::weaken($source->{schema}) if ref($self);
- my $rs_class = $source->result_class;
+ $source->schema($self);
+ weaken $source->{schema} if ref($self);
my %reg = %{$self->source_registrations};
$reg{$moniker} = $source;
$self->source_registrations(\%reg);
- return if ($params->{extra});
- return unless defined($rs_class) && $rs_class->can('result_source_instance');
-
- my %map = %{$self->class_mappings};
- if (
- exists $map{$rs_class}
- and
- $map{$rs_class} ne $moniker
- and
- $rs_class->result_source_instance ne $orig_source
- ) {
- carp "$rs_class already has a source, use register_extra_source for additional sources";
+ return $source if $params->{extra};
+
+ my $rs_class = $source->result_class;
+ if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) {
+ my %map = %{$self->class_mappings};
+ if (
+ exists $map{$rs_class}
+ and
+ $map{$rs_class} ne $moniker
+ and
+ $rsrc ne $_[2] # orig_source
+ ) {
+ carp
+ "$rs_class already had a registered source which was replaced by this call. "
+ . 'Perhaps you wanted register_extra_source(), though it is more likely you did '
+ . 'something wrong.'
+ ;
+ }
+
+ $map{$rs_class} = $moniker;
+ $self->class_mappings(\%map);
+ }
+
+ return $source;
+}
+
+my $global_phase_destroy;
+sub DESTROY {
+ return if $global_phase_destroy ||= in_global_destruction;
+
+ my $self = shift;
+ my $srcs = $self->source_registrations;
+
+ for my $moniker (keys %$srcs) {
+ # find first source that is not about to be GCed (someone other than $self
+ # holds a reference to it) and reattach to it, weakening our own link
+ #
+ # during global destruction (if we have not yet bailed out) this should throw
+ # which will serve as a signal to not try doing anything else
+ # however beware - on older perls the exception seems randomly untrappable
+ # due to some weird race condition during thread joining :(((
+ if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) {
+ local $@;
+ eval {
+ $srcs->{$moniker}->schema($self);
+ weaken $srcs->{$moniker};
+ 1;
+ } or do {
+ $global_phase_destroy = 1;
+ };
+
+ last;
+ }
}
- $map{$rs_class} = $moniker;
- $self->class_mappings(\%map);
}
sub _unregister_source {
my ($self, $moniker) = @_;
- my %reg = %{$self->source_registrations};
+ my %reg = %{$self->source_registrations};
my $source = delete $reg{$moniker};
$self->source_registrations(\%reg);
=cut
-{
- my $warn;
-
- sub compose_connection {
- my ($self, $target, @info) = @_;
+sub compose_connection {
+ my ($self, $target, @info) = @_;
- carp "compose_connection deprecated as of 0.08000"
- unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
+ carp_once "compose_connection deprecated as of 0.08000"
+ unless $INC{"DBIx/Class/CDBICompat.pm"};
- my $base = 'DBIx::Class::ResultSetProxy';
- eval "require ${base};";
+ my $base = 'DBIx::Class::ResultSetProxy';
+ try {
+ eval "require ${base};"
+ }
+ catch {
$self->throw_exception
- ("No arguments to load_classes and couldn't load ${base} ($@)")
- if $@;
-
- if ($self eq $target) {
- # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
- foreach my $moniker ($self->sources) {
- my $source = $self->source($moniker);
- my $class = $source->result_class;
- $self->inject_base($class, $base);
- $class->mk_classdata(resultset_instance => $source->resultset);
- $class->mk_classdata(class_resolver => $self);
- }
- $self->connection(@info);
- return $self;
- }
+ ("No arguments to load_classes and couldn't load ${base} ($_)")
+ };
- my $schema = $self->compose_namespace($target, $base);
- {
- no strict 'refs';
- my $name = join '::', $target, 'schema';
- *$name = Sub::Name::subname $name, sub { $schema };
- }
-
- $schema->connection(@info);
- foreach my $moniker ($schema->sources) {
- my $source = $schema->source($moniker);
+ if ($self eq $target) {
+ # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
+ foreach my $moniker ($self->sources) {
+ my $source = $self->source($moniker);
my $class = $source->result_class;
- #warn "$moniker $class $source ".$source->storage;
- $class->mk_classdata(result_source_instance => $source);
+ $self->inject_base($class, $base);
$class->mk_classdata(resultset_instance => $source->resultset);
- $class->mk_classdata(class_resolver => $schema);
+ $class->mk_classdata(class_resolver => $self);
}
- return $schema;
+ $self->connection(@info);
+ return $self;
+ }
+
+ my $schema = $self->compose_namespace($target, $base);
+ {
+ no strict 'refs';
+ my $name = join '::', $target, 'schema';
+ *$name = subname $name, sub { $schema };
}
+
+ $schema->connection(@info);
+ foreach my $moniker ($schema->sources) {
+ my $source = $schema->source($moniker);
+ my $class = $source->result_class;
+ #warn "$moniker $class $source ".$source->storage;
+ $class->mk_classdata(result_source_instance => $source);
+ $class->mk_classdata(resultset_instance => $source->resultset);
+ $class->mk_classdata(class_resolver => $schema);
+ }
+ return $schema;
}
1;
schema version using a diff from your I<upgrade_directory>. If a suitable diff is
not found then no upgrade is possible.
-NB: At the moment, only SQLite and MySQL are supported. This is due to
-spotty behaviour in the SQL::Translator producers, please help us by
-enhancing them. Ask on the mailing list or IRC channel for details (community details
-in L<DBIx::Class>).
+=head1 SEE ALSO
+
+L<DBIx::Class::DeploymentHandler> is a much more powerful alternative to this
+module. Examples of things it can do that this module cannot do include
+
+=over
+
+=item *
+
+Downgrades in addition to upgrades
+
+=item *
+
+Multiple sql files files per upgrade/downgrade/install
+
+=item *
+
+Perl scripts allowed for upgrade/downgrade/install
+
+=item *
+
+Just one set of files needed for upgrade, unlike this module where one might
+need to generate C<factorial(scalar @versions)>
+
+=back
=head1 GETTING STARTED
use warnings;
use base 'DBIx::Class::Schema';
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
use Time::HiRes qw/gettimeofday/;
+use Try::Tiny;
+use namespace::clean;
__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');
# must be called on a fresh database
if ($self->get_db_version()) {
- carp 'Install not possible as versions table already exists in database';
+ $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
}
# default to current version if none passed
# db and schema at same version. do nothing
if ( $db_version eq $self->schema_version ) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
# db and schema at same version. do nothing
if ($db_version eq $target_version) {
- carp "Upgrade not necessary\n";
+ carp 'Upgrade not necessary';
return;
}
$self->create_upgrade_path({ upgrade_file => $upgrade_file });
unless (-f $upgrade_file) {
- carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+ carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
return;
}
my ($self, $rs) = @_;
my $vtable = $self->{vschema}->resultset('Table');
- my $version = eval {
+ my $version = try {
$vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
->get_column ('version')
->next;
sub connection {
my $self = shift;
$self->next::method(@_);
- $self->_on_connect($_[3]);
+ $self->_on_connect();
return $self;
}
sub _on_connect
{
- my ($self, $args) = @_;
+ my ($self) = @_;
- $args = {} unless $args;
+ my $conn_info = $self->storage->connect_info;
+ $self->{vschema} = DBIx::Class::Version->connect(@$conn_info);
+ my $conn_attrs = $self->{vschema}->storage->_dbic_connect_attributes || {};
- $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
my $vtable = $self->{vschema}->resultset('Table');
# useful when connecting from scripts etc
- return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
+ return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version}));
# check for legacy versions table and move to new if exists
- my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
unless ($self->_source_exists($vtable)) {
- my $vtable_compat = $vschema_compat->resultset('TableCompat');
+ my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat');
if ($self->_source_exists($vtable_compat)) {
$self->{vschema}->deploy;
map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
- $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
+ $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
}
}
if($pversion eq $self->schema_version)
{
-# carp "This version is already installed\n";
+ #carp "This version is already installed";
return 1;
}
if(!$pversion)
{
- carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+ carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
return 1;
}
carp "Versions out of sync. This is " . $self->schema_version .
- ", your database contains version $pversion, please call upgrade on your Schema.\n";
+ ", your database contains version $pversion, please call upgrade on your Schema.";
}
# is this just a waste of time? if not then merge with DBI.pm
print $file $diff;
close($file);
- carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
+ carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.";
}
# This is necessary since there are legitimate cases when upgrades can happen
# back to back within the same second. This breaks things since we relay on the
# ability to sort by the 'installed' value. The logical choice of an autoinc
- # is not possible, as it will break multiple legacy installations. Also it is
+ # is not possible, as it will break multiple legacy installations. Also it is
# not possible to format the string sanely, as the column is a varchar(20).
# The 'v' character is added to the front of the string, so that any version
# formatted by this new function will sort _after_ any existing 200... strings.
my @tm = gettimeofday();
my @dt = gmtime ($tm[0]);
- my $o = $vtable->create({
+ my $o = $vtable->create({
version => $version,
installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
$dt[5] + 1900,
$dt[2],
$dt[1],
$dt[0],
- $tm[1] / 1000, # convert to millisecs, format as up/down rounded int above
+ int($tm[1] / 1000), # convert to millisecs
),
});
}
my @data = split /\n/, join '', <$fh>;
close $fh;
- @data = grep {
- $_ &&
- !/^--/ &&
- !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m
- } split /;/,
- join '', @data;
+ @data = split /;/,
+ join '',
+ grep { $_ &&
+ !/^--/ &&
+ !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi }
+ @data;
return \@data;
}
{
my ($self, $rs) = @_;
- my $c = eval {
- $rs->search({ 1, 0 })->count;
+ return try {
+ $rs->search(\'1=0')->cursor->next;
+ 1;
+ } catch {
+ 0;
};
- return 0 if $@ || !defined $c;
-
- return 1;
}
1;
package DBIx::Class::Serialize::Storable;
use strict;
use warnings;
-use Storable;
+
+use Storable();
+use DBIx::Class::Carp;
+
+carp 'The Serialize::Storable component is now *DEPRECATED*. It has not '
+ .'been providing any useful functionality for quite a while, and in fact '
+ .'destroys prefetched results in its current implementation. Do not use!';
+
sub STORABLE_freeze {
my ($self, $cloning) = @_;
my $to_serialize = { %$self };
- # The source is either derived from _source_handle or is
- # reattached in the thaw handler below
- delete $to_serialize->{result_source};
-
# Dynamic values, easy to recalculate
delete $to_serialize->{$_} for qw/related_resultsets _inflated_column/;
- return (Storable::freeze($to_serialize));
+ return (Storable::nfreeze($to_serialize));
}
sub STORABLE_thaw {
my ($self, $cloning, $serialized) = @_;
%$self = %{ Storable::thaw($serialized) };
-
- # if the handle went missing somehow, reattach
- $self->result_source($self->result_source_instance)
- if !$self->_source_handle && $self->can('result_source_instance');
}
1;
=head1 NAME
- DBIx::Class::Serialize::Storable - hooks for Storable freeze/thaw
+ DBIx::Class::Serialize::Storable - hooks for Storable nfreeze/thaw
+
+=head1 DEPRECATION NOTE
+
+This component is now B<DEPRECATED>. It has not been providing any useful
+functionality for quite a while, and in fact destroys prefetched results
+in its current implementation. Do not use!
=head1 SYNOPSIS
use base qw/DBIx::Class/;
use mro 'c3';
-use DBIx::Class::Exception;
-use Scalar::Util();
-use IO::File;
+{
+ package # Hide from PAUSE
+ DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
+ use base 'DBIx::Class::Exception';
+}
+
+use DBIx::Class::Carp;
+use DBIx::Class::Storage::BlockRunner;
+use Scalar::Util qw/blessed weaken/;
use DBIx::Class::Storage::TxnScopeGuard;
+use Try::Tiny;
+use namespace::clean;
-__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
-__PACKAGE__->mk_group_accessors('inherited' => 'cursor_class');
+__PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
+__PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
__PACKAGE__->cursor_class('DBIx::Class::Cursor');
sub cursor { shift->cursor_class(@_); }
-package # Hide from PAUSE
- DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
-
-use overload '"' => sub {
- 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION'
-};
-
-sub new {
- my $class = shift;
- my $self = {};
- return bless $self, $class;
-}
-
-package DBIx::Class::Storage;
-
=head1 NAME
DBIx::Class::Storage - Generic Storage Handler
$self = ref $self if ref $self;
- my $new = {};
- bless $new, $self;
+ my $new = bless( {
+ transaction_depth => 0,
+ savepoints => [],
+ }, $self);
$new->set_schema($schema);
- $new->debugobj(new DBIx::Class::Storage::Statistics());
-
- #my $fh;
-
- my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
- || $ENV{DBIC_TRACE};
-
- $new->debug(1) if $debug_env;
+ $new->debug(1)
+ if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};
$new;
}
sub set_schema {
my ($self, $schema) = @_;
$self->schema($schema);
- Scalar::Util::weaken($self->{schema}) if ref $self->{schema};
+ weaken $self->{schema} if ref $self->{schema};
}
=head2 connected
sub throw_exception {
my $self = shift;
- if ($self->schema) {
+ if (ref $self and $self->schema) {
$self->schema->throw_exception(@_);
}
else {
};
my $rs;
- eval {
+ try {
$rs = $schema->txn_do($coderef);
- };
-
- if ($@) { # Transaction failed
- die "something terrible has happened!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+ } catch {
+ my $error = shift;
+ # Transaction failed
+ die "something terrible has happened!"
+ if ($error =~ /Rollback failed/); # Rollback failed
deal_with_failed_transaction();
- }
+ };
In a nested transaction (calling txn_do() from within a txn_do() coderef) only
the outermost transaction will issue a L</txn_commit>, and txn_do() can be
=cut
sub txn_do {
- my ($self, $coderef, @args) = @_;
-
- ref $coderef eq 'CODE' or $self->throw_exception
- ('$coderef must be a CODE reference');
-
- my (@return_values, $return_value);
-
- $self->txn_begin; # If this throws an exception, no rollback is needed
-
- my $wantarray = wantarray; # Need to save this since the context
- # inside the eval{} block is independent
- # of the context that called txn_do()
- eval {
-
- # Need to differentiate between scalar/list context to allow for
- # returning a list in scalar context to get the size of the list
- if ($wantarray) {
- # list context
- @return_values = $coderef->(@args);
- } elsif (defined $wantarray) {
- # scalar context
- $return_value = $coderef->(@args);
- } else {
- # void context
- $coderef->(@args);
- }
- $self->txn_commit;
- };
-
- if ($@) {
- my $error = $@;
-
- eval {
- $self->txn_rollback;
- };
-
- if ($@) {
- my $rollback_error = $@;
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $self->throw_exception($error) # propagate nested rollback
- if $rollback_error =~ /$exception_class/;
-
- $self->throw_exception(
- "Transaction aborted: $error. Rollback failed: ${rollback_error}"
- );
- } else {
- $self->throw_exception($error); # txn failed but rollback succeeded
- }
- }
-
- return $wantarray ? @return_values : $return_value;
+ my $self = shift;
+ my $coderef = shift;
+
+ DBIx::Class::Storage::BlockRunner->new(
+ storage => $self,
+ run_code => $coderef,
+ run_args => \@_, # take a ref instead of a copy, to preserve coderef @_ aliasing semantics
+ wrap_txn => 1,
+ retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
+ )->run;
}
=head2 txn_begin
=cut
-sub txn_begin { die "Virtual method!" }
+sub txn_begin {
+ my $self = shift;
+
+ if($self->transaction_depth == 0) {
+ $self->debugobj->txn_begin()
+ if $self->debug;
+ $self->_exec_txn_begin;
+ }
+ elsif ($self->auto_savepoint) {
+ $self->svp_begin;
+ }
+ $self->{transaction_depth}++;
+
+}
=head2 txn_commit
=cut
-sub txn_commit { die "Virtual method!" }
+sub txn_commit {
+ my $self = shift;
+
+ if ($self->transaction_depth == 1) {
+ $self->debugobj->txn_commit() if $self->debug;
+ $self->_exec_txn_commit;
+ $self->{transaction_depth}--;
+ }
+ elsif($self->transaction_depth > 1) {
+ $self->{transaction_depth}--;
+ $self->svp_release if $self->auto_savepoint;
+ }
+ else {
+ $self->throw_exception( 'Refusing to commit without a started transaction' );
+ }
+}
=head2 txn_rollback
=cut
-sub txn_rollback { die "Virtual method!" }
+sub txn_rollback {
+ my $self = shift;
+
+ if ($self->transaction_depth == 1) {
+ $self->debugobj->txn_rollback() if $self->debug;
+ $self->_exec_txn_rollback;
+ $self->{transaction_depth}--;
+ }
+ elsif ($self->transaction_depth > 1) {
+ $self->{transaction_depth}--;
+
+ if ($self->auto_savepoint) {
+ $self->svp_rollback;
+ $self->svp_release;
+ }
+ else {
+ DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
+ "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
+ );
+ }
+ }
+ else {
+ $self->throw_exception( 'Refusing to roll back without a started transaction' );
+ }
+}
=head2 svp_begin
=cut
-sub svp_begin { die "Virtual method!" }
+sub svp_begin {
+ my ($self, $name) = @_;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ unless $self->transaction_depth;
+
+ my $exec = $self->can('_exec_svp_begin')
+ or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
+
+ $name = $self->_svp_generate_name
+ unless defined $name;
+
+ push @{ $self->{savepoints} }, $name;
+
+ $self->debugobj->svp_begin($name) if $self->debug;
+
+ $exec->($self, $name);
+}
+
+sub _svp_generate_name {
+ my ($self) = @_;
+ return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
+}
+
=head2 svp_release
=cut
-sub svp_release { die "Virtual method!" }
+sub svp_release {
+ my ($self, $name) = @_;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ unless $self->transaction_depth;
+
+ my $exec = $self->can('_exec_svp_release')
+ or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
+
+ if (defined $name) {
+ my @stack = @{ $self->savepoints };
+ my $svp;
+
+ do { $svp = pop @stack } until $svp eq $name;
+
+ $self->throw_exception ("Savepoint '$name' does not exist")
+ unless $svp;
+
+ $self->savepoints(\@stack); # put back what's left
+ }
+ else {
+ $name = pop @{ $self->savepoints }
+ or $self->throw_exception('No savepoints to release');;
+ }
+
+ $self->debugobj->svp_release($name) if $self->debug;
+
+ $exec->($self, $name);
+}
=head2 svp_rollback
=cut
-sub svp_rollback { die "Virtual method!" }
+sub svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->throw_exception ("You can't use savepoints outside a transaction")
+ unless $self->transaction_depth;
-=for comment
+ my $exec = $self->can('_exec_svp_rollback')
+ or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
+
+ if (defined $name) {
+ my @stack = @{ $self->savepoints };
+ my $svp;
+
+ # a rollback doesn't remove the named savepoint,
+ # only everything after it
+ while (@stack and $stack[-1] ne $name) {
+ pop @stack
+ };
+
+ $self->throw_exception ("Savepoint '$name' does not exist")
+ unless @stack;
+
+ $self->savepoints(\@stack); # put back what's left
+ }
+ else {
+ $name = $self->savepoints->[-1]
+ or $self->throw_exception('No savepoints to rollback');;
+ }
+
+ $self->debugobj->svp_rollback($name) if $self->debug;
+
+ $exec->($self, $name);
+}
=head2 txn_scope_guard
=head2 sql_maker
Returns a C<sql_maker> object - normally an object of class
-C<DBIx::Class::SQLAHacks>.
+C<DBIx::Class::SQLMaker>.
=cut
=head2 debug
-Causes trace information to be emitted on the C<debugobj> object.
-(or C<STDERR> if C<debugobj> has not specifically been set).
+Causes trace information to be emitted on the L</debugobj> object.
+(or C<STDERR> if L</debugobj> has not specifically been set).
This is the equivalent to setting L</DBIC_TRACE> in your
shell environment.
method of using a coderef as a callback. See the aforementioned Statistics
class for more information.
+=cut
+
+sub debugobj {
+ my $self = shift;
+
+ if (@_) {
+ return $self->{debugobj} = $_[0];
+ }
+
+ $self->{debugobj} ||= do {
+ if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
+ require DBIx::Class::Storage::Debug::PrettyPrint;
+ if ($profile =~ /^\.?\//) {
+ require Config::Any;
+
+ my $cfg = try {
+ Config::Any->load_files({ files => [$profile], use_ext => 1 });
+ } catch {
+ # sanitize the error message a bit
+ $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
+ $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
+ };
+
+ DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]});
+ }
+ else {
+ DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile });
+ }
+ }
+ else {
+ require DBIx::Class::Storage::Statistics;
+ DBIx::Class::Storage::Statistics->new
+ }
+ };
+}
+
=head2 debugcb
Sets a callback to be executed each time a statement is run; takes a sub
reference. Callback is executed as $sub->($op, $info) where $op is
SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
-See L<debugobj> for a better way.
+See L</debugobj> for a better way.
=cut
=head2 DBIC_TRACE
If C<DBIC_TRACE> is set then trace information
-is produced (as when the L<debug> method is set).
+is produced (as when the L</debug> method is set).
If the value is of the form C<1=/path/name> then the trace output is
written to the file C</path/name>.
This environment variable is checked when the storage object is first
-created (when you call connect on your schema). So, run-time changes
-to this environment variable will not take effect unless you also
+created (when you call connect on your schema). So, run-time changes
+to this environment variable will not take effect unless you also
re-connect on your schema.
+=head2 DBIC_TRACE_PROFILE
+
+If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
+will be used to format the output from C<DBIC_TRACE>. The value it
+is set to is the C<profile> that it will be used. If the value is a
+filename the file is read with L<Config::Any> and the results are
+used as the configuration for tracing. See L<SQL::Abstract::Tree/new>
+for what that structure should look like.
+
+
=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
Old name for DBIC_TRACE
--- /dev/null
+package # hide from pause until we figure it all out
+ DBIx::Class::Storage::BlockRunner;
+
+use Sub::Quote 'quote_sub';
+use DBIx::Class::Exception;
+use DBIx::Class::Carp;
+use Context::Preserve 'preserve_context';
+use Scalar::Util qw/weaken blessed/;
+use Try::Tiny;
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::BlockRunner - Try running a block of code until success with a configurable retry logic
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=cut
+
+has storage => (
+ is => 'ro',
+ required => 1,
+);
+
+has wrap_txn => (
+ is => 'ro',
+ required => 1,
+);
+
+# true - retry, false - rethrow, or you can throw your own (not catching)
+has retry_handler => (
+ is => 'ro',
+ required => 1,
+ isa => quote_sub( q|
+ (ref $_[0]) eq 'CODE'
+ or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
+ |),
+);
+
+has run_code => (
+ is => 'ro',
+ required => 1,
+ isa => quote_sub( q|
+ (ref $_[0]) eq 'CODE'
+ or DBIx::Class::Exception->throw('run_code must be a CODE reference')
+ |),
+);
+
+has run_args => (
+ is => 'ro',
+ isa => quote_sub( q|
+ (ref $_[0]) eq 'ARRAY'
+ or DBIx::Class::Exception->throw('run_args must be an ARRAY reference')
+ |),
+ default => quote_sub( '[]' ),
+);
+
+has retry_debug => (
+ is => 'rw',
+ default => quote_sub( '$ENV{DBIC_STORAGE_RETRY_DEBUG}' ),
+);
+
+has max_retried_count => (
+ is => 'ro',
+ default => quote_sub( '20' ),
+);
+
+has retried_count => (
+ is => 'ro',
+ init_arg => undef,
+ writer => '_set_retried_count',
+ clearer => '_reset_retried_count',
+ default => quote_sub(q{ 0 }),
+ lazy => 1,
+ trigger => quote_sub(q{
+ DBIx::Class::Exception->throw(sprintf (
+ 'Exceeded max_retried_count amount of %d, latest exception: %s',
+ $_[0]->max_retried_count, $_[0]->last_exception
+ )) if $_[0]->max_retried_count < ($_[1]||0);
+ }),
+);
+
+has exception_stack => (
+ is => 'ro',
+ init_arg => undef,
+ clearer => '_reset_exception_stack',
+ default => quote_sub(q{ [] }),
+ lazy => 1,
+);
+
+sub last_exception { shift->exception_stack->[-1] }
+
+sub run {
+ my $self = shift;
+
+ DBIx::Class::Exception->throw('run() takes no arguments') if @_;
+
+ $self->_reset_exception_stack;
+ $self->_reset_retried_count;
+ my $storage = $self->storage;
+
+ return $self->run_code->( @{$self->run_args} )
+ if (! $self->wrap_txn and $storage->{_in_do_block});
+
+ local $storage->{_in_do_block} = 1 unless $storage->{_in_do_block};
+
+ return $self->_run;
+}
+
+# this is the actual recursing worker
+sub _run {
+ # warnings here mean I did not anticipate some ueber-complex case
+ # fatal warnings are not warranted
+ no warnings;
+ use warnings;
+
+ my $self = shift;
+
+ # from this point on (defined $txn_init_depth) is an indicator for wrap_txn
+ # save a bit on method calls
+ my $txn_init_depth = $self->wrap_txn ? $self->storage->transaction_depth : undef;
+ my $txn_begin_ok;
+
+ my $run_err = '';
+
+ weaken (my $weakself = $self);
+
+ return preserve_context {
+ try {
+ if (defined $txn_init_depth) {
+ $weakself->storage->txn_begin;
+ $txn_begin_ok = 1;
+ }
+ $weakself->run_code->( @{$weakself->run_args} );
+ } catch {
+ $run_err = $_;
+ (); # important, affects @_ below
+ };
+ } replace => sub {
+ my @res = @_;
+
+ my $storage = $weakself->storage;
+ my $cur_depth = $storage->transaction_depth;
+
+ if (defined $txn_init_depth and $run_err eq '') {
+ my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
+
+ if ($delta_txn) {
+ # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
+ carp (sprintf
+ 'Unexpected reduction of transaction depth by %d after execution of '
+ . '%s, skipping txn_commit()',
+ $delta_txn,
+ $weakself->run_code,
+ ) unless $delta_txn == 1 and $cur_depth == 0;
+ }
+ else {
+ $run_err = eval { $storage->txn_commit; 1 } ? '' : $@;
+ }
+ }
+
+ # something above threw an error (could be the begin, the code or the commit)
+ if ($run_err ne '') {
+
+ # attempt a rollback if we did begin in the first place
+ if ($txn_begin_ok) {
+ # some DBDs go crazy if there is nothing to roll back on, perform a soft-check
+ my $rollback_exception = $storage->_seems_connected
+ ? (! eval { $storage->txn_rollback; 1 }) ? $@ : ''
+ : 'lost connection to storage'
+ ;
+
+ if ( $rollback_exception and (
+ ! defined blessed $rollback_exception
+ or
+ ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
+ ) ) {
+ $run_err = "Transaction aborted: $run_err. Rollback failed: $rollback_exception";
+ }
+ }
+
+ push @{ $weakself->exception_stack }, $run_err;
+
+ # init depth of > 0 ( > 1 with AC) implies nesting - no retry attempt queries
+ $storage->throw_exception($run_err) if (
+ (
+ defined $txn_init_depth
+ and
+ # FIXME - we assume that $storage->{_dbh_autocommit} is there if
+ # txn_init_depth is there, but this is a DBI-ism
+ $txn_init_depth > ( $storage->{_dbh_autocommit} ? 0 : 1 )
+ ) or ! $weakself->retry_handler->($weakself)
+ );
+
+ $weakself->_set_retried_count($weakself->retried_count + 1);
+
+ # we got that far - let's retry
+ carp( sprintf 'Retrying %s (run %d) after caught exception: %s',
+ $weakself->run_code,
+ $weakself->retried_count + 1,
+ $run_err,
+ ) if $weakself->retry_debug;
+
+ $storage->ensure_connected;
+ # if txn_depth is > 1 this means something was done to the
+ # original $dbh, otherwise we would not get past the preceeding if()
+ $storage->throw_exception(sprintf
+ 'Unexpected transaction depth of %d on freshly connected handle',
+ $storage->transaction_depth,
+ ) if (defined $txn_init_depth and $storage->transaction_depth);
+
+ return $weakself->_run;
+ }
+
+ return wantarray ? @res : $res[0];
+ };
+}
+
+=head1 AUTHORS
+
+see L<DBIx::Class>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-use DBI;
-use DBIx::Class::Storage::DBI::Cursor;
-use DBIx::Class::Storage::Statistics;
-use Scalar::Util();
-use List::Util();
-use Data::Dumper::Concise();
-use Sub::Name ();
-
-__PACKAGE__->mk_group_accessors('simple' =>
- qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
- _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
-);
+use DBIx::Class::Carp;
+use DBIx::Class::Exception;
+use Scalar::Util qw/refaddr weaken reftype blessed/;
+use List::Util qw/first/;
+use Sub::Name 'subname';
+use Context::Preserve 'preserve_context';
+use Try::Tiny;
+use overload ();
+use Data::Compare (); # no imports!!! guard against insane architecture
+use DBI::Const::GetInfoType (); # no import of retarded global hash
+use namespace::clean;
+
+# default cursor class, overridable in connect_info attributes
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+
+__PACKAGE__->mk_group_accessors('inherited' => qw/
+ sql_limit_dialect sql_quote_char sql_name_sep
+/);
+
+__PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class datetime_parser_type/);
+
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
+__PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default
+
+__PACKAGE__->sql_name_sep('.');
+
+__PACKAGE__->mk_group_accessors('simple' => qw/
+ _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
+ _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
+ _perform_autoinc_retrieval _autoinc_supplied_for_op
+/);
# the values for these accessors are picked out (and deleted) from
# the attribute hashref passed to connect_info
__PACKAGE__->mk_group_accessors('simple' => @storage_options);
-# default cursor class, overridable in connect_info attributes
-__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+# capability definitions, using a 2-tiered accessor system
+# The rationale is:
+#
+# A driver/user may define _use_X, which blindly without any checks says:
+# "(do not) use this capability", (use_dbms_capability is an "inherited"
+# type accessor)
+#
+# If _use_X is undef, _supports_X is then queried. This is a "simple" style
+# accessor, which in turn calls _determine_supports_X, and stores the return
+# in a special slot on the storage object, which is wiped every time a $dbh
+# reconnection takes place (it is not guaranteed that upon reconnection we
+# will get the same rdbms version). _determine_supports_X does not need to
+# exist on a driver, as we ->can for it before calling.
-__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
+my @capabilities = (qw/
+ insert_returning
+ insert_returning_bound
+ multicolumn_in
+
+ placeholders
+ typeless_placeholders
+
+ join_optimizer
+/);
+__PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
+__PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) );
+
+# on by default, not strictly a capability (pending rewrite)
+__PACKAGE__->_use_join_optimizer (1);
+sub _determine_supports_join_optimizer { 1 };
# Each of these methods need _determine_driver called before itself
# in order to function reliably. This is a purely DRY optimization
+#
+# get_(use)_dbms_capability need to be called on the correct Storage
+# class, as _use_X may be hardcoded class-wide, and _supports_X calls
+# _determine_supports_X which obv. needs a correct driver as well
my @rdbms_specific_methods = qw/
deployment_statements
sqlt_type
+ sql_maker
build_datetime_parser
datetime_parser_type
+ txn_begin
insert
insert_bulk
update
delete
select
select_single
+ with_deferred_fk_checks
+
+ get_use_dbms_capability
+ get_dbms_capability
+
+ _server_info
+ _get_server_version
/;
for my $meth (@rdbms_specific_methods) {
my $orig = __PACKAGE__->can ($meth)
- or next;
+ or die "$meth is not a ::Storage::DBI method!";
no strict qw/refs/;
no warnings qw/redefine/;
- *{__PACKAGE__ ."::$meth"} = Sub::Name::subname $meth => sub {
- if (not $_[0]->_driver_determined) {
+ *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
+ if (
+ # only fire when invoked on an instance, a valid class-based invocation
+ # would e.g. be setting a default for an inherited accessor
+ ref $_[0]
+ and
+ ! $_[0]->_driver_determined
+ and
+ ! $_[0]->{_in_determine_driver}
+ ) {
$_[0]->_determine_driver;
- goto $_[0]->can($meth);
+
+ # This for some reason crashes and burns on perl 5.8.1
+ # IFF the method ends up throwing an exception
+ #goto $_[0]->can ($meth);
+
+ my $cref = $_[0]->can ($meth);
+ goto $cref;
}
- $orig->(@_);
+
+ goto $orig;
};
}
-
=head1 NAME
DBIx::Class::Storage::DBI - DBI storage handler
);
$schema->resultset('Book')->search({
- written_on => $schema->storage->datetime_parser(DateTime->now)
+ written_on => $schema->storage->datetime_parser->format_datetime(DateTime->now)
});
=head1 DESCRIPTION
sub new {
my $new = shift->next::method(@_);
- $new->transaction_depth(0);
$new->_sql_maker_opts({});
- $new->{savepoints} = [];
- $new->{_in_dbh_do} = 0;
+ $new->_dbh_details({});
+ $new->{_in_do_block} = 0;
$new->{_dbh_gen} = 0;
+ # read below to see what this does
+ $new->_arm_global_destructor;
+
$new;
}
+# This is hack to work around perl shooting stuff in random
+# order on exit(). If we do not walk the remaining storage
+# objects in an END block, there is a *small but real* chance
+# of a fork()ed child to kill the parent's shared DBI handle,
+# *before perl reaches the DESTROY in this package*
+# Yes, it is ugly and effective.
+# Additionally this registry is used by the CLONE method to
+# make sure no handles are shared between threads
+{
+ my %seek_and_destroy;
+
+ sub _arm_global_destructor {
+ my $self = shift;
+ my $key = refaddr ($self);
+ $seek_and_destroy{$key} = $self;
+ weaken ($seek_and_destroy{$key});
+ }
+
+ END {
+ local $?; # just in case the DBI destructor changes it somehow
+
+ # destroy just the object if not native to this process/thread
+ $_->_verify_pid for (grep
+ { defined $_ }
+ values %seek_and_destroy
+ );
+ }
+
+ sub CLONE {
+ # As per DBI's recommendation, DBIC disconnects all handles as
+ # soon as possible (DBIC will reconnect only on demand from within
+ # the thread)
+ for (values %seek_and_destroy) {
+ next unless $_;
+ $_->{_dbh_gen}++; # so that existing cursors will drop as well
+ $_->_dbh(undef);
+
+ $_->transaction_depth(0);
+ $_->savepoints([]);
+ }
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ # some databases spew warnings on implicit disconnect
+ $self->_verify_pid;
+ local $SIG{__WARN__} = sub {};
+ $self->_dbh(undef);
+
+ # this op is necessary, since the very last perl runtime statement
+ # triggers a global destruction shootout, and the $SIG localization
+ # may very well be destroyed before perl actually gets to do the
+ # $dbh undef
+ 1;
+}
+
+# handle pid changes correctly - do not destroy parent's connection
+sub _verify_pid {
+ my $self = shift;
+
+ my $pid = $self->_conn_pid;
+ if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) {
+ $dbh->{InactiveDestroy} = 1;
+ $self->{_dbh_gen}++;
+ $self->_dbh(undef);
+ $self->transaction_depth(0);
+ $self->savepoints([]);
+ }
+
+ return;
+}
+
=head2 connect_info
This method is normally called by L<DBIx::Class::Schema/connection>, which
=head3 DBIx::Class specific connection attributes
-In addition to the standard L<DBI|DBI/ATTRIBUTES_COMMON_TO_ALL_HANDLES>
-L<connection|DBI/Database_Handle_Attributes> attributes, DBIx::Class recognizes
+In addition to the standard L<DBI|DBI/ATTRIBUTES COMMON TO ALL HANDLES>
+L<connection|DBI/Database Handle Attributes> attributes, DBIx::Class recognizes
the following connection options. These options can be mixed in with your other
L<DBI> connection attributes, or placed in a separate hashref
(C<\%extra_attributes>) as shown above.
=item limit_dialect
-Sets the limit dialect. This is useful for JDBC-bridge among others
-where the remote SQL-dialect cannot be determined by the name of the
-driver alone. See also L<SQL::Abstract::Limit>.
+Sets a specific SQL::Abstract::Limit-style limit dialect, overriding the
+default L</sql_limit_dialect> setting of the storage (if any). For a list
+of available limit dialects see L<DBIx::Class::SQLMaker::LimitDialects>.
+
+=item quote_names
+
+When true automatically sets L</quote_char> and L</name_sep> to the characters
+appropriate for your particular RDBMS. This option is preferred over specifying
+L</quote_char> directly.
=item quote_char
-Specifies what characters to use to quote table and column names. If
-you use this you will want to specify L</name_sep> as well.
+Specifies what characters to use to quote table and column names.
C<quote_char> expects either a single character, in which case is it
is placed on either side of the table/column name, or an arrayref of length
=item name_sep
-This only needs to be used in conjunction with C<quote_char>, and is used to
+This parameter is only useful in conjunction with C<quote_char>, and is used to
specify the character that separates elements (schemas, tables, columns) from
-each other. In most cases this is simply a C<.>.
-
-The consequences of not supplying this value is that L<SQL::Abstract>
-will assume DBIx::Class' uses of aliases to be complete column
-names. The output will look like I<"me.name"> when it should actually
-be I<"me"."name">.
+each other. If unspecified it defaults to the most commonly used C<.>.
=item unsafe
'postgres',
'my_pg_password',
{ AutoCommit => 1 },
- { quote_char => q{"}, name_sep => q{.} },
+ { quote_char => q{"} },
]
);
my @args = @{ $info->{arguments} };
- $self->_dbi_connect_info([@args,
- %attrs && !(ref $args[0] eq 'CODE') ? \%attrs : ()]);
+ if (keys %attrs and ref $args[0] ne 'CODE') {
+ carp
+ 'You provided explicit AutoCommit => 0 in your connection_info. '
+ . 'This is almost universally a bad idea (see the footnotes of '
+ . 'DBIx::Class::Storage::DBI for more info). If you still want to '
+ . 'do this you can set $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} to disable '
+ . 'this warning.'
+ if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK};
+
+ push @args, \%attrs if keys %attrs;
+ }
+ $self->_dbi_connect_info(\@args);
+
+ # FIXME - dirty:
+ # save attributes them in a separate accessor so they are always
+ # introspectable, even in case of a CODE $dbhmaker
+ $self->_dbic_connect_attributes (\%attrs);
return $self->_connect_info;
}
delete @attrs{@storage_opts} if @storage_opts;
my @sql_maker_opts = grep exists $attrs{$_},
- qw/limit_dialect quote_char name_sep/;
+ qw/limit_dialect quote_char name_sep quote_names/;
@{ $info{sql_maker_options} }{@sql_maker_opts} =
delete @attrs{@sql_maker_opts} if @sql_maker_opts;
return \%info;
}
-sub _default_dbi_connect_attributes {
- return {
+sub _default_dbi_connect_attributes () {
+ +{
AutoCommit => 1,
- RaiseError => 1,
PrintError => 0,
+ RaiseError => 1,
+ ShowErrorStatement => 1,
};
}
sub dbh_do {
my $self = shift;
- my $code = shift;
-
- my $dbh = $self->_get_dbh;
-
- return $self->$code($dbh, @_) if $self->{_in_dbh_do}
- || $self->{transaction_depth};
-
- local $self->{_in_dbh_do} = 1;
-
- my @result;
- my $want_array = wantarray;
+ my $run_target = shift;
- eval {
-
- if($want_array) {
- @result = $self->$code($dbh, @_);
- }
- elsif(defined $want_array) {
- $result[0] = $self->$code($dbh, @_);
- }
- else {
- $self->$code($dbh, @_);
- }
- };
-
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
+ # short circuit when we know there is no need for a runner
+ #
+ # FIXME - asumption may be wrong
+ # the rationale for the txn_depth check is that if this block is a part
+ # of a larger transaction, everything up to that point is screwed anyway
+ return $self->$run_target($self->_get_dbh, @_)
+ if $self->{_in_do_block} or $self->transaction_depth;
- $self->throw_exception($exception) if $self->connected;
+ my $args = \@_;
- # We were not connected - reconnect and retry, but let any
- # exception fall right through this time
- carp "Retrying $code after catching disconnected exception: $exception"
- if $ENV{DBIC_DBIRETRY_DEBUG};
- $self->_populate_dbh;
- $self->$code($self->_dbh, @_);
+ DBIx::Class::Storage::BlockRunner->new(
+ storage => $self,
+ run_code => sub { $self->$run_target ($self->_get_dbh, @$args ) },
+ wrap_txn => 0,
+ retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
+ )->run;
}
-# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
-# It also informs dbh_do to bypass itself while under the direction of txn_do,
-# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
sub txn_do {
- my $self = shift;
- my $coderef = shift;
-
- ref $coderef eq 'CODE' or $self->throw_exception
- ('$coderef must be a CODE reference');
-
- return $coderef->(@_) if $self->{transaction_depth} && ! $self->auto_savepoint;
-
- local $self->{_in_dbh_do} = 1;
-
- my @result;
- my $want_array = wantarray;
-
- my $tried = 0;
- while(1) {
- eval {
- $self->_get_dbh;
-
- $self->txn_begin;
- if($want_array) {
- @result = $coderef->(@_);
- }
- elsif(defined $want_array) {
- $result[0] = $coderef->(@_);
- }
- else {
- $coderef->(@_);
- }
- $self->txn_commit;
- };
-
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
-
- if($tried++ || $self->connected) {
- eval { $self->txn_rollback };
- my $rollback_exception = $@;
- if($rollback_exception) {
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $self->throw_exception($exception) # propagate nested rollback
- if $rollback_exception =~ /$exception_class/;
-
- $self->throw_exception(
- "Transaction aborted: ${exception}. "
- . "Rollback failed: ${rollback_exception}"
- );
- }
- $self->throw_exception($exception)
- }
-
- # We were not connected, and was first try - reconnect and retry
- # via the while loop
- carp "Retrying $coderef after catching disconnected exception: $exception"
- if $ENV{DBIC_DBIRETRY_DEBUG};
- $self->_populate_dbh;
- }
+ $_[0]->_get_dbh; # connects or reconnects on pid change, necessary to grab correct txn_depth
+ shift->next::method(@_);
}
=head2 disconnect
$self->_do_connection_actions(disconnect_call_ => $_) for @actions;
- $self->_dbh_rollback unless $self->_dbh_autocommit;
+ # stops the "implicit rollback on disconnect" warning
+ $self->_exec_txn_rollback unless $self->_dbh_autocommit;
+ %{ $self->_dbh->{CachedKids} } = ();
$self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
sub _seems_connected {
my $self = shift;
+ $self->_verify_pid;
+
my $dbh = $self->_dbh
or return 0;
- if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
- $self->_dbh(undef);
- $self->{_dbh_gen}++;
- return 0;
- }
- else {
- $self->_verify_pid;
- return 0 if !$self->_dbh;
- }
-
return $dbh->FETCH('Active');
}
return $dbh->ping;
}
-# handle pid changes correctly
-# NOTE: assumes $self->_dbh is a valid $dbh
-sub _verify_pid {
- my ($self) = @_;
-
- return if defined $self->_conn_pid && $self->_conn_pid == $$;
-
- $self->_dbh->{InactiveDestroy} = 1;
- $self->_dbh(undef);
- $self->{_dbh_gen}++;
-
- return;
-}
-
sub ensure_connected {
my ($self) = @_;
Returns a C<$dbh> - a data base handle of class L<DBI>. The returned handle
is guaranteed to be healthy by implicitly calling L</connected>, and if
necessary performing a reconnection before returning. Keep in mind that this
-is very B<expensive> on some database engines. Consider using L<dbh_do>
+is very B<expensive> on some database engines. Consider using L</dbh_do>
instead.
=cut
# this is the internal "get dbh or connect (don't check)" method
sub _get_dbh {
my $self = shift;
- $self->_verify_pid if $self->_dbh;
+ $self->_verify_pid;
$self->_populate_dbh unless $self->_dbh;
return $self->_dbh;
}
-sub _sql_maker_args {
- my ($self) = @_;
-
- return (
- bindtype=>'columns',
- array_datatypes => 1,
- limit_dialect => $self->_get_dbh,
- %{$self->_sql_maker_opts}
- );
-}
-
sub sql_maker {
my ($self) = @_;
unless ($self->_sql_maker) {
my $sql_maker_class = $self->sql_maker_class;
- $self->ensure_class_loaded ($sql_maker_class);
- $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
+
+ my %opts = %{$self->_sql_maker_opts||{}};
+ my $dialect =
+ $opts{limit_dialect}
+ ||
+ $self->sql_limit_dialect
+ ||
+ do {
+ my $s_class = (ref $self) || $self;
+ carp (
+ "Your storage class ($s_class) does not set sql_limit_dialect and you "
+ . 'have not supplied an explicit limit_dialect in your connection_info. '
+ . 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
+ . 'databases but can be (and often is) painfully slow. '
+ . "Please file an RT ticket against '$s_class' ."
+ );
+
+ 'GenericSubQ';
+ }
+ ;
+
+ my ($quote_char, $name_sep);
+
+ if ($opts{quote_names}) {
+ $quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do {
+ my $s_class = (ref $self) || $self;
+ carp (
+ "You requested 'quote_names' but your storage class ($s_class) does "
+ . 'not explicitly define a default sql_quote_char and you have not '
+ . 'supplied a quote_char as part of your connection_info. DBIC will '
+ .q{default to the ANSI SQL standard quote '"', which works most of }
+ . "the time. Please file an RT ticket against '$s_class'."
+ );
+
+ '"'; # RV
+ };
+
+ $name_sep = (delete $opts{name_sep}) || $self->sql_name_sep;
+ }
+
+ $self->_sql_maker($sql_maker_class->new(
+ bindtype=>'columns',
+ array_datatypes => 1,
+ limit_dialect => $dialect,
+ ($quote_char ? (quote_char => $quote_char) : ()),
+ name_sep => ($name_sep || '.'),
+ %opts,
+ ));
}
return $self->_sql_maker;
}
my @info = @{$self->_dbi_connect_info || []};
$self->_dbh(undef); # in case ->connected failed we might get sent here
+ $self->_dbh_details({}); # reset everything we know
+
$self->_dbh($self->_connect(@info));
- $self->_conn_pid($$);
- $self->_conn_tid(threads->tid) if $INC{'threads.pm'};
+ $self->_conn_pid($$) if $^O ne 'MSWin32'; # on win32 these are in fact threads
$self->_determine_driver;
$self->_do_connection_actions(connect_call_ => $_) for @actions;
}
+
+
+sub set_use_dbms_capability {
+ $_[0]->set_inherited ($_[1], $_[2]);
+}
+
+sub get_use_dbms_capability {
+ my ($self, $capname) = @_;
+
+ my $use = $self->get_inherited ($capname);
+ return defined $use
+ ? $use
+ : do { $capname =~ s/^_use_/_supports_/; $self->get_dbms_capability ($capname) }
+ ;
+}
+
+sub set_dbms_capability {
+ $_[0]->_dbh_details->{capability}{$_[1]} = $_[2];
+}
+
+sub get_dbms_capability {
+ my ($self, $capname) = @_;
+
+ my $cap = $self->_dbh_details->{capability}{$capname};
+
+ unless (defined $cap) {
+ if (my $meth = $self->can ("_determine$capname")) {
+ $cap = $self->$meth ? 1 : 0;
+ }
+ else {
+ $cap = 0;
+ }
+
+ $self->set_dbms_capability ($capname, $cap);
+ }
+
+ return $cap;
+}
+
+sub _server_info {
+ my $self = shift;
+
+ my $info;
+ unless ($info = $self->_dbh_details->{info}) {
+
+ $info = {};
+
+ my $server_version = try { $self->_get_server_version };
+
+ if (defined $server_version) {
+ $info->{dbms_version} = $server_version;
+
+ my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
+ my @verparts = split (/\./, $numeric_version);
+ if (
+ @verparts
+ &&
+ $verparts[0] <= 999
+ ) {
+ # consider only up to 3 version parts, iff not more than 3 digits
+ my @use_parts;
+ while (@verparts && @use_parts < 3) {
+ my $p = shift @verparts;
+ last if $p > 999;
+ push @use_parts, $p;
+ }
+ push @use_parts, 0 while @use_parts < 3;
+
+ $info->{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
+ }
+ }
+
+ $self->_dbh_details->{info} = $info;
+ }
+
+ return $info;
+}
+
+sub _get_server_version {
+ shift->_dbh_get_info('SQL_DBMS_VER');
+}
+
+sub _dbh_get_info {
+ my ($self, $info) = @_;
+
+ if ($info =~ /[^0-9]/) {
+ $info = $DBI::Const::GetInfoType::GetInfoType{$info};
+ $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
+ unless defined $info;
+ }
+
+ return try { $self->_get_dbh->get_info($info) } || undef;
+}
+
sub _determine_driver {
my ($self) = @_;
} else {
# if connect_info is a CODEREF, we have no choice but to connect
if (ref $self->_dbi_connect_info->[0] &&
- Scalar::Util::reftype($self->_dbi_connect_info->[0]) eq 'CODE') {
+ reftype $self->_dbi_connect_info->[0] eq 'CODE') {
$self->_populate_dbh;
$driver = $self->_dbh->{Driver}{Name};
}
else {
# try to use dsn to not require being connected, the driver may still
# force a connection in _rebless to determine version
- ($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i;
+ # (dsn may not be supplied at all if all we do is make a mock-schema)
+ my $dsn = $self->_dbi_connect_info->[0] || $ENV{DBI_DSN} || '';
+ ($driver) = $dsn =~ /dbi:([^:]+):/i;
+ $driver ||= $ENV{DBI_DRIVER};
}
}
- my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
- if ($self->load_optional_class($storage_class)) {
- mro::set_mro($storage_class, 'c3');
- bless $self, $storage_class;
- $self->_rebless();
+ if ($driver) {
+ my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
+ if ($self->load_optional_class($storage_class)) {
+ mro::set_mro($storage_class, 'c3');
+ bless $self, $storage_class;
+ $self->_rebless();
+ }
}
}
$self->_driver_determined(1);
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
$self->_init; # run driver-specific initializations
$self->_run_connection_actions
my $attrs = shift @do_args;
my @bind = map { [ undef, $_ ] } @do_args;
- $self->_query_start($sql, @bind);
- $self->_get_dbh->do($sql, $attrs, @do_args);
- $self->_query_end($sql, @bind);
+ $self->dbh_do(sub {
+ $_[0]->_query_start($sql, \@bind);
+ $_[1]->do($sql, $attrs, @do_args);
+ $_[0]->_query_end($sql, \@bind);
+ });
}
return $self;
my ($old_connect_via, $dbh);
- if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
- $old_connect_via = $DBI::connect_via;
- $DBI::connect_via = 'connect';
- }
+ local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
- eval {
+ try {
if(ref $info[0] eq 'CODE') {
- $dbh = $info[0]->();
+ $dbh = $info[0]->();
}
else {
- $dbh = DBI->connect(@info);
+ require DBI;
+ $dbh = DBI->connect(@info);
+ }
+
+ if (!$dbh) {
+ die $DBI::errstr;
}
- if($dbh && !$self->unsafe) {
- my $weak_self = $self;
- Scalar::Util::weaken($weak_self);
- $dbh->{HandleError} = sub {
+ unless ($self->unsafe) {
+
+ $self->throw_exception(
+ 'Refusing clobbering of {HandleError} installed on externally supplied '
+ ."DBI handle $dbh. Either remove the handler or use the 'unsafe' attribute."
+ ) if $dbh->{HandleError} and ref $dbh->{HandleError} ne '__DBIC__DBH__ERROR__HANDLER__';
+
+ # Default via _default_dbi_connect_attributes is 1, hence it was an explicit
+ # request, or an external handle. Complain and set anyway
+ unless ($dbh->{RaiseError}) {
+ carp( ref $info[0] eq 'CODE'
+
+ ? "The 'RaiseError' of the externally supplied DBI handle is set to false. "
+ ."DBIx::Class will toggle it back to true, unless the 'unsafe' connect "
+ .'attribute has been supplied'
+
+ : 'RaiseError => 0 supplied in your connection_info, without an explicit '
+ .'unsafe => 1. Toggling RaiseError back to true'
+ );
+
+ $dbh->{RaiseError} = 1;
+ }
+
+ # this odd anonymous coderef dereference is in fact really
+ # necessary to avoid the unwanted effect described in perl5
+ # RT#75792
+ sub {
+ my $weak_self = $_[0];
+ weaken $weak_self;
+
+ # the coderef is blessed so we can distinguish it from externally
+ # supplied handles (which must be preserved)
+ $_[1]->{HandleError} = bless sub {
if ($weak_self) {
$weak_self->throw_exception("DBI Exception: $_[0]");
}
else {
# the handler may be invoked by something totally out of
# the scope of DBIC
- croak ("DBI Exception: $_[0]");
+ DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
}
- };
- $dbh->{ShowErrorStatement} = 1;
- $dbh->{RaiseError} = 1;
- $dbh->{PrintError} = 0;
+ }, '__DBIC__DBH__ERROR__HANDLER__';
+ }->($self, $dbh);
}
+ }
+ catch {
+ $self->throw_exception("DBI Connection failed: $_")
};
- $DBI::connect_via = $old_connect_via if $old_connect_via;
-
- $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
- if !$dbh || $@;
-
$self->_dbh_autocommit($dbh->{AutoCommit});
-
$dbh;
}
-sub svp_begin {
- my ($self, $name) = @_;
-
- $name = $self->_svp_generate_name
- unless defined $name;
-
- $self->throw_exception ("You can't use savepoints outside a transaction")
- if $self->{transaction_depth} == 0;
-
- $self->throw_exception ("Your Storage implementation doesn't support savepoints")
- unless $self->can('_svp_begin');
-
- push @{ $self->{savepoints} }, $name;
-
- $self->debugobj->svp_begin($name) if $self->debug;
-
- return $self->_svp_begin($name);
-}
-
-sub svp_release {
- my ($self, $name) = @_;
-
- $self->throw_exception ("You can't use savepoints outside a transaction")
- if $self->{transaction_depth} == 0;
-
- $self->throw_exception ("Your Storage implementation doesn't support savepoints")
- unless $self->can('_svp_release');
-
- if (defined $name) {
- $self->throw_exception ("Savepoint '$name' does not exist")
- unless grep { $_ eq $name } @{ $self->{savepoints} };
-
- # Dig through the stack until we find the one we are releasing. This keeps
- # the stack up to date.
- my $svp;
-
- do { $svp = pop @{ $self->{savepoints} } } while $svp ne $name;
- } else {
- $name = pop @{ $self->{savepoints} };
- }
-
- $self->debugobj->svp_release($name) if $self->debug;
-
- return $self->_svp_release($name);
-}
-
-sub svp_rollback {
- my ($self, $name) = @_;
-
- $self->throw_exception ("You can't use savepoints outside a transaction")
- if $self->{transaction_depth} == 0;
-
- $self->throw_exception ("Your Storage implementation doesn't support savepoints")
- unless $self->can('_svp_rollback');
-
- if (defined $name) {
- # If they passed us a name, verify that it exists in the stack
- unless(grep({ $_ eq $name } @{ $self->{savepoints} })) {
- $self->throw_exception("Savepoint '$name' does not exist!");
- }
-
- # Dig through the stack until we find the one we are releasing. This keeps
- # the stack up to date.
- while(my $s = pop(@{ $self->{savepoints} })) {
- last if($s eq $name);
- }
- # Add the savepoint back to the stack, as a rollback doesn't remove the
- # named savepoint, only everything after it.
- push(@{ $self->{savepoints} }, $name);
- } else {
- # We'll assume they want to rollback to the last savepoint
- $name = $self->{savepoints}->[-1];
- }
-
- $self->debugobj->svp_rollback($name) if $self->debug;
-
- return $self->_svp_rollback($name);
-}
-
-sub _svp_generate_name {
- my ($self) = @_;
-
- return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
-}
-
sub txn_begin {
my $self = shift;
# this means we have not yet connected and do not know the AC status
- # (e.g. coderef $dbh)
- $self->ensure_connected if (! defined $self->_dbh_autocommit);
-
- if($self->{transaction_depth} == 0) {
- $self->debugobj->txn_begin()
- if $self->debug;
- $self->_dbh_begin_work;
+ # (e.g. coderef $dbh), need a full-fledged connection check
+ if (! defined $self->_dbh_autocommit) {
+ $self->ensure_connected;
}
- elsif ($self->auto_savepoint) {
- $self->svp_begin;
+ # Otherwise simply connect or re-connect on pid changes
+ else {
+ $self->_get_dbh;
}
- $self->{transaction_depth}++;
+
+ $self->next::method(@_);
}
-sub _dbh_begin_work {
+sub _exec_txn_begin {
my $self = shift;
# if the user is utilizing txn_do - good for him, otherwise we need to
# We do this via ->dbh_do instead of ->dbh, so that the ->dbh "ping"
# will be replaced by a failure of begin_work itself (which will be
# then retried on reconnect)
- if ($self->{_in_dbh_do}) {
+ if ($self->{_in_do_block}) {
$self->_dbh->begin_work;
} else {
$self->dbh_do(sub { $_[1]->begin_work });
sub txn_commit {
my $self = shift;
- if ($self->{transaction_depth} == 1) {
- $self->debugobj->txn_commit()
- if ($self->debug);
- $self->_dbh_commit;
- $self->{transaction_depth} = 0
- if $self->_dbh_autocommit;
- }
- elsif($self->{transaction_depth} > 1) {
- $self->{transaction_depth}--;
- $self->svp_release
- if $self->auto_savepoint;
+
+ $self->_verify_pid if $self->_dbh;
+ $self->throw_exception("Unable to txn_commit() on a disconnected storage")
+ unless $self->_dbh;
+
+ # esoteric case for folks using external $dbh handles
+ if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
+ carp "Storage transaction_depth 0 does not match "
+ ."false AutoCommit of $self->{_dbh}, attempting COMMIT anyway";
+ $self->transaction_depth(1);
}
+
+ $self->next::method(@_);
+
+ # if AutoCommit is disabled txn_depth never goes to 0
+ # as a new txn is started immediately on commit
+ $self->transaction_depth(1) if (
+ !$self->transaction_depth
+ and
+ defined $self->_dbh_autocommit
+ and
+ ! $self->_dbh_autocommit
+ );
}
-sub _dbh_commit {
- my $self = shift;
- my $dbh = $self->_dbh
- or $self->throw_exception('cannot COMMIT on a disconnected handle');
- $dbh->commit;
+sub _exec_txn_commit {
+ shift->_dbh->commit;
}
sub txn_rollback {
my $self = shift;
- my $dbh = $self->_dbh;
- eval {
- if ($self->{transaction_depth} == 1) {
- $self->debugobj->txn_rollback()
- if ($self->debug);
- $self->{transaction_depth} = 0
- if $self->_dbh_autocommit;
- $self->_dbh_rollback;
- }
- elsif($self->{transaction_depth} > 1) {
- $self->{transaction_depth}--;
- if ($self->auto_savepoint) {
- $self->svp_rollback;
- $self->svp_release;
- }
- }
- else {
- die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
- }
- };
- if ($@) {
- my $error = $@;
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $error =~ /$exception_class/ and $self->throw_exception($error);
- # ensure that a failed rollback resets the transaction depth
- $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
- $self->throw_exception($error);
+
+ $self->_verify_pid if $self->_dbh;
+ $self->throw_exception("Unable to txn_rollback() on a disconnected storage")
+ unless $self->_dbh;
+
+ # esoteric case for folks using external $dbh handles
+ if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
+ carp "Storage transaction_depth 0 does not match "
+ ."false AutoCommit of $self->{_dbh}, attempting ROLLBACK anyway";
+ $self->transaction_depth(1);
}
+
+ $self->next::method(@_);
+
+ # if AutoCommit is disabled txn_depth never goes to 0
+ # as a new txn is started immediately on commit
+ $self->transaction_depth(1) if (
+ !$self->transaction_depth
+ and
+ defined $self->_dbh_autocommit
+ and
+ ! $self->_dbh_autocommit
+ );
}
-sub _dbh_rollback {
- my $self = shift;
- my $dbh = $self->_dbh
- or $self->throw_exception('cannot ROLLBACK on a disconnected handle');
- $dbh->rollback;
+sub _exec_txn_rollback {
+ shift->_dbh->rollback;
+}
+
+# generate some identical methods
+for my $meth (qw/svp_begin svp_release svp_rollback/) {
+ no strict qw/refs/;
+ *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
+ my $self = shift;
+ $self->_verify_pid if $self->_dbh;
+ $self->throw_exception("Unable to $meth() on a disconnected storage")
+ unless $self->_dbh;
+ $self->next::method(@_);
+ };
}
# This used to be the top-half of _execute. It was split out to make it
# easier to override in NoBindVars without duping the rest. It takes up
# all of _execute's args, and emits $sql, @bind.
sub _prep_for_execute {
- my ($self, $op, $extra_bind, $ident, $args) = @_;
+ #my ($self, $op, $ident, $args) = @_;
+ return shift->_gen_sql_bind(@_)
+}
- if( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
- $ident = $ident->from();
- }
+sub _gen_sql_bind {
+ my ($self, $op, $ident, $args) = @_;
+
+ my ($sql, @bind) = $self->sql_maker->$op(
+ blessed($ident) ? $ident->from : $ident,
+ @$args,
+ );
- my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
+ if (
+ ! $ENV{DBIC_DT_SEARCH_OK}
+ and
+ $op eq 'select'
+ and
+ first { blessed($_->[1]) && $_->[1]->isa('DateTime') } @bind
+ ) {
+ carp_unique 'DateTime objects passed to search() are not supported '
+ . 'properly (InflateColumn::DateTime formats and settings are not '
+ . 'respected.) See "Formatting DateTime objects in queries" in '
+ . 'DBIx::Class::Manual::Cookbook. To disable this warning for good '
+ . 'set $ENV{DBIC_DT_SEARCH_OK} to true'
+ }
- unshift(@bind,
- map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
- if $extra_bind;
- return ($sql, \@bind);
+ return( $sql, $self->_resolve_bindattrs(
+ $ident, [ @{$args->[2]{bind}||[]}, @bind ]
+ ));
}
+sub _resolve_bindattrs {
+ my ($self, $ident, $bind, $colinfos) = @_;
-sub _fix_bind_params {
- my ($self, @bind) = @_;
+ $colinfos ||= {};
- ### Turn @bind from something like this:
- ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
- ### to this:
- ### ( "'1'", "'1'", "'3'" )
- return
- map {
- if ( defined( $_ && $_->[1] ) ) {
- map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
- }
- else { q{'NULL'}; }
- } @bind;
-}
+ my $resolve_bindinfo = sub {
+ #my $infohash = shift;
-sub _query_start {
- my ( $self, $sql, @bind ) = @_;
+ %$colinfos = %{ $self->_resolve_column_info($ident) }
+ unless keys %$colinfos;
+
+ my $ret;
+ if (my $col = $_[0]->{dbic_colname}) {
+ $ret = { %{$_[0]} };
- if ( $self->debug ) {
- @bind = $self->_fix_bind_params(@bind);
+ $ret->{sqlt_datatype} ||= $colinfos->{$col}{data_type}
+ if $colinfos->{$col}{data_type};
- $self->debugobj->query_start( $sql, @bind );
+ $ret->{sqlt_size} ||= $colinfos->{$col}{size}
+ if $colinfos->{$col}{size};
}
-}
-sub _query_end {
- my ( $self, $sql, @bind ) = @_;
+ $ret || $_[0];
+ };
- if ( $self->debug ) {
- @bind = $self->_fix_bind_params(@bind);
- $self->debugobj->query_end( $sql, @bind );
+ return [ map {
+ if (ref $_ ne 'ARRAY') {
+ [{}, $_]
+ }
+ elsif (! defined $_->[0]) {
+ [{}, $_->[1]]
+ }
+ elsif (ref $_->[0] eq 'HASH') {
+ [
+ ($_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) ? $_->[0] : $resolve_bindinfo->($_->[0]),
+ $_->[1]
+ ]
+ }
+ elsif (ref $_->[0] eq 'SCALAR') {
+ [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ]
+ }
+ else {
+ [ $resolve_bindinfo->({ dbic_colname => $_->[0] }), $_->[1] ]
}
+ } @$bind ];
}
-sub _dbh_execute {
- my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+sub _format_for_trace {
+ #my ($self, $bind) = @_;
- my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+ ### Turn @bind from something like this:
+ ### ( [ "artist", 1 ], [ \%attrs, 3 ] )
+ ### to this:
+ ### ( "'1'", "'3'" )
- $self->_query_start( $sql, @$bind );
+ map {
+ defined( $_ && $_->[1] )
+ ? qq{'$_->[1]'}
+ : q{NULL}
+ } @{$_[1] || []};
+}
- my $sth = $self->sth($sql,$op);
+sub _query_start {
+ my ( $self, $sql, $bind ) = @_;
- my $placeholder_index = 1;
+ $self->debugobj->query_start( $sql, $self->_format_for_trace($bind) )
+ if $self->debug;
+}
+
+sub _query_end {
+ my ( $self, $sql, $bind ) = @_;
+
+ $self->debugobj->query_end( $sql, $self->_format_for_trace($bind) )
+ if $self->debug;
+}
- foreach my $bound (@$bind) {
- my $attributes = {};
- my($column_name, @data) = @$bound;
+my $sba_compat;
+sub _dbi_attrs_for_bind {
+ my ($self, $ident, $bind) = @_;
- if ($bind_attributes) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
+ if (! defined $sba_compat) {
+ $self->_determine_driver;
+ $sba_compat = $self->can('source_bind_attributes') == \&source_bind_attributes
+ ? 0
+ : 1
+ ;
+ }
+
+ my $sba_attrs;
+ if ($sba_compat) {
+ my $class = ref $self;
+ carp_unique (
+ "The source_bind_attributes() override in $class relies on a deprecated codepath. "
+ .'You are strongly advised to switch your code to override bind_attribute_by_datatype() '
+ .'instead. This legacy compat shim will also disappear some time before DBIC 0.09'
+ );
+
+ my $sba_attrs = $self->source_bind_attributes
+ }
+
+ my @attrs;
+
+ for (map { $_->[0] } @$bind) {
+ push @attrs, do {
+ if (exists $_->{dbd_attrs}) {
+ $_->{dbd_attrs}
+ }
+ elsif($_->{sqlt_datatype}) {
+ # cache the result in the dbh_details hash, as it can not change unless
+ # we connect to something else
+ my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
+ if (not exists $cache->{$_->{sqlt_datatype}}) {
+ $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
+ }
+ $cache->{$_->{sqlt_datatype}};
+ }
+ elsif ($sba_attrs and $_->{dbic_colname}) {
+ $sba_attrs->{$_->{dbic_colname}} || undef;
+ }
+ else {
+ undef; # always push something at this position
+ }
}
+ }
- foreach my $data (@data) {
- my $ref = ref $data;
- $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
+ return \@attrs;
+}
- $sth->bind_param($placeholder_index, $data, $attributes);
- $placeholder_index++;
+sub _execute {
+ my ($self, $op, $ident, @args) = @_;
+
+ my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args);
+
+ shift->dbh_do( # retry over disconnects
+ '_dbh_execute',
+ $sql,
+ $bind,
+ $self->_dbi_attrs_for_bind($ident, $bind)
+ );
+}
+
+sub _dbh_execute {
+ my ($self, undef, $sql, $bind, $bind_attrs) = @_;
+
+ $self->_query_start( $sql, $bind );
+ my $sth = $self->_sth($sql);
+
+ for my $i (0 .. $#$bind) {
+ if (ref $bind->[$i][1] eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts
+ $sth->bind_param_inout(
+ $i + 1, # bind params counts are 1-based
+ $bind->[$i][1],
+ $bind->[$i][0]{dbd_size} || $self->_max_column_bytesize($bind->[$i][0]), # size
+ $bind_attrs->[$i],
+ );
+ }
+ else {
+ $sth->bind_param(
+ $i + 1,
+ (ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""'))
+ ? "$bind->[$i][1]"
+ : $bind->[$i][1]
+ ,
+ $bind_attrs->[$i],
+ );
}
}
# Can this fail without throwing an exception anyways???
my $rv = $sth->execute();
- $self->throw_exception($sth->errstr) if !$rv;
+ $self->throw_exception(
+ $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...'
+ ) if !$rv;
- $self->_query_end( $sql, @$bind );
+ $self->_query_end( $sql, $bind );
return (wantarray ? ($rv, $sth, @$bind) : $rv);
}
-sub _execute {
- my $self = shift;
- $self->dbh_do('_dbh_execute', @_); # retry over disconnects
+sub _prefetch_autovalues {
+ my ($self, $source, $to_insert) = @_;
+
+ my $colinfo = $source->columns_info;
+
+ my %values;
+ for my $col (keys %$colinfo) {
+ if (
+ $colinfo->{$col}{auto_nextval}
+ and
+ (
+ ! exists $to_insert->{$col}
+ or
+ ref $to_insert->{$col} eq 'SCALAR'
+ or
+ (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
+ )
+ ) {
+ $values{$col} = $self->_sequence_fetch(
+ 'NEXTVAL',
+ ( $colinfo->{$col}{sequence} ||=
+ $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
+ ),
+ );
+ }
+ }
+
+ \%values;
}
sub insert {
my ($self, $source, $to_insert) = @_;
- my $ident = $source->from;
- my $bind_attributes = $self->source_bind_attributes($source);
+ my $prefetched_values = $self->_prefetch_autovalues($source, $to_insert);
+
+ # fuse the values, but keep a separate list of prefetched_values so that
+ # they can be fused once again with the final return
+ $to_insert = { %$to_insert, %$prefetched_values };
+
+ # FIXME - we seem to assume undef values as non-supplied. This is wrong.
+ # Investigate what does it take to s/defined/exists/
+ my $col_infos = $source->columns_info;
+ my %pcols = map { $_ => 1 } $source->primary_columns;
+ my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col);
+ for my $col ($source->columns) {
+ if ($col_infos->{$col}{is_auto_increment}) {
+ $autoinc_supplied ||= 1 if defined $to_insert->{$col};
+ $retrieve_autoinc_col ||= $col unless $autoinc_supplied;
+ }
+
+ # nothing to retrieve when explicit values are supplied
+ next if (defined $to_insert->{$col} and ! (
+ ref $to_insert->{$col} eq 'SCALAR'
+ or
+ (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
+ ));
+
+ # the 'scalar keys' is a trick to preserve the ->columns declaration order
+ $retrieve_cols{$col} = scalar keys %retrieve_cols if (
+ $pcols{$col}
+ or
+ $col_infos->{$col}{retrieve_on_insert}
+ );
+ };
- my $updated_cols = {};
+ local $self->{_autoinc_supplied_for_op} = $autoinc_supplied;
+ local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col;
- foreach my $col ( $source->columns ) {
- if ( !defined $to_insert->{$col} ) {
- my $col_info = $source->column_info($col);
+ my ($sqla_opts, @ir_container);
+ if (%retrieve_cols and $self->_use_insert_returning) {
+ $sqla_opts->{returning_container} = \@ir_container
+ if $self->_use_insert_returning_bound;
- if ( $col_info->{auto_nextval} ) {
- $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
- 'nextval',
- $col_info->{sequence} ||
- $self->_dbh_get_autoinc_seq($self->_get_dbh, $source)
- );
- }
- }
+ $sqla_opts->{returning} = [
+ sort { $retrieve_cols{$a} <=> $retrieve_cols{$b} } keys %retrieve_cols
+ ];
+ }
+
+ my ($rv, $sth) = $self->_execute('insert', $source, $to_insert, $sqla_opts);
+
+ my %returned_cols = %$to_insert;
+ if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set
+ @ir_container = try {
+ local $SIG{__WARN__} = sub {};
+ my @r = $sth->fetchrow_array;
+ $sth->finish;
+ @r;
+ } unless @ir_container;
+
+ @returned_cols{@$retlist} = @ir_container if @ir_container;
}
+ else {
+ # pull in PK if needed and then everything else
+ if (my @missing_pri = grep { $pcols{$_} } keys %retrieve_cols) {
+
+ $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
+ unless $self->can('last_insert_id');
+
+ my @pri_values = $self->last_insert_id($source, @missing_pri);
+
+ $self->throw_exception( "Can't get last insert id" )
+ unless (@pri_values == @missing_pri);
+
+ @returned_cols{@missing_pri} = @pri_values;
+ delete $retrieve_cols{$_} for @missing_pri;
+ }
+
+ # if there is more left to pull
+ if (%retrieve_cols) {
+ $self->throw_exception(
+ 'Unable to retrieve additional columns without a Primary Key on ' . $source->source_name
+ ) unless %pcols;
+
+ my @left_to_fetch = sort { $retrieve_cols{$a} <=> $retrieve_cols{$b} } keys %retrieve_cols;
- $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
+ my $cur = DBIx::Class::ResultSet->new($source, {
+ where => { map { $_ => $returned_cols{$_} } (keys %pcols) },
+ select => \@left_to_fetch,
+ })->cursor;
- return $updated_cols;
+ @returned_cols{@left_to_fetch} = $cur->next;
+
+ $self->throw_exception('Duplicate row returned for PK-search after fresh insert')
+ if scalar $cur->next;
+ }
+ }
+
+ return { %$prefetched_values, %returned_cols };
}
-## Currently it is assumed that all values passed will be "normal", i.e. not
-## scalar refs, or at least, all the same type as the first set, the statement is
-## only prepped once.
sub insert_bulk {
my ($self, $source, $cols, $data) = @_;
- my %colvalues;
- @colvalues{@$cols} = (0..$#$cols);
+ my @col_range = (0..$#$cols);
+
+ # FIXME - perhaps this is not even needed? does DBI stringify?
+ #
+ # forcibly stringify whatever is stringifiable
+ # ResultSet::populate() hands us a copy - safe to mangle
+ for my $r (0 .. $#$data) {
+ for my $c (0 .. $#{$data->[$r]}) {
+ $data->[$r][$c] = "$data->[$r][$c]"
+ if ( ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') );
+ }
+ }
+
+ my $colinfos = $source->columns_info($cols);
+
+ local $self->{_autoinc_supplied_for_op} =
+ (first { $_->{is_auto_increment} } values %$colinfos)
+ ? 1
+ : 0
+ ;
+
+ # get a slice type index based on first row of data
+ # a "column" in this context may refer to more than one bind value
+ # e.g. \[ '?, ?', [...], [...] ]
+ #
+ # construct the value type index - a description of values types for every
+ # per-column slice of $data:
+ #
+ # nonexistent - nonbind literal
+ # 0 - regular value
+ # [] of bindattrs - resolved attribute(s) of bind(s) passed via literal+bind \[] combo
+ #
+ # also construct the column hash to pass to the SQL generator. For plain
+ # (non literal) values - convert the members of the first row into a
+ # literal+bind combo, with extra positional info in the bind attr hashref.
+ # This will allow us to match the order properly, and is so contrived
+ # because a user-supplied literal/bind (or something else specific to a
+ # resultsource and/or storage driver) can inject extra binds along the
+ # way, so one can't rely on "shift positions" ordering at all. Also we
+ # can't just hand SQLA a set of some known "values" (e.g. hashrefs that
+ # can be later matched up by address), because we want to supply a real
+ # value on which perhaps e.g. datatype checks will be performed
+ my ($proto_data, $value_type_idx);
+ for my $i (@col_range) {
+ my $colname = $cols->[$i];
+ if (ref $data->[0][$i] eq 'SCALAR') {
+ # no bind value at all - no type
+
+ $proto_data->{$colname} = $data->[0][$i];
+ }
+ elsif (ref $data->[0][$i] eq 'REF' and ref ${$data->[0][$i]} eq 'ARRAY' ) {
+ # repack, so we don't end up mangling the original \[]
+ my ($sql, @bind) = @${$data->[0][$i]};
+
+ # normalization of user supplied stuff
+ my $resolved_bind = $self->_resolve_bindattrs(
+ $source, \@bind, $colinfos,
+ );
+
+ # store value-less (attrs only) bind info - we will be comparing all
+ # supplied binds against this for sanity
+ $value_type_idx->{$i} = [ map { $_->[0] } @$resolved_bind ];
+
+ $proto_data->{$colname} = \[ $sql, map { [
+ # inject slice order to use for $proto_bind construction
+ { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i }
+ =>
+ $resolved_bind->[$_][1]
+ ] } (0 .. $#bind)
+ ];
+ }
+ else {
+ $value_type_idx->{$i} = 0;
+
+ $proto_data->{$colname} = \[ '?', [
+ { dbic_colname => $colname, _bind_data_slice_idx => $i }
+ =>
+ $data->[0][$i]
+ ] ];
+ }
+ }
- for my $i (0..$#$cols) {
- my $first_val = $data->[0][$i];
- next unless ref $first_val eq 'SCALAR';
+ my ($sql, $proto_bind) = $self->_prep_for_execute (
+ 'insert',
+ $source,
+ [ $proto_data ],
+ );
- $colvalues{ $cols->[$i] } = $first_val;
+ if (! @$proto_bind and keys %$value_type_idx) {
+ # if the bindlist is empty and we had some dynamic binds, this means the
+ # storage ate them away (e.g. the NoBindVars component) and interpolated
+ # them directly into the SQL. This obviously can't be good for multi-inserts
+ $self->throw_exception('Cannot insert_bulk without support for placeholders');
}
- # check for bad data and stringify stringifiable objects
- my $bad_slice = sub {
- my ($msg, $col_idx, $slice_idx) = @_;
+ # sanity checks
+ # FIXME - devise a flag "no babysitting" or somesuch to shut this off
+ #
+ # use an error reporting closure for convenience (less to pass)
+ my $bad_slice_report_cref = sub {
+ my ($msg, $r_idx, $c_idx) = @_;
$self->throw_exception(sprintf "%s for column '%s' in populate slice:\n%s",
$msg,
- $cols->[$col_idx],
+ $cols->[$c_idx],
do {
- local $Data::Dumper::Maxdepth = 1; # don't dump objects, if any
- Data::Dumper::Concise::Dumper({
- map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
+ require Data::Dumper::Concise;
+ local $Data::Dumper::Maxdepth = 5;
+ Data::Dumper::Concise::Dumper ({
+ map { $cols->[$_] =>
+ $data->[$r_idx][$_]
+ } @col_range
}),
}
);
};
- for my $datum_idx (0..$#$data) {
- my $datum = $data->[$datum_idx];
+ for my $col_idx (@col_range) {
+ my $reference_val = $data->[0][$col_idx];
- for my $col_idx (0..$#$cols) {
- my $val = $datum->[$col_idx];
- my $sqla_bind = $colvalues{ $cols->[$col_idx] };
- my $is_literal_sql = (ref $sqla_bind) eq 'SCALAR';
+ for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1
+ my $val = $data->[$row_idx][$col_idx];
- if ($is_literal_sql) {
- if (not ref $val) {
- $bad_slice->('bind found where literal SQL expected', $col_idx, $datum_idx);
+ if (! exists $value_type_idx->{$col_idx}) { # literal no binds
+ if (ref $val ne 'SCALAR') {
+ $bad_slice_report_cref->(
+ "Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
+ $row_idx,
+ $col_idx,
+ );
}
- elsif ((my $reftype = ref $val) ne 'SCALAR') {
- $bad_slice->("$reftype reference found where literal SQL expected",
- $col_idx, $datum_idx);
+ elsif ($$val ne $$reference_val) {
+ $bad_slice_report_cref->(
+ "Inconsistent literal SQL value (expecting \\'$$reference_val')",
+ $row_idx,
+ $col_idx,
+ );
}
- elsif ($$val ne $$sqla_bind){
- $bad_slice->("inconsistent literal SQL value, expecting: '$$sqla_bind'",
- $col_idx, $datum_idx);
+ }
+ elsif (! $value_type_idx->{$col_idx} ) { # regular non-literal value
+ if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) {
+ $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
}
}
- elsif (my $reftype = ref $val) {
- require overload;
- if (overload::Method($val, '""')) {
- $datum->[$col_idx] = "".$val;
+ else { # binds from a \[], compare type and attrs
+ if (ref $val ne 'REF' or ref $$val ne 'ARRAY') {
+ $bad_slice_report_cref->(
+ "Incorrect value (expecting ARRAYREF-ref \\['${$reference_val}->[0]', ... ])",
+ $row_idx,
+ $col_idx,
+ );
}
- else {
- $bad_slice->("$reftype reference found where bind expected",
- $col_idx, $datum_idx);
+ # start drilling down and bail out early on identical refs
+ elsif (
+ $reference_val != $val
+ or
+ $$reference_val != $$val
+ ) {
+ if (${$val}->[0] ne ${$reference_val}->[0]) {
+ $bad_slice_report_cref->(
+ "Inconsistent literal/bind SQL (expecting \\['${$reference_val}->[0]', ... ])",
+ $row_idx,
+ $col_idx,
+ );
+ }
+ # need to check the bind attrs - a bind will happen only once for
+ # the entire dataset, so any changes further down will be ignored.
+ elsif (! Data::Compare::Compare(
+ $value_type_idx->{$col_idx},
+ [
+ map
+ { $_->[0] }
+ @{$self->_resolve_bindattrs(
+ $source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
+ )}
+ ],
+ )) {
+ $bad_slice_report_cref->(
+ 'Differing bind attributes on literal/bind values not supported',
+ $row_idx,
+ $col_idx,
+ );
+ }
}
}
}
}
- my ($sql, $bind) = $self->_prep_for_execute (
- 'insert', undef, $source, [\%colvalues]
- );
- my @bind = @$bind;
-
- my $empty_bind = 1 if (not @bind) &&
- (grep { ref $_ eq 'SCALAR' } values %colvalues) == @$cols;
-
- if ((not @bind) && (not $empty_bind)) {
- $self->throw_exception(
- 'Cannot insert_bulk without support for placeholders'
- );
- }
-
- # neither _execute_array, nor _execute_inserts_with_no_binds are
- # atomic (even if _execute _array is a single call). Thus a safety
+ # neither _dbh_execute_for_fetch, nor _dbh_execute_inserts_with_no_binds
+ # are atomic (even if execute_for_fetch is a single call). Thus a safety
# scope guard
- my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
+ my $guard = $self->txn_scope_guard;
- $self->_query_start( $sql, ['__BULK__'] );
- my $sth = $self->sth($sql);
+ $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () );
+ my $sth = $self->_sth($sql);
my $rv = do {
- if ($empty_bind) {
- # bind_param_array doesn't work if there are no binds
- $self->_dbh_execute_inserts_with_no_binds( $sth, scalar @$data );
+ if (@$proto_bind) {
+ # proto bind contains the information on which pieces of $data to pull
+ # $cols is passed in only for prettier error-reporting
+ $self->_dbh_execute_for_fetch( $source, $sth, $proto_bind, $cols, $data );
}
else {
-# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
- $self->_execute_array( $source, $sth, \@bind, $cols, $data );
+ # bind_param_array doesn't work if there are no binds
+ $self->_dbh_execute_inserts_with_no_binds( $sth, scalar @$data );
}
};
- $self->_query_end( $sql, ['__BULK__'] );
-
+ $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
- $guard->commit if $guard;
+ $guard->commit;
- return (wantarray ? ($rv, $sth, @bind) : $rv);
+ return wantarray ? ($rv, $sth, @$proto_bind) : $rv;
}
-sub _execute_array {
- my ($self, $source, $sth, $bind, $cols, $data, @extra) = @_;
+# execute_for_fetch is capable of returning data just fine (it means it
+# can be used for INSERT...RETURNING and UPDATE...RETURNING. Since this
+# is the void-populate fast-path we will just ignore this altogether
+# for the time being.
+sub _dbh_execute_for_fetch {
+ my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
- ## This must be an arrayref, else nothing works!
- my $tuple_status = [];
+ my @idx_range = ( 0 .. $#$proto_bind );
- ## Get the bind_attributes, if any exist
- my $bind_attributes = $self->source_bind_attributes($source);
+ # If we have any bind attributes to take care of, we will bind the
+ # proto-bind data (which will never be used by execute_for_fetch)
+ # However since column bindtypes are "sticky", this is sufficient
+ # to get the DBD to apply the bindtype to all values later on
- ## Bind the values and execute
- my $placeholder_index = 1;
+ my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
- foreach my $bound (@$bind) {
+ for my $i (@idx_range) {
+ $sth->bind_param (
+ $i+1, # DBI bind indexes are 1-based
+ $proto_bind->[$i][1],
+ $bind_attrs->[$i],
+ ) if defined $bind_attrs->[$i];
+ }
- my $attributes = {};
- my ($column_name, $data_index) = @$bound;
+ # At this point $data slots named in the _bind_data_slice_idx of
+ # each piece of $proto_bind are either \[]s or plain values to be
+ # passed in. Construct the dispensing coderef. *NOTE* the order
+ # of $data will differ from this of the ?s in the SQL (due to
+ # alphabetical ordering by colname). We actually do want to
+ # preserve this behavior so that prepare_cached has a better
+ # chance of matching on unrelated calls
+ my %data_reorder = map { $proto_bind->[$_][0]{_bind_data_slice_idx} => $_ } @idx_range;
+
+ my $fetch_row_idx = -1; # saner loop this way
+ my $fetch_tuple = sub {
+ return undef if ++$fetch_row_idx > $#$data;
+
+ return [ map
+ { (ref $_ eq 'REF' and ref $$_ eq 'ARRAY')
+ ? map { $_->[-1] } @{$$_}[1 .. $#$$_]
+ : $_
+ }
+ map
+ { $data->[$fetch_row_idx][$_]}
+ sort
+ { $data_reorder{$a} <=> $data_reorder{$b} }
+ keys %data_reorder
+ ];
+ };
- if( $bind_attributes ) {
- $attributes = $bind_attributes->{$column_name}
- if defined $bind_attributes->{$column_name};
- }
+ my $tuple_status = [];
+ my ($rv, $err);
+ try {
+ $rv = $sth->execute_for_fetch(
+ $fetch_tuple,
+ $tuple_status,
+ );
+ }
+ catch {
+ $err = shift;
+ };
- my @data = map { $_->[$data_index] } @$data;
+ # Not all DBDs are create equal. Some throw on error, some return
+ # an undef $rv, and some set $sth->err - try whatever we can
+ $err = ($sth->errstr || 'UNKNOWN ERROR ($sth->errstr is unset)') if (
+ ! defined $err
+ and
+ ( !defined $rv or $sth->err )
+ );
- $sth->bind_param_array( $placeholder_index, [@data], $attributes );
- $placeholder_index++;
+ # Statement must finish even if there was an exception.
+ try {
+ $sth->finish
}
-
- my $rv = eval {
- $self->_dbh_execute_array($sth, $tuple_status, @extra);
+ catch {
+ $err = shift unless defined $err
};
- my $err = $@ || $sth->errstr;
-# Statement must finish even if there was an exception.
- eval { $sth->finish };
- $err = $@ unless $err;
-
- if ($err) {
+ if (defined $err) {
my $i = 0;
++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];
$self->throw_exception("Unexpected populate error: $err")
if ($i > $#$tuple_status);
- $self->throw_exception(sprintf "%s for populate slice:\n%s",
+ require Data::Dumper::Concise;
+ $self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s",
($tuple_status->[$i][1] || $err),
- Data::Dumper::Concise::Dumper({
- map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols)
- }),
+ Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
);
}
- return $rv;
-}
-sub _dbh_execute_array {
- my ($self, $sth, $tuple_status, @extra) = @_;
-
- return $sth->execute_array({ArrayTupleStatus => $tuple_status});
+ return $rv;
}
sub _dbh_execute_inserts_with_no_binds {
my ($self, $sth, $count) = @_;
- eval {
+ my $err;
+ try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$sth->execute foreach 1..$count;
+ }
+ catch {
+ $err = shift;
};
- my $exception = $@;
-# Make sure statement is finished even if there was an exception.
- eval { $sth->finish };
- $exception = $@ unless $exception;
+ # Make sure statement is finished even if there was an exception.
+ try {
+ $sth->finish
+ }
+ catch {
+ $err = shift unless defined $err;
+ };
- $self->throw_exception($exception) if $exception;
+ $self->throw_exception($err) if defined $err;
return $count;
}
sub update {
- my ($self, $source, @args) = @_;
-
- my $bind_attrs = $self->source_bind_attributes($source);
-
- return $self->_execute('update' => [], $source, $bind_attrs, @args);
+ #my ($self, $source, @args) = @_;
+ shift->_execute('update', @_);
}
sub delete {
- my ($self, $source, @args) = @_;
-
- my $bind_attrs = $self->source_bind_attributes($source);
-
- return $self->_execute('delete' => [], $source, $bind_attrs, @args);
-}
-
-# We were sent here because the $rs contains a complex search
-# which will require a subquery to select the correct rows
-# (i.e. joined or limited resultsets, or non-introspectable conditions)
-#
-# Generating a single PK column subquery is trivial and supported
-# by all RDBMS. However if we have a multicolumn PK, things get ugly.
-# Look at _multipk_update_delete()
-sub _subq_update_delete {
- my $self = shift;
- my ($rs, $op, $values) = @_;
-
- my $rsrc = $rs->result_source;
-
- # quick check if we got a sane rs on our hands
- my @pcols = $rsrc->_pri_cols;
-
- my $sel = $rs->_resolved_attrs->{select};
- $sel = [ $sel ] unless ref $sel eq 'ARRAY';
-
- if (
- join ("\x00", map { join '.', $rs->{attrs}{alias}, $_ } sort @pcols)
- ne
- join ("\x00", sort @$sel )
- ) {
- $self->throw_exception (
- '_subq_update_delete can not be called on resultsets selecting columns other than the primary keys'
- );
- }
-
- if (@pcols == 1) {
- return $self->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- { $pcols[0] => { -in => $rs->as_query } },
- );
- }
-
- else {
- return $self->_multipk_update_delete (@_);
- }
-}
-
-# ANSI SQL does not provide a reliable way to perform a multicol-PK
-# resultset update/delete involving subqueries. So by default resort
-# to simple (and inefficient) delete_all style per-row opearations,
-# while allowing specific storages to override this with a faster
-# implementation.
-#
-sub _multipk_update_delete {
- return shift->_per_row_update_delete (@_);
-}
-
-# This is the default loop used to delete/update rows for multi PK
-# resultsets, and used by mysql exclusively (because it can't do anything
-# else).
-#
-# We do not use $row->$op style queries, because resultset update/delete
-# is not expected to cascade (this is what delete_all/update_all is for).
-#
-# There should be no race conditions as the entire operation is rolled
-# in a transaction.
-#
-sub _per_row_update_delete {
- my $self = shift;
- my ($rs, $op, $values) = @_;
-
- my $rsrc = $rs->result_source;
- my @pcols = $rsrc->_pri_cols;
-
- my $guard = $self->txn_scope_guard;
-
- # emulate the return value of $sth->execute for non-selects
- my $row_cnt = '0E0';
-
- my $subrs_cur = $rs->cursor;
- my @all_pk = $subrs_cur->all;
- for my $pks ( @all_pk) {
-
- my $cond;
- for my $i (0.. $#pcols) {
- $cond->{$pcols[$i]} = $pks->[$i];
- }
-
- $self->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- $cond,
- );
-
- $row_cnt++;
- }
-
- $guard->commit;
-
- return $row_cnt;
+ #my ($self, $source, @args) = @_;
+ shift->_execute('delete', @_);
}
sub _select {
my $self = shift;
-
- # localization is neccessary as
- # 1) there is no infrastructure to pass this around before SQLA2
- # 2) _select_args sets it and _prep_for_execute consumes it
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{_dbic_rs_attrs};
-
- return $self->_execute($self->_select_args(@_));
+ $self->_execute($self->_select_args(@_));
}
sub _select_args_to_query {
my $self = shift;
- # localization is neccessary as
- # 1) there is no infrastructure to pass this around before SQLA2
- # 2) _select_args sets it and _prep_for_execute consumes it
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{_dbic_rs_attrs};
+ $self->throw_exception(
+ "Unable to generate limited query representation with 'software_limit' enabled"
+ ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) );
- # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $order, $rows, $offset)
+ # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset)
# = $self->_select_args($ident, $select, $cond, $attrs);
- my ($op, $bind, $ident, $bind_attrs, @args) =
+ my ($op, $ident, @args) =
$self->_select_args(@_);
- # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, [ $select, $cond, $order, $rows, $offset ]);
- my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, \@args);
+ # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
+ my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, \@args);
$prepared_bind ||= [];
return wantarray
- ? ($sql, $prepared_bind, $bind_attrs)
+ ? ($sql, $prepared_bind)
: \[ "($sql)", @$prepared_bind ]
;
}
sub _select_args {
my ($self, $ident, $select, $where, $attrs) = @_;
+ my $sql_maker = $self->sql_maker;
my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident);
- my $sql_maker = $self->sql_maker;
- $sql_maker->{_dbic_rs_attrs} = {
+ $attrs = {
%$attrs,
select => $select,
from => $ident,
where => $where,
$rs_alias && $alias2source->{$rs_alias}
- ? ( _source_handle => $alias2source->{$rs_alias}->handle )
+ ? ( _rsroot_rsrc => $alias2source->{$rs_alias} )
: ()
,
};
- # calculate bind_attrs before possible $ident mangling
- my $bind_attrs = {};
- for my $alias (keys %$alias2source) {
- my $bindtypes = $self->source_bind_attributes ($alias2source->{$alias}) || {};
- for my $col (keys %$bindtypes) {
-
- my $fqcn = join ('.', $alias, $col);
- $bind_attrs->{$fqcn} = $bindtypes->{$col} if $bindtypes->{$col};
-
- # Unqialified column names are nice, but at the same time can be
- # rather ambiguous. What we do here is basically go along with
- # the loop, adding an unqualified column slot to $bind_attrs,
- # alongside the fully qualified name. As soon as we encounter
- # another column by that name (which would imply another table)
- # we unset the unqualified slot and never add any info to it
- # to avoid erroneous type binding. If this happens the users
- # only choice will be to fully qualify his column name
-
- if (exists $bind_attrs->{$col}) {
- $bind_attrs->{$col} = {};
- }
- else {
- $bind_attrs->{$col} = $bind_attrs->{$fqcn};
- }
- }
+ # Sanity check the attributes (SQLMaker does it too, but
+ # in case of a software_limit we'll never reach there)
+ if (defined $attrs->{offset}) {
+ $self->throw_exception('A supplied offset attribute must be a non-negative integer')
+ if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
}
- # adjust limits
- if (
- $attrs->{software_limit}
- ||
- $sql_maker->_default_limit_syntax eq "GenericSubQ"
- ) {
- $attrs->{software_limit} = 1;
+ if (defined $attrs->{rows}) {
+ $self->throw_exception("The rows attribute must be a positive integer if present")
+ if ( $attrs->{rows} =~ /\D/ or $attrs->{rows} <= 0 );
}
- else {
- $self->throw_exception("rows attribute must be positive if present")
- if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
-
+ elsif ($attrs->{offset}) {
# MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
+ $attrs->{rows} = $sql_maker->__max_int;
}
my @limit;
# limited collapsing has_many
( $attrs->{rows} && $attrs->{collapse} )
||
- # limited prefetch with RNO subqueries
- (
- $attrs->{rows}
- &&
- $sql_maker->limit_dialect eq 'RowNumberOver'
- &&
- $attrs->{_prefetch_select}
- &&
- @{$attrs->{_prefetch_select}}
- )
- ||
- # grouped prefetch
+ # grouped prefetch (to satisfy group_by == select)
( $attrs->{group_by}
&&
@{$attrs->{group_by}}
&&
- $attrs->{_prefetch_select}
- &&
- @{$attrs->{_prefetch_select}}
+ $attrs->{_prefetch_selector_range}
)
) {
($ident, $select, $where, $attrs)
= $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
}
-
- elsif (
- ($attrs->{rows} || $attrs->{offset})
- &&
- $sql_maker->limit_dialect eq 'RowNumberOver'
- &&
- (ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
- &&
- scalar $self->_parse_order_by ($attrs->{order_by})
- ) {
- # the RNO limit dialect above mangles the SQL such that the join gets lost
- # wrap a subquery here
-
- push @limit, delete @{$attrs}{qw/rows offset/};
-
- my $subq = $self->_select_args_to_query (
- $ident,
- $select,
- $where,
- $attrs,
- );
-
- $ident = {
- -alias => $attrs->{alias},
- -source_handle => $ident->[0]{-source_handle},
- $attrs->{alias} => $subq,
- };
-
- # all part of the subquery now
- delete @{$attrs}{qw/order_by group_by having/};
- $where = undef;
- }
-
elsif (! $attrs->{software_limit} ) {
- push @limit, $attrs->{rows}, $attrs->{offset};
+ push @limit, (
+ $attrs->{rows} || (),
+ $attrs->{offset} || (),
+ );
}
# try to simplify the joinmap further (prune unreferenced type-single joins)
# invoked, and that's just bad...
###
- my $order = { map
- { $attrs->{$_} ? ( $_ => $attrs->{$_} ) : () }
- (qw/order_by group_by having/ )
- };
-
- return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit);
+ return ('select', $ident, $select, $where, $attrs, @limit);
}
# Returns a counting SELECT for a simple count
return { count => '*' };
}
-# Returns a SELECT which will end up in the subselect
-# There may or may not be a group_by, as the subquery
-# might have been called to accomodate a limit
-#
-# Most databases would be happy with whatever ends up
-# here, but some choke in various ways.
-#
-sub _subq_count_select {
- my ($self, $source, $rs_attrs) = @_;
-
- if (my $groupby = $rs_attrs->{group_by}) {
-
- my $avail_columns = $self->_resolve_column_info ($rs_attrs->{from});
-
- my $sel_index;
- for my $sel (@{$rs_attrs->{select}}) {
- if (ref $sel eq 'HASH' and $sel->{-as}) {
- $sel_index->{$sel->{-as}} = $sel;
- }
- }
-
- my @selection;
- for my $g_part (@$groupby) {
- if (ref $g_part or $avail_columns->{$g_part}) {
- push @selection, $g_part;
- }
- elsif ($sel_index->{$g_part}) {
- push @selection, $sel_index->{$g_part};
- }
- else {
- $self->throw_exception ("group_by criteria '$g_part' not contained within current resultset source(s)");
- }
- }
-
- return \@selection;
- }
-
- my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns);
- return @pcols ? \@pcols : [ 1 ];
-}
-
sub source_bind_attributes {
- my ($self, $source) = @_;
-
- my $bind_attributes;
- foreach my $column ($source->columns) {
-
- my $data_type = $source->column_info($column)->{data_type} || '';
- $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
- if $data_type;
- }
-
- return $bind_attributes;
+ shift->throw_exception(
+ 'source_bind_attributes() was never meant to be a callable public method - '
+ .'please contact the DBIC dev-team and describe your use case so that a reasonable '
+ .'solution can be provided'
+ ."\nhttp://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT"
+ );
}
=head2 select
return @row;
}
-=head2 sth
-
-=over 4
+=head2 sql_limit_dialect
-=item Arguments: $sql
-
-=back
-
-Returns a L<DBI> sth (statement handle) for the supplied SQL.
+This is an accessor for the default SQL limit dialect used by a particular
+storage driver. Can be overridden by supplying an explicit L</limit_dialect>
+to L<DBIx::Class::Schema/connect>. For a list of available limit dialects
+see L<DBIx::Class::SQLMaker::LimitDialects>.
=cut
# XXX You would think RaiseError would make this impossible,
# but apparently that's not true :(
- $self->throw_exception($dbh->errstr) if !$sth;
+ $self->throw_exception(
+ $dbh->errstr
+ ||
+ sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
+ .'an exception and/or setting $dbh->errstr',
+ length ($sql) > 20
+ ? substr($sql, 0, 20) . '...'
+ : $sql
+ ,
+ 'DBD::' . $dbh->{Driver}{Name},
+ )
+ ) if !$sth;
$sth;
}
sub sth {
+ carp_unique 'sth was mistakenly marked/documented as public, stop calling it (will be removed before DBIC v0.09)';
+ shift->_sth(@_);
+}
+
+sub _sth {
my ($self, $sql) = @_;
$self->dbh_do('_dbh_sth', $sql); # retry over disconnects
}
if ($dbh->can('column_info')) {
my %result;
- eval {
+ my $caught;
+ try {
my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
$sth->execute();
$result{$col_name} = \%column_info;
}
+ } catch {
+ $caught = 1;
};
- return \%result if !$@ && scalar keys %result;
+ return \%result if !$caught && scalar keys %result;
}
my %result;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my $id = eval { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+ my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
return $id if defined $id;
}
# Check if placeholders are supported at all
-sub _placeholders_supported {
+sub _determine_supports_placeholders {
my $self = shift;
my $dbh = $self->_get_dbh;
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
# Check if placeholders bound to non-string types throw exceptions
#
-sub _typeless_placeholders_supported {
+sub _determine_supports_typeless_placeholders {
my $self = shift;
my $dbh = $self->_get_dbh;
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
# this specifically tests a bind that is NOT a string
$dbh->do('select 1 where 1 = ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
=head2 sqlt_type
=cut
sub is_datatype_numeric {
- my ($self, $dt) = @_;
+ #my ($self, $dt) = @_;
- return 0 unless $dt;
+ return 0 unless $_[1];
- return $dt =~ /^ (?:
+ $_[1] =~ /^ (?:
numeric | int(?:eger)? | (?:tiny|small|medium|big)int | dec(?:imal)? | real | float | double (?: \s+ precision)? | (?:big)?serial
) $/ix;
}
sub create_ddl_dir {
my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
- if(!$dir || !-d $dir) {
+ unless ($dir) {
carp "No directory given, using ./\n";
- $dir = "./";
+ $dir = './';
+ } else {
+ -d $dir
+ or
+ (require File::Path and File::Path::make_path ("$dir")) # make_path does not like objects (i.e. Path::Class::Dir)
+ or
+ $self->throw_exception(
+ "Failed to create '$dir': " . ($! || $@ || 'error unknown')
+ );
}
+
+ $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir);
+
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
$databases = [ $databases ] if(ref($databases) ne 'ARRAY');
my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
+ # FIXME replace this block when a proper sane sql parser is available
my $file;
open($file, "<$filename")
or $self->throw_exception("Can't open $filename ($!)");
data => $schema,
);
- my @ret;
- my $wa = wantarray;
- if ($wa) {
- @ret = $tr->translate;
- }
- else {
- $ret[0] = $tr->translate;
- }
-
- $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
- unless (@ret && defined $ret[0]);
-
- return $wa ? @ret : $ret[0];
+ return preserve_context {
+ $tr->translate
+ } after => sub {
+ $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+ unless defined $_[0];
+ };
}
+# FIXME deploy() currently does not accurately report sql errors
+# Will always return true while errors are warned
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
my $deploy = sub {
my $line = shift;
- return if($line =~ /^--/);
return if(!$line);
+ return if($line =~ /^--/);
# next if($line =~ /^DROP/m);
return if($line =~ /^BEGIN TRANSACTION/m);
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- eval {
+ try {
# do a dbh_do cycle here, as we need some error checking in
# place (even though we will ignore errors)
$self->dbh_do (sub { $_[1]->do($line) });
+ } catch {
+ carp qq{$_ (running "${line}")};
};
- if ($@) {
- carp qq{$@ (running "${line}")};
- }
$self->_query_end($line);
};
my @statements = $schema->deployment_statements($type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
}
}
elsif (@statements == 1) {
- foreach my $line ( split(";\n", $statements[0])) {
+ # split on single line comments and end of statements
+ foreach my $line ( split(/\s*--.*\n|;\n/, $statements[0])) {
$deploy->( $line );
}
}
=head2 datetime_parser_type
-Defines (returns) the datetime parser class - currently hardwired to
-L<DateTime::Format::MySQL>
-
-=cut
-
-sub datetime_parser_type { "DateTime::Format::MySQL"; }
+Defines the datetime parser class - currently defaults to L<DateTime::Format::MySQL>
=head2 build_datetime_parser
sub build_datetime_parser {
my $self = shift;
my $type = $self->datetime_parser_type(@_);
- $self->ensure_class_loaded ($type);
return $type;
}
return $alias;
}
-sub DESTROY {
- my $self = shift;
+# The size in bytes to use for DBI's ->bind_param_inout, this is the generic
+# version and it may be necessary to amend or override it for a specific storage
+# if such binds are necessary.
+sub _max_column_bytesize {
+ my ($self, $attr) = @_;
- $self->_verify_pid if $self->_dbh;
+ my $max_size;
- # some databases need this to stop spewing warnings
- if (my $dbh = $self->_dbh) {
- local $@;
- eval {
- %{ $dbh->{CachedKids} } = ();
- $dbh->disconnect;
- };
+ if ($attr->{sqlt_datatype}) {
+ my $data_type = lc($attr->{sqlt_datatype});
+
+ if ($attr->{sqlt_size}) {
+
+ # String/sized-binary types
+ if ($data_type =~ /^(?:
+ l? (?:var)? char(?:acter)? (?:\s*varying)?
+ |
+ (?:var)? binary (?:\s*varying)?
+ |
+ raw
+ )\b/x
+ ) {
+ $max_size = $attr->{sqlt_size};
+ }
+ # Other charset/unicode types, assume scale of 4
+ elsif ($data_type =~ /^(?:
+ national \s* character (?:\s*varying)?
+ |
+ nchar
+ |
+ univarchar
+ |
+ nvarchar
+ )\b/x
+ ) {
+ $max_size = $attr->{sqlt_size} * 4;
+ }
+ }
+
+ if (!$max_size and !$self->_is_lob_type($data_type)) {
+ $max_size = 100 # for all other (numeric?) datatypes
+ }
}
- $self->_dbh(undef);
+ $max_size || $self->_dbic_connect_attributes->{LongReadLen} || $self->_get_dbh->{LongReadLen} || 8000;
+}
+
+# Determine if a data_type is some type of BLOB
+sub _is_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /lob|bfile|text|image|bytea|memo/i
+ || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary
+ |varchar|character\s*varying|nvarchar
+ |national\s*character\s*varying))?\z/xi);
+}
+
+sub _is_binary_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /blob|bfile|image|bytea/i
+ || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary))?\z/xi);
+}
+
+sub _is_text_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /^(?:clob|memo)\z/i
+ || $data_type =~ /^long(?:\s+(?:varchar|character\s*varying|nvarchar
+ |national\s*character\s*varying))\z/xi);
}
1;
DBIx::Class can do some wonderful magic with handling exceptions,
disconnections, and transactions when you use C<< AutoCommit => 1 >>
-(the default) combined with C<txn_do> for transaction support.
+(the default) combined with L<txn_do|DBIx::Class::Storage/txn_do> for
+transaction support.
If you set C<< AutoCommit => 0 >> in your connect info, then you are always
in an assumed transaction between commits, and you're telling us you'd
--- /dev/null
+package DBIx::Class::Storage::DBI::ACCESS;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::UniqueIdentifier';
+use mro 'c3';
+
+use DBI ();
+use List::Util 'first';
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('Top');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::ACCESS');
+__PACKAGE__->sql_quote_char ([qw/[ ]/]);
+
+sub sqlt_type { 'ACCESS' }
+
+__PACKAGE__->new_guid(undef);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ACCESS - Support specific to MS Access
+
+=head1 DESCRIPTION
+
+This is the base class for Microsoft Access support.
+
+This driver supports L<last_insert_id|DBIx::Class::Storage::DBI/last_insert_id>,
+empty inserts for tables with C<AUTOINCREMENT> columns, nested transactions via
+L<auto_savepoint|DBIx::Class::Storage::DBI/auto_savepoint>, C<GUID> columns via
+L<DBIx::Class::Storage::DBI::UniqueIdentifier>.
+
+=head1 SUPPORTED VERSIONS
+
+This module has currently only been tested on MS Access 2010.
+
+Information about how well it works on different version of MS Access is welcome
+(write the mailing list, or submit a ticket to RT if you find bugs.)
+
+=head1 USING GUID COLUMNS
+
+If you have C<GUID> PKs or other C<GUID> columns with
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> you will need to set a
+L<new_guid|DBIx::Class::Storage::DBI::UniqueIdentifier/new_guid> callback, like
+so:
+
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+Under L<Catalyst> you can use code similar to this in your
+L<Catalyst::Model::DBIC::Schema> C<Model.pm>:
+
+ after BUILD => sub {
+ my $self = shift;
+ $self->storage->new_guid(sub { Data::GUID->new->as_string });
+ };
+
+=cut
+
+sub _dbh_last_insert_id { $_[1]->selectrow_array('select @@identity') }
+
+# support empty insert
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $columns_info = $source->columns_info;
+
+ if (keys %$to_insert == 0) {
+ my $autoinc_col = first {
+ $columns_info->{$_}{is_auto_increment}
+ } keys %$columns_info;
+
+ if (not $autoinc_col) {
+ $self->throw_exception(
+'empty insert only supported for tables with an autoincrement column'
+ );
+ }
+
+ my $table = $source->from;
+ $table = $$table if ref $table;
+
+ $to_insert->{$autoinc_col} = \"dmax('${autoinc_col}', '${table}')+1";
+ }
+
+ return $self->next::method(@_);
+}
+
+sub bind_attribute_by_data_type {
+ my $self = shift;
+ my ($data_type) = @_;
+
+ my $attributes = $self->next::method(@_) || {};
+
+ if ($self->_is_text_lob_type($data_type)) {
+ $attributes->{TYPE} = DBI::SQL_LONGVARCHAR;
+ }
+ elsif ($self->_is_binary_lob_type($data_type)) {
+ $attributes->{TYPE} = DBI::SQL_LONGVARBINARY;
+ }
+
+ return $attributes;
+}
+
+# savepoints are not supported, but nested transactions are.
+# Unfortunately DBI does not support nested transactions.
+# WARNING: this code uses the undocumented 'BegunWork' DBI attribute.
+
+sub _exec_svp_begin {
+ my ($self, $name) = @_;
+
+ local $self->_dbh->{AutoCommit} = 1;
+ local $self->_dbh->{BegunWork} = 0;
+ $self->_exec_txn_begin;
+}
+
+# A new nested transaction on the same level releases the previous one.
+sub _exec_svp_release { 1 }
+
+sub _exec_svp_rollback {
+ my ($self, $name) = @_;
+
+ local $self->_dbh->{AutoCommit} = 0;
+ local $self->_dbh->{BegunWork} = 1;
+ $self->_exec_txn_rollback;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
-package # hide from PAUSE
- DBIx::Class::Storage::DBI::ADO;
+package DBIx::Class::Storage::DBI::ADO;
use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
+
+use Sub::Name;
+use Try::Tiny;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO - Support for L<DBD::ADO>
+
+=head1 DESCRIPTION
+
+This class provides a mechanism for discovering and loading a sub-class
+for a specific ADO backend, as well as some workarounds for L<DBD::ADO>. It
+should be transparent to the user.
+
+=cut
sub _rebless {
my $self = shift;
-# check for MSSQL
-# XXX This should be using an OpenSchema method of some sort, but I don't know
-# how.
-# Current version is stolen from Sybase.pm
- my $dbtype = eval {
- @{$self->_get_dbh
- ->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})
- }[2]
+ my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME');
+
+ if (not $dbtype) {
+ warn "Unable to determine ADO driver, failling back to generic support.\n";
+ return;
+ }
+
+ $dbtype =~ s/\W/_/gi;
+
+ my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
+
+ return if $self->isa($subclass);
+
+ if ($self->load_optional_class($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
+ }
+ else {
+ warn "Expected driver '$subclass' not found, using generic support. " .
+ "Please file an RT.\n";
+ }
+}
+
+# cleanup some warnings from DBD::ADO
+# RT#65563, not fixed as of DBD::ADO v2.98
+sub _dbh_get_info {
+ my $self = shift;
+
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_)
+ unless $_[0] =~ m{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm};
};
- unless ($@) {
- $dbtype =~ s/\W/_/gi;
- my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
+ $self->next::method(@_);
+}
+
+# Monkeypatch out the horrible warnings during global destruction.
+# A patch to DBD::ADO has been submitted as well, and it was fixed
+# as of 2.99
+# https://rt.cpan.org/Ticket/Display.html?id=65563
+sub _init {
+ unless ($DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__) {
+ require DBD::ADO;
+
+ unless (try { DBD::ADO->VERSION('2.99'); 1 }) {
+ no warnings 'redefine';
+ my $disconnect = *DBD::ADO::db::disconnect{CODE};
+
+ *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_)
+ unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
+ };
+ $disconnect->(@_);
+ };
}
+
+ $DBD::ADO::__DBIC_MONKEYPATCH_CHECKED__ = 1;
}
}
#}
1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::CursorUtils;
+
+use strict;
+use warnings;
+use base 'Exporter';
+
+our @EXPORT_OK = qw/_normalize_guids _strip_trailing_binary_nulls/;
+
+sub _strip_trailing_binary_nulls {
+ my ($select, $col_infos, $data) = @_;
+
+ foreach my $select_idx (0..$#$select) {
+
+ next unless defined $data->[$select_idx];
+
+ my $data_type = $col_infos->{$select->[$select_idx]}{data_type}
+ or next;
+
+ $data->[$select_idx] =~ s/\0+\z//
+ if $data_type =~ /binary|image/i;
+ }
+}
+
+sub _normalize_guids {
+ my ($select, $col_infos, $data, $storage) = @_;
+
+ foreach my $select_idx (0..$#$select) {
+
+ next unless defined $data->[$select_idx];
+
+ my $data_type = $col_infos->{$select->[$select_idx]}{data_type}
+ or next;
+
+ $data->[$select_idx] =~ s/\A \{ (.+) \} \z/$1/xs
+ if $storage->_is_guid_type($data_type);
+ }
+}
+
+1;
+
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::MS_Jet;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Storage::DBI::ADO
+ DBIx::Class::Storage::DBI::ACCESS
+/;
+use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids';
+use namespace::clean;
+
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::MS_Jet - Support for MS Access over ADO
+
+=head1 DESCRIPTION
+
+This driver is a subclass of L<DBIx::Class::Storage::DBI::ADO> and
+L<DBIx::Class::Storage::DBI::ACCESS> for connecting to MS Access via
+L<DBD::ADO>.
+
+See the documentation for L<DBIx::Class::Storage::DBI::ACCESS> for
+information on the MS Access driver for L<DBIx::Class>.
+
+This driver implements workarounds for C<TEXT/IMAGE/MEMO> columns, sets the
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor> to normalize returned
+C<GUID> values and provides L<DBIx::Class::InflateColumn::DateTime> support
+for C<DATETIME> columns.
+
+=head1 EXAMPLE DSNs
+
+ # older Access versions:
+ dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb
+
+ # newer Access versions:
+ dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False'
+
+=head1 TEXT/IMAGE/MEMO COLUMNS
+
+The ADO driver does not suffer from the
+L<problems|DBIx::Class::Storage::DBI::ODBC::ACCESS/"TEXT/IMAGE/MEMO COLUMNS">
+the L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver has with these types
+of columns. You can use them safely.
+
+When you execute a C<CREATE TABLE> statement over this driver with a C<TEXT>
+column, it will be converted to C<MEMO>, while in the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver it is converted to
+C<VARCHAR(255)>.
+
+However, the caveat about L<LongReadLen|DBI/LongReadLen> having to be twice the
+max size of your largest C<MEMO/TEXT> column C<+1> still applies. L<DBD::ADO>
+sets L<LongReadLen|DBI/LongReadLen> to a large value by default, so it should be
+safe to just leave it unset. If you do pass a L<LongReadLen|DBI/LongReadLen> in
+your L<connect_info|DBIx::Class::Storage::DBI/connect_info>, it will be
+multiplied by two and C<1> added, just as for the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver.
+
+=cut
+
+# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO)
+sub _run_connection_actions {
+ my $self = shift;
+
+ my $long_read_len = $self->_dbh->{LongReadLen};
+
+# This is the DBD::ADO default.
+ if ($long_read_len != 2147483647) {
+ $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
+ }
+
+ return $self->next::method(@_);
+}
+
+# AutoCommit does not get reset properly after transactions for some reason
+# (probably because of my nested transaction hacks in ACCESS.pm) fix it up
+# here.
+
+sub _exec_txn_commit {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_dbh->{AutoCommit} = $self->_dbh_autocommit
+ if $self->{transaction_depth} == 1;
+}
+
+sub _exec_txn_rollback {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_dbh->{AutoCommit} = $self->_dbh_autocommit
+ if $self->{transaction_depth} == 1;
+}
+
+# Fix up GUIDs for ->find, for cursors see the cursor_class above.
+
+sub select_single {
+ my $self = shift;
+ my ($ident, $select) = @_;
+
+ my @row = $self->next::method(@_);
+
+ return @row unless
+ $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
+
+ my $col_infos = $self->_resolve_column_info($ident);
+
+ _normalize_guids($select, $col_infos, \@row, $self);
+
+ return @row;
+}
+
+sub datetime_parser_type {
+ 'DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format'
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format;
+
+my $datetime_format = '%m/%d/%Y %I:%M:%S %p';
+my $datetime_parser;
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids';
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor - GUID Support for MS Access over
+ADO
+
+=head1 DESCRIPTION
+
+This class is for normalizing GUIDs retrieved from Microsoft Access over ADO.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::ACCESS> for information on the Microsoft
+Access driver.
+
+Unfortunately when using L<DBD::ADO>, GUIDs come back wrapped in braces, the
+purpose of this class is to remove them.
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by default.
+It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> safely with this class and not lose
+the GUID normalizing functionality,
+L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data
+for the inner cursor class.
+
+=cut
+
+sub _dbh_next {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @row = $next->(@_);
+
+ my $col_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ _normalize_guids($select, $col_infos, \@row, $storage);
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ _normalize_guids($select, $col_infos, $_, $storage) for @rows;
+
+ return @rows;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+# vim:sts=2 sw=2:
DBIx::Class::Storage::DBI::MSSQL
/;
use mro 'c3';
+use DBIx::Class::Carp;
+use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/;
+use namespace::clean;
-sub _rebless {
+__PACKAGE__->cursor_class(
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor'
+);
+
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format'
+);
+
+__PACKAGE__->new_guid(sub {
+ my $self = shift;
+ my $guid = $self->_get_dbh->selectrow_array('SELECT NEWID()');
+ $guid =~ s/\A \{ (.+) \} \z/$1/xs;
+ return $guid;
+});
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
+SQL Server via DBD::ADO
+
+=head1 SYNOPSIS
+
+This subclass supports MSSQL server connections via L<DBD::ADO>.
+
+=head1 DESCRIPTION
+
+The MSSQL specific functionality is provided by
+L<DBIx::Class::Storage::DBI::MSSQL>.
+
+=head1 EXAMPLE DSN
+
+ dbi:ADO:provider=sqlncli10;server=EEEBOX\SQLEXPRESS
+
+=head1 CAVEATS
+
+=head2 identities
+
+C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
+with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
+for caveats regarding this.
+
+=head2 truncation bug
+
+There is a bug with MSSQL ADO providers where data gets truncated based on the
+size of the bind sizes in the first prepare call:
+
+L<https://rt.cpan.org/Ticket/Display.html?id=52048>
+
+The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
+approximate maximum size of the data_type of the bound column, or 8000 (maximum
+VARCHAR size) if the data_type is not available.
+
+Please report problems with this driver and send patches.
+
+=head2 LongReadLen
+
+C<LongReadLen> is set to C<LongReadLen * 2 + 1> on connection as it is necessary
+for some LOB types. Be aware of this if you localize this value on the C<$dbh>
+directly.
+
+=head2 binary data
+
+Due perhaps to the ado_size workaround we use, and/or other reasons, binary data
+such as C<varbinary> column data comes back padded with trailing C<NULL> chars.
+The Cursor class for this driver
+(L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) removes them,
+of course if your binary data is actually C<NULL> padded that may be an issue to
+keep in mind when using this driver.
+
+=head2 uniqueidentifier columns
+
+uniqueidentifier columns come back from ADO wrapped in braces and must be
+submitted to the MSSQL ADO driver wrapped in braces. We take care of this
+transparently in this driver and the associated Cursor class
+(L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) so that you
+don't have to use braces in most cases (except in literal SQL, in those cases
+you will have to add the braces yourself.)
+
+=head2 fractional seconds
+
+Fractional seconds with L<DBIx::Class::InflateColumn::DateTime> are not
+currently supported, datetimes are truncated at the second.
+
+=cut
+
+sub _init {
my $self = shift;
+
+# SCOPE_IDENTITY() doesn't work
$self->_identity_method('@@identity');
+ $self->_no_scope_identity_query(1);
+
+ return $self->next::method(@_);
+}
+
+sub _run_connection_actions {
+ my $self = shift;
+
+# make transactions work
+ require DBD::ADO::Const;
+ $self->_dbh->{ado_conn}{CursorLocation} =
+ DBD::ADO::Const->Enums->{CursorLocationEnum}{adUseClient};
+
+# set LongReadLen = LongReadLen * 2 + 1
+# this may need to be in ADO.pm, being conservative for now...
+ my $long_read_len = $self->_dbh->{LongReadLen};
+
+# This is the DBD::ADO default.
+ if ($long_read_len != 2147483647) {
+ $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
+ }
+
+ return $self->next::method(@_);
+}
+
+
+# Fix up binary data and GUIDs for ->find, for cursors see the cursor_class
+# above.
+sub select_single {
+ my $self = shift;
+ my ($ident, $select) = @_;
+
+ my @row = $self->next::method(@_);
+
+ return @row unless $self->cursor_class->isa(
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor'
+ );
+
+ my $col_infos = $self->_resolve_column_info($ident);
+
+ _normalize_guids($select, $col_infos, \@row, $self);
+
+ _strip_trailing_binary_nulls($select, $col_infos, \@row);
+
+ return @row;
}
-sub source_bind_attributes {
+# We need to catch VARCHAR(max) before bind_attribute_by_data_type because it
+# could be specified by size, also if bind_attribute_by_data_type fails we want
+# to specify the default ado_size of 8000.
+# Also make sure GUID binds have braces on them or else ADO throws an "Invalid
+# character value for cast specification"
+
+sub _dbi_attrs_for_bind {
my $self = shift;
- my ($source) = @_;
+ my ($ident, $bind) = @_;
+
+ my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
+
+ foreach my $bind (@$bind) {
+ my $attrs = $bind->[0];
+ my $data_type = $attrs->{sqlt_datatype};
+ my $size = $attrs->{sqlt_size};
+
+ if ($size && lc($size) eq 'max') {
+ if ($data_type =~ /^(?:varchar|character varying|nvarchar|national char varying|national character varying|varbinary)\z/i) {
+ $attrs->{dbd_attrs} = { ado_size => $lob_max };
+ }
+ else {
+ carp_unique "bizarre data_type '$data_type' with size => 'max'";
+ }
+ }
+
+ if ($self->_is_guid_type($data_type) && substr($bind->[1], 0, 1) ne '{') {
+ $bind->[1] = '{' . $bind->[1] . '}';
+ }
+ }
- my $bind_attributes = $self->next::method(@_);
+ my $attrs = $self->next::method(@_);
- foreach my $column ($source->columns) {
- $bind_attributes->{$column}{ado_size} ||= 8000; # max VARCHAR
+ foreach my $attr (@$attrs) {
+ $attr->{ado_size} ||= 8000 if $attr;
}
- return $bind_attributes;
+ return $attrs;
+}
+
+# Can't edit all the binds in _dbi_attrs_for_bind for insert_bulk, so we take
+# care of those GUIDs here.
+sub insert_bulk {
+ my $self = shift;
+ my ($source, $cols, $data) = @_;
+
+ my $columns_info = $source->columns_info($cols);
+
+ my $col_idx = 0;
+ foreach my $col (@$cols) {
+ if ($self->_is_guid_type($columns_info->{$col}{data_type})) {
+ foreach my $data_row (@$data) {
+ if (substr($data_row->[$col_idx], 0, 1) ne '{') {
+ $data_row->[$col_idx] = '{' . $data_row->[$col_idx] . '}';
+ }
+ }
+ }
+ $col_idx++;
+ }
+
+ return $self->next::method(@_);
}
sub bind_attribute_by_data_type {
my ($self, $data_type) = @_;
- ($data_type = lc($data_type)) =~ s/\s+.*//;
+ $data_type = lc $data_type;
my $max_size =
$self->_mssql_max_data_type_representation_size_in_bytes->{$data_type};
my $res = {};
- $res->{ado_size} = $max_size if $max_size;
+
+ if ($max_size) {
+ $res->{ado_size} = $max_size;
+ }
+ else {
+ carp_unique "could not map data_type '$data_type' to a max size for ado_size: defaulting to 8000";
+ }
return $res;
}
-# approximate
-# XXX needs to support varchar(max) and varbinary(max)
+# FIXME This list is an abomination. We need a way to do this outside
+# of the scope of DBIC, as as it is right now nobody will ever think to
+# even look here to diagnose some sort of misbehavior.
sub _mssql_max_data_type_representation_size_in_bytes {
my $self = shift;
- my $blob_max = $self->_get_dbh->{LongReadLen} || 32768;
+ my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
return +{
# MSSQL types
char => 8000,
+ character => 8000,
varchar => 8000,
+ 'varchar(max)' => $lob_max,
+ 'character varying' => 8000,
binary => 8000,
varbinary => 8000,
- nchar => 8000,
- nvarchar => 8000,
+ 'varbinary(max)' => $lob_max,
+ nchar => 16000,
+ 'national character' => 16000,
+ 'national char' => 16000,
+ nvarchar => 16000,
+ 'nvarchar(max)' => ($lob_max*2),
+ 'national character varying' => 16000,
+ 'national char varying' => 16000,
numeric => 100,
smallint => 100,
tinyint => 100,
bigint => 100,
bit => 100,
decimal => 100,
+ dec => 100,
integer => 100,
int => 100,
+ 'int identity' => 100,
+ 'integer identity' => 100,
money => 100,
float => 100,
+ double => 100,
+ 'double precision' => 100,
real => 100,
uniqueidentifier => 100,
- ntext => $blob_max,
- text => $blob_max,
- image => $blob_max,
+ ntext => $lob_max,
+ text => $lob_max,
+ image => $lob_max,
date => 100,
datetime => 100,
datetime2 => 100,
timestamp => 100,
cursor => 100,
hierarchyid => 100,
+ rowversion => 100,
sql_variant => 100,
- table => 100,
- xml => $blob_max, # ???
-
-# some non-MSSQL types
+ table => $lob_max,
+ xml => $lob_max,
+
+# mysql types
+ bool => 100,
+ boolean => 100,
+ 'tinyint unsigned' => 100,
+ 'smallint unsigned' => 100,
+ 'mediumint unsigned' => 100,
+ 'int unsigned' => 100,
+ 'integer unsigned' => 100,
+ 'bigint unsigned' => 100,
+ 'float unsigned' => 100,
+ 'double unsigned' => 100,
+ 'double precision unsigned' => 100,
+ 'decimal unsigned' => 100,
+ 'fixed' => 100,
+ 'year' => 100,
+ tinyblob => $lob_max,
+ tinytext => $lob_max,
+ blob => $lob_max,
+ text => $lob_max,
+ mediumblob => $lob_max,
+ mediumtext => $lob_max,
+ longblob => $lob_max,
+ longtext => $lob_max,
+ enum => 100,
+ set => 8000,
+
+# Pg types
serial => 100,
bigserial => 100,
+ int8 => 100,
+ integer8 => 100,
+ serial8 => 100,
+ int4 => 100,
+ integer4 => 100,
+ serial4 => 100,
+ int2 => 100,
+ integer2 => 100,
+ float8 => 100,
+ float4 => 100,
+ 'bit varying' => 8000,
+ 'varbit' => 8000,
+ inet => 100,
+ cidr => 100,
+ macaddr => 100,
+ 'time without time zone' => 100,
+ 'time with time zone' => 100,
+ 'timestamp without time zone' => 100,
+ 'timestamp with time zone' => 100,
+ bytea => $lob_max,
+
+# DB2 types
+ graphic => 8000,
+ vargraphic => 8000,
+ 'long vargraphic' => $lob_max,
+ dbclob => $lob_max,
+ clob => $lob_max,
+ 'char for bit data' => 8000,
+ 'varchar for bit data' => 8000,
+ 'long varchar for bit data' => $lob_max,
+
+# oracle types
varchar2 => 8000,
- blob => $blob_max,
- clob => $blob_max,
+ binary_float => 100,
+ binary_double => 100,
+ raw => 8000,
+ nclob => $lob_max,
+ long => $lob_max,
+ 'long raw' => $lob_max,
+ 'timestamp with local time zone' => 100,
+
+# Sybase ASE types
+ unitext => $lob_max,
+ unichar => 16000,
+ univarchar => 16000,
+
+# SQL Anywhere types
+ 'long varbit' => $lob_max,
+ 'long bit varying' => $lob_max,
+ uniqueidentifierstr => 100,
+ 'long binary' => $lob_max,
+ 'long varchar' => $lob_max,
+ 'long nvarchar' => $lob_max,
+
+# Firebird types
+ 'char(x) character set unicode_fss' => 16000,
+ 'varchar(x) character set unicode_fss' => 16000,
+ 'blob sub_type text' => $lob_max,
+ 'blob sub_type text character set unicode_fss' => $lob_max,
+
+# Informix types
+ smallfloat => 100,
+ byte => $lob_max,
+ lvarchar => 8000,
+ 'datetime year to fraction(5)' => 100,
+ # FIXME add other datetime types
+
+# MS Access types
+ autoincrement => 100,
+ long => 100,
+ integer4 => 100,
+ integer2 => 100,
+ integer1 => 100,
+ logical => 100,
+ logical1 => 100,
+ yesno => 100,
+ currency => 100,
+ single => 100,
+ ieeesingle => 100,
+ ieeedouble => 100,
+ number => 100,
+ string => 8000,
+ guid => 100,
+ longchar => $lob_max,
+ memo => $lob_max,
+ longbinary => $lob_max,
}
}
-1;
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server - Support for Microsoft
-SQL Server via DBD::ADO
-
-=head1 SYNOPSIS
-
-This subclass supports MSSQL server connections via L<DBD::ADO>.
-
-=head1 DESCRIPTION
-
-The MSSQL specific functionality is provided by
-L<DBIx::Class::Storage::DBI::MSSQL>.
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format;
-=head2 CAVEATS
+my $datetime_format = '%m/%d/%Y %I:%M:%S %p';
+my $datetime_parser;
-=head3 identities
-
-C<_identity_method> is set to C<@@identity>, as C<SCOPE_IDENTITY()> doesn't work
-with L<DBD::ADO>. See L<DBIx::Class::Storage::DBI::MSSQL/IMPLEMENTATION NOTES>
-for caveats regarding this.
-
-=head3 truncation bug
-
-There is a bug with MSSQL ADO providers where data gets truncated based on the
-size of the bind sizes in the first prepare call:
-
-L<https://rt.cpan.org/Ticket/Display.html?id=52048>
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
-The C<ado_size> workaround is used (see L<DBD::ADO/"ADO Providers">) with the
-approximate maximum size of the data_type of the bound column, or 8000 (maximum
-VARCHAR size) if the data_type is not available.
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
-This code is incomplete and may be buggy. Particularly, C<VARCHAR(MAX)> is not
-supported yet. The data_type list for other DBs is also incomplete. Please
-report problems (and send patches.)
+1;
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor - Remove trailing
+NULLs in binary data and normalize GUIDs for MSSQL over ADO
+
+=head1 DESCRIPTION
+
+This class is for removing trailing C<NULL>s from binary data and removing braces
+from GUIDs retrieved from Microsoft SQL Server over ADO.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server> for information on the
+Microsoft SQL Server driver for ADO and L<DBIx::Class::Storage::DBI::MSSQL> for
+the Microsoft SQL Server driver base class.
+
+Unfortunately when using L<DBD::ADO>, binary data comes back padded with
+trailing C<NULL>s and GUIDs come back wrapped in braces, the purpose of this
+class is to remove the C<NULL>s and braces.
+L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by
+default. It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> safely with this class and not lose
+the binary data normalizing functionality,
+L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data
+for the inner cursor class.
+
+=cut
+
+sub _dbh_next {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @row = $next->(@_);
+
+ my $col_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ _normalize_guids($select, $col_infos, \@row, $storage);
+ _strip_trailing_binary_nulls($select, $col_infos, \@row);
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for (@rows) {
+ _normalize_guids($select, $col_infos, $_, $storage);
+ _strip_trailing_binary_nulls($select, $col_infos, $_);
+ }
+
+ return @rows;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+# vim:sts=2 sw=2:
CAST(? as $mapped_type)
-This option can also be enabled in L<DBIx::Class::Storage::DBI/connect_info> as:
+This option can also be enabled in
+L<connect_info|DBIx::Class::Storage::DBI/connect_info> as:
on_connect_call => ['set_auto_cast']
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
my ($sql, $bind) = $self->next::method (@_);
# gets skippeed.
if ($self->auto_cast && @$bind) {
my $new_sql;
- my @sql_part = split /\?/, $sql;
- my $col_info = $self->_resolve_column_info($ident,[ map $_->[0], @$bind ]);
-
- foreach my $bound (@$bind) {
- my $col = $bound->[0];
- my $type = $self->_native_data_type($col_info->{$col}{data_type});
-
- foreach my $data (@{$bound}[1..$#$bound]) {
- $new_sql .= shift(@sql_part) .
- ($type ? "CAST(? AS $type)" : '?');
- }
+ my @sql_part = split /\?/, $sql, scalar @$bind + 1;
+ for (@$bind) {
+ my $cast_type = $self->_native_data_type($_->[0]{sqlt_datatype});
+ $new_sql .= shift(@sql_part) . ($cast_type ? "CAST(? AS $cast_type)" : '?');
}
- $new_sql .= join '', @sql_part;
- $sql = $new_sql;
+ $sql = $new_sql . shift @sql_part;
}
return ($sql, $bind);
on_connect_call => ['set_auto_cast']
-in L<DBIx::Class::Storage::DBI/connect_info>.
+in L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
=cut
use base qw/DBIx::Class::Cursor/;
+use Try::Tiny;
+use namespace::clean;
+
__PACKAGE__->mk_group_accessors('simple' =>
- qw/sth/
+ qw/sth storage args pos attrs _dbh_gen/
);
=head1 NAME
my ($self) = @_;
# No need to care about failures here
- eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
+ try { $self->sth->finish }
+ if $self->sth && $self->sth->{Active};
$self->_soft_reset;
return undef;
}
}
sub DESTROY {
- my ($self) = @_;
-
# None of the reasons this would die matter if we're in DESTROY anyways
- local $@;
- eval { $self->sth->finish if $self->sth && $self->sth->{Active} };
+ if (my $sth = $_[0]->sth) {
+ local $SIG{__WARN__} = sub {};
+ try { $sth->finish } if $sth->FETCH('Active');
+ }
}
1;
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
+__PACKAGE__->datetime_parser_type('DateTime::Format::DB2');
+__PACKAGE__->sql_quote_char ('"');
+
+# lazy-default kind of thing
+sub sql_name_sep {
+ my $self = shift;
- my $sth = $dbh->prepare_cached('VALUES(IDENTITY_VAL_LOCAL())', {}, 3);
- $sth->execute();
+ my $v = $self->next::method(@_);
- my @res = $sth->fetchrow_array();
+ if (! defined $v and ! @_) {
+ $v = $self->next::method($self->_dbh_get_info('SQL_QUALIFIER_NAME_SEPARATOR') || '.');
+ }
- return @res ? $res[0] : undef;
+ return $v;
}
-sub datetime_parser_type { "DateTime::Format::DB2"; }
+sub sql_limit_dialect {
+ my $self = shift;
-sub _sql_maker_opts {
- my ( $self, $opts ) = @_;
+ my $v = $self->next::method(@_);
- if ( $opts ) {
- $self->{_sql_maker_opts} = { %$opts };
- }
+ if (! defined $v and ! @_) {
+ $v = $self->next::method(
+ ($self->_server_info->{normalized_dbms_version}||0) >= 5.004
+ ? 'RowNumberOver'
+ : 'FetchFirst'
+ );
+ }
- return { limit_dialect => 'RowNumberOver', %{$self->{_sql_maker_opts}||{}} };
+ return $v;
}
-1;
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
-=head1 NAME
+ my $name_sep = $self->sql_name_sep;
+
+ my $sth = $dbh->prepare_cached(
+ # An older equivalent of 'VALUES(IDENTITY_VAL_LOCAL())', for compat
+ # with ancient DB2 versions. Should work on modern DB2's as well:
+ # http://publib.boulder.ibm.com/infocenter/db2luw/v8/topic/com.ibm.db2.udb.doc/admin/r0002369.htm?resultof=%22%73%79%73%64%75%6d%6d%79%31%22%20
+ "SELECT IDENTITY_VAL_LOCAL() FROM sysibm${name_sep}sysdummy1",
+ {},
+ 3
+ );
+ $sth->execute();
-DBIx::Class::Storage::DBI::DB2 - Automatic primary key class for DB2
+ my @res = $sth->fetchrow_array();
-=head1 SYNOPSIS
+ return @res ? $res[0] : undef;
+}
+
+1;
+
+=head1 NAME
- # In your table classes
- use base 'DBIx::Class::Core';
- __PACKAGE__->set_primary_key('id');
+DBIx::Class::Storage::DBI::DB2 - IBM DB2 support for DBIx::Class
=head1 DESCRIPTION
-This class implements autoincrements for DB2.
+This class implements autoincrements for DB2, sets the limit dialect to
+RowNumberOver over FetchFirst depending on the availability of support for
+RowNumberOver, queries the server name_sep from L<DBI> and sets the L<DateTime>
+parser to L<DateTime::Format::DB2>.
-=head1 AUTHORS
+=head1 AUTHOR
-Jess Robinson
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::Firebird;
+
+use strict;
+use warnings;
+
+# Because DBD::Firebird is more or less a copy of
+# DBD::Interbase, inherit all the workarounds contained
+# in ::Storage::DBI::InterBase as opposed to inheriting
+# directly from ::Storage::DBI::Firebird::Common
+use base qw/DBIx::Class::Storage::DBI::InterBase/;
+
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Firebird - Driver for the Firebird RDBMS via
+L<DBD::Firebird>
+
+=head1 DESCRIPTION
+
+This is an empty subclass of L<DBIx::Class::Storage::DBI::InterBase> for use
+with L<DBD::Firebird>, see that driver for details.
+
+=cut
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::Firebird::Common;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use List::Util 'first';
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Firebird::Common - Driver Base Class for the Firebird RDBMS
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Firebird using C<RETURNING> as well as
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>, savepoints and server
+version detection.
+
+=cut
+
+# set default
+__PACKAGE__->_use_insert_returning (1);
+__PACKAGE__->sql_limit_dialect ('FirstSkip');
+__PACKAGE__->sql_quote_char ('"');
+
+sub _sequence_fetch {
+ my ($self, $nextval, $sequence) = @_;
+
+ $self->throw_exception("Can only fetch 'nextval' for a sequence")
+ if $nextval !~ /^nextval$/i;
+
+ $self->throw_exception('No sequence to fetch') unless $sequence;
+
+ my ($val) = $self->_get_dbh->selectrow_array(sprintf
+ 'SELECT GEN_ID(%s, 1) FROM rdb$database',
+ $self->sql_maker->_quote($sequence)
+ );
+
+ return $val;
+}
+
+sub _dbh_get_autoinc_seq {
+ my ($self, $dbh, $source, $col) = @_;
+
+ my $table_name = $source->from;
+ $table_name = $$table_name if ref $table_name;
+ $table_name = $self->sql_maker->quote_char ? $table_name : uc($table_name);
+
+ local $dbh->{LongReadLen} = 100000;
+ local $dbh->{LongTruncOk} = 1;
+
+ my $sth = $dbh->prepare(<<'EOF');
+SELECT t.rdb$trigger_source
+FROM rdb$triggers t
+WHERE t.rdb$relation_name = ?
+AND t.rdb$system_flag = 0 -- user defined
+AND t.rdb$trigger_type = 1 -- BEFORE INSERT
+EOF
+ $sth->execute($table_name);
+
+ while (my ($trigger) = $sth->fetchrow_array) {
+ my @trig_cols = map {
+ /^"([^"]+)/ ? $1 : uc($1)
+ } $trigger =~ /new\.("?\w+"?)/ig;
+
+ my ($quoted, $generator) = $trigger =~
+/(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
+
+ if ($generator) {
+ $generator = uc $generator unless $quoted;
+
+ return $generator
+ if first {
+ $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
+ } @trig_cols;
+ }
+ }
+
+ return undef;
+}
+
+sub _exec_svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("SAVEPOINT $name");
+}
+
+sub _exec_svp_release {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("RELEASE SAVEPOINT $name");
+}
+
+sub _exec_svp_rollback {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
+}
+
+# http://www.firebirdfaq.org/faq223/
+sub _get_server_version {
+ my $self = shift;
+
+ return $self->_get_dbh->selectrow_array(q{
+SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database
+ });
+}
+
+1;
+
+=head1 CAVEATS
+
+=over 4
+
+=item *
+
+C<last_insert_id> support by default only works for Firebird versions 2 or
+greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
+work with earlier versions.
+
+=back
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::IdentityInsert;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
+
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::IdentityInsert - Storage Component for Sybase ASE and
+MSSQL for Identity Inserts / Updates
+
+=head1 DESCRIPTION
+
+This is a storage component for Sybase ASE
+(L<DBIx::Class::Storage::DBI::Sybase::ASE>) and Microsoft SQL Server
+(L<DBIx::Class::Storage::DBI::MSSQL>) to support identity inserts, that is
+inserts of explicit values into C<IDENTITY> columns.
+
+This is done by wrapping C<INSERT> operations in a pair of table identity
+toggles like:
+
+ SET IDENTITY_INSERT $table ON
+ $sql
+ SET IDENTITY_INSERT $table OFF
+
+=cut
+
+# SET IDENTITY_X only works as part of a statement scope. We can not
+# $dbh->do the $sql and the wrapping set()s individualy. Hence the
+# sql mangling. The newlines are important.
+sub _prep_for_execute {
+ my $self = shift;
+
+ return $self->next::method(@_) unless $self->_autoinc_supplied_for_op;
+
+ my ($op, $ident) = @_;
+
+ my $table = $self->sql_maker->_quote($ident->name);
+ $op = uc $op;
+
+ my ($sql, $bind) = $self->next::method(@_);
+
+ return (<<EOS, $bind);
+SET IDENTITY_$op $table ON
+$sql
+SET IDENTITY_$op $table OFF
+EOS
+
+}
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
-
use mro 'c3';
+use Scope::Guard ();
+use Context::Preserve 'preserve_context';
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('SkipFirst');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::Informix::DateTime::Format'
+);
+
+
__PACKAGE__->mk_group_accessors('simple' => '__last_insert_id');
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Informix - Base Storage Class for Informix Support
+
+=head1 DESCRIPTION
+
+This class implements storage-specific support for the Informix RDBMS
+
+=head1 METHODS
+
+=cut
+
sub _execute {
my $self = shift;
my ($op) = @_;
my ($rv, $sth, @rest) = $self->next::method(@_);
- if ($op eq 'insert') {
- $self->__last_insert_id($sth->{ix_sqlerrd}[1]);
- }
+
+ $self->__last_insert_id($sth->{ix_sqlerrd}[1])
+ if $self->_perform_autoinc_retrieval;
+
return (wantarray ? ($rv, $sth, @rest) : $rv);
}
shift->__last_insert_id;
}
-sub _sql_maker_opts {
- my ( $self, $opts ) = @_;
+sub _exec_svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("SAVEPOINT $name");
+}
+
+# can't release savepoints
+sub _exec_svp_release { 1 }
- if ( $opts ) {
- $self->{_sql_maker_opts} = { %$opts };
- }
+sub _exec_svp_rollback {
+ my ($self, $name) = @_;
- return { limit_dialect => 'SkipFirst', %{$self->{_sql_maker_opts}||{}} };
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
-1;
+sub with_deferred_fk_checks {
+ my ($self, $sub) = @_;
-__END__
+ my $txn_scope_guard = $self->txn_scope_guard;
-=head1 NAME
+ $self->_do_query('SET CONSTRAINTS ALL DEFERRED');
+
+ my $sg = Scope::Guard->new(sub {
+ $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE');
+ });
-DBIx::Class::Storage::DBI::Informix - Base Storage Class for INFORMIX Support
+ return preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
+}
-=head1 SYNOPSIS
+=head2 connect_call_datetime_setup
-=head1 DESCRIPTION
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the C<DATE> and
+C<DATETIME> formats.
+
+Sets the following environment variables:
+
+ GL_DATE="%m/%d/%Y"
+ GL_DATETIME="%Y-%m-%d %H:%M:%S%F5"
+
+The C<DBDATE> and C<DBCENTURY> environment variables are cleared.
-This class implements storage-specific support for Informix
+B<NOTE:> setting the C<GL_DATE> environment variable seems to have no effect
+after the process has started, so the default format is used. The C<GL_DATETIME>
+setting does take effect however.
+
+The C<DATETIME> data type supports up to 5 digits after the decimal point for
+second precision, depending on how you have declared your column. The full
+possible precision is used.
+
+The column declaration for a C<DATETIME> with maximum precision is:
+
+ column_name DATETIME YEAR TO FRACTION(5)
+
+The C<DATE> data type stores the date portion only, and it B<MUST> be declared
+with:
+
+ data_type => 'date'
+
+in your Result class.
+
+You will need the L<DateTime::Format::Strptime> module for inflation to work.
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+
+ delete @ENV{qw/DBDATE DBCENTURY/};
+
+ $ENV{GL_DATE} = "%m/%d/%Y";
+ $ENV{GL_DATETIME} = "%Y-%m-%d %H:%M:%S%F5";
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::Informix::DateTime::Format;
+
+my $timestamp_format = '%Y-%m-%d %H:%M:%S.%5N'; # %F %T
+my $date_format = '%m/%d/%Y';
+
+my ($timestamp_parser, $date_parser);
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->format_datetime(shift);
+}
+
+sub parse_date {
+ shift;
+ require DateTime::Format::Strptime;
+ $date_parser ||= DateTime::Format::Strptime->new(
+ pattern => $date_format,
+ on_error => 'croak',
+ );
+ return $date_parser->parse_datetime(shift);
+}
+
+sub format_date {
+ shift;
+ require DateTime::Format::Strptime;
+ $date_parser ||= DateTime::Format::Strptime->new(
+ pattern => $date_format,
+ on_error => 'croak',
+ );
+ return $date_parser->format_datetime(shift);
+}
+
+1;
-=head1 AUTHORS
+=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
--- /dev/null
+package DBIx::Class::Storage::DBI::InterBase;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::Firebird::Common/;
+use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::InterBase - Driver for the Firebird RDBMS via
+L<DBD::InterBase>
+
+=head1 DESCRIPTION
+
+This driver is a subclass of L<DBIx::Class::Storage::DBI::Firebird::Common> for
+use with L<DBD::InterBase>, see that driver for general details.
+
+You need to use either the
+L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> option or
+L</connect_call_use_softcommit> (see L</CAVEATS>) for your code to function
+correctly with this driver. Otherwise you will likely get bizarre error messages
+such as C<no statement executing>. The alternative is to use the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver, which is more suitable
+for long running processes such as under L<Catalyst>.
+
+To turn on L<DBIx::Class::InflateColumn::DateTime> support, see
+L</connect_call_datetime_setup>.
+
+=cut
+
+__PACKAGE__->datetime_parser_type(
+ 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format'
+);
+
+sub _ping {
+ my $self = shift;
+
+ my $dbh = $self->_dbh or return 0;
+
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
+
+ return try {
+ $dbh->do('select 1 from rdb$database');
+ 1;
+ } catch {
+ 0;
+ };
+}
+
+# We want dialect 3 for new features and quoting to work, DBD::InterBase uses
+# dialect 1 (interbase compat) by default.
+sub _init {
+ my $self = shift;
+ $self->_set_sql_dialect(3);
+}
+
+sub _set_sql_dialect {
+ my $self = shift;
+ my $val = shift || 3;
+
+ my $dsn = $self->_dbi_connect_info->[0];
+
+ return if ref($dsn) eq 'CODE';
+
+ if ($dsn !~ /ib_dialect=/) {
+ $self->_dbi_connect_info->[0] = "$dsn;ib_dialect=$val";
+ my $connected = defined $self->_dbh;
+ $self->disconnect;
+ $self->ensure_connected if $connected;
+ }
+}
+
+=head2 connect_call_use_softcommit
+
+Used as:
+
+ on_connect_call => 'use_softcommit'
+
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the
+L<DBD::InterBase> C<ib_softcommit> option.
+
+You need either this option or C<< disable_sth_caching => 1 >> for
+L<DBIx::Class> code to function correctly (otherwise you may get C<no statement
+executing> errors.) Or use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird>
+driver.
+
+The downside of using this option is that your process will B<NOT> see UPDATEs,
+INSERTs and DELETEs from other processes for already open statements.
+
+=cut
+
+sub connect_call_use_softcommit {
+ my $self = shift;
+
+ $self->_dbh->{ib_softcommit} = 1;
+}
+
+=head2 connect_call_datetime_setup
+
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the date and
+timestamp formats using:
+
+ $dbh->{ib_time_all} = 'ISO';
+
+See L<DBD::InterBase> for more details.
+
+The C<TIMESTAMP> data type supports up to 4 digits after the decimal point for
+second precision. The full precision is used.
+
+The C<DATE> data type stores the date portion only, and it B<MUST> be declared
+with:
+
+ data_type => 'date'
+
+in your Result class.
+
+Timestamp columns can be declared with either C<datetime> or C<timestamp>.
+
+You will need the L<DateTime::Format::Strptime> module for inflation to work.
+
+For L<DBIx::Class::Storage::DBI::ODBC::Firebird>, this is a noop.
+
+=cut
+
+sub connect_call_datetime_setup {
+ my $self = shift;
+
+ $self->_get_dbh->{ib_time_all} = 'ISO';
+}
+
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::InterBase::DateTime::Format;
+
+my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
+my $date_format = '%Y-%m-%d';
+
+my ($timestamp_parser, $date_parser);
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->format_datetime(shift);
+}
+
+sub parse_date {
+ shift;
+ require DateTime::Format::Strptime;
+ $date_parser ||= DateTime::Format::Strptime->new(
+ pattern => $date_format,
+ on_error => 'croak',
+ );
+ return $date_parser->parse_datetime(shift);
+}
+
+sub format_date {
+ shift;
+ require DateTime::Format::Strptime;
+ $date_parser ||= DateTime::Format::Strptime->new(
+ pattern => $date_format,
+ on_error => 'croak',
+ );
+ return $date_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 CAVEATS
+
+=over 4
+
+=item *
+
+with L</connect_call_use_softcommit>, you will not be able to see changes made
+to data in other processes. If this is an issue, use
+L<disable_sth_caching|DBIx::Class::Storage::DBI/disable_sth_caching> as a
+workaround for the C<no statement executing> errors, this of course adversely
+affects performance.
+
+Alternately, use the L<ODBC|DBIx::Class::Storage::DBI::ODBC::Firebird> driver.
+
+=back
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/
+ DBIx::Class::Storage::DBI::UniqueIdentifier
+ DBIx::Class::Storage::DBI::IdentityInsert
+/;
use mro 'c3';
-use List::Util();
+use Try::Tiny;
+use List::Util 'first';
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
- _identity _identity_method
+ _identity _identity_method _no_scope_identity_query
/);
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL');
-sub _set_identity_insert {
- my ($self, $table) = @_;
+__PACKAGE__->sql_quote_char([qw/[ ]/]);
- my $sql = sprintf (
- 'SET IDENTITY_INSERT %s ON',
- $self->sql_maker->_quote ($table),
- );
-
- my $dbh = $self->_get_dbh;
- eval { $dbh->do ($sql) };
- if ($@) {
- $self->throw_exception (sprintf "Error executing '%s': %s",
- $sql,
- $dbh->errstr,
- );
- }
-}
-
-sub _unset_identity_insert {
- my ($self, $table) = @_;
-
- my $sql = sprintf (
- 'SET IDENTITY_INSERT %s OFF',
- $self->sql_maker->_quote ($table),
- );
-
- my $dbh = $self->_get_dbh;
- $dbh->do ($sql);
-}
-
-sub insert_bulk {
- my $self = shift;
- my ($source, $cols, $data) = @_;
-
- my $is_identity_insert = (List::Util::first
- { $source->column_info ($_)->{is_auto_increment} }
- (@{$cols})
- )
- ? 1
- : 0;
-
- if ($is_identity_insert) {
- $self->_set_identity_insert ($source->name);
- }
-
- $self->next::method(@_);
-
- if ($is_identity_insert) {
- $self->_unset_identity_insert ($source->name);
- }
-}
-
-# support MSSQL GUID column types
-
-sub insert {
- my $self = shift;
- my ($source, $to_insert) = @_;
-
- my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
-
- my %guid_cols;
- my @pk_cols = $source->primary_columns;
- my %pk_cols;
- @pk_cols{@pk_cols} = ();
-
- my @pk_guids = grep {
- $source->column_info($_)->{data_type}
- &&
- $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
- } @pk_cols;
-
- my @auto_guids = grep {
- $source->column_info($_)->{data_type}
- &&
- $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
- &&
- $source->column_info($_)->{auto_nextval}
- } grep { not exists $pk_cols{$_} } $source->columns;
-
- my @get_guids_for =
- grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
-
- my $updated_cols = {};
-
- for my $guid_col (@get_guids_for) {
- my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()');
- $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
- }
-
- my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
- ? 1
- : 0;
-
- if ($is_identity_insert) {
- $self->_set_identity_insert ($source->name);
- }
-
- $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
-
- if ($is_identity_insert) {
- $self->_unset_identity_insert ($source->name);
- }
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
+);
-
- return $updated_cols;
-}
+__PACKAGE__->new_guid('NEWID()');
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
+ my ($op, $ident, $args) = @_;
# cast MONEY values properly
if ($op eq 'insert' || $op eq 'update') {
my $fields = $args->[0];
+ my $colinfo = $ident->columns_info([keys %$fields]);
+
for my $col (keys %$fields) {
# $ident is a result source object with INSERT/UPDATE ops
- if ($ident->column_info ($col)->{data_type}
- &&
- $ident->column_info ($col)->{data_type} =~ /^money\z/i) {
+ if (
+ $colinfo->{$col}{data_type}
+ &&
+ $colinfo->{$col}{data_type} =~ /^money\z/i
+ ) {
my $val = $fields->{$col};
$fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
}
my ($sql, $bind) = $self->next::method (@_);
- if ($op eq 'insert') {
- $sql .= ';SELECT SCOPE_IDENTITY()';
-
+ # SELECT SCOPE_IDENTITY only works within a statement scope. We
+ # must try to always use this particular idiom frist, as it is the
+ # only one that guarantees retrieving the correct id under high
+ # concurrency. When this fails we will fall back to whatever secondary
+ # retrieval method is specified in _identity_method, but at this
+ # point we don't have many guarantees we will get what we expected.
+ # http://msdn.microsoft.com/en-us/library/ms190315.aspx
+ # http://davidhayden.com/blog/dave/archive/2006/01/17/2736.aspx
+ if ($self->_perform_autoinc_retrieval and not $self->_no_scope_identity_query) {
+ $sql .= "\nSELECT SCOPE_IDENTITY()";
}
return ($sql, $bind);
my $self = shift;
my ($op) = @_;
- my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+ # always list ctx - we need the $sth
+ my ($rv, $sth, @bind) = $self->next::method(@_);
- if ($op eq 'insert') {
+ if ($self->_perform_autoinc_retrieval) {
- # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
+ # attempt to bring back the result of SELECT SCOPE_IDENTITY() we tacked
# on in _prep_for_execute above
- my ($identity) = eval { $sth->fetchrow_array };
+ my $identity;
+
+ # we didn't even try on ftds
+ unless ($self->_no_scope_identity_query) {
+ ($identity) = try { $sth->fetchrow_array };
+ $sth->finish;
+ }
# SCOPE_IDENTITY failed, but we can do something else
if ( (! $identity) && $self->_identity_method) {
}
$self->_identity($identity);
- $sth->finish;
}
return wantarray ? ($rv, $sth, @bind) : $rv;
#
# MSSQL is retarded wrt ordered subselects. One needs to add a TOP
-# to *all* subqueries, but one also can't use TOP 100 PERCENT
+# to *all* subqueries, but one also *can't* use TOP 100 PERCENT
# http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
#
sub _select_args_to_query {
# see if this is an ordered subquery
my $attrs = $_[3];
- if ( scalar $self->_parse_order_by ($attrs->{order_by}) ) {
+ if (
+ $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ \s+ /xi
+ &&
+ scalar $self->_extract_order_criteria ($attrs->{order_by})
+ ) {
$self->throw_exception(
'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL
') unless $attrs->{unsafe_subselect_ok};
- my $max = 2 ** 32;
+ my $max = $self->sql_maker->__max_int;
$sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi;
}
# savepoint syntax is the same as in Sybase ASE
-sub _svp_begin {
+sub _exec_svp_begin {
my ($self, $name) = @_;
- $self->_get_dbh->do("SAVE TRANSACTION $name");
+ $self->_dbh->do("SAVE TRANSACTION $name");
}
# A new SAVE TRANSACTION with the same name releases the previous one.
-sub _svp_release { 1 }
+sub _exec_svp_release { 1 }
-sub _svp_rollback {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
-}
-
-sub build_datetime_parser {
- my $self = shift;
- my $type = "DateTime::Format::Strptime";
- eval "use ${type}";
- $self->throw_exception("Couldn't load ${type}: $@") if $@;
- return $type->new( pattern => '%Y-%m-%d %H:%M:%S' ); # %F %T
+ $self->_dbh->do("ROLLBACK TRANSACTION $name");
}
sub sqlt_type { 'SQLServer' }
-sub _get_mssql_version {
+sub sql_limit_dialect {
my $self = shift;
- my $data = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
+ my $supports_rno = 0;
- if ($data->{Character_Value} =~ /^(\d+)\./) {
- return $1;
- } else {
- $self->throw_exception(q{Your ProductVersion's Character_Value is missing or malformed!});
+ if (exists $self->_server_info->{normalized_dbms_version}) {
+ $supports_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9;
+ }
+ else {
+ # User is connecting via DBD::Sybase and has no permission to run
+ # stored procedures like xp_msver, or version detection failed for some
+ # other reason.
+ # So, we use a query to check if RNO is implemented.
+ try {
+ $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
+ $supports_rno = 1;
+ };
}
+
+ return $supports_rno ? 'RowNumberOver' : 'Top';
}
-sub sql_maker {
+sub _ping {
my $self = shift;
- unless ($self->_sql_maker) {
- unless ($self->{_sql_maker_opts}{limit_dialect}) {
- my $version = eval { $self->_get_mssql_version; } || 0;
+ my $dbh = $self->_dbh or return 0;
- $self->{_sql_maker_opts} = {
- limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
- %{$self->{_sql_maker_opts}||{}}
- };
- }
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
- my $maker = $self->next::method (@_);
- }
+ return try {
+ $dbh->do('select 1');
+ 1;
+ } catch {
+ 0;
+ };
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::MSSQL::DateTime::Format;
+
+my $datetime_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
+my $smalldatetime_format = '%Y-%m-%d %H:%M:%S';
+
+my ($datetime_parser, $smalldatetime_parser);
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
- return $self->_sql_maker;
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
+
+sub parse_smalldatetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $smalldatetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $smalldatetime_format,
+ on_error => 'croak',
+ );
+ return $smalldatetime_parser->parse_datetime(shift);
+}
+
+sub format_smalldatetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $smalldatetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $smalldatetime_format,
+ on_error => 'croak',
+ );
+ return $smalldatetime_parser->format_datetime(shift);
}
1;
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
+++ /dev/null
-package DBIx::Class::Storage::DBI::MultiColumnIn;
-
-use strict;
-use warnings;
-
-use base 'DBIx::Class::Storage::DBI';
-use mro 'c3';
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::MultiColumnIn - Storage component for RDBMS supporting multicolumn in clauses
-
-=head1 DESCRIPTION
-
-While ANSI SQL does not define a multicolumn in operator, many databases can
-in fact understand WHERE (cola, colb) IN ( SELECT subcol_a, subcol_b ... )
-The storage class for any such RDBMS should inherit from this class, in order
-to dramatically speed up update/delete operations on joined multipk resultsets.
-
-At this point the only overridden method is C<_multipk_update_delete()>
-
-=cut
-
-sub _multipk_update_delete {
- my $self = shift;
- my ($rs, $op, $values) = @_;
-
- my $rsrc = $rs->result_source;
- my @pcols = $rsrc->_pri_cols;
- my $attrs = $rs->_resolved_attrs;
-
- # naive check - this is an internal method after all, we should know what we are doing
- $self->throw_exception ('Number of columns selected by supplied resultset does not match number of primary keys')
- if ( ref $attrs->{select} ne 'ARRAY' or @{$attrs->{select}} != @pcols );
-
- # This is hideously ugly, but SQLA does not understand multicol IN expressions
- my $sqla = $self->_sql_maker;
- my ($sql, @bind) = @${$rs->as_query};
- $sql = sprintf ('(%s) IN %s', # the as_query stuff is already enclosed in ()s
- join (', ', map { $sqla->_quote ($_) } @pcols),
- $sql,
- );
-
- return $self->$op (
- $rsrc,
- $op eq 'update' ? $values : (),
- \[$sql, @bind],
- );
-
-}
-
-=head1 AUTHORS
-
-See L<DBIx::Class/CONTRIBUTORS>
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-1;
use base 'DBIx::Class::Storage::DBI';
use mro 'c3';
-=head1 NAME
+use DBIx::Class::SQLMaker::LimitDialects;
+use List::Util qw/first/;
+
+use namespace::clean;
+
+=head1 NAME
DBIx::Class::Storage::DBI::NoBindVars - Sometime DBDs have poor to no support for bind variables
my ($sql, $bind) = $self->next::method(@_);
# stringify bind args, quote via $dbh, and manually insert
- #my ($op, $extra_bind, $ident, $args) = @_;
- my $ident = $_[2];
+ #my ($op, $ident, $args) = @_;
+ my $ident = $_[1];
my @sql_part = split /\?/, $sql;
my $new_sql;
- my $col_info = $self->_resolve_column_info($ident, [ map $_->[0], @$bind ]);
-
- foreach my $bound (@$bind) {
- my $col = shift @$bound;
-
- my $datatype = $col_info->{$col}{data_type};
+ for (@$bind) {
+ my $data = (ref $_->[1]) ? "$_->[1]" : $_->[1]; # always stringify, array types are currently not supported
- foreach my $data (@$bound) {
- $data = ''.$data if ref $data;
+ my $datatype = $_->[0]{sqlt_datatype};
- $data = $self->_prep_interpolated_value($datatype, $data)
- if $datatype;
+ $data = $self->_prep_interpolated_value($datatype, $data)
+ if $datatype;
- $data = $self->_dbh->quote($data)
- unless $self->interpolate_unquoted($datatype, $data);
+ $data = $self->_get_dbh->quote($data)
+ unless ($datatype and $self->interpolate_unquoted($datatype, $data) );
- $new_sql .= shift(@sql_part) . $data;
- }
+ $new_sql .= shift(@sql_part) . $data;
}
+
$new_sql .= join '', @sql_part;
return ($new_sql, []);
value is interpreted as: true - do not quote, false - do quote. You should
override this in you Storage::DBI::<database> subclass, if your RDBMS
does not like quotes around certain datatypes (e.g. Sybase and integer
-columns). The default method always returns false (do quote).
+columns). The default method returns false, except for integer datatypes
+paired with values containing nothing but digits.
WARNING!!!
sub interpolate_unquoted {
#my ($self, $datatype, $value) = @_;
+
+ return 1 if (
+ defined $_[2]
+ and
+ $_[1]
+ and
+ $_[2] !~ /\D/
+ and
+ $_[1] =~ /int(?:eger)? | (?:tiny|small|medium|big)int/ix
+ );
+
return 0;
}
package DBIx::Class::Storage::DBI::ODBC;
use strict;
use warnings;
-
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
sub _rebless {
- my ($self) = @_;
-
- my $dbtype = eval { $self->_get_dbh->get_info(17) };
-
- unless ( $@ ) {
- # Translate the backend name into a perl identifier
- $dbtype =~ s/\W/_/gi;
- my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
- if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
- bless $self, $subclass;
- $self->_rebless;
- }
+ my ($self) = @_;
+
+ if (my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME')) {
+ # Translate the backend name into a perl identifier
+ $dbtype =~ s/\W/_/gi;
+ my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}";
+
+ return if $self->isa($subclass);
+
+ if ($self->load_optional_class($subclass)) {
+ bless $self, $subclass;
+ $self->_rebless;
}
+ else {
+ warn "Expected driver '$subclass' not found, using generic support. " .
+ "Please file an RT.\n";
+ }
+ }
+ else {
+ warn "Could not determine your database type, using generic support.\n";
+ }
+}
+
+# Whether or not we are connecting via the freetds ODBC driver.
+sub _using_freetds {
+ my $self = shift;
+
+ my $dsn = $self->_dbi_connect_info->[0];
+
+ return 1 if (
+ ( (! ref $dsn) and $dsn =~ /driver=FreeTDS/i)
+ or
+ ( ($self->_dbh_get_info('SQL_DRIVER_NAME')||'') =~ /tdsodbc/i )
+ );
+
+ return 0;
+}
+
+# Either returns the FreeTDS version via which we are connecting, 0 if can't
+# be determined, or undef otherwise
+sub _using_freetds_version {
+ my $self = shift;
+ return undef unless $self->_using_freetds;
+ return $self->_dbh_get_info('SQL_DRIVER_VER') || 0;
+}
+
+sub _disable_odbc_array_ops {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
+
+ if (eval { DBD::ODBC->VERSION('1.35_01') }) {
+ $dbh->{odbc_array_operations} = 0;
+ }
+ elsif (eval { DBD::ODBC->VERSION('1.33_01') }) {
+ $dbh->{odbc_disable_array_operations} = 1;
+ }
}
1;
This class simply provides a mechanism for discovering and loading a sub-class
for a specific ODBC backend. It should be transparent to the user.
-=head1 AUTHORS
+=head1 AUTHOR
-Marc Mims C<< <marc@questright.com> >>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
package DBIx::Class::Storage::DBI::ODBC::ACCESS;
+
use strict;
use warnings;
-
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::ACCESS
+/;
use mro 'c3';
-use DBI;
-
-my $ERR_MSG_START = __PACKAGE__ . ' failed: ';
-
-sub insert {
- my $self = shift;
- my ( $source, $to_insert ) = @_;
-
- my $bind_attributes = $self->source_bind_attributes( $source );
- my ( undef, $sth ) = $self->_execute( 'insert' => [], $source, $bind_attributes, $to_insert );
+__PACKAGE__->mk_group_accessors(inherited =>
+ 'disable_sth_caching_for_image_insert_or_update'
+);
- #store the identity here since @@IDENTITY is connection global and this prevents
- #possibility that another insert to a different table overwrites it for this resultsource
- my $identity = 'SELECT @@IDENTITY';
- my $max_sth = $self->{ _dbh }->prepare( $identity )
- or $self->throw_exception( $ERR_MSG_START . $self->{ _dbh }->errstr() );
- $max_sth->execute() or $self->throw_exception( $ERR_MSG_START . $max_sth->errstr );
+__PACKAGE__->disable_sth_caching_for_image_insert_or_update(1);
- my $row = $max_sth->fetchrow_arrayref()
- or $self->throw_exception( $ERR_MSG_START . "$identity did not return any result." );
+=head1 NAME
- $self->{ last_pk }->{ $source->name() } = $row;
+DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
- return $to_insert;
-}
+=head1 DESCRIPTION
-sub last_insert_id {
- my $self = shift;
- my ( $result_source ) = @_;
+This class implements support specific to Microsoft Access over ODBC.
- return @{ $self->{ last_pk }->{ $result_source->name() } };
-}
+It is a subclass of L<DBIx::Class::Storage::DBI::ODBC> and
+L<DBIx::Class::Storage::DBI::ACCESS>, see those classes for more
+information.
-sub bind_attribute_by_data_type {
- my $self = shift;
+It is loaded automatically by by L<DBIx::Class::Storage::DBI::ODBC> when it
+detects a MS Access back-end.
- my ( $data_type ) = @_;
+This driver implements workarounds for C<IMAGE> and C<MEMO> columns, and
+L<DBIx::Class::InflateColumn::DateTime> support for C<DATETIME> columns.
- return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR;
+=head1 EXAMPLE DSN
- return;
-}
+ dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb
-sub sqlt_type { 'ACCESS' }
+=head1 TEXT/IMAGE/MEMO COLUMNS
-1;
+Avoid using C<TEXT> columns as they will be truncated to 255 bytes. Some other
+drivers (like L<ADO|DBIx::Class::Storage::DBI::ADO::MS_Jet>) will automatically
+convert C<TEXT> columns to C<MEMO>, but the ODBC driver does not.
-=head1 NAME
+C<IMAGE> columns work correctly, but the statements for inserting or updating an
+C<IMAGE> column will not be L<cached|DBI/prepare_cached>, due to a bug in the
+Access ODBC driver.
-DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
+C<MEMO> columns work correctly as well, but you must take care to set
+L<LongReadLen|DBI/LongReadLen> to C<$max_memo_size * 2 + 1>. This is done for
+you automatically if you pass L<LongReadLen|DBI/LongReadLen> in your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>; but if you set this
+attribute directly on the C<$dbh>, keep this limitation in mind.
-=head1 WARNING
+=cut
-I am not a DBI, DBIx::Class or MS Access guru. Use this module with that in
-mind.
+# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO)
+sub _run_connection_actions {
+ my $self = shift;
-This module is currently considered alpha software and can change without notice.
+ my $long_read_len = $self->_dbh->{LongReadLen};
-=head1 DESCRIPTION
+ # 80 is another default (just like 0) on some drivers
+ if ($long_read_len != 0 && $long_read_len != 80) {
+ $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1;
+ }
-This class implements support specific to Microsoft Access over ODBC.
+ # batch operations do not work
+ $self->_disable_odbc_array_ops;
-It is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it
-detects a MS Access back-end.
+ return $self->next::method(@_);
+}
-=head1 SUPPORTED VERSIONS
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
-This module have currently only been tested on MS Access 2003 using the Jet 4.0 engine.
+ my $columns_info = $source->columns_info;
-As far as my knowledge it should work on MS Access 2000 or later, but that have not been tested.
-Information about support for different version of MS Access is welcome.
+ my $is_image_insert = 0;
-=head1 IMPLEMENTATION NOTES
+ for my $col (keys %$to_insert) {
+ if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) {
+ $is_image_insert = 1;
+ last;
+ }
+ }
-MS Access supports the @@IDENTITY function for retrieving the id of the latest inserted row.
-@@IDENTITY is global to the connection, so to support the possibility of getting the last inserted
-id for different tables, the insert() function stores the inserted id on a per table basis.
-last_insert_id() then just returns the stored value.
+ local $self->{disable_sth_caching} = 1 if $is_image_insert
+ && $self->disable_sth_caching_for_image_insert_or_update;
-=head1 KNOWN ACCESS PROBLEMS
+ return $self->next::method(@_);
+}
-=over
+sub update {
+ my $self = shift;
+ my ($source, $fields) = @_;
-=item Invalid precision value
+ my $columns_info = $source->columns_info;
-This error message is received when trying to store more than 255 characters in a MEMO field.
-The problem is (to my knowledge) an error in the MS Access ODBC driver. The problem is fixed
-by setting the C<data_type> of the column to C<SQL_LONGVARCHAR> in C<add_columns>.
-C<SQL_LONGVARCHAR> is a constant in the C<DBI> module.
+ my $is_image_insert = 0;
-=back
+ for my $col (keys %$fields) {
+ if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) {
+ $is_image_insert = 1;
+ last;
+ }
+ }
-=head1 IMPLEMENTED FUNCTIONS
+ local $self->{disable_sth_caching} = 1 if $is_image_insert
+ && $self->disable_sth_caching_for_image_insert_or_update;
-=head2 bind_attribute_by_data_type
+ return $self->next::method(@_);
+}
-This function currently supports the SQL_LONGVARCHAR column type.
+sub datetime_parser_type {
+ 'DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format'
+}
-=head2 insert
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format;
-=head2 last_insert_id
+my $datetime_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part
+my $datetime_parser;
-=head2 sqlt_type
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
-=head1 BUGS
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->format_datetime(shift);
+}
-Most likely. Bug reports are welcome.
+1;
-=head1 AUTHORS
+=head1 AUTHOR
-Øystein Torget C<< <oystein.torget@dnv.com> >>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
-=head1 COPYRIGHT
+=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
-Det Norske Veritas AS (DNV)
-
-http://www.dnv.com
-
=cut
-
+# vim:sts=2 sw=2:
package DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL;
+
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::ODBC/;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::DB2
+/;
use mro 'c3';
-sub _dbh_last_insert_id {
- my ($self, $dbh, $source, $col) = @_;
-
- # get the schema/table separator:
- # '.' when SQL naming is active
- # '/' when system naming is active
- my $sep = $dbh->get_info(41);
- my $sth = $dbh->prepare_cached(
- "SELECT IDENTITY_VAL_LOCAL() FROM SYSIBM${sep}SYSDUMMY1", {}, 3);
- $sth->execute();
-
- my @res = $sth->fetchrow_array();
-
- return @res ? $res[0] : undef;
-}
-
-sub _sql_maker_opts {
- my ($self) = @_;
-
- $self->dbh_do(sub {
- my ($self, $dbh) = @_;
-
- return {
- limit_dialect => 'FetchFirst',
- name_sep => $dbh->get_info(41)
- };
- });
-}
-
1;
=head1 NAME
DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL - Support specific to DB2/400
over ODBC
-=head1 SYNOPSIS
-
- # In your result (table) classes
- use base 'DBIx::Class::Core';
- __PACKAGE__->set_primary_key('id');
-
-
=head1 DESCRIPTION
-This class implements support specific to DB2/400 over ODBC, including
-auto-increment primary keys, SQL::Abstract::Limit dialect, and name separator
-for connections using either SQL naming or System naming.
-
-
-=head1 AUTHORS
+This is an empty subclass of L<DBIx::Class::Storage::DBI::DB2>.
-Marc Mims C<< <marc@questright.com> >>
+=head1 AUTHOR
-Based on DBIx::Class::Storage::DBI::DB2 by Jess Robinson.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
+# vim:sts=2 sw=2:
--- /dev/null
+package DBIx::Class::Storage::DBI::ODBC::Firebird;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::Firebird::Common
+/;
+use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ODBC::Firebird - Driver for using the Firebird RDBMS
+through ODBC
+
+=head1 DESCRIPTION
+
+Most functionality is provided by
+L<DBIx::Class::Storage::DBI::Firebird::Common>, see that driver for details.
+
+To build the ODBC driver for Firebird on Linux for unixODBC, see:
+
+L<http://www.firebirdnews.org/?p=1324>
+
+This driver does not suffer from the nested statement handles across commits
+issue that the L<DBD::InterBase|DBIx::Class::Storage::DBI::InterBase> or the
+L<DBD::Firebird|DBIx::Class::Storage::DBI::Firebird> based driver does. This
+makes it more suitable for long running processes such as under L<Catalyst>.
+
+=cut
+
+__PACKAGE__->datetime_parser_type ('DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format');
+
+# batch operations in DBD::ODBC 1.35 do not work with the official ODBC driver
+sub _run_connection_actions {
+ my $self = shift;
+
+ if ($self->_dbh_get_info('SQL_DRIVER_NAME') eq 'OdbcFb') {
+ $self->_disable_odbc_array_ops;
+ }
+
+ return $self->next::method(@_);
+}
+
+# releasing savepoints doesn't work for some reason, but that shouldn't matter
+sub _exec_svp_release { 1 }
+
+sub _exec_svp_rollback {
+ my ($self, $name) = @_;
+
+ try {
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ }
+ catch {
+ # Firebird ODBC driver bug, ignore
+ if (not /Unable to fetch information about the error/) {
+ $self->throw_exception($_);
+ }
+ };
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ODBC::Firebird::DateTime::Format;
+
+# inherit parse/format date
+our @ISA = 'DBIx::Class::Storage::DBI::InterBase::DateTime::Format';
+
+my $timestamp_format = '%Y-%m-%d %H:%M:%S.%4N'; # %F %T
+my $timestamp_parser;
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $timestamp_parser ||= DateTime::Format::Strptime->new(
+ pattern => $timestamp_format,
+ on_error => 'croak',
+ );
+ return $timestamp_parser->format_datetime(shift);
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::MSSQL/;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::MSSQL
+/;
use mro 'c3';
-
-use List::Util();
-use Scalar::Util ();
+use Scalar::Util 'reftype';
+use Try::Tiny;
+use DBIx::Class::Carp;
+use namespace::clean;
__PACKAGE__->mk_group_accessors(simple => qw/
_using_dynamic_cursors
Most of the functionality is provided from the superclass
L<DBIx::Class::Storage::DBI::MSSQL>.
+=head1 USAGE NOTES
+
+=head2 Basic Linux Setup (Debian)
+
+ sudo aptitude install tdsodbc libdbd-odbc-perl unixodbc
+
+In case it is not already there put the following in C</etc/odbcinst.ini>:
+
+ [FreeTDS]
+ Description = FreeTDS
+ Driver = /usr/lib/odbc/libtdsodbc.so
+ Setup = /usr/lib/odbc/libtdsS.so
+ UsageCount = 1
+
+Set your C<$dsn> in L<connect_info|DBIx::Class::Storage::DBI/connect_info> as follows:
+
+ dbi:ODBC:server=<my.host.name>;port=1433;driver=FreeTDS;tds_version=8.0
+
+If you use the EasySoft driver (L<http://www.easysoft.com>):
+
+ dbi:ODBC:server=<my.host.name>;port=1433;driver=Easysoft ODBC-SQL Server
+
+=head2 Basic Windows Setup
+
+Use the following C<$dsn> for the Microsoft ODBC driver:
+
+ dbi:ODBC:driver={SQL Server};server=SERVER\SQL_SERVER_INSTANCE_NAME
+
+And for the Native Client:
+
+ dbi:ODBC:driver={SQL Server Native Client 10.0};server=SERVER\SQL_SERVER_INSTANCE_NAME
+
+Go into Control Panel -> System and Security -> Administrative Tools -> Data
+Sources (ODBC) to check driver names and to set up data sources.
+
+Use System DSNs, not User DSNs if you want to use DSNs.
+
+If you set up a DSN, use the following C<$dsn> for
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>:
+
+ dbi:ODBC:dsn=MY_DSN
+
=head1 MULTIPLE ACTIVE STATEMENTS
The following options are alternative ways to enable concurrent executing
-statement support. Each has its own advantages and drawbacks.
+statement support. Each has its own advantages and drawbacks and works on
+different platforms. Read each section carefully.
+
+For more details about using MAS in MSSQL over DBD::ODBC see this excellent
+document provided by EasySoft:
+L<http://www.easysoft.com/developer/languages/perl/multiple-active-statements.html>.
+
+In order of preference, they are:
+
+=over 8
+
+=item * L<mars|/connect_call_use_mars>
+
+=item * L<dynamic_cursors|/connect_call_use_dynamic_cursors>
+
+=item * L<server_cursors|/connect_call_use_server_cursors>
+
+=back
+
+=head1 METHODS
+
+=head2 connect_call_use_mars
+
+Use as:
+
+ on_connect_call => 'use_mars'
+
+in your connection info, or alternatively specify it directly:
+
+ Your::Schema->connect (
+ $original_dsn . '; MARS_Connection=Yes',
+ $user,
+ $pass,
+ \%attrs,
+ )
+
+Use to enable a feature of SQL Server 2005 and later, "Multiple Active Result
+Sets". See L<DBD::ODBC::FAQ/Does DBD::ODBC support Multiple Active Statements?>
+for more information.
+
+This does not work on FreeTDS drivers at the time of this writing, and only
+works with the Native Client, later versions of the Windows MS ODBC driver, and
+the Easysoft driver.
+
+=cut
+
+sub connect_call_use_mars {
+ my $self = shift;
+
+ my $dsn = $self->_dbi_connect_info->[0];
+
+ if (ref($dsn) eq 'CODE') {
+ $self->throw_exception('cannot change the DBI DSN on a CODE ref connect_info');
+ }
+
+ if ($dsn !~ /MARS_Connection=/) {
+ if ($self->_using_freetds) {
+ $self->throw_exception('FreeTDS does not support MARS at the time of '
+ .'writing.');
+ }
+
+ if (exists $self->_server_info->{normalized_dbms_version} &&
+ $self->_server_info->{normalized_dbms_version} < 9) {
+ $self->throw_exception('SQL Server 2005 or later required to use MARS.');
+ }
+
+ if (my ($data_source) = $dsn =~ /^dbi:ODBC:([\w-]+)\z/i) { # prefix with DSN
+ warn "Bare DSN in ODBC connect string, rewriting as 'dsn=$data_source'"
+ ." for MARS\n";
+ $dsn = "dbi:ODBC:dsn=$data_source";
+ }
+
+ $self->_dbi_connect_info->[0] = "$dsn;MARS_Connection=Yes";
+ $self->disconnect;
+ $self->ensure_connected;
+ }
+}
+
+sub connect_call_use_MARS {
+ carp "'connect_call_use_MARS' has been deprecated, use "
+ ."'connect_call_use_mars' instead.";
+ shift->connect_call_use_mars(@_)
+}
=head2 connect_call_use_dynamic_cursors
on_connect_call => 'use_dynamic_cursors'
-in your L<DBIx::Class::Storage::DBI/connect_info> as one way to enable multiple
-concurrent statements.
+Which will add C<< odbc_cursortype => 2 >> to your DBI connection
+attributes, or alternatively specify the necessary flag directly:
-Will add C<< odbc_cursortype => 2 >> to your DBI connection attributes. See
-L<DBD::ODBC/odbc_cursortype> for more information.
+ Your::Schema->connect (@dsn, { ... odbc_cursortype => 2 })
-Alternatively, you can add it yourself and dynamic cursor support will be
-automatically enabled.
+See L<DBD::ODBC/odbc_cursortype> for more information.
If you're using FreeTDS, C<tds_version> must be set to at least C<8.0>.
This will not work with CODE ref connect_info's.
-B<WARNING:> this will break C<SCOPE_IDENTITY()>, and C<SELECT @@IDENTITY> will
-be used instead, which on SQL Server 2005 and later will return erroneous
-results on tables which have an on insert trigger that inserts into another
-table with an C<IDENTITY> column.
+B<WARNING:> on FreeTDS (and maybe some other drivers) this will break
+C<SCOPE_IDENTITY()>, and C<SELECT @@IDENTITY> will be used instead, which on SQL
+Server 2005 and later will return erroneous results on tables which have an on
+insert trigger that inserts into another table with an C<IDENTITY> column.
+
+B<WARNING:> on FreeTDS, changes made in one statement (e.g. an insert) may not
+be visible from a following statement (e.g. a select.)
+
+B<WARNING:> FreeTDS versions > 0.82 seem to have completely broken the ODBC
+protocol. DBIC will not allow dynamic cursor support with such versions to
+protect your data. Please hassle the authors of FreeTDS to act on the bugs that
+make their driver not overly usable with DBD::ODBC.
=cut
sub connect_call_use_dynamic_cursors {
my $self = shift;
- if (ref($self->_dbi_connect_info->[0]) eq 'CODE') {
- $self->throw_exception ('Cannot set DBI attributes on a CODE ref connect_info');
- }
+ if (($self->_dbic_connect_attributes->{odbc_cursortype} || 0) < 2) {
- my $dbi_attrs = $self->_dbi_connect_info->[-1];
+ my $dbi_inf = $self->_dbi_connect_info;
- unless (ref($dbi_attrs) && Scalar::Util::reftype($dbi_attrs) eq 'HASH') {
- $dbi_attrs = {};
- push @{ $self->_dbi_connect_info }, $dbi_attrs;
- }
+ $self->throw_exception ('Cannot set DBI attributes on a CODE ref connect_info')
+ if ref($dbi_inf->[0]) eq 'CODE';
+
+ # reenter connection information with the attribute re-set
+ $dbi_inf->[3] = {} if @$dbi_inf <= 3;
+ $dbi_inf->[3]{odbc_cursortype} = 2;
+
+ $self->_dbi_connect_info($dbi_inf);
- if (not exists $dbi_attrs->{odbc_cursortype}) {
- # turn on support for multiple concurrent statements, unless overridden
- $dbi_attrs->{odbc_cursortype} = 2;
$self->disconnect; # resetting dbi attrs, so have to reconnect
$self->ensure_connected;
- $self->_set_dynamic_cursors;
}
}
-sub _set_dynamic_cursors {
+sub _run_connection_actions {
my $self = shift;
- my $dbh = $self->_get_dbh;
-
- eval {
- local $dbh->{RaiseError} = 1;
- local $dbh->{PrintError} = 0;
- $dbh->do('SELECT @@IDENTITY');
- };
- if ($@) {
- $self->throw_exception (<<'EOF');
-
-Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2),
-if you're using FreeTDS, make sure to set tds_version to 8.0 or greater.
-EOF
- }
-
- $self->_using_dynamic_cursors(1);
- $self->_identity_method('@@identity');
-}
-sub _init {
- my $self = shift;
-
- no warnings qw/uninitialized/;
+ $self->next::method (@_);
+ # keep the dynamic_cursors_support and driver-state in sync
+ # on every reconnect
+ my $use_dyncursors = ($self->_dbic_connect_attributes->{odbc_cursortype} || 0) > 1;
if (
- ref($self->_dbi_connect_info->[0]) ne 'CODE'
- &&
- ref ($self->_dbi_connect_info->[-1]) eq 'HASH'
- &&
- $self->_dbi_connect_info->[-1]{odbc_cursortype} == 2
+ $use_dyncursors
+ xor
+ !!$self->_using_dynamic_cursors
) {
- $self->_set_dynamic_cursors;
- return;
+ if ($use_dyncursors) {
+ try {
+ my $dbh = $self->_dbh;
+ local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
+ $dbh->do('SELECT @@IDENTITY');
+ } catch {
+ $self->throw_exception (
+ 'Your drivers do not seem to support dynamic cursors (odbc_cursortype => 2).'
+ . (
+ $self->_using_freetds
+ ? ' If you are using FreeTDS, make sure to set tds_version to 8.0 or greater.'
+ : ''
+ )
+ );
+ };
+
+ $self->_using_dynamic_cursors(1);
+ $self->_identity_method('@@identity');
+ }
+ else {
+ $self->_using_dynamic_cursors(0);
+ $self->_identity_method(undef);
+ }
}
- $self->_using_dynamic_cursors(0);
+ $self->_no_scope_identity_query($self->_using_dynamic_cursors
+ ? $self->_using_freetds
+ : undef
+ );
+
+ # freetds is too damn broken, some fixups
+ if ($self->_using_freetds) {
+
+ # no dynamic cursors starting from 0.83
+ if ($self->_using_dynamic_cursors) {
+ my $fv = $self->_using_freetds_version || 999; # assume large if can't be determined
+ $self->throw_exception(
+ 'Dynamic cursors (odbc_cursortype => 2) are not supported with FreeTDS > 0.82 '
+ . "(you have $fv). Please hassle FreeTDS authors to fix the outstanding bugs in "
+ . 'their driver.'
+ ) if $fv > 0.82
+ }
+
+ # FreeTDS is too broken wrt execute_for_fetch batching
+ # just disable it outright until things quiet down
+ $self->_disable_odbc_array_ops;
+ }
}
=head2 connect_call_use_server_cursors
B<WARNING>: this does not work on all versions of SQL Server, and may lock up
your database!
+At the time of writing, this option only works on Microsoft's Windows drivers,
+later versions of the ODBC driver and the Native Client driver.
+
=cut
sub connect_call_use_server_cursors {
my $self = shift;
my $sql_rowset_size = shift || 2;
- $self->_get_dbh->{odbc_SQL_ROWSET_SIZE} = $sql_rowset_size;
-}
-
-=head2 connect_call_use_MARS
-
-Use as:
-
- on_connect_call => 'use_MARS'
-
-Use to enable a feature of SQL Server 2005 and later, "Multiple Active Result
-Sets". See L<DBD::ODBC::FAQ/Does DBD::ODBC support Multiple Active Statements?>
-for more information.
-
-B<WARNING>: This has implications for the way transactions are handled.
-
-=cut
-
-sub connect_call_use_MARS {
- my $self = shift;
-
- my $dsn = $self->_dbi_connect_info->[0];
-
- if (ref($dsn) eq 'CODE') {
- $self->throw_exception('cannot change the DBI DSN on a CODE ref connect_info');
- }
-
- if ($dsn !~ /MARS_Connection=/) {
- $self->_dbi_connect_info->[0] = "$dsn;MARS_Connection=Yes";
- my $was_connected = defined $self->_dbh;
- $self->disconnect;
- $self->ensure_connected if $was_connected;
+ if ($^O !~ /win32|cygwin/i) {
+ $self->throw_exception('Server cursors only work on Windows platforms at '
+ .'the time of writing.');
}
-}
-
-sub _get_mssql_version {
- my $self = shift;
-
- my ($version) = $self->_get_dbh->get_info(18) =~ /^(\d+)/;
- return $version;
+ $self->_get_dbh->{odbc_SQL_ROWSET_SIZE} = $sql_rowset_size;
}
1;
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut
-# vim: sw=2 sts=2
+# vim:sw=2 sts=2 et
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::SQLAnywhere/;
+use base qw/
+ DBIx::Class::Storage::DBI::ODBC
+ DBIx::Class::Storage::DBI::SQLAnywhere
+/;
use mro 'c3';
1;
All functionality is provided by L<DBIx::Class::Storage::DBI::SQLAnywhere>, see
that module for details.
+=head1 CAVEATS
+
+=head2 uniqueidentifierstr data type
+
+If you use the C<uniqueidentifierstr> type with this driver, your queries may
+fail with:
+
+ Data truncated (SQL-01004)
+
+B<WORKAROUND:> use the C<uniqueidentifier> type instead, it is more efficient
+anyway.
+
=head1 AUTHOR
See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
sub _rebless {
- my ($self) = @_;
+ my ($self) = @_;
- my $version = eval { $self->_get_dbh->get_info(18); };
+ # Default driver
+ my $class = $self->_server_info->{normalized_dbms_version} < 9
+ ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
+ : 'DBIx::Class::Storage::DBI::Oracle::Generic';
- if ( !$@ ) {
- my ($major, $minor, $patchlevel) = split(/\./, $version);
-
- # Default driver
- my $class = $major <= 8
- ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
- : 'DBIx::Class::Storage::DBI::Oracle::Generic';
-
- $self->ensure_class_loaded ($class);
- bless $self, $class;
- }
+ $self->ensure_class_loaded ($class);
+ bless $self, $class;
}
1;
This class simply provides a mechanism for discovering and loading a sub-class
for a specific version Oracle backend. It should be transparent to the user.
-For Oracle major versions <= 8 it loads the ::Oracle::WhereJoins subclass,
+For Oracle major versions < 9 it loads the ::Oracle::WhereJoins subclass,
which unrolls the ANSI join style DBIC normally generates into entries in
the WHERE clause for compatibility purposes. To force usage of this version
no matter the database version, add
use strict;
use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use DBIx::Class::Carp;
use Scope::Guard ();
-use Context::Preserve ();
+use Context::Preserve 'preserve_context';
+use Try::Tiny;
+use List::Util 'first';
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('RowNum');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
+__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
+
+sub __cache_queries_with_max_lob_parts { 2 }
=head1 NAME
use base 'DBIx::Class::Core';
__PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
__PACKAGE__->set_primary_key('id');
- __PACKAGE__->sequence('mysequence');
+
+ # Somewhere in your Code
+ # add some data to a table with a hierarchical relationship
+ $schema->resultset('Person')->create ({
+ firstname => 'foo',
+ lastname => 'bar',
+ children => [
+ {
+ firstname => 'child1',
+ lastname => 'bar',
+ children => [
+ {
+ firstname => 'grandchild',
+ lastname => 'bar',
+ }
+ ],
+ },
+ {
+ firstname => 'child2',
+ lastname => 'bar',
+ },
+ ],
+ });
+
+ # select from the hierarchical relationship
+ my $rs = $schema->resultset('Person')->search({},
+ {
+ 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
+ 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
+ 'order_siblings_by' => { -asc => 'name' },
+ };
+ );
+
+ # this will select the whole tree starting from person "foo bar", creating
+ # following query:
+ # SELECT
+ # me.persionid me.firstname, me.lastname, me.parentid
+ # FROM
+ # person me
+ # START WITH
+ # firstname = 'foo' and lastname = 'bar'
+ # CONNECT BY
+ # parentid = prior personid
+ # ORDER SIBLINGS BY
+ # firstname ASC
=head1 DESCRIPTION
This class implements base Oracle support. The subclass
L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
-versions before 9.
+versions before 9.0.
=head1 METHODS
=cut
-use base qw/DBIx::Class::Storage::DBI/;
-use mro 'c3';
+sub _determine_supports_insert_returning {
+ my $self = shift;
+
+# TODO find out which version supports the RETURNING syntax
+# 8i has it and earlier docs are a 404 on oracle.com
+
+ return 1
+ if $self->_server_info->{normalized_dbms_version} >= 8.001;
+
+ return 0;
+}
+
+__PACKAGE__->_use_insert_returning_bound (1);
sub deployment_statements {
my $self = shift;;
$sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
$sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
- my $oracle_version = eval { $self->_get_dbh->get_info(18) };
-
- $sqltargs->{producer_args}{oracle_version} = $oracle_version;
+ if (
+ ! exists $sqltargs->{producer_args}{oracle_version}
+ and
+ my $dver = $self->_server_info->{dbms_version}
+ ) {
+ $sqltargs->{producer_args}{oracle_version} = $dver;
+ }
$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
}
my @ids = ();
foreach my $col (@columns) {
my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
- my $id = $self->_sequence_fetch( 'currval', $seq );
+ my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
push @ids, $id;
}
return @ids;
my ($self, $dbh, $source, $col) = @_;
my $sql_maker = $self->sql_maker;
+ my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
my $source_name;
if ( ref $source->name eq 'SCALAR' ) {
$source_name = ${$source->name};
+
+ # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
+ # stuff unless it is already quoted
+ $source_name = uc ($source_name) if $source_name !~ /\"/;
}
else {
$source_name = $source->name;
+ $source_name = uc($source_name) unless $ql;
}
- $source_name = uc($source_name) unless $sql_maker->quote_char;
# trigger_body is a LONG
local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
local $sql_maker->{bindtype} = 'normal';
# look up the correct sequence automatically
- my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
+ my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
+
+ # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
+ $schema ||= \'= USER';
+
my ($sql, @bind) = $sql_maker->select (
'ALL_TRIGGERS',
- ['trigger_body'],
+ [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
{
- $schema ? (owner => $schema) : (),
- table_name => $table || $source_name,
- triggering_event => 'INSERT',
- status => 'ENABLED',
+ OWNER => $schema,
+ TABLE_NAME => $table || $source_name,
+ TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
+ TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
+ STATUS => 'ENABLED',
},
);
- my $sth = $dbh->prepare($sql);
- $sth->execute (@bind);
- while (my ($insert_trigger) = $sth->fetchrow_array) {
- return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
+ # to find all the triggers that mention the column in question a simple
+ # regex grep since the trigger_body above is a LONG and hence not searchable
+ # via -like
+ my @triggers = ( map
+ { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
+ ( grep
+ { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
+ @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
+ )
+ );
+
+ # extract all sequence names mentioned in each trigger, throw away
+ # triggers without apparent sequences
+ @triggers = map {
+ my @seqs = $_->{body} =~ / ( [\.\w\"\-]+ ) \. nextval /xig;
+ @seqs
+ ? { %$_, sequences => \@seqs }
+ : ()
+ ;
+ } @triggers;
+
+ my $chosen_trigger;
+
+ # if only one trigger matched things are easy
+ if (@triggers == 1) {
+
+ if ( @{$triggers[0]{sequences}} == 1 ) {
+ $chosen_trigger = $triggers[0];
+ }
+ else {
+ $self->throw_exception( sprintf (
+ "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
+ . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+ $triggers[0]{name},
+ $source_name,
+ $col,
+ $col,
+ ) );
+ }
+ }
+ # got more than one matching trigger - see if we can narrow it down
+ elsif (@triggers > 1) {
+
+ my @candidates = grep
+ { $_->{body} =~ / into \s+ \:new\.$col /xi }
+ @triggers
+ ;
+
+ if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
+ $chosen_trigger = $candidates[0];
+ }
+ else {
+ $self->throw_exception( sprintf (
+ "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
+ . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+ $source_name,
+ $col,
+ ( join ', ', map { "'$_->{name}'" } @triggers ),
+ $col,
+ ) );
+ }
+ }
+
+ if ($chosen_trigger) {
+ my $seq_name = $chosen_trigger->{sequences}[0];
+
+ $seq_name = "$chosen_trigger->{schema}.$seq_name"
+ unless $seq_name =~ /\./;
+
+ return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
+ return $seq_name;
}
- $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
+
+ $self->throw_exception( sprintf (
+ "No suitable BEFORE INSERT triggers found for column %s.%s. "
+ . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+ $source_name,
+ $col,
+ $col,
+ ));
}
sub _sequence_fetch {
my ( $self, $type, $seq ) = @_;
- my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
+
+ # use the maker to leverage quoting settings
+ my $sth = $self->_dbh->prepare_cached(
+ $self->sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] )
+ );
+ $sth->execute;
+ my ($id) = $sth->fetchrow_array;
+ $sth->finish;
return $id;
}
my $dbh = $self->_dbh or return 0;
local $dbh->{RaiseError} = 1;
+ local $dbh->{PrintError} = 0;
- eval {
- $dbh->do("select 1 from dual");
+ return try {
+ $dbh->do('select 1 from dual');
+ 1;
+ } catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
sub _dbh_execute {
- my $self = shift;
- my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
-
- my $wantarray = wantarray;
-
- my (@res, $exception, $retried);
-
- RETRY: {
- do {
- eval {
- if ($wantarray) {
- @res = $self->next::method(@_);
- } else {
- $res[0] = $self->next::method(@_);
- }
- };
- $exception = $@;
- if ($exception =~ /ORA-01003/) {
- # ORA-01003: no statement parsed (someone changed the table somehow,
- # invalidating your cursor.)
- my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
- delete $dbh->{CachedKids}{$sql};
- } else {
- last RETRY;
+ my ($self, $dbh, $sql, $bind) = @_;
+
+ # Turn off sth caching for multi-part LOBs. See _prep_for_execute above.
+ local $self->{disable_sth_caching} = 1 if first {
+ ($_->[0]{_ora_lob_autosplit_part}||0)
+ >
+ (__cache_queries_with_max_lob_parts - 1)
+ } @$bind;
+
+ my $next = $self->next::can;
+
+ # if we are already in a txn we can't retry anything
+ return shift->$next(@_)
+ if $self->transaction_depth;
+
+ # cheat the blockrunner - we do want to rerun things regardless of outer state
+ local $self->{_in_do_block};
+
+ return DBIx::Class::Storage::BlockRunner->new(
+ storage => $self,
+ run_code => $next,
+ run_args => \@_,
+ wrap_txn => 0,
+ retry_handler => sub {
+ # ORA-01003: no statement parsed (someone changed the table somehow,
+ # invalidating your cursor.)
+ return 0 if ($_[0]->retried_count or $_[0]->last_exception !~ /ORA-01003/);
+
+ # re-prepare towards new table data
+ if (my $dbh = $_[0]->storage->_dbh) {
+ delete $dbh->{CachedKids}{$_[0]->run_args->[2]};
}
- } while (not $retried++);
- }
+ return 1;
+ },
+ )->run;
+}
- $self->throw_exception($exception) if $exception;
+sub _dbh_execute_for_fetch {
+ #my ($self, $sth, $tuple_status, @extra) = @_;
- wantarray ? @res : $res[0]
+ # DBD::Oracle warns loudly on partial execute_for_fetch failures
+ local $_[1]->{PrintWarn} = 0;
+
+ shift->next::method(@_);
}
=head2 get_autoinc_seq
$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
}
-=head2 columns_info_for
-
-This wraps the superclass version of this method to force table
-names to uppercase
-
-=cut
-
-sub columns_info_for {
- my ($self, $table) = @_;
-
- $self->next::method($table);
-}
-
=head2 datetime_parser_type
This sets the proper DateTime::Format module for use with
L<DBIx::Class::InflateColumn::DateTime>.
-=cut
-
-sub datetime_parser_type { return "DateTime::Format::Oracle"; }
-
=head2 connect_call_datetime_setup
Used as:
on_connect_call => 'datetime_setup'
-In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
-timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
-necessary environment variables for L<DateTime::Format::Oracle>, which is used
-by it.
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
+date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
+and the necessary environment variables for L<DateTime::Format::Oracle>, which
+is used by it.
Maximum allowable precision is used, unless the environment variables have
already been set.
);
}
-=head2 source_bind_attributes
+### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
+### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
+#
+# Handle LOB types in Oracle. Under a certain size (4k?), you can get away
+# with the driver assuming your input is the deprecated LONG type if you
+# encode it as a hex string. That ain't gonna fly at larger values, where
+# you'll discover you have to do what this does.
+#
+# This method had to be overridden because we need to set ora_field to the
+# actual column, and that isn't passed to the call (provided by Storage) to
+# bind_attribute_by_data_type.
+#
+# According to L<DBD::Oracle>, the ora_field isn't always necessary, but
+# adding it doesn't hurt, and will save your bacon if you're modifying a
+# table with more than one LOB column.
+#
+sub _dbi_attrs_for_bind {
+ my ($self, $ident, $bind) = @_;
+
+ my $attrs = $self->next::method($ident, $bind);
+
+ for my $i (0 .. $#$attrs) {
+ if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
+ $attrs->[$i]{ora_field} = $col;
+ }
+ }
-Handle LOB types in Oracle. Under a certain size (4k?), you can get away
-with the driver assuming your input is the deprecated LONG type if you
-encode it as a hex string. That ain't gonna fly at larger values, where
-you'll discover you have to do what this does.
+ $attrs;
+}
-This method had to be overridden because we need to set ora_field to the
-actual column, and that isn't passed to the call (provided by Storage) to
-bind_attribute_by_data_type.
+sub bind_attribute_by_data_type {
+ my ($self, $dt) = @_;
-According to L<DBD::Oracle>, the ora_field isn't always necessary, but
-adding it doesn't hurt, and will save your bacon if you're modifying a
-table with more than one LOB column.
+ if ($self->_is_lob_type($dt)) {
-=cut
+ # this is a hot-ish codepath, store an escape-flag in the DBD namespace, so that
+ # things like Class::Unload work (unlikely but possible)
+ unless ($DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__) {
+
+ # no earlier - no later
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ $self->throw_exception(
+ "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
+ "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
+ );
+ }
+
+ $DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__ = 1;
+ }
+
+ return {
+ ora_type => $self->_is_text_lob_type($dt)
+ ? DBD::Oracle::ORA_CLOB()
+ : DBD::Oracle::ORA_BLOB()
+ };
+ }
+ else {
+ return undef;
+ }
+}
-sub source_bind_attributes
-{
- require DBD::Oracle;
+# Handle blob columns in WHERE.
+#
+# For equality comparisons:
+#
+# We split data intended for comparing to a LOB into 2000 character chunks and
+# compare them using dbms_lob.substr on the LOB column.
+#
+# We turn off DBD::Oracle LOB binds for these partial LOB comparisons by passing
+# dbd_attrs => undef, because these are regular varchar2 comparisons and
+# otherwise the query will fail.
+#
+# Since the most common comparison size is likely to be under 4000 characters
+# (TEXT comparisons previously deployed to other RDBMSes) we disable
+# prepare_cached for queries with more than two part comparisons to a LOB
+# column. This is done in _dbh_execute (above) which was previously overridden
+# to gracefully recover from an Oracle error. This is to be careful to not
+# exhaust your application's open cursor limit.
+#
+# See:
+# http://itcareershift.com/blog1/2011/02/21/oracle-max-number-of-open-cursors-complete-reference-for-the-new-oracle-dba/
+# on the open_cursor limit.
+#
+# For everything else:
+#
+# We assume that everything that is not a LOB comparison, will most likely be a
+# LIKE query or some sort of function invocation. This may prove to be a naive
+# assumption in the future, but for now it should cover the two most likely
+# things users would want to do with a BLOB or CLOB, an equality test or a LIKE
+# query (on a CLOB.)
+#
+# For these expressions, the bind must NOT have the attributes of a LOB bind for
+# DBD::Oracle, otherwise the query will fail. This is done by passing
+# dbd_attrs => undef.
+
+sub _prep_for_execute {
my $self = shift;
- my($source) = @_;
+ my ($op) = @_;
- my %bind_attributes;
+ return $self->next::method(@_)
+ if $op eq 'insert';
- foreach my $column ($source->columns) {
- my $data_type = $source->column_info($column)->{data_type} || '';
- next unless $data_type;
+ my ($sql, $bind) = $self->next::method(@_);
- my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
+ my $lob_bind_indices = { map {
+ (
+ $bind->[$_][0]{sqlt_datatype}
+ and
+ $self->_is_lob_type($bind->[$_][0]{sqlt_datatype})
+ ) ? ( $_ => 1 ) : ()
+ } ( 0 .. $#$bind ) };
- if ($data_type =~ /^[BC]LOB$/i) {
- if ($DBD::Oracle::VERSION eq '1.23') {
- $self->throw_exception(
-"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
-"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
+ return ($sql, $bind) unless %$lob_bind_indices;
+
+ my ($final_sql, @final_binds);
+ if ($op eq 'update') {
+ $self->throw_exception('Update with complex WHERE clauses currently not supported')
+ if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
+
+ my $where_sql;
+ ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
+
+ if (my $set_bind_count = $final_sql =~ y/?//) {
+
+ delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
+
+ # bail if only the update part contains blobs
+ return ($sql, $bind) unless %$lob_bind_indices;
+
+ @final_binds = splice @$bind, 0, $set_bind_count;
+ $lob_bind_indices = { map
+ { $_ - $set_bind_count => $lob_bind_indices->{$_} }
+ keys %$lob_bind_indices
+ };
+ }
+
+ # if we got that far - assume the where SQL is all we got
+ # (the first part is already shoved into $final_sql)
+ $sql = $where_sql;
+ }
+ elsif ($op ne 'select' and $op ne 'delete') {
+ $self->throw_exception("Unsupported \$op: $op");
+ }
+
+ my @sql_parts = split /\?/, $sql;
+
+ my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
+
+ for my $b_idx (0 .. $#$bind) {
+ my $bound = $bind->[$b_idx];
+
+ if (
+ $lob_bind_indices->{$b_idx}
+ and
+ my ($col, $eq) = $sql_parts[0] =~ $col_equality_re
+ ) {
+ my $data = $bound->[1];
+
+ $data = "$data" if ref $data;
+
+ my @parts = unpack '(a2000)*', $data;
+
+ my @sql_frag;
+
+ for my $idx (0..$#parts) {
+ push @sql_frag, sprintf (
+ 'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
+ $col, ($idx*2000 + 1),
);
}
- $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
- ? DBD::Oracle::ORA_CLOB()
- : DBD::Oracle::ORA_BLOB()
+ my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
+
+ $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
+
+ $final_sql .= shift @sql_parts;
+
+ for my $idx (0..$#parts) {
+ push @final_binds, [
+ {
+ %{ $bound->[0] },
+ _ora_lob_autosplit_part => $idx,
+ dbd_attrs => undef,
+ },
+ $parts[$idx]
+ ];
+ }
+ }
+ else {
+ $final_sql .= shift(@sql_parts) . '?';
+ push @final_binds, $lob_bind_indices->{$b_idx}
+ ? [
+ {
+ %{ $bound->[0] },
+ dbd_attrs => undef,
+ },
+ $bound->[1],
+ ] : $bound
;
- $column_bind_attrs{'ora_field'} = $column;
}
+ }
- $bind_attributes{$column} = \%column_bind_attrs;
+ if (@sql_parts > 1) {
+ carp "There are more placeholders than binds, this should not happen!";
+ @sql_parts = join ('?', @sql_parts);
}
- return \%bind_attributes;
+ $final_sql .= $sql_parts[0];
+
+ return ($final_sql, \@final_binds);
}
-sub _svp_begin {
+# Savepoints stuff.
+
+sub _exec_svp_begin {
my ($self, $name) = @_;
- $self->_get_dbh->do("SAVEPOINT $name");
+ $self->_dbh->do("SAVEPOINT $name");
}
# Oracle automatically releases a savepoint when you start another one with the
# same name.
-sub _svp_release { 1 }
+sub _exec_svp_release { 1 }
-sub _svp_rollback {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
=head2 relname_to_table_alias
my $alias = $self->next::method(@_);
- return $alias if length($alias) <= 30;
-
- # get a base64 md5 of the alias with join_count
- require Digest::MD5;
- my $ctx = Digest::MD5->new;
- $ctx->add($alias);
- my $md5 = $ctx->b64digest;
-
- # remove alignment mark just in case
- $md5 =~ s/=*\z//;
-
- # truncate and prepend to truncated relname without vowels
- (my $devoweled = $relname) =~ s/[aeiou]//g;
- my $shortened = substr($devoweled, 0, 18);
-
- my $new_alias =
- $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
-
- return $new_alias;
+ # we need to shorten here in addition to the shortening in SQLA itself,
+ # since the final relnames are a crucial for the join optimizer
+ return $self->sql_maker->_shorten_identifier($alias);
}
=head2 with_deferred_fk_checks
my $txn_scope_guard = $self->txn_scope_guard;
$self->_do_query('alter session set constraints = deferred');
-
+
my $sg = Scope::Guard->new(sub {
$self->_do_query('alter session set constraints = immediate');
});
- return Context::Preserve::preserve_context(sub { $sub->() },
- after => sub { $txn_scope_guard->commit });
+ return
+ preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
}
+=head1 ATTRIBUTES
+
+Following additional attributes can be used in resultsets.
+
+=head2 connect_by or connect_by_nocycle
+
+=over 4
+
+=item Value: \%connect_by
+
+=back
+
+A hashref of conditions used to specify the relationship between parent rows
+and child rows of the hierarchy.
+
+
+ connect_by => { parentid => 'prior personid' }
+
+ # adds a connect by statement to the query:
+ # SELECT
+ # me.persionid me.firstname, me.lastname, me.parentid
+ # FROM
+ # person me
+ # CONNECT BY
+ # parentid = prior persionid
+
+
+ connect_by_nocycle => { parentid => 'prior personid' }
+
+ # adds a connect by statement to the query:
+ # SELECT
+ # me.persionid me.firstname, me.lastname, me.parentid
+ # FROM
+ # person me
+ # CONNECT BY NOCYCLE
+ # parentid = prior persionid
+
+
+=head2 start_with
+
+=over 4
+
+=item Value: \%condition
+
+=back
+
+A hashref of conditions which specify the root row(s) of the hierarchy.
+
+It uses the same syntax as L<DBIx::Class::ResultSet/search>
+
+ start_with => { firstname => 'Foo', lastname => 'Bar' }
+
+ # SELECT
+ # me.persionid me.firstname, me.lastname, me.parentid
+ # FROM
+ # person me
+ # START WITH
+ # firstname = 'foo' and lastname = 'bar'
+ # CONNECT BY
+ # parentid = prior persionid
+
+=head2 order_siblings_by
+
+=over 4
+
+=item Value: ($order_siblings_by | \@order_siblings_by)
+
+=back
+
+Which column(s) to order the siblings by.
+
+It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
+
+ 'order_siblings_by' => 'firstname ASC'
+
+ # SELECT
+ # me.persionid me.firstname, me.lastname, me.parentid
+ # FROM
+ # person me
+ # CONNECT BY
+ # parentid = prior persionid
+ # ORDER SIBLINGS BY
+ # firstname ASC
+
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
=cut
1;
+# vim:sts=2 sw=2:
use base qw( DBIx::Class::Storage::DBI::Oracle::Generic );
use mro 'c3';
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::OracleJoins');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins');
1;
=head1 PURPOSE
-This module was originally written to support Oracle < 9i where ANSI joins
-weren't supported at all, but became the module for Oracle >= 8 because
-Oracle's optimising of ANSI joins is horrible.
+This module is used with Oracle < 9.0 due to lack of support for standard
+ANSI join syntax.
=head1 SYNOPSIS
=head1 METHODS
-See L<DBIx::Class::SQLAHacks::OracleJoins> for implementation details.
+See L<DBIx::Class::SQLMaker::OracleJoins> for implementation details.
=head1 BUGS
=over
-=item L<DBIx::Class::SQLAHacks>
+=item L<DBIx::Class::SQLMaker>
-=item L<DBIx::Class::SQLAHacks::OracleJoins>
+=item L<DBIx::Class::SQLMaker::OracleJoins>
=item L<DBIx::Class::Storage::DBI::Oracle::Generic>
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/;
-use mro 'c3';
-
-use DBD::Pg qw(:pg_types);
-
-# Ask for a DBD::Pg with array support
-warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
- if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv()
+use base qw/DBIx::Class::Storage::DBI/;
+
+use Scope::Guard ();
+use Context::Preserve 'preserve_context';
+use DBIx::Class::Carp;
+use Try::Tiny;
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('LimitOffset');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type ('DateTime::Format::Pg');
+__PACKAGE__->_use_multicolumn_in (1);
+
+sub _determine_supports_insert_returning {
+ return shift->_server_info->{normalized_dbms_version} >= 8.002
+ ? 1
+ : 0
+ ;
+}
sub with_deferred_fk_checks {
my ($self, $sub) = @_;
- $self->_get_dbh->do('SET CONSTRAINTS ALL DEFERRED');
- $sub->();
+ my $txn_scope_guard = $self->txn_scope_guard;
+
+ $self->_do_query('SET CONSTRAINTS ALL DEFERRED');
+
+ my $sg = Scope::Guard->new(sub {
+ $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE');
+ });
+
+ return preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
}
+# only used when INSERT ... RETURNING is disabled
sub last_insert_id {
my ($self,$source,@cols) = @_;
my @values;
+ my $col_info = $source->columns_info(\@cols);
+
for my $col (@cols) {
- my $seq = ( $source->column_info($col)->{sequence} ||= $self->dbh_do('_dbh_get_autoinc_seq', $source, $col) )
+ my $seq = ( $col_info->{$col}{sequence} ||= $self->dbh_do('_dbh_get_autoinc_seq', $source, $col) )
or $self->throw_exception( sprintf(
'could not determine sequence for column %s.%s, please consider adding a schema-qualified sequence to its column info',
$source->name,
$col,
));
- push @values, $self->_dbh_last_insert_id ($self->_dbh, $seq);
+ push @values, $self->_dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
}
return @values;
}
-# there seems to be absolutely no reason to have this as a separate method,
-# but leaving intact in case someone is already overriding it
-sub _dbh_last_insert_id {
- my ($self, $dbh, $seq) = @_;
- $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
-}
+sub _sequence_fetch {
+ my ($self, $function, $sequence) = @_;
+
+ $self->throw_exception('No sequence to fetch') unless $sequence;
+ my ($val) = $self->_get_dbh->selectrow_array(
+ sprintf ("select %s('%s')", $function, (ref $sequence eq 'SCALAR') ? $$sequence : $sequence)
+ );
+
+ return $val;
+}
sub _dbh_get_autoinc_seq {
my ($self, $dbh, $source, $col) = @_;
return 'PostgreSQL';
}
-sub datetime_parser_type { return "DateTime::Format::Pg"; }
-
sub bind_attribute_by_data_type {
my ($self,$data_type) = @_;
- my $bind_attributes = {
- bytea => { pg_type => DBD::Pg::PG_BYTEA },
- blob => { pg_type => DBD::Pg::PG_BYTEA },
- };
-
- if( defined $bind_attributes->{$data_type} ) {
- return $bind_attributes->{$data_type};
+ if ($self->_is_binary_lob_type($data_type)) {
+ # this is a hot-ish codepath, use an escape flag to minimize
+ # amount of function/method calls
+ # additionally version.pm is cock, and memleaks on multiple
+ # ->VERSION calls
+ # the flag is stored in the DBD namespace, so that Class::Unload
+ # will work (unlikely, but still)
+ unless ($DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__) {
+ if ($self->_server_info->{normalized_dbms_version} >= 9.0) {
+ try { DBD::Pg->VERSION('2.17.2'); 1 } or carp (
+ __PACKAGE__.': BYTEA columns are known to not work on Pg >= 9.0 with DBD::Pg < 2.17.2'
+ );
+ }
+ elsif (not try { DBD::Pg->VERSION('2.9.2'); 1 } ) { carp (
+ __PACKAGE__.': DBD::Pg 2.9.2 or greater is strongly recommended for BYTEA column support'
+ )}
+
+ $DBD::Pg::__DBIC_DBD_VERSION_CHECK_DONE__ = 1;
+ }
+
+ return { pg_type => DBD::Pg::PG_BYTEA() };
}
else {
- return;
+ return undef;
}
}
-sub _sequence_fetch {
- my ( $self, $type, $seq ) = @_;
- my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
- return $id;
+sub _exec_svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_dbh->pg_savepoint($name);
}
-sub _svp_begin {
+sub _exec_svp_release {
my ($self, $name) = @_;
- $self->_get_dbh->pg_savepoint($name);
+ $self->_dbh->pg_release($name);
}
-sub _svp_release {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->pg_release($name);
+ $self->_dbh->pg_rollback_to($name);
}
-sub _svp_rollback {
- my ($self, $name) = @_;
+sub deployment_statements {
+ my $self = shift;;
+ my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
+
+ $sqltargs ||= {};
+
+ if (
+ ! exists $sqltargs->{producer_args}{postgres_version}
+ and
+ my $dver = $self->_server_info->{normalized_dbms_version}
+ ) {
+ $sqltargs->{producer_args}{postgres_version} = $dver;
+ }
- $self->_get_dbh->pg_rollback_to($name);
+ $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
}
1;
# In your result (table) classes
use base 'DBIx::Class::Core';
__PACKAGE__->set_primary_key('id');
- __PACKAGE__->sequence('mysequence');
=head1 DESCRIPTION
package DBIx::Class::Storage::DBI::Replicated;
BEGIN {
- use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
- croak('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') )
+ die('The following modules are required for Replication ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated') . "\n" )
unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
use MooseX::Types::Moose qw/ClassName HashRef Object/;
use Scalar::Util 'reftype';
use Hash::Merge;
-use List::Util qw/min max/;
+use List::Util qw/min max reduce/;
+use Context::Preserve 'preserve_context';
+use Try::Tiny;
use namespace::clean -except => 'meta';
$schema->storage_type( ['::DBI::Replicated', {balancer=>'::Random'}] );
$schema->connection(...);
-Next, you need to add in the Replicants. Basically this is an array of
+Next, you need to add in the Replicants. Basically this is an array of
arrayrefs, where each arrayref is database connect information. Think of these
arguments as what you'd pass to the 'normal' $schema->connect method.
You can force a given query to use a particular storage using the search
attribute 'force_pool'. For example:
- my $RS = $schema->resultset('Source')->search(undef, {force_pool=>'master'});
+ my $rs = $schema->resultset('Source')->search(undef, {force_pool=>'master'});
-Now $RS will force everything (both reads and writes) to use whatever was setup
-as the master storage. 'master' is hardcoded to always point to the Master,
+Now $rs will force everything (both reads and writes) to use whatever was setup
+as the master storage. 'master' is hardcoded to always point to the Master,
but you can also use any Replicant name. Please see:
L<DBIx::Class::Storage::DBI::Replicated::Pool> and the replicants attribute for more.
in a transaction when you are reading and writing to the same tables at the
same time, since your replicants will often lag a bit behind the master.
-See L<DBIx::Class::Storage::DBI::Replicated::Instructions> for more help and
-walkthroughs.
+If you have a multi-statement read only transaction you can force it to select
+a random server in the pool by:
+
+ my $rs = $schema->resultset('Source')->search( undef,
+ { force_pool => $db->storage->read_handler->next_storage }
+ );
=head1 DESCRIPTION
=head2 pool_type
-Contains the classname which will instantiate the L</pool> object. Defaults
+Contains the classname which will instantiate the L</pool> object. Defaults
to: L<DBIx::Class::Storage::DBI::Replicated::Pool>.
=cut
=head2 pool
-Is a <DBIx::Class::Storage::DBI::Replicated::Pool> or derived class. This is a
+Is a L<DBIx::Class::Storage::DBI::Replicated::Pool> or derived class. This is a
container class for one or more replicated databases.
=cut
=head2 balancer
-Is a <DBIx::Class::Storage::DBI::Replicated::Balancer> or derived class. This
-is a class that takes a pool (<DBIx::Class::Storage::DBI::Replicated::Pool>)
+Is a L<DBIx::Class::Storage::DBI::Replicated::Balancer> or derived class. This
+is a class that takes a pool (L<DBIx::Class::Storage::DBI::Replicated::Pool>)
=cut
=head1 ATTRIBUTES IMPLEMENTING THE DBIx::Storage::DBI INTERFACE
-The following methods are delegated all the methods required for the
+The following methods are delegated all the methods required for the
L<DBIx::Class::Storage::DBI> interface.
-=head2 read_handler
-
-Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
-
-=cut
-
-has 'read_handler' => (
- is=>'rw',
- isa=>Object,
- lazy_build=>1,
- handles=>[qw/
- select
- select_single
- columns_info_for
- _dbh_columns_info_for
- _select
- /],
-);
-
-=head2 write_handler
-
-Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
-as well as methods that don't write or read that can be called on only one
-storage, methods that return a C<$dbh>, and any methods that don't make sense to
-run on a replicant.
-
=cut
-has 'write_handler' => (
- is=>'ro',
- isa=>Object,
- lazy_build=>1,
- handles=>[qw/
+my $method_dispatch = {
+ writer => [qw/
on_connect_do
on_disconnect_do
on_connect_call
txn_commit
txn_rollback
txn_scope_guard
- sth
+ _exec_txn_rollback
+ _exec_txn_begin
+ _exec_txn_commit
deploy
with_deferred_fk_checks
dbh_do
- reload_row
- with_deferred_fk_checks
_prep_for_execute
-
- backup
is_datatype_numeric
_count_select
- _subq_count_select
- _subq_update_delete
svp_rollback
svp_begin
svp_release
relname_to_table_alias
- _straight_join_to_node
_dbh_last_insert_id
- _fix_bind_params
_default_dbi_connect_attributes
_dbi_connect_info
+ _dbic_connect_attributes
auto_savepoint
- _sqlt_version_ok
+ _query_start
_query_end
+ _format_for_trace
+ _dbi_attrs_for_bind
bind_attribute_by_data_type
transaction_depth
_dbh
_select_args
- _dbh_execute_array
- _sql_maker_args
+ _dbh_execute_for_fetch
_sql_maker
- _query_start
- _sqlt_version_error
- _per_row_update_delete
- _dbh_begin_work
_dbh_execute_inserts_with_no_binds
_select_args_to_query
+ _gen_sql_bind
_svp_generate_name
- _multipk_update_delete
- source_bind_attributes
_normalize_connect_info
_parse_connect_do
- _dbh_commit
- _execute_array
- _placeholders_supported
- _verify_pid
savepoints
- _sqlt_minimum_version
_sql_maker_opts
_conn_pid
- _typeless_placeholders_supported
- _conn_tid
_dbh_autocommit
_native_data_type
_get_dbh
sql_maker_class
- _dbh_rollback
- _adjust_select_args_for_complex_prefetch
- _resolve_ident_sources
- _resolve_column_info
- _prune_unused_joins
- _strip_cond_qualifiers
- _parse_order_by
- _resolve_aliastypes_from_select_args
_execute
_do_query
+ _sth
_dbh_sth
_dbh_execute
+ /, Class::MOP::Class->initialize('DBIx::Class::Storage::DBIHacks')->get_method_list ],
+ reader => [qw/
+ select
+ select_single
+ columns_info_for
+ _dbh_columns_info_for
+ _select
/],
+ unimplemented => [qw/
+ _arm_global_destructor
+ _verify_pid
+
+ source_bind_attributes
+
+ get_use_dbms_capability
+ set_use_dbms_capability
+ get_dbms_capability
+ set_dbms_capability
+ _dbh_details
+ _dbh_get_info
+
+ sql_limit_dialect
+ sql_quote_char
+ sql_name_sep
+
+ _prefetch_autovalues
+ _perform_autoinc_retrieval
+ _autoinc_supplied_for_op
+
+ _resolve_bindattrs
+
+ _max_column_bytesize
+ _is_lob_type
+ _is_binary_lob_type
+ _is_text_lob_type
+
+ sth
+ /,(
+ # the capability framework
+ # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem
+ grep
+ { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x }
+ ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names )
+ )],
+};
+
+if (DBIx::Class::_ENV_::DBICTEST) {
+
+ my $seen;
+ for my $type (keys %$method_dispatch) {
+ for (@{$method_dispatch->{$type}}) {
+ push @{$seen->{$_}}, $type;
+ }
+ }
+
+ if (my @dupes = grep { @{$seen->{$_}} > 1 } keys %$seen) {
+ die(join "\n", '',
+ 'The following methods show up multiple times in ::Storage::DBI::Replicated handlers:',
+ (map { "$_: " . (join ', ', @{$seen->{$_}}) } sort @dupes),
+ '',
+ );
+ }
+
+ if (my @cant = grep { ! DBIx::Class::Storage::DBI->can($_) } keys %$seen) {
+ die(join "\n", '',
+ '::Storage::DBI::Replicated specifies handling of the following *NON EXISTING* ::Storage::DBI methods:',
+ @cant,
+ '',
+ );
+ }
+}
+
+for my $method (@{$method_dispatch->{unimplemented}}) {
+ __PACKAGE__->meta->add_method($method, sub {
+ my $self = shift;
+ $self->throw_exception("$method must not be called on ".(blessed $self).' objects');
+ });
+}
+
+=head2 read_handler
+
+Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
+
+=cut
+
+has 'read_handler' => (
+ is=>'rw',
+ isa=>Object,
+ lazy_build=>1,
+ handles=>$method_dispatch->{reader},
+);
+
+=head2 write_handler
+
+Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
+as well as methods that don't write or read that can be called on only one
+storage, methods that return a C<$dbh>, and any methods that don't make sense to
+run on a replicant.
+
+=cut
+
+has 'write_handler' => (
+ is=>'ro',
+ isa=>Object,
+ lazy_build=>1,
+ handles=>$method_dispatch->{writer},
);
+
+
has _master_connect_info_opts =>
(is => 'rw', isa => HashRef, default => sub { {} });
around connect_info => sub {
my ($next, $self, $info, @extra) = @_;
- my $wantarray = wantarray;
-
my $merge = Hash::Merge->new('LEFT_PRECEDENT');
my %opts;
$merge->merge((delete $opts{pool_args} || {}), $self->pool_args)
);
- $self->pool($self->_build_pool)
- if $self->pool;
+ ## Since we possibly changed the pool_args, we need to clear the current
+ ## pool object so that next time it is used it will be rebuilt.
+ $self->clear_pool;
}
if (@opts{qw/balancer_type balancer_args/}) {
$self->_master_connect_info_opts(\%opts);
- my (@res, $res);
- if ($wantarray) {
- @res = $self->$next($info, @extra);
- } else {
- $res = $self->$next($info, @extra);
- }
-
- # Make sure master is blessed into the correct class and apply role to it.
- my $master = $self->master;
- $master->_determine_driver;
- Moose::Meta::Class->initialize(ref $master);
+ return preserve_context {
+ $self->$next($info, @extra);
+ } after => sub {
+ # Make sure master is blessed into the correct class and apply role to it.
+ my $master = $self->master;
+ $master->_determine_driver;
+ Moose::Meta::Class->initialize(ref $master);
- DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
+ DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
- # link pool back to master
- $self->pool->master($master);
-
- $wantarray ? @res : $res;
+ # link pool back to master
+ $self->pool->master($master);
+ };
};
=head1 METHODS
=cut
sub BUILDARGS {
- my ($class, $schema, $storage_type_args, @args) = @_;
+ my ($class, $schema, $storage_type_args, @args) = @_;
return {
schema=>$schema,
my $reliably = sub {
my $name = shift @_;
$schema->resultset('User')->create({name=>$name});
- my $user_rs = $schema->resultset('User')->find({name=>$name});
+ my $user_rs = $schema->resultset('User')->find({name=>$name});
return $user_rs;
};
=cut
sub execute_reliably {
- my ($self, $coderef, @args) = @_;
+ my $self = shift;
+ my $coderef = shift;
unless( ref $coderef eq 'CODE') {
$self->throw_exception('Second argument must be a coderef');
}
- ##Get copy of master storage
- my $master = $self->master;
-
- ##Get whatever the current read hander is
- my $current = $self->read_handler;
-
- ##Set the read handler to master
- $self->read_handler($master);
-
- ## do whatever the caller needs
- my @result;
- my $want_array = wantarray;
+ ## replace the current read handler for the remainder of the scope
+ local $self->{read_handler} = $self->master;
- eval {
- if($want_array) {
- @result = $coderef->(@args);
- } elsif(defined $want_array) {
- ($result[0]) = ($coderef->(@args));
- } else {
- $coderef->(@args);
- }
+ my $args = \@_;
+ return try {
+ $coderef->(@$args);
+ } catch {
+ $self->throw_exception("coderef returned an error: $_");
};
-
- ##Reset to the original state
- $self->read_handler($current);
-
- ##Exception testing has to come last, otherwise you might leave the
- ##read_handler set to master.
-
- if($@) {
- $self->throw_exception("coderef returned an error: $@");
- } else {
- return $want_array ? @result : $result[0];
- }
}
=head2 set_reliable_storage
foreach my $source ($self->all_storages) {
$source->limit_dialect(@_);
}
- return $self->master->quote_char;
+ return $self->master->limit_dialect;
}
=head2 quote_char
my $self = shift;
return max map $_->lag_behind_master, $self->replicants;
-}
+}
=head2 is_replicating
sub _driver_determined {
my $self = shift;
-
+
if (@_) {
$_->_driver_determined(@_) for $self->all_storages;
}
sub _init {
my $self = shift;
-
+
$_->_init for $self->all_storages;
}
sub _run_connection_actions {
my $self = shift;
-
+
$_->_run_connection_actions for $self->all_storages;
}
sub _do_connection_actions {
my $self = shift;
-
+
if (@_) {
$_->_do_connection_actions(@_) for $self->all_storages;
}
return min map $_->_ping, $self->all_storages;
}
+# not using the normalized_version, because we want to preserve
+# version numbers much longer than the conventional xxx.yyyzzz
+my $numify_ver = sub {
+ my $ver = shift;
+ my @numparts = split /\D+/, $ver;
+ my $format = '%d.' . (join '', ('%06d') x (@numparts - 1));
+
+ return sprintf $format, @numparts;
+};
+sub _server_info {
+ my $self = shift;
+
+ if (not $self->_dbh_details->{info}) {
+ $self->_dbh_details->{info} = (
+ reduce { $a->[0] < $b->[0] ? $a : $b }
+ map [ $numify_ver->($_->{dbms_version}), $_ ],
+ map $_->_server_info, $self->all_storages
+ )->[1];
+ }
+
+ return $self->next::method;
+}
+
+sub _get_server_version {
+ my $self = shift;
+
+ return $self->_server_info->{dbms_version};
+}
+
=head1 GOTCHAS
Due to the fact that replicants can lag behind a master, you must take care to
=head1 NAME
-DBIx::Class::Storage::DBI::Replicated::Balancer - A Software Load Balancer
+DBIx::Class::Storage::DBI::Replicated::Balancer - A Software Load Balancer
=head1 SYNOPSIS
=head2 auto_validate_every ($seconds)
-If auto_validate has some sort of value, run the L<validate_replicants> every
-$seconds. Be careful with this, because if you set it to 0 you will end up
-validating every query.
+If auto_validate has some sort of value, run
+L<DBIx::Class::Storage::DBI::Replicated::Pool/validate_replicants>
+every $seconds. Be careful with this, because if you set it to 0 you
+will end up validating every query.
=cut
Replicant storages (slaves) handle all read only traffic. The assumption is
that your database will become readbound well before it becomes write bound
-and that being able to spread your read only traffic around to multiple
+and that being able to spread your read only traffic around to multiple
databases is going to help you to scale traffic.
This attribute returns the next slave to handle a read request. Your L</pool>
This method should be defined in the class which consumes this role.
Given a pool object, return the next replicant that will serve queries. The
-default behavior is to grab the first replicant it finds but you can write
-your own subclasses of L<DBIx::Class::Storage::DBI::Replicated::Balancer> to
+default behavior is to grab the first replicant it finds but you can write
+your own subclasses of L<DBIx::Class::Storage::DBI::Replicated::Balancer> to
support other balance systems.
This returns from the pool of active replicants. If there are no active
=cut
+my $on_master;
+
around 'next_storage' => sub {
my ($next_storage, $self, @args) = @_;
my $now = time;
## Do we need to validate the replicants?
if(
- $self->has_auto_validate_every &&
+ $self->has_auto_validate_every &&
($self->auto_validate_every + $self->pool->last_validated) <= $now
- ) {
+ ) {
$self->pool->validate_replicants;
}
## Get a replicant, or the master if none
if(my $next = $self->$next_storage(@args)) {
+ $self->master->debugobj->print("Moved back to slave\n") if $on_master;
+ $on_master = 0;
return $next;
} else {
- $self->master->debugobj->print("No Replicants validate, falling back to master reads. ");
+ $self->master->debugobj->print("No Replicants validate, falling back to master reads.\n")
+ unless $on_master++;
+
return $self->master;
}
};
if (my $forced_pool = $args[-1]->{force_pool}) {
delete $args[-1]->{force_pool};
- return $self->_get_forced_pool($forced_pool)->select(@args);
+ return $self->_get_forced_pool($forced_pool)->select(@args);
} elsif($self->master->{transaction_depth}) {
return $self->master->select(@args);
} else {
if (my $forced_pool = $args[-1]->{force_pool}) {
delete $args[-1]->{force_pool};
- return $self->_get_forced_pool($forced_pool)->select_single(@args);
+ return $self->_get_forced_pool($forced_pool)->select_single(@args);
} elsif($self->master->{transaction_depth}) {
return $self->master->select_single(@args);
} else {
return $replicant;
} else {
$self->master->throw_exception("$forced_pool is not a named replicant.");
- }
+ }
}
=head1 AUTHOR
using it. It is not a document explaining how to setup MySQL native replication
either. Copious external resources are available for both. This document
presumes you have the basics down.
-
+
=head1 DESCRIPTION
L<DBIx::Class> supports a framework for using database replication. This system
-is integrated completely, which means once it's setup you should be able to
+is integrated completely, which means once it's setup you should be able to
automatically just start using a replication cluster without additional work or
changes to your code. Some caveats apply, primarily related to the proper use
of transactions (you are wrapping all your database modifying statements inside
L<MySQL::Sandbox>.
If you are using this with a L<Catalyst> based application, you may also want
-to see more recent updates to L<Catalyst::Model::DBIC::Schema>, which has
+to see more recent updates to L<Catalyst::Model::DBIC::Schema>, which has
support for replication configuration options as well.
=head1 REPLICATED STORAGE
is assigned a storage_type, which when fully connected will reflect your
underlying storage engine as defined by your chosen database driver. For
example, if you connect to a MySQL database, your storage_type will be
-L<DBIx::Class::Storage::DBI::mysql> Your storage type class will contain
+L<DBIx::Class::Storage::DBI::mysql> Your storage type class will contain
database specific code to help smooth over the differences between databases
and let L<DBIx::Class> do its thing.
If you want to use replication, you will override this setting so that the
-replicated storage engine will 'wrap' your underlying storages and present
+replicated storage engine will 'wrap' your underlying storages and present
a unified interface to the end programmer. This wrapper storage class will
delegate method calls to either a master database or one or more replicated
databases based on if they are read only (by default sent to the replicants)
-or write (reserved for the master). Additionally, the Replicated storage
+or write (reserved for the master). Additionally, the Replicated storage
will monitor the health of your replicants and automatically drop them should
one exceed configurable parameters. Later, it can automatically restore a
replicant when its health is restored.
a transaction, replicated storage will automatically delegate all database
traffic to the master storage. There are several ways to enable this high
integrity mode, but wrapping your statements inside a transaction is the easy
-and canonical option.
+and canonical option.
=head1 PARTS OF REPLICATED STORAGE
A replicated storage contains several parts. First, there is the replicated
storage itself (L<DBIx::Class::Storage::DBI::Replicated>). A replicated storage
takes a pool of replicants (L<DBIx::Class::Storage::DBI::Replicated::Pool>)
-and a software balancer (L<DBIx::Class::Storage::DBI::Replicated::Pool>). The
-balancer does the job of splitting up all the read traffic amongst the
+and a software balancer (L<DBIx::Class::Storage::DBI::Replicated::Balancer>).
+The balancer does the job of splitting up all the read traffic amongst the
replicants in the Pool. Currently there are two types of balancers, a Random one
which chooses a Replicant in the Pool using a naive randomizer algorithm, and a
First replicant, which just uses the first one in the Pool (and obviously is
'balancer_args' get passed to the balancer when it's instantiated. All
balancers have the 'auto_validate_every' option. This is the number of seconds
we allow to pass between validation checks on a load balanced replicant. So
-the higher the number, the more possibility that your reads to the replicant
+the higher the number, the more possibility that your reads to the replicant
may be inconsistent with what's on the master. Setting this number too low
will result in increased database loads, so choose a number with care. Our
experience is that setting the number around 5 seconds results in a good
use List::Util 'sum';
use Scalar::Util 'reftype';
use DBI ();
-use Carp::Clan qw/^DBIx::Class/;
use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
+use Try::Tiny;
use namespace::clean -except => 'meta';
=head1 DESCRIPTION
In a replicated storage type, there is at least one replicant to handle the
-read-only traffic. The Pool class manages this replicant, or list of
+read-only traffic. The Pool class manages this replicant, or list of
replicants, and gives some methods for querying information about their status.
=head1 ATTRIBUTES
default=>'DBIx::Class::Storage::DBI',
handles=>{
'create_replicant' => 'new',
- },
+ },
);
=head2 replicants
}
$replicant->id($key);
- $self->set_replicant($key => $replicant);
+ $self->set_replicant($key => $replicant);
push @newly_created, $replicant;
}
sub _safely {
my ($self, $replicant, $name, $code) = @_;
- eval {
- $code->()
- };
- if ($@) {
+ return try {
+ $code->();
+ 1;
+ } catch {
$replicant->debugobj->print(sprintf(
"Exception trying to $name for replicant %s, error is %s",
- $replicant->_dbi_connect_info->[0], $@)
+ $replicant->_dbi_connect_info->[0], $_)
);
- return undef;
- }
-
- return 1;
+ undef;
+ };
}
=head2 connected_replicants
defined by L</maximum_lag>. Replicants that fail any of these tests are set to
inactive, and thus removed from the replication pool.
-This tests L<all_replicants>, since a replicant that has been previous marked
+This tests L</all_replicants>, since a replicant that has been previous marked
as inactive can be reactivated should it start to pass the validation tests again.
See L<DBIx::Class::Storage::DBI> for more about checking if a replicating
if($lag_behind_master <= $self->maximum_lag) {
$replicant->active(1);
} else {
- $replicant->active(0);
+ $replicant->active(0);
}
- }
+ }
} else {
$replicant->active(0);
}
$replicant->active(0);
}
}
- ## Mark that we completed this validation.
- $self->_last_validated(time);
+ ## Mark that we completed this validation.
+ $self->_last_validated(time);
}
=head1 AUTHOR
use Scalar::Util 'reftype';
requires qw/_query_start/;
+use Try::Tiny;
use namespace::clean -except => 'meta';
=head1 NAME
around '_query_start' => sub {
my ($method, $self, $sql, @bind) = @_;
- my $dsn = eval { $self->dsn } || $self->_dbi_connect_info->[0];
+ my $dsn = (try { $self->dsn }) || $self->_dbi_connect_info->[0];
my($op, $rest) = (($sql=~m/^(\w+)(.+)$/),'NOP', 'NO SQL');
my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
if ((reftype($dsn)||'') ne 'CODE') {
"$op [DSN_$storage_type=$dsn]$rest";
}
- elsif (my $id = eval { $self->id }) {
+ elsif (my $id = try { $self->id }) {
"$op [$storage_type=$id]$rest";
}
else {
+++ /dev/null
-package DBIx::Class::Storage::DBI::Role::QueryCounter;
-
-use Moose::Role;
-requires '_query_start';
-
-=head1 NAME
-
-DBIx::Class::Storage::DBI::Role::QueryCounter - Role to add a query counter
-
-=head1 SYNOPSIS
-
- my $query_count = $schema->storage->query_count;
-
-=head1 DESCRIPTION
-
-Each time the schema does a query, increment the counter.
-
-=head1 ATTRIBUTES
-
-This package defines the following attributes.
-
-=head2 _query_count
-
-Is the attribute holding the current query count. It defines a public reader
-called 'query_count' which you can use to access the total number of queries
-that DBIC has run since connection.
-
-=cut
-
-has '_query_count' => (
- reader=>'query_count',
- writer=>'_set_query_count',
- isa=>'Int',
- required=>1,
- default=>0,
-);
-
-
-=head1 METHODS
-
-This module defines the following methods.
-
-=head2 _query_start
-
-Override on the method so that we count the queries.
-
-=cut
-
-around '_query_start' => sub {
- my ($_query_start, $self, @args) = @_;
- $self->_increment_query_count;
- return $self->$_query_start(@args);
-};
-
-
-=head2 _increment_query_count
-
-Used internally. You won't need this unless you enjoy messing with the query
-count.
-
-=cut
-
-sub _increment_query_count {
- my $self = shift @_;
- my $current = $self->query_count;
- $self->_set_query_count(++$current);
-}
-
-
-=head1 AUTHORS
-
-See L<DBIx::Class> for more information regarding authors.
-
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
-
-
-1;
use strict;
use warnings;
-use base qw/DBIx::Class::Storage::DBI/;
+use base qw/DBIx::Class::Storage::DBI::UniqueIdentifier/;
use mro 'c3';
-use List::Util ();
+use List::Util 'first';
+use Try::Tiny;
+use namespace::clean;
-__PACKAGE__->mk_group_accessors(simple => qw/
- _identity
-/);
+__PACKAGE__->mk_group_accessors(simple => qw/_identity/);
+__PACKAGE__->sql_limit_dialect ('RowNumberOver');
+__PACKAGE__->sql_quote_char ('"');
+
+__PACKAGE__->new_guid('UUIDTOSTR(NEWID())');
+
+# default to the UUID decoding cursor, overridable by the user
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::SQLAnywhere::Cursor');
=head1 NAME
-DBIx::Class::Storage::DBI::SQLAnywhere - Driver for Sybase SQL Anywhere
+DBIx::Class::Storage::DBI::SQLAnywhere - Driver for SQL Anywhere
=head1 DESCRIPTION
-This class implements autoincrements for Sybase SQL Anywhere, selects the
-RowNumberOver limit implementation and provides
-L<DBIx::Class::InflateColumn::DateTime> support.
+This class implements autoincrements for SQL Anywhere and provides
+L<DBIx::Class::InflateColumn::DateTime> support and support for the
+C<uniqueidentifier> type (via
+L<DBIx::Class::Storage::DBI::SQLAnywhere::Cursor>.)
You need the C<DBD::SQLAnywhere> driver that comes with the SQL Anywhere
distribution, B<NOT> the one on CPAN. It is usually under a path such as:
sub last_insert_id { shift->_identity }
-sub insert {
+sub _prefetch_autovalues {
my $self = shift;
my ($source, $to_insert) = @_;
- my $identity_col = List::Util::first {
- $source->column_info($_)->{is_auto_increment}
- } $source->columns;
+ my $values = $self->next::method(@_);
+
+ my $colinfo = $source->columns_info;
+
+ my $identity_col =
+ first { $colinfo->{$_}{is_auto_increment} } keys %$colinfo;
# user might have an identity PK without is_auto_increment
+#
+# FIXME we probably should not have supported the above, see what
+# does it take to move away from it
if (not $identity_col) {
foreach my $pk_col ($source->primary_columns) {
- if (not exists $to_insert->{$pk_col}) {
+ if (
+ ! exists $to_insert->{$pk_col}
+ and
+ $colinfo->{$pk_col}{data_type}
+ and
+ $colinfo->{$pk_col}{data_type} !~ /^uniqueidentifier/i
+ ) {
$identity_col = $pk_col;
last;
}
my $table_name = $source->from;
$table_name = $$table_name if ref $table_name;
- my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
+ my ($identity) = try {
+ $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')")
+ };
- $to_insert->{$identity_col} = $identity;
+ if (defined $identity) {
+ $values->{$identity_col} = $identity;
+ $self->_identity($identity);
+ }
+ }
- $self->_identity($identity);
+ return $values;
+}
+
+sub _uuid_to_str {
+ my ($self, $data) = @_;
+
+ $data = unpack 'H*', $data;
+
+ for my $pos (8, 13, 18, 23) {
+ substr($data, $pos, 0) = '-';
}
- return $self->next::method(@_);
+ return $data;
}
-# this sub stolen from DB2
+# select_single does not invoke a cursor object at all, hence UUID decoding happens
+# here if the proper cursor class is set
+sub select_single {
+ my $self = shift;
+
+ my @row = $self->next::method(@_);
+
+ return @row
+ unless $self->cursor_class->isa('DBIx::Class::Storage::DBI::SQLAnywhere::Cursor');
+
+ my ($ident, $select) = @_;
+
+ my $col_info = $self->_resolve_column_info($ident);
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
-sub _sql_maker_opts {
- my ( $self, $opts ) = @_;
+ my $data_type = $col_info->{$selected}{data_type}
+ or next;
- if ( $opts ) {
- $self->{_sql_maker_opts} = { %$opts };
+ if ($self->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
+
+ if (length $returned == 16) {
+ $row[$select_idx] = $self->_uuid_to_str($returned);
+ }
+ }
}
- return { limit_dialect => 'RowNumberOver', %{$self->{_sql_maker_opts}||{}} };
+ return @row;
}
# this sub stolen from MSSQL
sub build_datetime_parser {
my $self = shift;
my $type = "DateTime::Format::Strptime";
- eval "use ${type}";
- $self->throw_exception("Couldn't load ${type}: $@") if $@;
+ try {
+ eval "require ${type}"
+ }
+ catch {
+ $self->throw_exception("Couldn't load ${type}: $_");
+ };
+
return $type->new( pattern => '%Y-%m-%d %H:%M:%S.%6N' );
}
);
}
-sub _svp_begin {
+sub _exec_svp_begin {
my ($self, $name) = @_;
- $self->_get_dbh->do("SAVEPOINT $name");
+ $self->_dbh->do("SAVEPOINT $name");
}
# can't release savepoints that have been rolled back
-sub _svp_release { 1 }
+sub _exec_svp_release { 1 }
-sub _svp_rollback {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::SQLAnywhere::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::SQLAnywhere::Cursor - GUID Support for SQL Anywhere
+over L<DBD::SQLAnywhere>
+
+=head1 DESCRIPTION
+
+This class is for normalizing GUIDs retrieved from SQL Anywhere via
+L<DBD::SQLAnywhere>.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::SQLAnywhere> for information on the SQL Anywhere
+driver.
+
+Unfortunately when using L<DBD::SQLAnywhere>, GUIDs come back in binary, the
+purpose of this class is to transform them to text.
+L<DBIx::Class::Storage::DBI::SQLAnywhere> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by default.
+It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> safely with this class and not lose
+the GUID normalizing functionality,
+L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data
+for the inner cursor class.
+
+=cut
+
+sub _dbh_next {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @row = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row[$select_idx];
+
+ if (length $returned == 16) {
+ $row[$select_idx] = $storage->_uuid_to_str($returned);
+ }
+ }
+ }
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_info = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for my $row (@rows) {
+ for my $select_idx (0..$#$select) {
+ my $selected = $select->[$select_idx];
+
+ next if ref $selected;
+
+ my $data_type = $col_info->{$selected}{data_type};
+
+ if ($storage->_is_guid_type($data_type)) {
+ my $returned = $row->[$select_idx];
+
+ if (length $returned == 16) {
+ $row->[$select_idx] = $storage->_uuid_to_str($returned);
+ }
+ }
+ }
+ }
+
+ return @rows;
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
-use POSIX 'strftime';
-use File::Copy;
-use File::Spec;
+use DBIx::Class::Carp;
+use Scalar::Util 'looks_like_number';
+use namespace::clean;
+
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::SQLite');
+__PACKAGE__->sql_limit_dialect ('LimitOffset');
+__PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->datetime_parser_type ('DateTime::Format::SQLite');
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite
+
+=head1 SYNOPSIS
+
+ # In your table classes
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->set_primary_key('id');
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for SQLite.
+
+=head1 METHODS
+
+=cut
+
+sub backup {
+
+ require File::Spec;
+ require File::Copy;
+ require POSIX;
-sub backup
-{
my ($self, $dir) = @_;
$dir ||= './';
{
$dbname = $1 if($dsn =~ /^dbi:SQLite:(.+)$/i);
}
- $self->throw_exception("Cannot determine name of SQLite db file")
+ $self->throw_exception("Cannot determine name of SQLite db file")
if(!$dbname || !-f $dbname);
# print "Found database: $dbname\n";
# my $dbfile = file($dbname);
my ($vol, $dbdir, $file) = File::Spec->splitpath($dbname);
# my $file = $dbfile->basename();
- $file = strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
+ $file = POSIX::strftime("%Y-%m-%d-%H_%M_%S", localtime()) . $file;
$file = "B$file" while(-f $file);
mkdir($dir) unless -f $dir;
my $backupfile = File::Spec->catfile($dir, $file);
- my $res = copy($dbname, $backupfile);
+ my $res = File::Copy::copy($dbname, $backupfile);
$self->throw_exception("Backup failed! ($!)") if(!$res);
return $backupfile;
}
+sub _exec_svp_begin {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("SAVEPOINT $name");
+}
+
+sub _exec_svp_release {
+ my ($self, $name) = @_;
+
+ $self->_dbh->do("RELEASE SAVEPOINT $name");
+}
+
+sub _exec_svp_rollback {
+ my ($self, $name) = @_;
+
+ # For some reason this statement changes the value of $dbh->{AutoCommit}, so
+ # we localize it here to preserve the original value.
+ local $self->_dbh->{AutoCommit} = $self->_dbh->{AutoCommit};
+
+ $self->_dbh->do("ROLLBACK TRANSACTION TO SAVEPOINT $name");
+}
+
sub deployment_statements {
- my $self = shift;;
+ my $self = shift;
my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
$sqltargs ||= {};
- my $sqlite_version = $self->_get_dbh->{sqlite_version};
+ if (
+ ! exists $sqltargs->{producer_args}{sqlite_version}
+ and
+ my $dver = $self->_server_info->{normalized_dbms_version}
+ ) {
+ $sqltargs->{producer_args}{sqlite_version} = $dver;
+ }
- # numify, SQLT does a numeric comparison
- $sqlite_version =~ s/^(\d+) \. (\d+) (?: \. (\d+))? .*/${1}.${2}/x;
+ $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
+}
- $sqltargs->{producer_args}{sqlite_version} = $sqlite_version;
+sub bind_attribute_by_data_type {
+ $_[1] =~ /^ (?: int(?:eger)? | (?:tiny|small|medium)int ) $/ix
+ ? do { require DBI; DBI::SQL_INTEGER() }
+ : undef
+ ;
+}
- $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
+# DBD::SQLite (at least up to version 1.31 has a bug where it will
+# non-fatally nummify a string value bound as an integer, resulting
+# in insertions of '0' into supposed-to-be-numeric fields
+# Since this can result in severe data inconsistency, remove the
+# bind attr if such a sitation is detected
+#
+# FIXME - when a DBD::SQLite version is released that eventually fixes
+# this sutiation (somehow) - no-op this override once a proper DBD
+# version is detected
+sub _dbi_attrs_for_bind {
+ my ($self, $ident, $bind) = @_;
+ my $bindattrs = $self->next::method($ident, $bind);
+
+ for (0.. $#$bindattrs) {
+ if (
+ defined $bindattrs->[$_]
+ and
+ defined $bind->[$_][1]
+ and
+ $bindattrs->[$_] eq DBI::SQL_INTEGER()
+ and
+ ! looks_like_number ($bind->[$_][1])
+ ) {
+ carp_unique( sprintf (
+ "Non-numeric value supplied for column '%s' despite the numeric datatype",
+ $bind->[$_][0]{dbic_colname} || "# $_"
+ ) );
+ undef $bindattrs->[$_];
+ }
+ }
+
+ return $bindattrs;
}
-sub datetime_parser_type { return "DateTime::Format::SQLite"; }
+=head2 connect_call_use_foreign_keys
-1;
+Used as:
-=head1 NAME
+ on_connect_call => 'use_foreign_keys'
-DBIx::Class::Storage::DBI::SQLite - Automatic primary key class for SQLite
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to turn on foreign key
+(including cascading) support for recent versions of SQLite and L<DBD::SQLite>.
-=head1 SYNOPSIS
+Executes:
- # In your table classes
- use base 'DBIx::Class::Core';
- __PACKAGE__->set_primary_key('id');
+ PRAGMA foreign_keys = ON
-=head1 DESCRIPTION
+See L<http://www.sqlite.org/foreignkeys.html> for more information.
-This class implements autoincrements for SQLite.
+=cut
+
+sub connect_call_use_foreign_keys {
+ my $self = shift;
+
+ $self->_do_query(
+ 'PRAGMA foreign_keys = ON'
+ );
+}
+
+1;
=head1 AUTHORS
use strict;
use warnings;
+use Try::Tiny;
+use namespace::clean;
use base qw/DBIx::Class::Storage::DBI/;
sub _rebless {
my $self = shift;
- my $dbtype = eval {
- @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
+ my $dbtype;
+ try {
+ $dbtype = @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
+ } catch {
+ $self->throw_exception("Unable to estable connection to determine database type: $_")
};
- $self->throw_exception("Unable to estable connection to determine database type: $@")
- if $@;
-
if ($dbtype) {
$dbtype =~ s/\W/_/gi;
}
}
+sub _init {
+ # once the driver is determined see if we need to insert the DBD::Sybase w/ FreeTDS fixups
+ # this is a dirty version of "instance role application", \o/ DO WANT Moo \o/
+ my $self = shift;
+ if (! $self->isa('DBIx::Class::Storage::DBI::Sybase::FreeTDS') and $self->_using_freetds) {
+ require DBIx::Class::Storage::DBI::Sybase::FreeTDS;
+
+ my @isa = @{mro::get_linear_isa(ref $self)};
+ my $class = shift @isa; # this is our current ref
+
+ my $trait_class = $class . '::FreeTDS';
+ mro::set_mro ($trait_class, 'c3');
+ no strict 'refs';
+ @{"${trait_class}::ISA"} = ($class, 'DBIx::Class::Storage::DBI::Sybase::FreeTDS', @isa);
+
+ bless ($self, $trait_class);
+
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
+ $self->_init(@_);
+ }
+
+ $self->next::method(@_);
+}
+
sub _ping {
my $self = shift;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
+# FIXME if the main connection goes stale, does opening another for this statement
+# really determine anything?
+
if ($dbh->{syb_no_child_con}) {
-# if extra connections are not allowed, then ->ping is reliable
- my $ping = eval { $dbh->ping };
- return $@ ? 0 : $ping;
+ return try {
+ $self->_connect(@{$self->_dbi_connect_info || [] })
+ ->do('select 1');
+ 1;
+ }
+ catch {
+ 0;
+ };
}
- eval {
-# XXX if the main connection goes stale, does opening another for this statement
-# really determine anything?
+ return try {
$dbh->do('select 1');
+ 1;
+ }
+ catch {
+ 0;
};
-
- return $@ ? 0 : 1;
}
sub _set_max_connect {
}
}
-=head2 using_freetds
-
-Whether or not L<DBD::Sybase> was compiled against FreeTDS. If false, it means
-the Sybase OpenClient libraries were used.
-
-=cut
-
-sub using_freetds {
+# Whether or not DBD::Sybase was compiled against FreeTDS. If false, it means
+# the Sybase OpenClient libraries were used.
+sub _using_freetds {
my $self = shift;
-
- return $self->_get_dbh->{syb_oc_version} =~ /freetds/i;
+ return ($self->_get_dbh->{syb_oc_version}||'') =~ /freetds/i;
}
-=head2 set_textsize
-
-When using FreeTDS and/or MSSQL, C<< $dbh->{LongReadLen} >> is not available,
-use this function instead. It does:
-
- $dbh->do("SET TEXTSIZE $bytes");
-
-Takes the number of bytes, or uses the C<LongReadLen> value from your
-L<DBIx::Class/connect_info> if omitted, lastly falls back to the C<32768> which
-is the L<DBD::Sybase> default.
-
-=cut
-
-sub set_textsize {
- my $self = shift;
- my $text_size = shift ||
- eval { $self->_dbi_connect_info->[-1]->{LongReadLen} } ||
- 32768; # the DBD::Sybase default
-
- return unless defined $text_size;
-
- $self->_dbh->do("SET TEXTSIZE $text_size");
+# Either returns the FreeTDS version against which DBD::Sybase was compiled,
+# 0 if can't be determined, or undef otherwise
+sub _using_freetds_version {
+ my $inf = shift->_get_dbh->{syb_oc_version};
+ return undef unless ($inf||'') =~ /freetds/i;
+ return $inf =~ /v([0-9\.]+)/ ? $1 : 0;
}
1;
use warnings;
use base qw/
- DBIx::Class::Storage::DBI::Sybase
- DBIx::Class::Storage::DBI::AutoCast
+ DBIx::Class::Storage::DBI::Sybase
+ DBIx::Class::Storage::DBI::AutoCast
+ DBIx::Class::Storage::DBI::IdentityInsert
/;
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util();
-use List::Util();
+use DBIx::Class::Carp;
+use Scalar::Util qw/blessed weaken/;
+use List::Util 'first';
use Sub::Name();
-use Data::Dumper::Concise();
+use Data::Dumper::Concise 'Dumper';
+use Try::Tiny;
+use Context::Preserve 'preserve_context';
+use namespace::clean;
+
+__PACKAGE__->sql_limit_dialect ('RowCountOrGenericSubQ');
+__PACKAGE__->sql_quote_char ([qw/[ ]/]);
+__PACKAGE__->datetime_parser_type(
+ 'DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format'
+);
__PACKAGE__->mk_group_accessors('simple' =>
- qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
+ qw/_identity _identity_method _blob_log_on_update _parent_storage
+ _writer_storage _is_writer_storage
_bulk_storage _is_bulk_storage _began_bulk_work
- _bulk_disabled_due_to_coderef_connect_info_warned
- _identity_method/
+ /
);
+
my @also_proxy_to_extra_storages = qw/
connect_call_set_auto_cast auto_cast connect_call_blob_setup
connect_call_datetime_setup
without doing a C<SELECT MAX(col)>. This is done safely in a transaction
(locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
-A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
+A recommended L<connect_info|DBIx::Class::Storage::DBI/connect_info> setting:
on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
my $no_bind_vars = __PACKAGE__ . '::NoBindVars';
- if ($self->using_freetds) {
- carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
+ if ($self->_using_freetds) {
+ carp_once <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
You are using FreeTDS with Sybase.
variable.
EOF
- if (not $self->_typeless_placeholders_supported) {
- if ($self->_placeholders_supported) {
+ if (not $self->_use_typeless_placeholders) {
+ if ($self->_use_placeholders) {
$self->auto_cast(1);
}
else {
$self->_rebless;
}
# this is highly unlikely, but we check just in case
- elsif (not $self->_typeless_placeholders_supported) {
+ elsif (not $self->_use_typeless_placeholders) {
$self->auto_cast(1);
}
}
sub _init {
my $self = shift;
+
+ $self->next::method(@_);
+
+ if ($self->_using_freetds && (my $ver = $self->_using_freetds_version||999) > 0.82) {
+ carp_once(
+ "Buggy FreeTDS version $ver detected, statement caching will not work and "
+ . 'will be disabled.'
+ );
+ $self->disable_sth_caching(1);
+ }
+
$self->_set_max_connect(256);
# create storage for insert/(update blob) transactions,
# unless this is that storage
- return if $self->_is_extra_storage;
+ return if $self->_parent_storage;
my $writer_storage = (ref $self)->new;
- $writer_storage->_is_extra_storage(1);
+ $writer_storage->_is_writer_storage(1); # just info
$writer_storage->connect_info($self->connect_info);
$writer_storage->auto_cast($self->auto_cast);
+ weaken ($writer_storage->{_parent_storage} = $self);
$self->_writer_storage($writer_storage);
# create a bulk storage unless connect_info is a coderef
my $bulk_storage = (ref $self)->new;
- $bulk_storage->_is_extra_storage(1);
$bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics
$bulk_storage->connect_info($self->connect_info);
# this is why
$bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1';
+ weaken ($bulk_storage->{_parent_storage} = $self);
$self->_bulk_storage($bulk_storage);
}
$self->next::method;
}
+# This is only invoked for FreeTDS drivers by ::Storage::DBI::Sybase::FreeTDS
+sub _set_autocommit_stmt {
+ my ($self, $on) = @_;
+
+ return 'SET CHAINED ' . ($on ? 'OFF' : 'ON');
+}
+
# Set up session settings for Sybase databases for the connection.
#
# Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
# DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
# we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
# only want when AutoCommit is off.
-#
-# Also SET TEXTSIZE for FreeTDS because LongReadLen doesn't work.
sub _run_connection_actions {
my $self = shift;
if ($self->_is_bulk_storage) {
-# this should be cleared on every reconnect
+ # this should be cleared on every reconnect
$self->_began_bulk_work(0);
return;
}
- if (not $self->using_freetds) {
- $self->_dbh->{syb_chained_txn} = 1;
- } else {
- # based on LongReadLen in connect_info
- $self->set_textsize;
-
- if ($self->_dbh_autocommit) {
- $self->_dbh->do('SET CHAINED OFF');
- } else {
- $self->_dbh->do('SET CHAINED ON');
- }
- }
+ $self->_dbh->{syb_chained_txn} = 1
+ unless $self->_using_freetds;
$self->next::method(@_);
}
if exists $args{log_on_update};
}
-sub _is_lob_type {
- my $self = shift;
- my $type = shift;
- $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
-}
-
sub _is_lob_column {
my ($self, $source, $column) = @_;
sub _prep_for_execute {
my $self = shift;
- my ($op, $extra_bind, $ident, $args) = @_;
+ my ($op, $ident) = @_;
+
+ #
+### This is commented out because all tests pass. However I am leaving it
+### here as it may prove necessary (can't think through all combinations)
+### BTW it doesn't currently work exactly - need better sensitivity to
+ # currently set value
+ #
+ # inherit these from the parent for the duration of _prep_for_execute
+ # Don't know how to make a localizing loop with if's, otherwise I would
+ #local $self->{_autoinc_supplied_for_op}
+ # = $self->_parent_storage->_autoinc_supplied_for_op
+ #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage;
+ #local $self->{_perform_autoinc_retrieval}
+ # = $self->_parent_storage->_perform_autoinc_retrieval
+ #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage;
my ($sql, $bind) = $self->next::method (@_);
- my $table = Scalar::Util::blessed($ident) ? $ident->from : $ident;
-
- my $bind_info = $self->_resolve_column_info(
- $ident, [map $_->[0], @{$bind}]
- );
- my $bound_identity_col = List::Util::first
- { $bind_info->{$_}{is_auto_increment} }
- (keys %$bind_info)
- ;
- my $identity_col = Scalar::Util::blessed($ident) &&
- List::Util::first
- { $ident->column_info($_)->{is_auto_increment} }
- $ident->columns
- ;
-
- if (($op eq 'insert' && $bound_identity_col) ||
- ($op eq 'update' && exists $args->[0]{$identity_col})) {
- $sql = join ("\n",
- $self->_set_table_identity_sql($op => $table, 'on'),
- $sql,
- $self->_set_table_identity_sql($op => $table, 'off'),
- );
- }
-
- if ($op eq 'insert' && (not $bound_identity_col) && $identity_col &&
- (not $self->{insert_bulk})) {
- $sql =
- "$sql\n" .
- $self->_fetch_identity_sql($ident, $identity_col);
+ if (my $identity_col = $self->_perform_autoinc_retrieval) {
+ $sql .= "\n" . $self->_fetch_identity_sql($ident, $identity_col)
}
return ($sql, $bind);
}
-sub _set_table_identity_sql {
- my ($self, $op, $table, $on_off) = @_;
+sub _fetch_identity_sql {
+ my ($self, $source, $col) = @_;
- return sprintf 'SET IDENTITY_%s %s %s',
- uc($op), $self->sql_maker->_quote($table), uc($on_off);
+ return sprintf ("SELECT MAX(%s) FROM %s",
+ map { $self->sql_maker->_quote ($_) } ($col, $source->from)
+ );
}
# Stolen from SQLT, with some modifications. This is a makeshift
return uc($TYPE_MAPPING{$type} || $type);
}
-sub _fetch_identity_sql {
- my ($self, $source, $col) = @_;
-
- return sprintf ("SELECT MAX(%s) FROM %s",
- map { $self->sql_maker->_quote ($_) } ($col, $source->from)
- );
-}
sub _execute {
my $self = shift;
my ($op) = @_;
- my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
+ my ($rv, $sth, @bind) = $self->next::method(@_);
- if ($op eq 'insert') {
- $self->_identity($sth->fetchrow_array);
- $sth->finish;
- }
+ $self->_identity( ($sth->fetchall_arrayref)->[0][0] )
+ if $self->_perform_autoinc_retrieval;
return wantarray ? ($rv, $sth, @bind) : $rv;
}
my $self = shift;
my ($source, $to_insert) = @_;
- my $identity_col = (List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns) || '';
+ my $columns_info = $source->columns_info;
+
+ my $identity_col =
+ (first { $columns_info->{$_}{is_auto_increment} }
+ keys %$columns_info )
+ || '';
+
+ # FIXME - this is duplication from DBI.pm. When refactored towards
+ # the LobWriter this can be folded back where it belongs.
+ local $self->{_autoinc_supplied_for_op} = exists $to_insert->{$identity_col}
+ ? 1
+ : 0
+ ;
+ local $self->{_perform_autoinc_retrieval} =
+ ($identity_col and ! exists $to_insert->{$identity_col})
+ ? $identity_col
+ : undef
+ ;
# check for empty insert
# INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
# do we need the horrific SELECT MAX(COL) hack?
- my $dumb_last_insert_id =
- $identity_col
- && (not exists $to_insert->{$identity_col})
- && ($self->_identity_method||'') ne '@@IDENTITY';
+ my $need_dumb_last_insert_id = (
+ $self->_perform_autoinc_retrieval
+ &&
+ ($self->_identity_method||'') ne '@@IDENTITY'
+ );
my $next = $self->next::can;
# we are already in a transaction, or there are no blobs
# and we don't need the PK - just (try to) do it
if ($self->{transaction_depth}
- || (!$blob_cols && !$dumb_last_insert_id)
+ || (!$blob_cols && !$need_dumb_last_insert_id)
) {
return $self->_insert (
$next, $source, $to_insert, $blob_cols, $identity_col
my $self = shift;
my ($source, $fields, $where, @rest) = @_;
- my $wantarray = wantarray;
-
- my $blob_cols = $self->_remove_blob_cols($source, $fields);
+ #
+ # When *updating* identities, ASE requires SET IDENTITY_UPDATE called
+ #
+ if (my $blob_cols = $self->_remove_blob_cols($source, $fields)) {
- my $table = $source->name;
-
- my $identity_col = List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns;
-
- my $is_identity_update = $identity_col && defined $fields->{$identity_col};
-
- return $self->next::method(@_) unless $blob_cols;
+ # If there are any blobs in $where, Sybase will return a descriptive error
+ # message.
+ # XXX blobs can still be used with a LIKE query, and this should be handled.
-# If there are any blobs in $where, Sybase will return a descriptive error
-# message.
-# XXX blobs can still be used with a LIKE query, and this should be handled.
+ # update+blob update(s) done atomically on separate connection
+ $self = $self->_writer_storage;
-# update+blob update(s) done atomically on separate connection
- $self = $self->_writer_storage;
+ my $guard = $self->txn_scope_guard;
- my $guard = $self->txn_scope_guard;
+ # First update the blob columns to be updated to '' (taken from $fields, where
+ # it is originally put by _remove_blob_cols .)
+ my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
-# First update the blob columns to be updated to '' (taken from $fields, where
-# it is originally put by _remove_blob_cols .)
- my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
+ # We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
+ $self->next::method($source, \%blobs_to_empty, $where, @rest);
-# We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
+ # Now update the blobs before the other columns in case the update of other
+ # columns makes the search condition invalid.
+ my $rv = $self->_update_blobs($source, $blob_cols, $where);
- $self->next::method($source, \%blobs_to_empty, $where, @rest);
+ if (keys %$fields) {
-# Now update the blobs before the other columns in case the update of other
-# columns makes the search condition invalid.
- $self->_update_blobs($source, $blob_cols, $where);
+ # Now set the identity update flags for the actual update
+ local $self->{_autoinc_supplied_for_op} = (first
+ { $_->{is_auto_increment} }
+ values %{ $source->columns_info([ keys %$fields ]) }
+ ) ? 1 : 0;
- my @res;
- if (%$fields) {
- if ($wantarray) {
- @res = $self->next::method(@_);
- }
- elsif (defined $wantarray) {
- $res[0] = $self->next::method(@_);
+ my $next = $self->next::can;
+ my $args = \@_;
+ return preserve_context {
+ $self->$next(@$args);
+ } after => sub { $guard->commit };
}
else {
- $self->next::method(@_);
+ $guard->commit;
+ return $rv;
}
}
-
- $guard->commit;
-
- return $wantarray ? @res : $res[0];
+ else {
+ # Set the identity update flags for the actual update
+ local $self->{_autoinc_supplied_for_op} = (first
+ { $_->{is_auto_increment} }
+ values %{ $source->columns_info([ keys %$fields ]) }
+ ) ? 1 : 0;
+
+ return $self->next::method(@_);
+ }
}
sub insert_bulk {
my $self = shift;
my ($source, $cols, $data) = @_;
- my $identity_col = List::Util::first
- { $source->column_info($_)->{is_auto_increment} }
- $source->columns;
+ my $columns_info = $source->columns_info;
- my $is_identity_insert = (List::Util::first
- { $_ eq $identity_col }
- @{$cols}
- ) ? 1 : 0;
+ my $identity_col =
+ first { $columns_info->{$_}{is_auto_increment} }
+ keys %$columns_info;
- my @source_columns = $source->columns;
+ # FIXME - this is duplication from DBI.pm. When refactored towards
+ # the LobWriter this can be folded back where it belongs.
+ local $self->{_autoinc_supplied_for_op} =
+ (first { $_ eq $identity_col } @$cols)
+ ? 1
+ : 0
+ ;
my $use_bulk_api =
$self->_bulk_storage &&
$self->_get_dbh->{syb_has_blk};
- if ((not $use_bulk_api)
- &&
- (ref($self->_dbi_connect_info->[0]) eq 'CODE')
- &&
- (not $self->_bulk_disabled_due_to_coderef_connect_info_warned)) {
- carp <<'EOF';
-Bulk API support disabled due to use of a CODEREF connect_info. Reverting to
-regular array inserts.
-EOF
- $self->_bulk_disabled_due_to_coderef_connect_info_warned(1);
+ if (! $use_bulk_api and ref($self->_dbi_connect_info->[0]) eq 'CODE') {
+ carp_unique( join ' ',
+ 'Bulk API support disabled due to use of a CODEREF connect_info.',
+ 'Reverting to regular array inserts.',
+ );
}
if (not $use_bulk_api) {
my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
-# _execute_array uses a txn anyway, but it ends too early in case we need to
+# next::method uses a txn anyway, but it ends too early in case we need to
# select max(col) to get the identity for inserting blobs.
($self, my $guard) = $self->{transaction_depth} == 0 ?
($self->_writer_storage, $self->_writer_storage->txn_scope_guard)
:
($self, undef);
- local $self->{insert_bulk} = 1;
-
$self->next::method(@_);
if ($blob_cols) {
- if ($is_identity_insert) {
+ if ($self->_autoinc_supplied_for_op) {
$self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
}
else {
# otherwise, use the bulk API
# rearrange @$data so that columns are in database order
- my %orig_idx;
- @orig_idx{@$cols} = 0..$#$cols;
+# and so we submit a full column list
+ my %orig_order = map { $cols->[$_] => $_ } 0..$#$cols;
+
+ my @source_columns = $source->columns;
- my %new_idx;
- @new_idx{@source_columns} = 0..$#source_columns;
+ # bcp identity index is 1-based
+ my $identity_idx = first { $source_columns[$_] eq $identity_col } (0..$#source_columns);
+ $identity_idx = defined $identity_idx ? $identity_idx + 1 : 0;
my @new_data;
- for my $datum (@$data) {
- my $new_datum = [];
- for my $col (@source_columns) {
-# identity data will be 'undef' if not $is_identity_insert
-# columns with defaults will also be 'undef'
- $new_datum->[ $new_idx{$col} ] =
- exists $orig_idx{$col} ? $datum->[ $orig_idx{$col} ] : undef;
- }
- push @new_data, $new_datum;
+ for my $slice_idx (0..$#$data) {
+ push @new_data, [map {
+ # identity data will be 'undef' if not _autoinc_supplied_for_op()
+ # columns with defaults will also be 'undef'
+ exists $orig_order{$_}
+ ? $data->[$slice_idx][$orig_order{$_}]
+ : undef
+ } @source_columns];
}
-# bcp identity index is 1-based
- my $identity_idx = exists $new_idx{$identity_col} ?
- $new_idx{$identity_col} + 1 : 0;
+ my $proto_bind = $self->_resolve_bindattrs(
+ $source,
+ [map {
+ [ { dbic_colname => $source_columns[$_], _bind_data_slice_idx => $_ }
+ => $new_data[0][$_] ]
+ } (0 ..$#source_columns) ],
+ $columns_info
+ );
## Set a client-side conversion error handler, straight from DBD::Sybase docs.
# This ignores any data conversion errors detected by the client side libs, as
return 0;
});
- eval {
+ my $exception = '';
+ try {
my $bulk = $self->_bulk_storage;
my $guard = $bulk->txn_scope_guard;
+## FIXME - once this is done - address the FIXME on finish() below
## XXX get this to work instead of our own $sth
## will require SQLA or *Hacks changes for ordered columns
# $bulk->next::method($source, \@source_columns, \@new_data, {
# syb_bcp_attribs => {
-# identity_flag => $is_identity_insert,
+# identity_flag => $self->_autoinc_supplied_for_op ? 1 : 0,
# identity_column => $identity_idx,
# }
# });
# 'insert', # op
{
syb_bcp_attribs => {
- identity_flag => $is_identity_insert,
+ identity_flag => $self->_autoinc_supplied_for_op ? 1 : 0,
identity_column => $identity_idx,
}
}
);
- my @bind = do {
- my $idx = 0;
- map [ $_, $idx++ ], @source_columns;
- };
+ {
+ # FIXME the $sth->finish in _execute_array does a rollback for some
+ # reason. Disable it temporarily until we fix the SQLMaker thing above
+ no warnings 'redefine';
+ no strict 'refs';
+ local *{ref($sth).'::finish'} = sub {};
- $self->_execute_array(
- $source, $sth, \@bind, \@source_columns, \@new_data, sub {
- $guard->commit
- }
- );
+ $self->_dbh_execute_for_fetch(
+ $source, $sth, $proto_bind, \@source_columns, \@new_data
+ );
+ }
+
+ $guard->commit;
$bulk->_query_end($sql);
+ } catch {
+ $exception = shift;
};
- my $exception = $@;
DBD::Sybase::set_cslib_cb($orig_cslib_cb);
if ($exception =~ /-Y option/) {
- carp <<"EOF";
-
-Sybase bulk API operation failed due to character set incompatibility, reverting
-to regular array inserts:
+ my $w = 'Sybase bulk API operation failed due to character set incompatibility, '
+ . 'reverting to regular array inserts. Try unsetting the LANG environment variable'
+ ;
+ $w .= "\n$exception" if $self->debug;
+ carp $w;
-*** Try unsetting the LANG environment variable.
-
-$exception
-EOF
$self->_bulk_storage(undef);
unshift @_, $self;
goto \&insert_bulk;
}
}
-sub _dbh_execute_array {
- my ($self, $sth, $tuple_status, $cb) = @_;
-
- my $rv = $self->next::method($sth, $tuple_status);
- $cb->() if $cb;
-
- return $rv;
-}
-
# Make sure blobs are not bound as placeholders, and return any non-empty ones
# as a hash.
sub _remove_blob_cols {
sub _update_blobs {
my ($self, $source, $blob_cols, $where) = @_;
- my @primary_cols = eval { $source->_pri_cols };
- $self->throw_exception("Cannot update TEXT/IMAGE column(s): $@")
- if $@;
-
-# check if we're updating a single row by PK
- my $pk_cols_in_where = 0;
- for my $col (@primary_cols) {
- $pk_cols_in_where++ if defined $where->{$col};
- }
- my @rows;
+ my @primary_cols = try
+ { $source->_pri_cols }
+ catch {
+ $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
+ };
- if ($pk_cols_in_where == @primary_cols) {
+ my @pks_to_update;
+ if (
+ ref $where eq 'HASH'
+ and
+ @primary_cols == grep { defined $where->{$_} } @primary_cols
+ ) {
my %row_to_update;
@row_to_update{@primary_cols} = @{$where}{@primary_cols};
- @rows = \%row_to_update;
- } else {
+ @pks_to_update = \%row_to_update;
+ }
+ else {
my $cursor = $self->select ($source, \@primary_cols, $where, {});
- @rows = map {
+ @pks_to_update = map {
my %row; @row{@primary_cols} = @$_; \%row
} $cursor->all;
}
- for my $row (@rows) {
- $self->_insert_blobs($source, $blob_cols, $row);
+ for my $ident (@pks_to_update) {
+ $self->_insert_blobs($source, $blob_cols, $ident);
}
}
my $table = $source->name;
my %row = %$row;
- my @primary_cols = eval { $source->_pri_cols} ;
- $self->throw_exception("Cannot update TEXT/IMAGE column(s): $@")
- if $@;
+ my @primary_cols = try
+ { $source->_pri_cols }
+ catch {
+ $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
+ };
$self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
my $sth = $cursor->sth;
if (not $sth) {
-
$self->throw_exception(
"Could not find row in table '$table' for blob update:\n"
- . Data::Dumper::Concise::Dumper (\%where)
+ . (Dumper \%where)
);
}
- eval {
+ try {
do {
$sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
} while $sth->fetch;
$sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
$sth->func('ct_finish_send') or die $sth->errstr;
- };
- my $exception = $@;
- $sth->finish if $sth;
- if ($exception) {
- if ($self->using_freetds) {
+ }
+ catch {
+ if ($self->_using_freetds) {
$self->throw_exception (
- 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
- . $exception
+ "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_"
);
- } else {
- $self->throw_exception($exception);
+ }
+ else {
+ $self->throw_exception($_);
}
}
+ finally {
+ $sth->finish if $sth;
+ };
}
}
on_connect_call => 'datetime_setup'
-In L<DBIx::Class::Storage::DBI/connect_info> to set:
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set:
$dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
$dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
-On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
-L<DateTime::Format::Sybase>, which you will need to install.
-
-This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
+This works for both C<DATETIME> and C<SMALLDATETIME> columns, note that
C<SMALLDATETIME> columns only have minute precision.
=cut
-{
- my $old_dbd_warned = 0;
+sub connect_call_datetime_setup {
+ my $self = shift;
+ my $dbh = $self->_get_dbh;
- sub connect_call_datetime_setup {
- my $self = shift;
- my $dbh = $self->_get_dbh;
-
- if ($dbh->can('syb_date_fmt')) {
- # amazingly, this works with FreeTDS
- $dbh->syb_date_fmt('ISO_strict');
- } elsif (not $old_dbd_warned) {
- carp "Your DBD::Sybase is too old to support ".
- "DBIx::Class::InflateColumn::DateTime, please upgrade!";
- $old_dbd_warned = 1;
- }
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else {
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ .'DBIx::Class::InflateColumn::DateTime, please upgrade!';
+
+ # FIXME - in retrospect this is a rather bad US-centric choice
+ # of format. Not changing as a bugwards compat, though in reality
+ # the only piece that sees the results of $dt object formatting
+ # (as opposed to parsing) is the database itself, so theoretically
+ # changing both this SET command and the formatter definition of
+ # ::S::D::Sybase::ASE::DateTime::Format below should be safe and
+ # transparent
$dbh->do('SET DATEFORMAT mdy');
-
- 1;
}
}
-sub datetime_parser_type { "DateTime::Format::Sybase" }
-
-# ->begin_work and such have no effect with FreeTDS but we run them anyway to
-# let the DBD keep any state it needs to.
-#
-# If they ever do start working, the extra statements will do no harm (because
-# Sybase supports nested transactions.)
-sub _dbh_begin_work {
+sub _exec_txn_begin {
my $self = shift;
# bulkLogin=1 connections are always in a transaction, and can only call BEGIN
$self->next::method(@_);
- if ($self->using_freetds) {
- $self->_get_dbh->do('BEGIN TRAN');
- }
-
$self->_began_bulk_work(1) if $self->_is_bulk_storage;
}
-sub _dbh_commit {
- my $self = shift;
- if ($self->using_freetds) {
- $self->_dbh->do('COMMIT');
- }
- return $self->next::method(@_);
-}
-
-sub _dbh_rollback {
- my $self = shift;
- if ($self->using_freetds) {
- $self->_dbh->do('ROLLBACK');
- }
- return $self->next::method(@_);
-}
-
# savepoint support using ASE syntax
-sub _svp_begin {
+sub _exec_svp_begin {
my ($self, $name) = @_;
- $self->_get_dbh->do("SAVE TRANSACTION $name");
+ $self->_dbh->do("SAVE TRANSACTION $name");
}
# A new SAVE TRANSACTION with the same name releases the previous one.
-sub _svp_release { 1 }
+sub _exec_svp_release { 1 }
-sub _svp_rollback {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
+ $self->_dbh->do("ROLLBACK TRANSACTION $name");
+}
+
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format;
+
+my $datetime_parse_format = '%Y-%m-%dT%H:%M:%S.%3NZ';
+my $datetime_format_format = '%m/%d/%Y %H:%M:%S.%3N';
+
+my ($datetime_parser, $datetime_formatter);
+
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_parse_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
+
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_formatter ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format_format,
+ on_error => 'croak',
+ );
+ return $datetime_formatter->format_datetime(shift);
}
1;
=head1 Schema::Loader Support
As of version C<0.05000>, L<DBIx::Class::Schema::Loader> should work well with
-most (if not all) versions of Sybase ASE.
+most versions of Sybase ASE.
=head1 FreeTDS
Sybase ASE for Linux (which comes with the Open Client libraries) may be
downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
-To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
+To see if you're using FreeTDS run:
perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
-Some versions of the libraries involved will not support placeholders, in which
-case the storage will be reblessed to
+It is recommended to set C<tds version> for your ASE server to C<5.0> in
+C</etc/freetds/freetds.conf>.
+
+Some versions or configurations of the libraries involved will not support
+placeholders, in which case the storage will be reblessed to
L<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars>.
In some configurations, placeholders will work but will throw implicit type
conversion errors for anything that's not expecting a string. In such a case,
the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
automatically set, which you may enable on connection with
-L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
-for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
-definitions in your Result classes, and are mapped to a Sybase type (if it isn't
-already) using a mapping based on L<SQL::Translator>.
+L<connect_call_set_auto_cast|DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>.
+The type info for the C<CAST>s is taken from the
+L<DBIx::Class::ResultSource/data_type> definitions in your Result classes, and
+are mapped to a Sybase type (if it isn't already) using a mapping based on
+L<SQL::Translator>.
In other configurations, placeholders will work just as they do with the Sybase
Open Client libraries.
have active cursors when doing an insert.
When using C<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars> transactions
-are disabled, as there are no concurrency issues with C<SELECT @@IDENTITY> as
-it's a session variable.
+are unnecessary and not used, as there are no concurrency issues with C<SELECT
+@@IDENTITY> which is a session variable.
=head1 TRANSACTIONS
-Due to limitations of the TDS protocol, L<DBD::Sybase>, or both, you cannot
-begin a transaction while there are active cursors, nor can you use multiple
-active cursors within a transaction. An active cursor is, for example, a
+Due to limitations of the TDS protocol and L<DBD::Sybase>, you cannot begin a
+transaction while there are active cursors, nor can you use multiple active
+cursors within a transaction. An active cursor is, for example, a
L<ResultSet|DBIx::Class::ResultSet> that has been executed using C<next> or
C<first> but has not been exhausted or L<reset|DBIx::Class::ResultSet/reset>.
instead.
However, the C<LongReadLen> you pass in
-L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
-C<SET TEXTSIZE> command on connection.
+L<connect_info|DBIx::Class::Storage::DBI/connect_info> is used to execute the
+equivalent C<SET TEXTSIZE> command on connection.
-See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
-setting you need to work with C<IMAGE> columns.
+See L</connect_call_blob_setup> for a
+L<connect_info|DBIx::Class::Storage::DBI/connect_info> setting you need to work
+with C<IMAGE> columns.
=head1 BULK API
B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
calls in your C<Result> classes B<must> list columns in database order for this
to work. Also, you may have to unset the C<LANG> environment variable before
-loading your app, if it doesn't match the character set of your database.
+loading your app, as C<BCP -Y> is not yet supported in DBD::Sybase .
When inserting IMAGE columns using this method, you'll need to use
L</connect_call_blob_setup> as well.
data_type => undef,
default_value => \'getdate()',
is_nullable => 0,
+ inflate_datetime => 1,
}
The C<data_type> must exist and must be C<undef>. Then empty inserts will work
=item *
-Adaptive Server Anywhere (ASA) support, with possible SQLA::Limit support.
-
-=item *
-
Blob update with a LIKE query on a blob, without invalidating the WHERE condition.
=item *
=head1 AUTHOR
-See L<DBIx::Class/CONTRIBUTORS>.
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
=head1 LICENSE
DBIx::Class::Storage::DBI::Sybase::ASE
/;
use mro 'c3';
-use List::Util ();
-use Scalar::Util ();
+use List::Util 'first';
+use Scalar::Util 'looks_like_number';
+use namespace::clean;
sub _init {
my $self = shift;
sub _fetch_identity_sql { 'SELECT ' . $_[0]->_identity_method }
-my $number = sub { Scalar::Util::looks_like_number($_[0]) };
+my $number = sub { looks_like_number $_[0] };
my $decimal = sub { $_[0] =~ /^ [-+]? \d+ (?:\.\d*)? \z/x };
return $self->next::method(@_) if not defined $value or not defined $type;
- if (my $key = List::Util::first { $type =~ /$_/i } keys %noquote) {
+ if (my $key = first { $type =~ /$_/i } keys %noquote) {
return 1 if $noquote{$key}->($value);
}
elsif ($self->is_datatype_numeric($type) && $number->($value)) {
--- /dev/null
+package DBIx::Class::Storage::DBI::Sybase::FreeTDS;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::Sybase/;
+use mro 'c3';
+use Try::Tiny;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Sybase::FreeTDS - Base class for drivers using
+DBD::Sybase over FreeTDS.
+
+=head1 DESCRIPTION
+
+This is the base class for Storages designed to work with L<DBD::Sybase> over
+FreeTDS.
+
+It is a subclass of L<DBIx::Class::Storage::DBI::Sybase>.
+
+=head1 METHODS
+
+=cut
+
+# The subclass storage driver defines _set_autocommit_stmt
+# for MsSQL it is SET IMPLICIT_TRANSACTIONS ON/OFF
+# for proper Sybase it's SET CHAINED ON/OFF
+sub _set_autocommit {
+ my $self = shift;
+
+ if ($self->_dbh_autocommit) {
+ $self->_dbh->do($self->_set_autocommit_stmt(1));
+ } else {
+ $self->_dbh->do($self->_set_autocommit_stmt(0));
+ }
+}
+
+# Handle AutoCommit and SET TEXTSIZE because LongReadLen doesn't work.
+#
+sub _run_connection_actions {
+ my $self = shift;
+
+ # based on LongReadLen in connect_info
+ $self->set_textsize;
+
+ $self->_set_autocommit;
+
+ $self->next::method(@_);
+}
+
+=head2 set_textsize
+
+When using DBD::Sybase with FreeTDS, C<< $dbh->{LongReadLen} >> is not available,
+use this function instead. It does:
+
+ $dbh->do("SET TEXTSIZE $bytes");
+
+Takes the number of bytes, or uses the C<LongReadLen> value from your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info> if omitted, lastly falls
+back to the C<32768> which is the L<DBD::Sybase> default.
+
+=cut
+
+sub set_textsize {
+ my $self = shift;
+ my $text_size =
+ shift
+ ||
+ try { $self->_dbic_cinnect_attributes->{LongReadLen} }
+ ||
+ 32768; # the DBD::Sybase default
+
+ $self->_dbh->do("SET TEXTSIZE $text_size");
+}
+
+sub _exec_txn_begin {
+ my $self = shift;
+
+ if ($self->{_in_do_block}) {
+ $self->_dbh->do('BEGIN TRAN');
+ }
+ else {
+ $self->dbh_do(sub { $_[1]->do('BEGIN TRAN') });
+ }
+}
+
+sub _exec_txn_commit {
+ my $self = shift;
+
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot COMMIT on a disconnected handle');
+
+ $dbh->do('COMMIT');
+}
+
+sub _exec_txn_rollback {
+ my $self = shift;
+
+ my $dbh = $self->_dbh
+ or $self->throw_exception('cannot ROLLBACK on a disconnected handle');
+
+ $dbh->do('ROLLBACK');
+}
+
+1;
+
+=head1 AUTHORS
+
+See L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use DBIx::Class::Carp;
carp 'Setting of storage_type is redundant as connections through DBD::Sybase'
.' are now properly recognized and reblessed into the appropriate subclass'
$schema->storage_type('::DBI::Sybase::MSSQL');
$schema->connect_info('dbi:Sybase:....', ...);
-=head1 BUGS
-
-Currently, this doesn't work right unless you call C<Class::C3::reinitialize()>
-after connecting.
-
=head1 AUTHORS
Brandon L Black <blblack@gmail.com>
/;
use mro 'c3';
+use DBIx::Class::Carp;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server - Support for Microsoft
+SQL Server via DBD::Sybase
+
+=head1 SYNOPSIS
+
+This subclass supports MSSQL server connections via L<DBD::Sybase>.
+
+=head1 DESCRIPTION
+
+This driver tries to determine whether your version of L<DBD::Sybase> and
+supporting libraries (usually FreeTDS) support using placeholders, if not the
+storage will be reblessed to
+L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars>.
+
+The MSSQL specific functionality is provided by
+L<DBIx::Class::Storage::DBI::MSSQL>.
+
+=head1 METHODS
+
+=cut
+
+__PACKAGE__->datetime_parser_type(
+ 'DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format'
+);
+
sub _rebless {
my $self = shift;
my $dbh = $self->_get_dbh;
return if ref $self ne __PACKAGE__;
+ if (not $self->_use_typeless_placeholders) {
+ carp_once <<'EOF' unless $ENV{DBIC_MSSQL_FREETDS_LOWVER_NOWARN};
+Placeholders do not seem to be supported in your configuration of
+DBD::Sybase/FreeTDS.
- if (not $self->_typeless_placeholders_supported) {
+This means you are taking a large performance hit, as caching of prepared
+statements is disabled.
+
+Make sure to configure your server with "tds version" of 8.0 or 7.0 in
+/etc/freetds/freetds.conf .
+
+To turn off this warning, set the DBIC_MSSQL_FREETDS_LOWVER_NOWARN environment
+variable.
+EOF
require
DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars;
bless $self,
}
}
-sub _run_connection_actions {
+sub _init {
my $self = shift;
- # LongReadLen doesn't work with MSSQL through DBD::Sybase, and the default is
- # huge on some versions of SQL server and can cause memory problems, so we
- # fix it up here (see ::DBI::Sybase.pm)
- $self->set_textsize;
-
$self->next::method(@_);
+
+ # work around massively broken freetds versions after 0.82
+ # - explicitly no scope_identity
+ # - no sth caching
+ #
+ # warn about the fact as well, do not provide a mechanism to shut it up
+ if ($self->_using_freetds and (my $ver = $self->_using_freetds_version||999) > 0.82) {
+ carp_once(
+ "Your DBD::Sybase was compiled against buggy FreeTDS version $ver. "
+ . 'Statement caching does not work and will be disabled.'
+ );
+
+ $self->_identity_method('@@identity');
+ $self->_no_scope_identity_query(1);
+ $self->disable_sth_caching(1);
+ }
}
-sub _dbh_begin_work {
- my $self = shift;
+# invoked only if DBD::Sybase is compiled against FreeTDS
+sub _set_autocommit_stmt {
+ my ($self, $on) = @_;
- $self->_get_dbh->do('BEGIN TRAN');
+ return 'SET IMPLICIT_TRANSACTIONS ' . ($on ? 'OFF' : 'ON');
}
-sub _dbh_commit {
+sub _get_server_version {
my $self = shift;
- my $dbh = $self->_dbh
- or $self->throw_exception('cannot COMMIT on a disconnected handle');
- $dbh->do('COMMIT');
+
+ my $product_version = $self->_get_dbh->selectrow_hashref('master.dbo.xp_msver ProductVersion');
+
+ if ((my $version = $product_version->{Character_Value}) =~ /^(\d+)\./) {
+ return $version;
+ }
+ else {
+ $self->throw_exception(
+ "MSSQL Version Retrieval Failed, Your ProductVersion's Character_Value is missing or malformed!"
+ );
+ }
}
-sub _dbh_rollback {
+=head2 connect_call_datetime_setup
+
+Used as:
+
+ on_connect_call => 'datetime_setup'
+
+In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set:
+
+ $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
+
+On connection for use with L<DBIx::Class::InflateColumn::DateTime>
+
+This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
+C<SMALLDATETIME> columns only have minute precision.
+
+=cut
+
+sub connect_call_datetime_setup {
my $self = shift;
- my $dbh = $self->_dbh
- or $self->throw_exception('cannot ROLLBACK on a disconnected handle');
- $dbh->do('ROLLBACK');
+ my $dbh = $self->_get_dbh;
+
+ if ($dbh->can('syb_date_fmt')) {
+ # amazingly, this works with FreeTDS
+ $dbh->syb_date_fmt('ISO_strict');
+ }
+ else{
+ carp_once
+ 'Your DBD::Sybase is too old to support '
+ . 'DBIx::Class::InflateColumn::DateTime, please upgrade!';
+ }
}
-1;
-=head1 NAME
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::DateTime::Format;
-DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server - Support for Microsoft
-SQL Server via DBD::Sybase
-
-=head1 SYNOPSIS
+my $datetime_parse_format = '%Y-%m-%dT%H:%M:%S.%3NZ';
+my $datetime_format_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
-This subclass supports MSSQL server connections via L<DBD::Sybase>.
+my ($datetime_parser, $datetime_formatter);
-=head1 DESCRIPTION
+sub parse_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_parser ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_parse_format,
+ on_error => 'croak',
+ );
+ return $datetime_parser->parse_datetime(shift);
+}
-This driver tries to determine whether your version of L<DBD::Sybase> and
-supporting libraries (usually FreeTDS) support using placeholders, if not the
-storage will be reblessed to
-L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server::NoBindVars>.
+sub format_datetime {
+ shift;
+ require DateTime::Format::Strptime;
+ $datetime_formatter ||= DateTime::Format::Strptime->new(
+ pattern => $datetime_format_format,
+ on_error => 'croak',
+ );
+ return $datetime_formatter->format_datetime(shift);
+}
-The MSSQL specific functionality is provided by
-L<DBIx::Class::Storage::DBI::MSSQL>.
+1;
=head1 AUTHOR
sub _init {
my $self = shift;
$self->disable_sth_caching(1);
+
+ $self->next::method(@_);
}
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::UniqueIdentifier;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI';
+use mro 'c3';
+
+__PACKAGE__->mk_group_accessors(inherited => 'new_guid');
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::UniqueIdentifier - Storage component for RDBMSes
+supporting GUID types
+
+=head1 DESCRIPTION
+
+This is a storage component for databases that support GUID types such as
+C<uniqueidentifier>, C<uniqueidentifierstr> or C<guid>.
+
+GUIDs are generated automatically for PK columns with a supported
+L<data_type|DBIx::Class::ResultSource/data_type>, as well as non-PK with
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> set.
+
+=head1 METHODS
+
+=head2 new_guid
+
+The composing class must set C<new_guid> to the method used to generate a new
+GUID. It can also set it to C<undef>, in which case the user is required to set
+it, or a runtime error will be thrown. It can be:
+
+=over 4
+
+=item string
+
+In which case it is used as the name of database function to create a new GUID,
+
+=item coderef
+
+In which case the coderef should return a string GUID, using L<Data::GUID>, or
+whatever GUID generation method you prefer. It is passed the C<$self>
+L<DBIx::Class::Storage> reference as a parameter.
+
+=back
+
+For example:
+
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+=cut
+
+my $GUID_TYPE = qr/^(?:uniqueidentifier(?:str)?|guid)\z/i;
+
+sub _is_guid_type {
+ my ($self, $data_type) = @_;
+
+ return $data_type =~ $GUID_TYPE;
+}
+
+sub _prefetch_autovalues {
+ my $self = shift;
+ my ($source, $to_insert) = @_;
+
+ my $col_info = $source->columns_info;
+
+ my %guid_cols;
+ my @pk_cols = $source->primary_columns;
+ my %pk_col_idx;
+ @pk_col_idx{@pk_cols} = ();
+
+ my @pk_guids = grep {
+ $col_info->{$_}{data_type}
+ &&
+ $col_info->{$_}{data_type} =~ $GUID_TYPE
+ } @pk_cols;
+
+ my @auto_guids = grep {
+ $col_info->{$_}{data_type}
+ &&
+ $col_info->{$_}{data_type} =~ $GUID_TYPE
+ &&
+ $col_info->{$_}{auto_nextval}
+ } grep { not exists $pk_col_idx{$_} } $source->columns;
+
+ my @get_guids_for =
+ grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
+
+ for my $guid_col (@get_guids_for) {
+ my $new_guid;
+
+ my $guid_method = $self->new_guid;
+
+ if (not defined $guid_method) {
+ $self->throw_exception(
+ 'You must set new_guid on your storage. See perldoc '
+ .'DBIx::Class::Storage::DBI::UniqueIdentifier'
+ );
+ }
+
+ if (ref $guid_method eq 'CODE') {
+ $to_insert->{$guid_col} = $guid_method->($self);
+ }
+ else {
+ ($to_insert->{$guid_col}) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
+ }
+ }
+
+ return $self->next::method(@_);
+}
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
use strict;
use warnings;
-use base qw/
- DBIx::Class::Storage::DBI::MultiColumnIn
- DBIx::Class::Storage::DBI
-/;
-use mro 'c3';
+use base qw/DBIx::Class::Storage::DBI/;
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MySQL');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MySQL');
+__PACKAGE__->sql_limit_dialect ('LimitXY');
+__PACKAGE__->sql_quote_char ('`');
+
+__PACKAGE__->_use_multicolumn_in (1);
sub with_deferred_fk_checks {
my ($self, $sub) = @_;
$dbh->{mysql_insertid};
}
+# here may seem like an odd place to override, but this is the first
+# method called after we are connected *and* the driver is determined
+# ($self is reblessed). See code flow in ::Storage::DBI::_populate_dbh
+sub _run_connection_actions {
+ my $self = shift;
+
+ # default mysql_auto_reconnect to off unless explicitly set
+ if (
+ $self->_dbh->{mysql_auto_reconnect}
+ and
+ ! exists $self->_dbic_connect_attributes->{mysql_auto_reconnect}
+ ) {
+ $self->_dbh->{mysql_auto_reconnect} = 0;
+ }
+
+ $self->next::method(@_);
+}
+
# we need to figure out what mysql version we're running
sub sql_maker {
my $self = shift;
my $maker = $self->next::method (@_);
# mysql 3 does not understand a bare JOIN
- my $mysql_ver = $self->_get_dbh->get_info(18);
+ my $mysql_ver = $self->_dbh_get_info('SQL_DBMS_VER');
$maker->{_default_jointype} = 'INNER' if $mysql_ver =~ /^3/;
}
return 'MySQL';
}
-sub _svp_begin {
+sub deployment_statements {
+ my $self = shift;
+ my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
+
+ $sqltargs ||= {};
+
+ if (
+ ! exists $sqltargs->{producer_args}{mysql_version}
+ and
+ my $dver = $self->_server_info->{normalized_dbms_version}
+ ) {
+ $sqltargs->{producer_args}{mysql_version} = $dver;
+ }
+
+ $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
+}
+
+sub _exec_svp_begin {
my ($self, $name) = @_;
- $self->_get_dbh->do("SAVEPOINT $name");
+ $self->_dbh->do("SAVEPOINT $name");
}
-sub _svp_release {
+sub _exec_svp_release {
my ($self, $name) = @_;
- $self->_get_dbh->do("RELEASE SAVEPOINT $name");
+ $self->_dbh->do("RELEASE SAVEPOINT $name");
}
-sub _svp_rollback {
+sub _exec_svp_rollback {
my ($self, $name) = @_;
- $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+ $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
sub is_replicating {
return shift->_get_dbh->selectrow_hashref('show slave status')->{Seconds_Behind_Master};
}
-# MySql can not do subquery update/deletes, only way is slow per-row operations.
-# This assumes you have set proper transaction isolation and use innodb.
-sub _subq_update_delete {
- return shift->_per_row_update_delete (@_);
-}
-
1;
=head1 NAME
=head1 DESCRIPTION
-This class implements MySQL specific bits of L<DBIx::Class::Storage::DBI>.
+This class implements MySQL specific bits of L<DBIx::Class::Storage::DBI>,
+like AutoIncrement column support and savepoints. Also it augments the
+SQL maker to support the MySQL-specific C<STRAIGHT_JOIN> join type, which
+you can use by specifying C<< join_type => 'straight' >> in the
+L<relationship attributes|DBIx::Class::Relationship::Base/join_type>
+
It also provides a one-stop on-connect macro C<set_strict_mode> which sets
session variables such that MySQL behaves more predictably as far as the
#
# This module contains code that should never have seen the light of day,
# does not belong in the Storage, or is otherwise unfit for public
-# display. The arrival of SQLA2 should immediately oboslete 90% of this
+# display. The arrival of SQLA2 should immediately obsolete 90% of this
#
use strict;
use base 'DBIx::Class::Storage';
use mro 'c3';
-use Carp::Clan qw/^DBIx::Class/;
+use List::Util 'first';
+use Scalar::Util 'blessed';
+use Sub::Name 'subname';
+use namespace::clean;
#
# This code will remove non-selecting/non-restricting joins from
# {from} specs, aiding the RDBMS query optimizer
#
sub _prune_unused_joins {
- my ($self) = shift;
-
+ my $self = shift;
my ($from, $select, $where, $attrs) = @_;
+ return $from unless $self->_use_join_optimizer;
+
if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY') {
return $from; # only standard {from} specs are supported
}
# {multiplying} joins can go
delete $aliastypes->{multiplying} if $attrs->{group_by};
-
my @newfrom = $from->[0]; # FROM head is always present
- my %need_joins = (map { %{$_||{}} } (values %$aliastypes) );
+ my %need_joins;
+ for (values %$aliastypes) {
+ # add all requested aliases
+ $need_joins{$_} = 1 for keys %$_;
+
+ # add all their parents (as per joinpath which is an AoH { table => alias })
+ $need_joins{$_} = 1 for map { values %$_ } map { @$_ } values %$_;
+ }
for my $j (@{$from}[1..$#$from]) {
push @newfrom, $j if (
(! $j->[0]{-alias}) # legacy crap
#
# This is the code producing joined subqueries like:
-# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
+# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
#
sub _adjust_select_args_for_complex_prefetch {
my ($self, $from, $select, $where, $attrs) = @_;
$self->throw_exception ('Nothing to prefetch... how did we get here?!')
- if not @{$attrs->{_prefetch_select}};
+ if not @{$attrs->{_prefetch_selector_range}};
$self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
my $outer_attrs = { %$attrs };
delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
- my $inner_attrs = { %$attrs };
- delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/;
+ my $inner_attrs = { %$attrs, _is_internal_subuery => 1 };
+ delete $inner_attrs->{$_} for qw/for collapse _prefetch_selector_range _collapse_order_by select as/;
# bring over all non-collapse-induced order_by into the inner query (if any)
# the outer one will have to keep them all
delete $inner_attrs->{order_by};
- if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
+ if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}||[]} ) {
$inner_attrs->{order_by} = [
@{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
];
# on the outside we substitute any function for its alias
my $outer_select = [ @$select ];
my $inner_select = [];
- for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) {
+
+ my ($p_start, $p_end) = @{$outer_attrs->{_prefetch_selector_range}};
+ for my $i (0 .. $p_start - 1, $p_end + 1 .. $#$outer_select) {
my $sel = $outer_select->[$i];
if (ref $sel eq 'HASH' ) {
}
push @$inner_select, $sel;
+
+ push @{$inner_attrs->{as}}, $attrs->{as}[$i];
}
- # construct the inner $from for the subquery
+ # construct the inner $from and lock it in a subquery
# we need to prune first, because this will determine if we need a group_by below
- my $inner_from = $self->_prune_unused_joins ($from, $inner_select, $where, $inner_attrs);
-
- # if a multi-type join was needed in the subquery - add a group_by to simulate the
- # collapse in the subq
- $inner_attrs->{group_by} ||= $inner_select
- if List::Util::first
- { ! $_->[0]{-is_single} }
- (@{$inner_from}[1 .. $#$inner_from])
- ;
+ # the fake group_by is so that the pruner throws away all non-selecting, non-restricting
+ # multijoins (since we def. do not care about those inside the subquery)
+
+ my $inner_subq = do {
+
+ # must use it here regardless of user requests
+ local $self->{_use_join_optimizer} = 1;
+
+ my $inner_from = $self->_prune_unused_joins ($from, $inner_select, $where, {
+ group_by => ['dummy'], %$inner_attrs,
+ });
+
+ my $inner_aliastypes =
+ $self->_resolve_aliastypes_from_select_args( $inner_from, $inner_select, $where, $inner_attrs );
+
+ # we need to simulate collapse in the subq if a multiplying join is pulled
+ # by being a non-selecting restrictor
+ if (
+ ! $inner_attrs->{group_by}
+ and
+ first {
+ $inner_aliastypes->{restricting}{$_}
+ and
+ ! $inner_aliastypes->{selecting}{$_}
+ } ( keys %{$inner_aliastypes->{multiplying}||{}} )
+ ) {
+ my $unprocessed_order_chunks;
+ ($inner_attrs->{group_by}, $unprocessed_order_chunks) = $self->_group_over_selection (
+ $inner_from, $inner_select, $inner_attrs->{order_by}
+ );
+
+ $self->throw_exception (
+ 'A required group_by clause could not be constructed automatically due to a complex '
+ . 'order_by criteria. Either order_by columns only (no functions) or construct a suitable '
+ . 'group_by by hand'
+ ) if $unprocessed_order_chunks;
+ }
- # generate the subquery
- my $subq = $self->_select_args_to_query (
- $inner_from,
- $inner_select,
- $where,
- $inner_attrs,
- );
+ # we already optimized $inner_from above
+ local $self->{_use_join_optimizer} = 0;
- my $subq_joinspec = {
- -alias => $attrs->{alias},
- -source_handle => $inner_from->[0]{-source_handle},
- $attrs->{alias} => $subq,
+ # generate the subquery
+ $self->_select_args_to_query (
+ $inner_from,
+ $inner_select,
+ $where,
+ $inner_attrs,
+ );
};
# Generate the outer from - this is relatively easy (really just replace
# - it is part of the restrictions, in which case we need to collapse the outer
# result by tackling yet another group_by to the outside of the query
- # normalize a copy of $from, so it will be easier to work with further
- # down (i.e. promote the initial hashref to an AoH)
$from = [ @$from ];
- $from->[0] = [ $from->[0] ];
# so first generate the outer_from, up to the substitution point
my @outer_from;
while (my $j = shift @$from) {
+ $j = [ $j ] unless ref $j eq 'ARRAY'; # promote the head-from to an AoH
+
if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap
+
push @outer_from, [
- $subq_joinspec,
+ {
+ -alias => $attrs->{alias},
+ -rsrc => $j->[0]{-rsrc},
+ $attrs->{alias} => $inner_subq,
+ },
@{$j}[1 .. $#$j],
];
last; # we'll take care of what's left in $from below
}
}
- # scan the from spec against different attributes, and see which joins are needed
+ # scan the *remaining* from spec against different attributes, and see which joins are needed
# in what role
my $outer_aliastypes =
$self->_resolve_aliastypes_from_select_args( $from, $outer_select, $where, $outer_attrs );
+ # unroll parents
+ my ($outer_select_chain, $outer_restrict_chain) = map { +{
+ map { $_ => 1 } map { values %$_} map { @$_ } values %{ $outer_aliastypes->{$_} || {} }
+ } } qw/selecting restricting/;
+
# see what's left - throw away if not selecting/restricting
- # also throw in a group_by if restricting to guard against
- # cross-join explosions
- #
+ # also throw in a group_by if a non-selecting multiplier,
+ # to guard against cross-join explosions
+ my $need_outer_group_by;
while (my $j = shift @$from) {
my $alias = $j->[0]{-alias};
- if ($outer_aliastypes->{select}{$alias}) {
- push @outer_from, $j;
+ if (
+ $outer_select_chain->{$alias}
+ ) {
+ push @outer_from, $j
}
- elsif ($outer_aliastypes->{restrict}{$alias}) {
+ elsif ($outer_restrict_chain->{$alias}) {
push @outer_from, $j;
- $outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
+ $need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0;
}
}
# demote the outer_from head
$outer_from[0] = $outer_from[0][0];
+ if ($need_outer_group_by and ! $outer_attrs->{group_by}) {
+
+ my $unprocessed_order_chunks;
+ ($outer_attrs->{group_by}, $unprocessed_order_chunks) = $self->_group_over_selection (
+ \@outer_from, $outer_select, $outer_attrs->{order_by}
+ );
+
+ $self->throw_exception (
+ 'A required group_by clause could not be constructed automatically due to a complex '
+ . 'order_by criteria. Either order_by columns only (no functions) or construct a suitable '
+ . 'group_by by hand'
+ ) if $unprocessed_order_chunks;
+
+ }
+
# This is totally horrific - the $where ends up in both the inner and outer query
# Unfortunately not much can be done until SQLA2 introspection arrives, and even
# then if where conditions apply to the *right* side of the prefetch, you may have
return (\@outer_from, $outer_select, $where, $outer_attrs);
}
+#
+# I KNOW THIS SUCKS! GET SQLA2 OUT THE DOOR SO THIS CAN DIE!
+#
# Due to a lack of SQLA2 we fall back to crude scans of all the
# select/where/order/group attributes, in order to determine what
# aliases are neded to fulfill the query. This information is used
# throughout the code to prune unnecessary JOINs from the queries
# in an attempt to reduce the execution time.
# Although the method is pretty horrific, the worst thing that can
-# happen is for it to fail due to an unqualified column, which in
-# turn will result in a vocal exception. Qualifying the column will
-# invariably solve the problem.
+# happen is for it to fail due to some scalar SQL, which in turn will
+# result in a vocal exception.
sub _resolve_aliastypes_from_select_args {
my ( $self, $from, $select, $where, $attrs ) = @_;
or next;
$alias_list->{$al} = $j;
- $aliases_by_type->{multiplying}{$al} = 1
- unless $j->{-is_single};
+ $aliases_by_type->{multiplying}{$al} ||= $j->{-join_path}||[] if (
+ # not array == {from} head == can't be multiplying
+ ( ref($_) eq 'ARRAY' and ! $j->{-is_single} )
+ or
+ # a parent of ours is already a multiplier
+ ( grep { $aliases_by_type->{multiplying}{$_} } @{ $j->{-join_path}||[] } )
+ );
}
+ # get a column to source/alias map (including unqualified ones)
+ my $colinfo = $self->_resolve_column_info ($from);
+
# set up a botched SQLA
my $sql_maker = $self->sql_maker;
- my $sep = quotemeta ($self->_sql_maker_opts->{name_sep} || '.');
- local $sql_maker->{quote_char}; # so that we can regex away
+ # these are throw away results, do not pollute the bind stack
+ local $sql_maker->{select_bind};
+ local $sql_maker->{where_bind};
+ local $sql_maker->{group_bind};
+ local $sql_maker->{having_bind};
+
+ # we can't scan properly without any quoting (\b doesn't cut it
+ # everywhere), so unless there is proper quoting set - use our
+ # own weird impossible character.
+ # Also in the case of no quoting, we need to explicitly disable
+ # name_sep, otherwise sorry nasty legacy syntax like
+ # { 'count(foo.id)' => { '>' => 3 } } will stop working >:(
+ local $sql_maker->{quote_char} = $sql_maker->{quote_char};
+ local $sql_maker->{name_sep} = $sql_maker->{name_sep};
+
+ unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) {
+ $sql_maker->{quote_char} = ["\x00", "\xFF"];
+ # if we don't unset it we screw up retarded but unfortunately working
+ # 'MAX(foo.bar)' => { '>', 3 }
+ $sql_maker->{name_sep} = '';
+ }
+
+ my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
+
+ # generate sql chunks
+ my $to_scan = {
+ restricting => [
+ $sql_maker->_recurse_where ($where),
+ $sql_maker->_parse_rs_attrs ({
+ map { $_ => $attrs->{$_} } (qw/group_by having/)
+ }),
+ ],
+ selecting => [
+ $sql_maker->_recurse_fields ($select),
+ ( map { $_->[0] } $self->_extract_order_criteria ($attrs->{order_by}, $sql_maker) ),
+ ],
+ };
- my $select_sql = $sql_maker->_recurse_fields ($select);
- my $where_sql = $sql_maker->where ($where);
- my $group_by_sql = $sql_maker->_order_by({
- map { $_ => $attrs->{$_} } qw/group_by having/
- });
- my @order_by_chunks = ($self->_parse_order_by ($attrs->{order_by}) );
+ # throw away empty chunks
+ $_ = [ map { $_ || () } @$_ ] for values %$to_scan;
- # match every alias to the sql chunks above
+ # first loop through all fully qualified columns and get the corresponding
+ # alias (should work even if they are in scalarrefs)
for my $alias (keys %$alias_list) {
- my $al_re = qr/\b $alias $sep/x;
-
- for my $piece ($where_sql, $group_by_sql) {
- $aliases_by_type->{restrict}{$alias} = 1 if ($piece =~ $al_re);
+ my $al_re = qr/
+ $lquote $alias $rquote $sep
+ |
+ \b $alias \.
+ /x;
+
+ for my $type (keys %$to_scan) {
+ for my $piece (@{$to_scan->{$type}}) {
+ $aliases_by_type->{$type}{$alias} ||= $alias_list->{$alias}{-join_path}||[]
+ if ($piece =~ $al_re);
+ }
}
+ }
+
+ # now loop through unqualified column names, and try to locate them within
+ # the chunks
+ for my $col (keys %$colinfo) {
+ next if $col =~ / \. /x; # if column is qualified it was caught by the above
+
+ my $col_re = qr/ $lquote $col $rquote /x;
- for my $piece ($select_sql, @order_by_chunks ) {
- $aliases_by_type->{select}{$alias} = 1 if ($piece =~ $al_re);
+ for my $type (keys %$to_scan) {
+ for my $piece (@{$to_scan->{$type}}) {
+ if ($piece =~ $col_re) {
+ my $alias = $colinfo->{$col}{-source_alias};
+ $aliases_by_type->{$type}{$alias} ||= $alias_list->{$alias}{-join_path}||[];
+ }
+ }
}
}
# Add any non-left joins to the restriction list (such joins are indeed restrictions)
for my $j (values %$alias_list) {
my $alias = $j->{-alias} or next;
- $aliases_by_type->{restrict}{$alias} = 1 if (
+ $aliases_by_type->{restricting}{$alias} ||= $j->{-join_path}||[] if (
(not $j->{-join_type})
or
($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
);
}
- # mark all join parents as mentioned
- # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too )
- for my $type (keys %$aliases_by_type) {
- for my $alias (keys %{$aliases_by_type->{$type}}) {
- $aliases_by_type->{$type}{$_} = 1
- for (map { keys %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
+ return $aliases_by_type;
+}
+
+# This is the engine behind { distinct => 1 }
+sub _group_over_selection {
+ my ($self, $from, $select, $order_by) = @_;
+
+ my $rs_column_list = $self->_resolve_column_info ($from);
+
+ my (@group_by, %group_index);
+
+ # the logic is: if it is a { func => val } we assume an aggregate,
+ # otherwise if \'...' or \[...] we assume the user knows what is
+ # going on thus group over it
+ for (@$select) {
+ if (! ref($_) or ref ($_) ne 'HASH' ) {
+ push @group_by, $_;
+ $group_index{$_}++;
+ if ($rs_column_list->{$_} and $_ !~ /\./ ) {
+ # add a fully qualified version as well
+ $group_index{"$rs_column_list->{$_}{-source_alias}.$_"}++;
+ }
}
}
- return $aliases_by_type;
+ # add any order_by parts that are not already present in the group_by
+ # we need to be careful not to add any named functions/aggregates
+ # i.e. order_by => [ ... { count => 'foo' } ... ]
+ my @leftovers;
+ for ($self->_extract_order_criteria($order_by)) {
+ # only consider real columns (for functions the user got to do an explicit group_by)
+ if (@$_ != 1) {
+ push @leftovers, $_;
+ next;
+ }
+ my $chunk = $_->[0];
+ my $colinfo = $rs_column_list->{$chunk} or do {
+ push @leftovers, $_;
+ next;
+ };
+
+ $chunk = "$colinfo->{-source_alias}.$chunk" if $chunk !~ /\./;
+ push @group_by, $chunk unless $group_index{$chunk}++;
+ }
+
+ return wantarray
+ ? (\@group_by, (@leftovers ? \@leftovers : undef) )
+ : \@group_by
+ ;
}
sub _resolve_ident_sources {
# the reason this is so contrived is that $ident may be a {from}
# structure, specifying multiple tables to join
- if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
+ if ( blessed $ident && $ident->isa("DBIx::Class::ResultSource") ) {
# this is compat mode for insert/update/delete which do not deal with aliases
$alias2source->{me} = $ident;
$rs_alias = 'me';
$tabinfo = $_->[0];
}
- $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve
- if ($tabinfo->{-source_handle});
+ $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-rsrc}
+ if ($tabinfo->{-rsrc});
}
}
my ($self, $ident, $colnames) = @_;
my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
- my $sep = $self->_sql_maker_opts->{name_sep} || '.';
- my $qsep = quotemeta $sep;
-
- my (%return, %seen_cols, @auto_colnames);
+ my (%seen_cols, @auto_colnames);
# compile a global list of column names, to be able to properly
# disambiguate unqualified column names (if at all possible)
my $rsrc = $alias2src->{$alias};
for my $colname ($rsrc->columns) {
push @{$seen_cols{$colname}}, $alias;
- push @auto_colnames, "$alias$sep$colname" unless $colnames;
+ push @auto_colnames, "$alias.$colname" unless $colnames;
}
}
grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols),
];
- COLUMN:
+ my (%return, $colinfos);
foreach my $col (@$colnames) {
- my ($alias, $colname) = $col =~ m/^ (?: ([^$qsep]+) $qsep)? (.+) $/x;
+ my ($source_alias, $colname) = $col =~ m/^ (?: ([^\.]+) \. )? (.+) $/x;
- unless ($alias) {
- # see if the column was seen exactly once (so we know which rsrc it came from)
- if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) {
- $alias = $seen_cols{$colname}[0];
- }
- else {
- next COLUMN;
- }
- }
+ # if the column was seen exactly once - we know which rsrc it came from
+ $source_alias ||= $seen_cols{$colname}[0]
+ if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1);
- my $rsrc = $alias2src->{$alias};
- $return{$col} = $rsrc && {
- %{$rsrc->column_info($colname)},
+ next unless $source_alias;
+
+ my $rsrc = $alias2src->{$source_alias}
+ or next;
+
+ $return{$col} = {
+ %{
+ ( $colinfos->{$source_alias} ||= $rsrc->columns_info )->{$colname}
+ ||
+ $self->throw_exception(
+ "No such column '$colname' on source " . $rsrc->source_name
+ );
+ },
-result_source => $rsrc,
- -source_alias => $alias,
+ -source_alias => $source_alias,
+ -fq_colname => $col eq $colname ? "$source_alias.$col" : $col,
+ -colname => $colname,
};
+
+ $return{"$source_alias.$colname"} = $return{$col} if $col eq $colname;
}
return \%return;
# the top of the stack, and if not - make sure the chain is inner-joined down
# to the root.
#
-sub _straight_join_to_node {
+sub _inner_join_to_node {
my ($self, $from, $alias) = @_;
# subqueries and other oddness are naturally not supported
# So it looks like we will have to switch some stuff around.
# local() is useless here as we will be leaving the scope
# anyway, and deep cloning is just too fucking expensive
- # So replace the first hashref in the node arrayref manually
+ # So replace the first hashref in the node arrayref manually
my @new_from = ($from->[0]);
- my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
+ my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path
for my $j (@{$from}[1 .. $#$from]) {
my $jalias = $j->[0]{-alias};
return \@new_from;
}
-# Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
-# a condition containing 'me' or other table prefixes will not work
-# at all. What this code tries to do (badly) is introspect the condition
-# and remove all column qualifiers. If it bails out early (returns undef)
-# the calling code should try another approach (e.g. a subquery)
-sub _strip_cond_qualifiers {
- my ($self, $where) = @_;
-
- my $cond = {};
-
- # No-op. No condition, we're updating/deleting everything
- return $cond unless $where;
-
- if (ref $where eq 'ARRAY') {
- $cond = [
- map {
- my %hash;
- foreach my $key (keys %{$_}) {
- $key =~ /([^.]+)$/;
- $hash{$1} = $_->{$key};
- }
- \%hash;
- } @$where
- ];
- }
- elsif (ref $where eq 'HASH') {
- if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
- $cond->{-and} = [];
- my @cond = @{$where->{-and}};
- for (my $i = 0; $i < @cond; $i++) {
- my $entry = $cond[$i];
- my $hash;
- my $ref = ref $entry;
- if ($ref eq 'HASH' or $ref eq 'ARRAY') {
- $hash = $self->_strip_cond_qualifiers($entry);
- }
- elsif (! $ref) {
- $entry =~ /([^.]+)$/;
- $hash->{$1} = $cond[++$i];
+# yet another atrocity: attempt to extract all columns from a
+# where condition by hooking _quote
+sub _extract_condition_columns {
+ my ($self, $cond, $sql_maker) = @_;
+
+ return [] unless $cond;
+
+ $sql_maker ||= $self->{_sql_ident_capturer} ||= do {
+ # FIXME - replace with a Moo trait
+ my $orig_sm_class = ref $self->sql_maker;
+ my $smic_class = "${orig_sm_class}::_IdentCapture_";
+
+ unless ($smic_class->isa('SQL::Abstract')) {
+
+ no strict 'refs';
+ *{"${smic_class}::_quote"} = subname "${smic_class}::_quote" => sub {
+ my ($self, $ident) = @_;
+ if (ref $ident eq 'SCALAR') {
+ $ident = $$ident;
+ my $storage_quotes = $self->sql_quote_char || '"';
+ my ($ql, $qr) = map
+ { quotemeta $_ }
+ (ref $storage_quotes eq 'ARRAY' ? @$storage_quotes : ($storage_quotes) x 2 )
+ ;
+
+ while ($ident =~ /
+ $ql (\w+) $qr
+ |
+ ([\w\.]+)
+ /xg) {
+ $self->{_captured_idents}{$1||$2}++;
+ }
}
else {
- $self->throw_exception ("_strip_cond_qualifiers() is unable to handle a condition reftype $ref");
+ $self->{_captured_idents}{$ident}++;
}
- push @{$cond->{-and}}, $hash;
- }
+ return $ident;
+ };
+
+ *{"${smic_class}::_get_captured_idents"} = subname "${smic_class}::_get_captures" => sub {
+ (delete shift->{_captured_idents}) || {};
+ };
+
+ $self->inject_base ($smic_class, $orig_sm_class);
+
}
- else {
- foreach my $key (keys %$where) {
- $key =~ /([^.]+)$/;
- $cond->{$1} = $where->{$key};
- }
+
+ $smic_class->new();
+ };
+
+ $sql_maker->_recurse_where($cond);
+
+ return [ sort keys %{$sql_maker->_get_captured_idents} ];
+}
+
+sub _extract_order_criteria {
+ my ($self, $order_by, $sql_maker) = @_;
+
+ my $parser = sub {
+ my ($sql_maker, $order_by) = @_;
+
+ return scalar $sql_maker->_order_by_chunks ($order_by)
+ unless wantarray;
+
+ my @chunks;
+ for ($sql_maker->_order_by_chunks ($order_by) ) {
+ my $chunk = ref $_ ? $_ : [ $_ ];
+ $chunk->[0] =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ push @chunks, $chunk;
}
+
+ return @chunks;
+ };
+
+ if ($sql_maker) {
+ return $parser->($sql_maker, $order_by);
}
else {
- return undef;
+ $sql_maker = $self->sql_maker;
+ local $sql_maker->{quote_char};
+ return $parser->($sql_maker, $order_by);
}
-
- return $cond;
}
-sub _parse_order_by {
- my ($self, $order_by) = @_;
+sub _order_by_is_stable {
+ my ($self, $ident, $order_by, $where) = @_;
- return scalar $self->sql_maker->_order_by_chunks ($order_by)
- unless wantarray;
+ my $colinfo = $self->_resolve_column_info($ident, [
+ (map { $_->[0] } $self->_extract_order_criteria($order_by)),
+ $where ? @{$self->_extract_fixed_condition_columns($where)} :(),
+ ]);
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{quote_char}; #disable quoting
- my @chunks;
- for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
- $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
- push @chunks, $chunk;
+ return undef unless keys %$colinfo;
+
+ my $cols_per_src;
+ $cols_per_src->{$_->{-source_alias}}{$_->{-colname}} = $_ for values %$colinfo;
+
+ for (values %$cols_per_src) {
+ my $src = (values %$_)[0]->{-result_source};
+ return 1 if $src->_identifying_column_set($_);
}
- return @chunks;
+ return undef;
+}
+
+# returns an arrayref of column names which *definitely* have som
+# sort of non-nullable equality requested in the given condition
+# specification. This is used to figure out if a resultset is
+# constrained to a column which is part of a unique constraint,
+# which in turn allows us to better predict how ordering will behave
+# etc.
+#
+# this is a rudimentary, incomplete, and error-prone extractor
+# however this is OK - it is conservative, and if we can not find
+# something that is in fact there - the stack will recover gracefully
+# Also - DQ and the mst it rode in on will save us all RSN!!!
+sub _extract_fixed_condition_columns {
+ my ($self, $where, $nested) = @_;
+
+ return unless ref $where eq 'HASH';
+
+ my @cols;
+ for my $lhs (keys %$where) {
+ if ($lhs =~ /^\-and$/i) {
+ push @cols, ref $where->{$lhs} eq 'ARRAY'
+ ? ( map { $self->_extract_fixed_condition_columns($_, 1) } @{$where->{$lhs}} )
+ : $self->_extract_fixed_condition_columns($where->{$lhs}, 1)
+ ;
+ }
+ elsif ($lhs !~ /^\-/) {
+ my $val = $where->{$lhs};
+
+ push @cols, $lhs if (defined $val and (
+ ! ref $val
+ or
+ (ref $val eq 'HASH' and keys %$val == 1 and defined $val->{'='})
+ ));
+ }
+ }
+ return $nested ? @cols : \@cols;
}
1;
use base qw/DBIx::Class/;
use IO::File;
+use namespace::clean;
-__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh silence/);
+__PACKAGE__->mk_group_accessors(simple => qw/callback _debugfh silence/);
=head1 NAME
should be set to STDERR - although see information on the
L<DBIC_TRACE> environment variable.
-=head2 print
-
-Prints the specified string to our debugging filehandle, which we will attempt
-to open if we haven't yet. Provided to save our methods the worry of how
-to display the message.
+As getter it will lazily open a filehandle for you if one is not already set.
=cut
-sub print {
- my ($self, $msg) = @_;
- return if $self->silence;
+sub debugfh {
+ my $self = shift;
- if(!defined($self->debugfh())) {
+ if (@_) {
+ $self->_debugfh($_[0]);
+ } elsif (!defined($self->_debugfh())) {
my $fh;
my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
|| $ENV{DBIC_TRACE};
if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
- $fh = IO::File->new($1, 'w')
+ $fh = IO::File->new($1, 'a')
or die("Cannot open trace file $1");
} else {
$fh = IO::File->new('>&STDERR')
}
$fh->autoflush();
- $self->debugfh($fh);
+ $self->_debugfh($fh);
}
+ $self->_debugfh;
+}
+
+=head2 print
+
+Prints the specified string to our debugging filehandle. Provided to save our
+methods the worry of how to display the message.
+
+=cut
+sub print {
+ my ($self, $msg) = @_;
+
+ return if $self->silence;
+
$self->debugfh->print($msg);
}
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use Scalar::Util qw/weaken blessed refaddr/;
+use DBIx::Class;
+use DBIx::Class::Exception;
+use DBIx::Class::Carp;
+use namespace::clean;
+
+my ($guards_count, $compat_handler, $foreign_handler);
sub new {
my ($class, $storage) = @_;
+ my $guard = {
+ inactivated => 0,
+ storage => $storage,
+ };
+
+ # we are starting with an already set $@ - in order for things to work we need to
+ # be able to recognize it upon destruction - store its weakref
+ # recording it before doing the txn_begin stuff
+ if (defined $@ and $@ ne '') {
+ $guard->{existing_exception_ref} = (ref $@ ne '') ? $@ : \$@;
+ weaken $guard->{existing_exception_ref};
+ }
+
$storage->txn_begin;
- bless [ 0, $storage ], ref $class || $class;
+
+ $guard->{dbh} = $storage->_dbh;
+ weaken $guard->{dbh};
+
+ bless $guard, ref $class || $class;
+
+ # install a callback carefully
+ if (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and !$guards_count) {
+
+ # if the thrown exception is a plain string, wrap it in our
+ # own exception class
+ # this is actually a pretty cool idea, may very well keep it
+ # after perl is fixed
+ $compat_handler ||= bless(
+ sub {
+ $@ = (blessed($_[0]) or ref($_[0]))
+ ? $_[0]
+ : bless ( { msg => $_[0] }, 'DBIx::Class::Exception')
+ ;
+ die;
+ },
+ '__TxnScopeGuard__FIXUP__',
+ );
+
+ if ($foreign_handler = $SIG{__DIE__}) {
+ $SIG{__DIE__} = bless (
+ sub {
+ # we trust the foreign handler to do whatever it wants, all we do is set $@
+ eval { $compat_handler->(@_) };
+ $foreign_handler->(@_);
+ },
+ '__TxnScopeGuard__FIXUP__',
+ );
+ }
+ else {
+ $SIG{__DIE__} = $compat_handler;
+ }
+ }
+
+ $guards_count++;
+
+ $guard;
}
sub commit {
my $self = shift;
- $self->[1]->txn_commit;
- $self->[0] = 1;
+ $self->{storage}->throw_exception("Refusing to execute multiple commits on scope guard $self")
+ if $self->{inactivated};
+
+ $self->{storage}->txn_commit;
+ $self->{inactivated} = 1;
}
sub DESTROY {
- my ($dismiss, $storage) = @{$_[0]};
+ my $self = shift;
- return if $dismiss;
+ $guards_count--;
- my $exception = $@;
+ # don't touch unless it's ours, and there are no more of us left
+ if (
+ DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT
+ and
+ !$guards_count
+ ) {
+
+ if (ref $SIG{__DIE__} eq '__TxnScopeGuard__FIXUP__') {
+ # restore what we saved
+ if ($foreign_handler) {
+ $SIG{__DIE__} = $foreign_handler;
+ }
+ else {
+ delete $SIG{__DIE__};
+ }
+ }
+
+ # make sure we do not leak the foreign one in case it exists
+ undef $foreign_handler;
+ }
+
+ return if $self->{inactivated};
+
+ # if our dbh is not ours anymore, the $dbh weakref will go undef
+ $self->{storage}->_verify_pid;
+ return unless $self->{dbh};
+
+ my $exception = $@ if (
+ defined $@
+ and
+ $@ ne ''
+ and
+ (
+ ! defined $self->{existing_exception_ref}
+ or
+ refaddr( ref $@ eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref})
+ )
+ );
{
local $@;
carp 'A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back.'
- unless $exception;
-
- eval { $storage->txn_rollback };
- my $rollback_exception = $@;
-
- if ($rollback_exception && $rollback_exception !~ /DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION/) {
- if ($exception) {
+ unless defined $exception;
+
+ my $rollback_exception;
+ # do minimal connectivity check due to weird shit like
+ # https://rt.cpan.org/Public/Bug/Display.html?id=62370
+ try { $self->{storage}->_seems_connected && $self->{storage}->txn_rollback }
+ catch { $rollback_exception = shift };
+
+ if ( $rollback_exception and (
+ ! defined blessed $rollback_exception
+ or
+ ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
+ ) ) {
+ # append our text - THIS IS A TEMPORARY FIXUP!
+ # a real stackable exception object is in the works
+ if (ref $exception eq 'DBIx::Class::Exception') {
+ $exception->{msg} = "Transaction aborted: $exception->{msg} "
+ ."Rollback failed: ${rollback_exception}";
+ }
+ elsif ($exception) {
$exception = "Transaction aborted: ${exception} "
."Rollback failed: ${rollback_exception}";
}
}
}
- $@ = $exception;
+ $@ = $exception unless DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT;
}
1;
=head1 DESCRIPTION
An object that behaves much like L<Scope::Guard>, but hardcoded to do the
-right thing with transactions in DBIx::Class.
+right thing with transactions in DBIx::Class.
=head1 METHODS
=head1 NAME
-DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
+DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns (DEPRECATED)
=head1 SYNOPSIS
=head1 DESCRIPTION
-This module allows you to get columns data that have utf8 (Unicode) flag.
-
-=head2 Warning
+This module allows you to get and store utf8 (unicode) column data
+in a database that does not natively support unicode. It ensures
+that column data is correctly serialised as a byte stream when
+stored and de-serialised to unicode strings on retrieval.
+
+ THE USE OF THIS MODULE (AND ITS COUSIN DBIx::Class::ForceUTF8) IS VERY
+ STRONGLY DISCOURAGED, PLEASE READ THE WARNINGS BELOW FOR AN EXPLANATION.
+
+If you want to continue using this module and do not want to receive
+further warnings set the environment variable C<DBIC_UTF8COLUMNS_OK>
+to a true value.
+
+=head2 Warning - Module does not function properly on create/insert
+
+Recently (April 2010) a bug was found deep in the core of L<DBIx::Class>
+which affects any component attempting to perform encoding/decoding by
+overloading L<store_column|DBIx::Class::Row/store_column> and
+L<get_columns|DBIx::Class::Row/get_columns>. As a result of this problem
+L<create|DBIx::Class::ResultSet/create> sends the original column values
+to the database, while L<update|DBIx::Class::ResultSet/update> sends the
+encoded values. L<DBIx::Class::UTF8Columns> and L<DBIx::Class::ForceUTF8>
+are both affected by ths bug.
+
+It is unclear how this bug went undetected for so long (it was
+introduced in March 2006), No attempts to fix it will be made while the
+implications of changing such a fundamental behavior of DBIx::Class are
+being evaluated. However in this day and age you should not be using
+this module anyway as Unicode is properly supported by all major
+database engines, as explained below.
+
+If you have specific questions about the integrity of your data in light
+of this development - please
+L<join us on IRC or the mailing list|DBIx::Class/GETTING HELP/SUPPORT>
+to further discuss your concerns with the team.
+
+=head2 Warning - Native Database Unicode Support
+
+If your database natively supports Unicode (as does SQLite with the
+C<sqlite_unicode> connect flag, MySQL with C<mysql_enable_utf8>
+connect flag or Postgres with the C<pg_enable_utf8> connect flag),
+then this component should B<not> be used, and will corrupt unicode
+data in a subtle and unexpected manner.
+
+It is far better to do Unicode support within the database if
+possible rather than converting data to and from raw bytes on every
+database round trip.
+
+=head2 Warning - Component Overloading
Note that this module overloads L<DBIx::Class::Row/store_column> in a way
that may prevent other components overloading the same method from working
use strict;
use warnings;
-use vars qw($DEBUG $VERSION @EXPORT_OK);
+our ($DEBUG, $VERSION, @EXPORT_OK);
$VERSION = '1.10';
$DEBUG = 0 unless defined $DEBUG;
use Exporter;
use SQL::Translator::Utils qw(debug normalize_name);
-use Carp::Clan qw/^SQL::Translator|^DBIx::Class/;
-use Scalar::Util ();
+use DBIx::Class::Carp qw/^SQL::Translator|^DBIx::Class|^Try::Tiny/;
+use DBIx::Class::Exception;
+use Scalar::Util qw/weaken blessed/;
+use Try::Tiny;
+use namespace::clean;
use base qw(Exporter);
# We're working with DBIx::Class Schemas, not data streams.
# -------------------------------------------------------------------
sub parse {
- # this is a hack to prevent schema leaks due to a retarded SQLT implementation
- # DO NOT REMOVE (until SQLT2 is out, the all of this will be rewritten anyway)
- Scalar::Util::weaken ($_[1]) if ref ($_[1]);
-
my ($tr, $data) = @_;
my $args = $tr->parser_args;
my $dbicschema = $args->{'DBIx::Class::Schema'} || $args->{"DBIx::Schema"} ||$data;
$dbicschema ||= $args->{'package'};
my $limit_sources = $args->{'sources'};
- croak 'No DBIx::Class::Schema' unless ($dbicschema);
+ # this is a hack to prevent schema leaks due to a retarded SQLT implementation
+ # DO NOT REMOVE (until SQLT2 is out, the all of this will be rewritten anyway)
+ ref $_ and weaken $_
+ for $_[1], $dbicschema, @{$args}{qw/DBIx::Schema DBIx::Class::Schema package/};
+
+ DBIx::Class::Exception->throw('No DBIx::Class::Schema') unless ($dbicschema);
if (!ref $dbicschema) {
- eval "use $dbicschema;";
- croak "Can't load $dbicschema ($@)" if($@);
+ eval "require $dbicschema"
+ or DBIx::Class::Exception->throw("Can't load $dbicschema: $@");
}
my $schema = $tr->schema;
$dbicschema->throw_exception ("'sources' parameter must be an array or hash ref")
unless( $ref eq 'ARRAY' || ref eq 'HASH' );
- # limit monikers to those specified in
+ # limit monikers to those specified in
my $sources;
if ($ref eq 'ARRAY') {
$sources->{$_} = 1 for (@$limit_sources);
# Ignore any rel cond that isn't a straight hash
next unless ref $rel_info->{cond} eq 'HASH';
- my $relsource = $source->related_source($rel);
+ my $relsource = try { $source->related_source($rel) };
+ unless ($relsource) {
+ warn "Ignoring relationship '$rel' - related resultsource '$rel_info->{class}' is not registered with this schema\n";
+ next;
+ };
# related sources might be excluded via a {sources} filter or might be views
next unless exists $table_monikers{$relsource->source_name};
# Force the order of @cond to match the order of ->add_columns
my $idx;
my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns;
- my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
+ my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
# Get the key information, mapping off the foreign/self markers
my @refkeys = map {/^\w+\.(\w+)$/} @cond;
my $dependencies = {
map { $_ => _resolve_deps ($_, \%tables) } (keys %tables)
};
+
for my $table (sort
{
keys %{$dependencies->{$a} || {} } <=> keys %{ $dependencies->{$b} || {} }
# the hook might have already removed the table
if ($schema->get_table($table) && $table =~ /^ \s* \( \s* SELECT \s+/ix) {
- warn <<'EOW';
+ carp <<'EOW';
Custom SQL through ->name(\'( SELECT ...') is DEPRECATED, for more details see
"Arbitrary SQL through a custom ResultSource" in DBIx::Class::Manual::Cookbook
}
my %views;
- foreach my $moniker (sort keys %view_monikers)
+ my @views = map { $dbicschema->source($_) } keys %view_monikers;
+
+ my $view_dependencies = {
+ map {
+ $_ => _resolve_deps( $dbicschema->source($_), \%view_monikers )
+ } ( keys %view_monikers )
+ };
+
+ my @view_sources =
+ sort {
+ keys %{ $view_dependencies->{ $a->source_name } || {} } <=>
+ keys %{ $view_dependencies->{ $b->source_name } || {} }
+ || $a->source_name cmp $b->source_name
+ }
+ map { $dbicschema->source($_) }
+ keys %view_monikers;
+
+ foreach my $source (@view_sources)
{
- my $source = $dbicschema->source($moniker);
my $view_name = $source->name;
# FIXME - this isn't the right way to do it, but sqlt does not
# Quick and dirty dependency graph calculator
#
sub _resolve_deps {
- my ($table, $tables, $seen) = @_;
-
- my $ret = {};
- $seen ||= {};
-
- # copy and bump all deps by one (so we can reconstruct the chain)
- my %seen = map { $_ => $seen->{$_} + 1 } (keys %$seen);
- $seen{$table} = 1;
-
- for my $dep (keys %{$tables->{$table}{foreign_table_deps}} ) {
-
- if ($seen->{$dep}) {
-
- # warn and remove the circular constraint so we don't get flooded with the same warning over and over
- #carp sprintf ("Circular dependency detected, schema may not be deployable:\n%s\n",
- # join (' -> ', (sort { $seen->{$b} <=> $seen->{$a} } (keys %$seen) ), $table, $dep )
- #);
- #delete $tables->{$table}{foreign_table_deps}{$dep};
-
- return {};
+ my ( $question, $answers, $seen ) = @_;
+ my $ret = {};
+ $seen ||= {};
+ my @deps;
+
+ # copy and bump all deps by one (so we can reconstruct the chain)
+ my %seen = map { $_ => $seen->{$_} + 1 } ( keys %$seen );
+ if ( blessed($question)
+ && $question->isa('DBIx::Class::ResultSource::View') )
+ {
+ $seen{ $question->result_class } = 1;
+ @deps = keys %{ $question->{deploy_depends_on} };
+ }
+ else {
+ $seen{$question} = 1;
+ @deps = keys %{ $answers->{$question}{foreign_table_deps} };
}
- my $subdeps = _resolve_deps ($dep, $tables, \%seen);
- $ret->{$_} += $subdeps->{$_} for ( keys %$subdeps );
-
- ++$ret->{$dep};
- }
+ for my $dep (@deps) {
+ if ( $seen->{$dep} ) {
+ return {};
+ }
+ my $next_dep;
- return $ret;
+ if ( blessed($question)
+ && $question->isa('DBIx::Class::ResultSource::View') )
+ {
+ no warnings 'uninitialized';
+ my ($next_dep_source_name) =
+ grep {
+ $question->schema->source($_)->result_class eq $dep
+ && !( $question->schema->source($_)
+ ->isa('DBIx::Class::ResultSource::Table') )
+ } @{ [ $question->schema->sources ] };
+ return {} unless $next_dep_source_name;
+ $next_dep = $question->schema->source($next_dep_source_name);
+ }
+ else {
+ $next_dep = $dep;
+ }
+ my $subdeps = _resolve_deps( $next_dep, $answers, \%seen );
+ $ret->{$_} += $subdeps->{$_} for ( keys %$subdeps );
+ ++$ret->{$dep};
+ }
+ return $ret;
}
1;
=cut
use strict;
-use vars qw[ $VERSION $DEBUG $WARN ];
+our ($VERSION, $DEBUG, $WARN);
$VERSION = '0.1';
$DEBUG = 0 unless defined $DEBUG;
--- /dev/null
+die "Makefile.PL does not seem to have been executed from the root distdir\n"
+ unless -d 'lib';
+
+# $FindBin::Bin is the location of the inluding Makefile.PL, not this file
+require FindBin;
+unshift @INC, "$FindBin::Bin/lib";
+
+# adjust ENV for $AUTHOR system() calls
+require Config;
+$ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+require File::Spec;
+require File::Find;
+
+my $xt_dirs;
+File::Find::find(sub {
+ return if $xt_dirs->{$File::Find::dir};
+ $xt_dirs->{$File::Find::dir} = 1 if (
+ $_ =~ /\.t$/ and -f $_
+ );
+}, 'xt');
+
+my $xt_tests = join (' ', map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs );
+
+# this will add the xt tests to the `make test` target among other things
+Meta->tests(join (' ', map { $_ || () } Meta->tests, $xt_tests ) );
+
+# inject an explicit xt test run for making a tarball (distdir is exempt)
+postamble <<"EOP";
+
+.PHONY: test_xt
+
+dist : test_xt
+
+test_xt :
+\tPERL_DL_NONLAZY=1 RELEASE_TESTING=1 \$(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" "test_harness(\$(TEST_VERBOSE), 'inc', '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $xt_tests
+
+EOP
+
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+my ($optdep_msg, $opt_testdeps);
+
+if ($args->{skip_author_deps}) {
+ $optdep_msg = <<'EOW';
+
+******************************************************************************
+******************************************************************************
+*** ***
+*** IGNORING AUTHOR MODE: no optional test dependencies will be forced. ***
+*** ***
+*** If you are using this checkout with the intention of submitting a DBIC ***
+*** patch, you are *STRONGLY ENCOURAGED* to install all dependencies, so ***
+*** that every possible unit-test will run. ***
+*** ***
+******************************************************************************
+******************************************************************************
+
+EOW
+}
+else {
+ $optdep_msg = <<'EOW';
+
+******************************************************************************
+******************************************************************************
+*** ***
+*** AUTHOR MODE: all optional test dependencies converted to hard requires ***
+*** ( to disable re-run Makefile.PL with --skip-author-deps ) ***
+*** ***
+******************************************************************************
+******************************************************************************
+
+EOW
+
+ require DBIx::Class::Optional::Dependencies;
+ my %reqs_for_group = %{DBIx::Class::Optional::Dependencies->req_group_list};
+
+ # exclude the rdbms_* groups which are for DBIC users
+ $opt_testdeps = {
+ map { %{$reqs_for_group{$_}} } grep { !/^rdbms_/ } keys %reqs_for_group
+ };
+
+ print "Including all optional deps\n";
+ $reqs->{test_requires} = {
+ %{$reqs->{test_requires}},
+ %$opt_testdeps
+ };
+}
+
+# nasty hook into both M::AI init and the prompter, so that the optdep message
+# comes at the right places (on top and then right above the prompt)
+{
+ require Module::AutoInstall;
+ no warnings 'redefine';
+ no strict 'refs';
+
+ for (qw/_prompt import/) {
+ my $meth = "Module::AutoInstall::$_";
+ my $orig = \&{$meth};
+ *{$meth} = sub {
+ print $optdep_msg;
+ goto $orig;
+ };
+ }
+}
+
+# this will run after the Makefile is written and the main Makefile.PL terminates
+#
+END {
+ # Re-write META.yml at the end to _exclude_ all forced build-requires (we do not
+ # want to ship this) We are also not using M::I::AuthorRequires as this will be
+ # an extra dep, and deps in Makefile.PL still suck
+ # Also always test the result so we stop shipping borked dependency lists to CPAN
+
+ # FIXME test_requires is not yet part of META
+ my %original_build_requires = ( %$build_requires, %$test_requires );
+ my @all_build_requires = @{delete Meta->{values}{build_requires}||[]};
+ my %removed_build_requires;
+
+ for (@all_build_requires) {
+ if ($original_build_requires{$_->[0]}) {
+ push @{Meta->{values}{build_requires}}, $_;
+ }
+ else {
+ $removed_build_requires{$_->[0]} = $_->[1]
+ unless $_->[0] eq 'ExtUtils::MakeMaker';
+ }
+ }
+
+ if (keys %removed_build_requires) {
+ print "Regenerating META with author requires excluded\n";
+ Meta->write;
+ }
+
+ # test that we really took things away (just in case, happened twice somehow)
+ if (! -f 'META.yml') {
+ warn "No META.yml generated?! aborting...\n";
+ unlink 'Makefile';
+ exit 1;
+ }
+ my $meta = do { local @ARGV = 'META.yml'; local $/; <> };
+
+ # this is safe as there is a fatal check earlier in the main Makefile.PL
+ # to make sure there are no duplicates (i.e. $opt_testdeps does not contain
+ # any real dependencies)
+ my @illegal_leftovers = grep
+ { $meta =~ /^ \s+ \Q$_\E \: \s+ /mx }
+ ( sort keys %$opt_testdeps )
+ ;
+
+ if (@illegal_leftovers) {
+ warn join ("\n",
+ "\n\nFATAL FAIL! It looks like some author dependencies made it to the META.yml:\n",
+ map { "\t$_" } @illegal_leftovers
+ ) . "\n\n";
+ unlink 'Makefile';
+ exit 1;
+ }
+}
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+print "Appending to the no_index META list\n";
+
+# Deprecated/internal modules need no exposure when building the meta
+no_index directory => $_ for (qw|
+ lib/DBIx/Class/Admin
+ lib/DBIx/Class/PK/Auto
+ lib/DBIx/Class/CDBICompat
+|);
+no_index package => $_ for (qw/
+ DBIx::Class::Storage::DBIHacks
+ DBIx::Class::Carp
+ DBIx::Class::ResultSet::Pager
+/);
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+# Makefile syntax allows adding extra dep-specs for already-existing targets,
+# and simply appends them on *LAST*-come *FIRST*-serve basis.
+# This allows us to inject extra depenencies for standard EUMM targets
+
+postamble <<"EOP";
+
+.PHONY: dbic_clonedir_cleanup_readme dbic_clonedir_gen_readme
+
+distdir : dbic_clonedir_cleanup_readme
+
+create_distdir : dbic_clonedir_gen_readme
+
+dbic_clonedir_gen_readme :
+\tpod2text lib/DBIx/Class.pm > README
+
+dbic_clonedir_cleanup_readme :
+\t\$(RM_F) README
+
+EOP
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+# Makefile syntax allows adding extra dep-specs for already-existing targets,
+# and simply appends them on *LAST*-come *FIRST*-serve basis.
+# This allows us to inject extra depenencies for standard EUMM targets
+
+postamble <<"EOP";
+
+.PHONY: dbic_distdir_dbicadmin_pod_inject
+
+distdir : dbic_distdir_dbicadmin_pod_inject
+
+# The pod self-injection code is in fact a hidden option in
+# dbicadmin itself, we execute the one in the distdir
+dbic_distdir_dbicadmin_pod_inject :
+\t\$(ABSPERL) -I\$(DISTVNAME)/lib \$(DISTVNAME)/script/dbicadmin --selfinject-pod
+
+EOP
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+# generate the pod as both a clone-dir step, and a makefile distdir step
+my $ver = Meta->version;
+
+print "Regenerating Optional/Dependencies.pod\n";
+require DBIx::Class::Optional::Dependencies;
+DBIx::Class::Optional::Dependencies->_gen_pod ($ver);
+
+postamble <<"EOP";
+
+.PHONY: dbic_clonedir_gen_optdeps_pod
+
+create_distdir : dbic_clonedir_gen_optdeps_pod
+
+dbic_clonedir_gen_optdeps_pod :
+\t\$(ABSPERL) -Ilib -MDBIx::Class::Optional::Dependencies -e 'DBIx::Class::Optional::Dependencies->_gen_pod($ver)'
+
+EOP
+
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+# FIXME Disabled due to unsolved issues, ask theorbtwo
+#require Module::Install::Pod::Inherit;
+#PodInherit();
+
+# keep the Makefile.PL eval happy
+1;
--- /dev/null
+# Makefile syntax allows adding extra dep-specs for already-existing targets,
+# and simply appends them on *LAST*-come *FIRST*-serve basis.
+# This allows us to inject extra depenencies for standard EUMM targets
+
+print "Removing MANIFEST, will regenerate on next `make dist(dir)`\n";
+unlink 'MANIFEST';
+
+# preamble. so that the manifest target is first, hence executes last
+preamble <<"EOP";
+
+create_distdir : manifest
+
+EOP
+
+# keep the Makefile.PL eval happy
+1;
+++ /dev/null
-#!/usr/bin/perl
-
-#
-# So you wrote a new mk_hash implementation which passed all tests (particularly
-# t/68inflate_resultclass_hashrefinflator) and would like to see how it holds up
-# against older versions of the same. Just add your coderef to the HRI::Bench
-# namespace and add a name/ref pair to the %bench_list hash. Happy testing.
-
-package DBIx::Class::ResultClass::HashRefInflator::Bench;
-
-use warnings;
-use strict;
-
-my $current_mk_hash;
-$current_mk_hash = sub {
- if (ref $_[0] eq 'ARRAY') { # multi relationship
- return [ map { $current_mk_hash->(@$_) || () } (@_) ];
- }
- else {
- my $hash = {
- # the main hash could be an undef if we are processing a skipped-over join
- $_[0] ? %{$_[0]} : (),
-
- # the second arg is a hash of arrays for each prefetched relation
- map
- { $_ => $current_mk_hash->( @{$_[1]->{$_}} ) }
- ( $_[1] ? (keys %{$_[1]}) : () )
- };
-
- # if there is at least one defined column consider the resultset real
- # (and not an emtpy has_many rel containing one empty hashref)
- for (values %$hash) {
- return $hash if defined $_;
- }
-
- return undef;
- }
-};
-
-# the (incomplete, fails a test) implementation before svn:4760
-my $old_mk_hash;
-$old_mk_hash = sub {
- my ($me, $rest) = @_;
-
- # $me is the hashref of cols/data from the immediate resultsource
- # $rest is a deep hashref of all the data from the prefetched
- # related sources.
-
- # to avoid emtpy has_many rels contain one empty hashref
- return undef if (not keys %$me);
-
- my $def;
-
- foreach (values %$me) {
- if (defined $_) {
- $def = 1;
- last;
- }
- }
- return undef unless $def;
-
- return { %$me,
- map {
- ( $_ =>
- ref($rest->{$_}[0]) eq 'ARRAY'
- ? [ grep defined, map $old_mk_hash->(@$_), @{$rest->{$_}} ]
- : $old_mk_hash->( @{$rest->{$_}} )
- )
- } keys %$rest
- };
-};
-
-
-our %bench_list = (
- current_implementation => $current_mk_hash,
- old_implementation => $old_mk_hash,
-);
-
-1;
-
-package benchmark_hashrefinflator;
-
-use warnings;
-use strict;
-
-use FindBin;
-use lib ("$FindBin::Bin/../lib", "$FindBin::Bin/../t/lib");
-
-use Benchmark qw/timethis cmpthese/;
-use DBICTest;
-
-chdir ("$FindBin::Bin/..");
-my $schema = DBICTest->init_schema();
-
-my $test_sub = sub {
- my $rs_hashrefinf = $schema->resultset ('Artist')->search ({}, {
- prefetch => { cds => 'tracks' },
- });
- $rs_hashrefinf->result_class('DBIx::Class::ResultClass::HashRefInflator::Bench');
- my @stuff = $rs_hashrefinf->all;
-};
-
-
-my $results;
-for my $b (keys %DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list) {
-
- print "Timing $b... ";
-
- # switch the inflator
- no warnings qw/redefine once/;
- no strict qw/refs/;
- local *DBIx::Class::ResultClass::HashRefInflator::Bench::inflate_result = sub {
- return $DBIx::Class::ResultClass::HashRefInflator::Bench::bench_list{$b}->(@_[2,3]);
- };
-
- $results->{$b} = timethis (-2, $test_sub);
-}
-cmpthese ($results);
+++ /dev/null
-#!/usr/bin/perl
-
-die "must be run from DBIx::Class root dir" unless -d 't/run';
-
-gen_tests($_) for qw/BasicRels HelperRels/;
-
-sub gen_tests {
- my $variant = shift;
- my $dir = lc $variant;
- system("rm -f t/$dir/*.t");
-
- foreach my $test (map { m[^t/run/(.+)\.tl$]; $1 } split(/\n/, `ls t/run/*.tl`)) {
- open(my $fh, '>', "t/$dir/${test}.t") or die $!;
- print $fh <<"EOF";
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::$variant;
-
-require "t/run/${test}.tl";
-run_tests(DBICTest->schema);
-EOF
- close $fh;
- }
-}
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
# Originally by: Zbigniew Lukasiak, C<zz bb yy@gmail.com>
# but refactored and modified to our nefarious purposes
-#!/usr/bin/perl
+#!/usr/bin/env perl
use strict;
use warnings;
+++ /dev/null
-#!/usr/bin/perl
-use strict;
-use warnings;
-use lib qw(lib t/lib);
-
-# USAGE:
-# maint/inheritance_pod.pl Some::Module
-
-my $module = $ARGV[0];
-eval(" require $module; ");
-
-my @modules = Class::C3::calculateMRO($module);
-shift( @modules );
-
-print "=head1 INHERITED METHODS\n\n";
-
-foreach my $module (@modules) {
- print "=head2 $module\n\n";
- print "=over 4\n\n";
- my $file = $module;
- $file =~ s/::/\//g;
- $file .= '.pm';
- foreach my $path (@INC){
- if (-e "$path/$file") {
- open(MODULE,"<$path/$file");
- while (my $line = <MODULE>) {
- if ($line=~/^\s*sub ([a-z][a-z_]+) \{/) {
- my $method = $1;
- print "=item *\n\n";
- print "L<$method|$module/$method>\n\n";
- }
- }
- close(MODULE);
- last;
- }
- }
- print "=back\n\n";
-}
-
-1;
+++ /dev/null
-#!/bin/sh
-
-cd maint;
-rm svn-log.perl;
-wget https://thirdlobe.com/svn/repo-tools/trunk/svn-log.perl;
+++ /dev/null
-#!/usr/bin/env perl
-# $Id$
-
-# This program is Copyright 2005 by Rocco Caputo. All rights are
-# reserved. This program is free software. It may be modified, used,
-# and redistributed under the same terms as Perl itself.
-
-# Generate a nice looking change log from the subversion logs for a
-# Perl project. The log is also easy for machines to parse.
-
-use warnings;
-use strict;
-
-use Getopt::Long;
-use Text::Wrap qw(wrap fill $columns $huge);
-use POSIX qw(strftime);
-use XML::Parser;
-
-my %month = qw(
- Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06
- Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12
-);
-
-$Text::Wrap::huge = "wrap";
-$Text::Wrap::columns = 74;
-
-my $days_back = 365; # Go back a year by default.
-my $send_help = 0; # Display help and exit.
-my $svn_repo; # Where to log from.
-
-use constant LOG_REV => 0;
-use constant LOG_DATE => 1;
-use constant LOG_WHO => 2;
-use constant LOG_MESSAGE => 3;
-use constant LOG_PATHS => 4;
-
-use constant PATH_PATH => 0;
-use constant PATH_ACTION => 1;
-use constant PATH_CPF_PATH => 2;
-use constant PATH_CPF_REV => 3;
-
-use constant TAG_REV => 0;
-use constant TAG_TAG => 1;
-use constant TAG_LOG => 2;
-
-use constant MAX_TIMESTAMP => "9999-99-99 99:99:99";
-
-GetOptions(
- "age=s" => \$days_back,
- "repo=s" => \$svn_repo,
- "help" => \$send_help,
-) or exit;
-
-# Find the trunk for the current repository if one isn't specified.
-unless (defined $svn_repo) {
- $svn_repo = `svn info . | grep '^URL: '`;
- if (length $svn_repo) {
- chomp $svn_repo;
- $svn_repo =~ s{^URL\:\s+(.+?)/trunk/?.*$}{$1};
- }
- else {
- $send_help = 1;
- }
-}
-
-die(
- "$0 usage:\n",
- " --repo REPOSITORY\n",
- " [--age DAYS]\n",
- "\n",
- "REPOSITORY must have a trunk subdirectory and a tags directory where\n",
- "release tags are kept.\n",
-) if $send_help;
-
-my $earliest_date = strftime "%F", gmtime(time() - $days_back * 86400);
-
-### 1. Gather a list of tags for the repository, their revisions and
-### dates.
-
-my %tag;
-
-open(TAG, "svn -v list $svn_repo/tags|") or die $!;
-while (<TAG>) {
- # The date is unused, however.
- next unless (
- my ($rev, $date, $tag) = m{
- (\d+).*?(\S\S\S\s+\d\d\s+(?:\d\d\d\d|\d\d:\d\d))\s+(v[0-9_.]+)
- }x
- );
-
- my @tag_log = gather_log("$svn_repo/tags/$tag", "--stop-on-copy");
- die "Tag $tag has changes after tagging!\n" if @tag_log > 1;
-
- my $timestamp = $tag_log[0][LOG_DATE];
- $tag{$timestamp} = [
- $rev, # TAG_REV
- $tag, # TAG_TAG
- [ ], # TAG_LOG
- ];
-}
-close TAG;
-
-# Fictitious "HEAD" tag for revisions that came after the last tag.
-
-$tag{+MAX_TIMESTAMP} = [
- "HEAD", # TAG_REV
- "(untagged)", # TAG_TAG
- undef, # TAG_LOG
-];
-
-### 2. Gather the log for the trunk. Place log entries under their
-### proper tags.
-
-my @tag_dates = sort keys %tag;
-while (my $date = pop(@tag_dates)) {
-
- # We're done if this date's before our earliest date.
- if ($date lt $earliest_date) {
- delete $tag{$date};
- next;
- }
-
- my $tag = $tag{$date}[TAG_TAG];
- #warn "Gathering information for tag $tag...\n";
-
- my $this_rev = $tag{$date}[TAG_REV];
- my $prev_rev;
- if (@tag_dates) {
- $prev_rev = $tag{$tag_dates[-1]}[TAG_REV];
- }
- else {
- $prev_rev = 0;
- }
-
- my @log = gather_log("$svn_repo/trunk", "-r", "$this_rev:$prev_rev");
-
- $tag{$date}[TAG_LOG] = \@log;
-}
-
-### 3. PROFIT! No, wait... generate the nice log file.
-
-foreach my $timestamp (sort { $b cmp $a } keys %tag) {
- my $tag_rec = $tag{$timestamp};
-
- # Skip this tag if there are no log entries.
- next unless @{$tag_rec->[TAG_LOG]};
-
- my $tag_line = "$timestamp $tag_rec->[TAG_TAG]";
- my $tag_bar = "=" x length($tag_line);
- print $tag_bar, "\n", $tag_line, "\n", $tag_bar, "\n\n";
-
- foreach my $log_rec (@{$tag_rec->[TAG_LOG]}) {
-
- my @paths = @{$log_rec->[LOG_PATHS]};
- if (@paths > 1) {
- @paths = grep {
- $_->[PATH_PATH] ne "/trunk" or $_->[PATH_ACTION] ne "M"
- } @paths;
- }
-
- my $time_line = wrap(
- " ", " ",
- join(
- "; ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
-
- if ($time_line =~ /\n/) {
- $time_line = wrap(
- " ", " ",
- "$log_rec->[LOG_DATE] (r$log_rec->[LOG_REV]) by $log_rec->[LOG_WHO]\n"
- ) .
- wrap(
- " ", " ",
- join(
- "; ",
- map { "$_->[PATH_PATH] $_->[PATH_ACTION]" } @paths
- )
- );
- }
-
- print $time_line, "\n\n";
-
- # Blank lines should have the indent level of whitespace. This
- # makes it easier for other utilities to parse them.
-
- my @paragraphs = split /\n\s*\n/, $log_rec->[LOG_MESSAGE];
- foreach my $paragraph (@paragraphs) {
-
- # Trim off identical leading space from every line.
- my ($whitespace) = $paragraph =~ /^(\s*)/;
- if (length $whitespace) {
- $paragraph =~ s/^$whitespace//mg;
- }
-
- # Re-flow the paragraph if it isn't indented from the norm.
- # This should preserve indented quoted text, wiki-style.
- unless ($paragraph =~ /^\s/) {
- $paragraph = fill(" ", " ", $paragraph);
- }
- }
-
- print join("\n \n", @paragraphs), "\n\n";
- }
-}
-
-print(
- "==============\n",
- "End of Excerpt\n",
- "==============\n",
-);
-
-### Z. Helper functions.
-
-sub gather_log {
- my ($url, @flags) = @_;
-
- my (@log, @stack);
-
- my $parser = XML::Parser->new(
- Handlers => {
- Start => sub {
- my ($self, $tag, %att) = @_;
- push @stack, [ $tag, \%att ];
- if ($tag eq "logentry") {
- push @log, [ ];
- $log[-1][LOG_WHO] = "(nobody)";
- }
- },
- Char => sub {
- my ($self, $text) = @_;
- $stack[-1][1]{0} .= $text;
- },
- End => sub {
- my ($self, $tag) = @_;
- die "close $tag w/out open" unless @stack;
- my ($pop_tag, $att) = @{pop @stack};
-
- die "$tag ne $pop_tag" if $tag ne $pop_tag;
-
- if ($tag eq "date") {
- my $timestamp = $att->{0};
- my ($date, $time) = split /[T.]/, $timestamp;
- $log[-1][LOG_DATE] = "$date $time";
- return;
- }
-
- if ($tag eq "logentry") {
- $log[-1][LOG_REV] = $att->{revision};
- return;
- }
-
- if ($tag eq "msg") {
- $log[-1][LOG_MESSAGE] = $att->{0};
- return;
- }
-
- if ($tag eq "author") {
- $log[-1][LOG_WHO] = $att->{0};
- return;
- }
-
- if ($tag eq "path") {
- my $path = $att->{0};
- $path =~ s{^/trunk/}{};
- push(
- @{$log[-1][LOG_PATHS]}, [
- $path, # PATH_PATH
- $att->{action}, # PATH_ACTION
- ]
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_PATH] = $att->{"copyfrom-path"} if (
- exists $att->{"copyfrom-path"}
- );
-
- $log[-1][LOG_PATHS][-1][PATH_CPF_REV] = $att->{"copyfrom-rev"} if (
- exists $att->{"copyfrom-rev"}
- );
- return;
- }
-
- }
- }
- );
-
- my $cmd = "svn -v --xml @flags log $url";
- #warn "Command: $cmd\n";
-
- open(LOG, "$cmd|") or die $!;
- $parser->parse(*LOG);
- close LOG;
-
- return @log;
-}
-#!/usr/bin/perl
+#!/usr/bin/env perl
use strict;
use warnings;
(
['Actions'],
["action" => hidden => { one_of => [
- ['create' => 'Create version diffs needs preversion',],
+ ['create' => 'Create version diffs needs preversion'],
['upgrade' => 'Upgrade the database to the current schema '],
- ['install' => 'Install the schema version tables to an existing database',],
- ['deploy' => 'Deploy the schema to the database',],
- ['select' => 'Select data from the schema', ],
- ['insert' => 'Insert data into the schema', ],
- ['update' => 'Update data in the schema', ],
- ['delete' => 'Delete data from the schema',],
+ ['install' => 'Install the schema version tables to an existing database'],
+ ['deploy' => 'Deploy the schema to the database'],
+ ['select' => 'Select data from the schema'],
+ ['insert' => 'Insert data into the schema'],
+ ['update' => 'Update data in the schema'],
+ ['delete' => 'Delete data from the schema'],
['op:s' => 'compatiblity option all of the above can be suppied as --op=<action>'],
['help' => 'display this help', { implies => { schema_class => '__dummy__' } } ],
['selfinject-pod' => 'hidden', { implies => { schema_class => '__dummy__' } } ],
- ], required=> 1 }],
+ ], required => 1 }],
['Arguments'],
+ ["configuration" => hidden => { one_of => [
+ ['config-file|config:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
+ ['connect-info:s%' => 'Supply the connect info as trailing options e.g. --connect-info dsn=<dsn> user=<user> password=<pass>' ],
+ ['connect:s' => 'Supply the connect info as a JSON-encoded structure, e.g. an --connect=["dsn","user","pass"]'],
+ ] }],
['schema-class:s' => 'The class of the schema to load', { required => 1 } ],
- ['resultset|resultset-class|class:s' => 'The resultset to operate on for data manipulation' ],
['config-stanza:s' => 'Where in the config to find the connection_info, supply in form MyApp::Model::DB',],
- ['config:s' => 'Supply the config file for parsing by Config::Any', { depends => 'config_stanza'} ],
- ['connect-info:s%' => 'Supply the connect info as additonal options ie -I dsn=<dsn> user=<user> password=<pass> '],
- ['connect:s' => 'Supply the connect info as a json string' ],
+ ['resultset|resultset-class|class:s' => 'The resultset to operate on for data manipulation' ],
['sql-dir:s' => 'The directory where sql diffs will be created'],
['sql-type:s' => 'The RDBMs flavour you wish to use'],
['version:i' => 'Supply a version install'],
['force' => 'Be forceful with some operations'],
['trace' => 'Turn on DBIx::Class trace output'],
['quiet' => 'Be less verbose'],
+ ['I:s@' => 'Same as perl\'s -I, prepended to current @INC'],
)
);
-die "please only use one of --config or --connect-info\n" if ($opts->{config} and $opts->{connect_info});
-
if($opts->{selfinject_pod}) {
die "This is an internal method, do not call!!!\n"
);
}
+# FIXME - lowercasing will eventually go away when Getopt::Long::Descriptive is fixed
+if($opts->{i}) {
+ require lib;
+ lib->import( @{delete $opts->{i}} );
+}
+
if($opts->{help}) {
- $usage->die();
+ $usage->die();
}
# option compatability mangle
+# (can not be joined in the spec, one is s% the other is s)
if($opts->{connect}) {
$opts->{connect_info} = delete $opts->{connect};
}
my $admin = DBIx::Class::Admin->new( %$opts );
-
my $action = $opts->{action};
$action = $opts->{op} if ($action eq 'op');
-print "Performig action $action...\n";
+print "Performing action $action...\n";
my $res = $admin->$action();
if ($action eq 'select') {
+++ /dev/null
-use warnings;
-use strict;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-# Don't run tests for installs
-unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
- plan( skip_all => "Author tests not required for installation" );
-}
-
-require DBIx::Class;
-unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) {
- my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_pod');
- $ENV{RELEASE_TESTING} || DBICTest::AuthorCheck->is_author
- ? die ("Failed to load release-testing module requirements: $missing")
- : plan skip_all => "Test needs: $missing"
-}
-
-Test::Pod::all_pod_files_ok();
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed)
+
+{
+ package AAA;
+
+ use base "DBIx::Class::Core";
+}
+
+{
+ package BBB;
+
+ use base 'AAA';
+
+ #Injecting a direct parent.
+ __PACKAGE__->inject_base( __PACKAGE__, 'AAA' );
+}
+
+{
+ package CCC;
+
+ use base 'AAA';
+
+ #Injecting an indirect parent.
+ __PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
+}
+
+eval { mro::get_linear_isa('BBB'); };
+ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
+
+eval { mro::get_linear_isa('CCC'); };
+ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
+
+use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
+
+is_deeply (
+ mro::get_linear_isa('DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'),
+ [qw/
+ DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server
+ DBIx::Class::Storage::DBI::Sybase
+ DBIx::Class::Storage::DBI::MSSQL
+ DBIx::Class::Storage::DBI::UniqueIdentifier
+ DBIx::Class::Storage::DBI::IdentityInsert
+ DBIx::Class::Storage::DBI
+ DBIx::Class::Storage::DBIHacks
+ DBIx::Class::Storage
+ DBIx::Class
+ DBIx::Class::Componentised
+ Class::C3::Componentised
+ DBIx::Class::AccessorGroup
+ Class::Accessor::Grouped
+ /],
+ 'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'
+);
+
+my $storage = DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server->new;
+$storage->connect_info(['dbi:SQLite::memory:']); # determine_driver's init() connects for this subclass
+$storage->_determine_driver;
+is (
+ $storage->can('sql_limit_dialect'),
+ 'DBIx::Class::Storage::DBI::MSSQL'->can('sql_limit_dialect'),
+ 'Correct method picked'
+);
+
+if ($] >= 5.010) {
+ ok (! $INC{'Class/C3.pm'}, 'No Class::C3 loaded on perl 5.10+');
+
+ # Class::C3::Componentised loads MRO::Compat unconditionally to satisfy
+ # the assumption that once Class::C3::X is loaded, so is Class::C3
+ #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+');
+}
+
+done_testing;
+++ /dev/null
-
-use strict;
-use Test::More tests => 2;
-use MRO::Compat;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
-{
-package AAA;
-
-use base "DBIx::Class::Core";
-
-package BBB;
-
-use base 'AAA';
-
-#Injecting a direct parent.
-__PACKAGE__->inject_base( __PACKAGE__, 'AAA' );
-
-
-package CCC;
-
-use base 'AAA';
-
-#Injecting an indirect parent.
-__PACKAGE__->inject_base( __PACKAGE__, 'DBIx::Class::Core' );
-}
-
-eval { mro::get_linear_isa('BBB'); };
-ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
-
-eval { mro::get_linear_isa('CCC'); };
-ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
use lib qw(t/lib);
+use DBICTest;
use DBICTest::ForeignComponent;
# Tests if foreign component was loaded by calling foreign's method
+++ /dev/null
-use warnings;
-use strict;
-
-use Test::More;
-use lib 't/lib';
-use DBICTest;
-
-my @MODULES = (
- 'Test::NoTabs 0.9',
-);
-
-plan skip_all => 'Does not work with done_testing, temp disabled';
-
-# Don't run tests for installs
-unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
- plan( skip_all => "Author tests not required for installation" );
-}
-# Load the testing modules
-foreach my $MODULE ( @MODULES ) {
- eval "use $MODULE";
- if ( $@ ) {
- $ENV{RELEASE_TESTING}
- ? die( "Failed to load required release-testing module $MODULE" )
- : plan( skip_all => "$MODULE not available for testing" );
- }
-}
-
-all_perl_files_ok(qw/t lib script maint/);
-
-done_testing;
+++ /dev/null
-use warnings;
-use strict;
-
-use Test::More;
-use lib 't/lib';
-use DBICTest;
-
-my @MODULES = (
- 'Test::EOL 0.6',
-);
-
-plan skip_all => 'Does not work with done_testing, temp disabled';
-
-# Don't run tests for installs
-unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
- plan( skip_all => "Author tests not required for installation" );
-}
-# Load the testing modules
-foreach my $MODULE ( @MODULES ) {
- eval "use $MODULE";
- if ( $@ ) {
- $ENV{RELEASE_TESTING}
- ? die( "Failed to load required release-testing module $MODULE" )
- : plan( skip_all => "$MODULE not available for testing" );
- }
-}
-
-TODO: {
- local $TODO = 'Do not fix those yet - we have way too many branches out there, merging will be hell';
- all_perl_files_ok({ trailing_whitespace => 1}, qw/t lib script maint/);
-}
-
-done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
{
- package DBICTest::ResultSource::OtherSource;
- use strict;
- use warnings;
- use base qw/DBIx::Class::ResultSource::Table/;
+ package DBICTest::ArtistRS;
+ use strict;
+ use warnings;
+ use base qw/DBIx::Class::ResultSet/;
}
-plan tests => 4;
-
my $schema = DBICTest->init_schema();
my $artist_source = $schema->source('Artist');
-my $new_source = DBICTest::ResultSource::OtherSource->new({
+my $new_source = DBIx::Class::ResultSource::Table->new({
%$artist_source,
- name => 'artist_preview',
- _relationships => Storable::dclone( $artist_source->_relationships ),
+ name => 'artist_preview',
+ resultset_class => 'DBICTest::ArtistRS',
+ _relationships => {}, # copying them as-is is bad taste
});
-
$new_source->add_column('other_col' => { data_type => 'integer', default_value => 1 });
-my $warn = '';
-local $SIG{__WARN__} = sub { $warn = shift };
-
{
$schema->register_extra_source( 'artist->extra' => $new_source );
- my $source = $schema->source('DBICTest::Artist');
- is($source->source_name, 'Artist', 'original source still primary source');
+ my $primary_source = $schema->source('DBICTest::Artist');
+ is($primary_source->source_name, 'Artist', 'original source still primary source');
+ ok(! $primary_source->has_column('other_col'), 'column definition did not leak to original source');
+ isa_ok($schema->resultset ('artist->extra'), 'DBICTest::ArtistRS');
}
-{
+warnings_are (sub {
my $source = $schema->source('DBICTest::Artist');
$schema->register_source($source->source_name, $source);
- is($warn, '', "re-registering an existing source under the same name causes no errors");
-}
-
-{
- my $new_source_name = 'Artist->preview(artist_preview)';
- $schema->register_source( $new_source_name => $new_source );
-
- ok(($warn =~ /DBICTest::Artist already has a source, use register_extra_source for additional sources/), 'registering extra source causes errors');
-
- my $source = $schema->source('DBICTest::Artist');
- is($source->source_name, $new_source_name, 'original source still primary source');
-}
-
-1;
+}, [], 're-registering an existing source under the same name causes no warnings' );
+
+warnings_like (
+ sub {
+ my $new_source_name = 'Artist->preview(artist_preview)';
+ $schema->register_source( $new_source_name => $new_source );
+
+ my $primary_source = $schema->source('DBICTest::Artist');
+ is($primary_source->source_name, $new_source_name, 'new source is primary source');
+ ok($primary_source->has_column('other_col'), 'column correctly defined on new source');
+
+ isa_ok ($schema->resultset ($new_source_name), 'DBICTest::ArtistRS');
+
+ my $original_source = $schema->source('Artist');
+ ok(! $original_source->has_column('other_col'), 'column definition did not leak to original source');
+ isa_ok ($original_source->resultset, 'DBIx::Class::ResultSet');
+ isa_ok ($schema->resultset('Artist'), 'DBIx::Class::ResultSet');
+ },
+ [
+ qr/DBICTest::Artist already had a registered source which was replaced by this call/
+ ],
+ 'registering source to an existing result warns'
+);
+
+done_testing;
use lib qw(t/lib);
use DBICTest;
use Path::Class::File ();
+use List::Util qw/shuffle/;
my $schema = DBICTest->init_schema();
# [ 10000, "ntn" ],
my $start_id = 'populateXaaaaaa';
-my $rows = 10;
+my $rows = 10_000;
my $offset = 3;
-$schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } ( 1 .. $rows ) ] );
+$schema->populate('Artist', [ [ qw/artistid name/ ], map { [ ($_ + $offset) => $start_id++ ] } shuffle ( 1 .. $rows ) ] );
is (
$schema->resultset ('Artist')->search ({ name => { -like => 'populateX%' } })->count,
$rows,
}
} ('Huey', 'Dewey', $ex_title, 'Louie')
])
-}, qr/columns .+ are not unique for populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
+}, qr/\Qexecute_for_fetch() aborted with '\E.+ at populate slice.+$ex_title/ms, 'Readable exception thrown for failed populate');
## make sure populate honors fields/orders in list context
## schema order
is($link7->url, undef, 'Link 7 url');
is($link7->title, 'gtitle', 'Link 7 title');
-my $rs = $schema->resultset('Artist');
-$rs->delete;
+# populate with literals
+{
+ my $rs = $schema->resultset('Link');
+ $rs->delete;
-# test _execute_array_empty (insert_bulk with all literal sql)
+ # test insert_bulk with all literal sql (no binds)
-$rs->populate([
+ $rs->populate([
(+{
- name => \"'DT'",
- rank => \500,
- charfield => \"'mtfnpy'",
+ url => \"'cpan.org'",
+ title => \"'The ''best of'' cpan'",
}) x 5
-]);
+ ]);
-is((grep {
- $_->name eq 'DT' &&
- $_->rank == 500 &&
- $_->charfield eq 'mtfnpy'
-} $rs->all), 5, 'populate with all literal SQL');
+ is((grep {
+ $_->url eq 'cpan.org' &&
+ $_->title eq "The 'best of' cpan",
+ } $rs->all), 5, 'populate with all literal SQL');
-$rs->delete;
+ $rs->delete;
-# test mixed binds with literal sql
+ # test mixed binds with literal sql
-$rs->populate([
+ $rs->populate([
(+{
- name => \"'DT'",
- rank => 500,
- charfield => \"'mtfnpy'",
+ url => \"'cpan.org'",
+ title => "The 'best of' cpan",
}) x 5
-]);
+ ]);
-is((grep {
- $_->name eq 'DT' &&
- $_->rank == 500 &&
- $_->charfield eq 'mtfnpy'
-} $rs->all), 5, 'populate with all literal SQL');
+ is((grep {
+ $_->url eq 'cpan.org' &&
+ $_->title eq "The 'best of' cpan",
+ } $rs->all), 5, 'populate with all literal SQL');
-$rs->delete;
+ $rs->delete;
+}
+
+# populate with literal+bind
+{
+ my $rs = $schema->resultset('Link');
+ $rs->delete;
+
+ # test insert_bulk with all literal/bind sql
+ $rs->populate([
+ (+{
+ url => \['?', [ {} => 'cpan.org' ] ],
+ title => \['?', [ {} => "The 'best of' cpan" ] ],
+ }) x 5
+ ]);
-###
+ is((grep {
+ $_->url eq 'cpan.org' &&
+ $_->title eq "The 'best of' cpan",
+ } $rs->all), 5, 'populate with all literal/bind');
+ $rs->delete;
+
+ # test insert_bulk with mix literal and literal/bind
+ $rs->populate([
+ (+{
+ url => \"'cpan.org'",
+ title => \['?', [ {} => "The 'best of' cpan" ] ],
+ }) x 5
+ ]);
+
+ is((grep {
+ $_->url eq 'cpan.org' &&
+ $_->title eq "The 'best of' cpan",
+ } $rs->all), 5, 'populate with all literal/bind SQL');
+
+ $rs->delete;
+
+ # test mixed binds with literal sql/bind
+
+ $rs->populate([ map { +{
+ url => \[ '? || ?', [ {} => 'cpan.org_' ], [ undef, $_ ] ],
+ title => "The 'best of' cpan",
+ } } (1 .. 5) ]);
+
+ for (1 .. 5) {
+ ok($rs->find({ url => "cpan.org_$_" }), "Row $_ correctly created with dynamic literal/bind populate" );
+ }
+
+ $rs->delete;
+}
+
+my $rs = $schema->resultset('Artist');
+$rs->delete;
throws_ok {
$rs->populate([
{
name => 'foo3',
},
]);
-} qr/slice/, 'bad slice';
+} qr/\Qexecute_for_fetch() aborted with 'datatype mismatch\E\b/, 'bad slice';
is($rs->count, 0, 'populate is atomic');
name => \"'foo'",
}
]);
-} qr/bind expected/, 'literal sql where bind expected throws';
+} qr/Literal SQL found where a plain bind value is expected/, 'literal sql where bind expected throws';
# ... and vice-versa.
name => \"'foo'",
}
]);
-} qr/literal SQL expected/i, 'bind where literal sql expected throws';
+} qr/\QIncorrect value (expecting SCALAR-ref/, 'bind where literal sql expected throws';
throws_ok {
$rs->populate([
name => \"'bar'",
}
]);
-} qr/inconsistent/, 'literal sql must be the same in all slices';
+} qr/Inconsistent literal SQL value/, 'literal sql must be the same in all slices';
+
+throws_ok {
+ $rs->populate([
+ {
+ artistid => 1,
+ name => \['?', [ {} => 'foo' ] ],
+ },
+ {
+ artistid => 2,
+ name => \"'bar'",
+ }
+ ]);
+} qr/\QIncorrect value (expecting ARRAYREF-ref/, 'literal where literal+bind expected throws';
+
+throws_ok {
+ $rs->populate([
+ {
+ artistid => 1,
+ name => \['?', [ { sqlt_datatype => 'foooo' } => 'foo' ] ],
+ },
+ {
+ artistid => 2,
+ name => \['?', [ {} => 'foo' ] ],
+ }
+ ]);
+} qr/\QDiffering bind attributes on literal\/bind values not supported for column 'name'/, 'literal+bind with differing attrs throws';
+
+lives_ok {
+ $rs->populate([
+ {
+ artistid => 1,
+ name => \['?', [ undef, 'foo' ] ],
+ },
+ {
+ artistid => 2,
+ name => \['?', [ {} => 'bar' ] ],
+ }
+ ]);
+} 'literal+bind with semantically identical attrs works after normalization';
# the stringification has nothing to do with the artist name
# this is solely for testing consistency
}])
} 'multicol-PK has_many populate works';
+lives_ok ( sub {
+ $schema->populate('CD', [
+ {cdid => 10001, artist => $artist->id, title => 'Pretty Much Empty', year => 2011, tracks => []},
+ ])
+}, 'empty has_many relationship accepted by populate');
+
done_testing;
##
## GOALS: We need to test the method for both void and array context for all
## the following relationship types: belongs_to, has_many. Additionally we
-## need to each each of those for both specified PK's and autogenerated PK's
+## need to test each of those for both specified PK's and autogenerated PK's
##
## Also need to test some stuff that should generate errors.
## ----------------------------------------------------------------------------
isa_ok $artist1, 'DBICTest::Artist';
isa_ok $artist2, 'DBICTest::Artist';
isa_ok $artist3, 'DBICTest::Artist';
- isa_ok $undef, 'DBICTest::Artist';
+ isa_ok $undef, 'DBICTest::Artist';
ok $artist1->name eq '001First Artist', "Got Expected Artist Name for Artist001";
ok $artist2->name eq '002Second Artist', "Got Expected Artist Name for Artist002";
ok $artist3->name eq '003Third Artist', "Got Expected Artist Name for Artist003";
- ok !defined $undef->name, "Got Expected Artist Name for Artist004";
+ ok !defined $undef->name, "Got Expected Artist Name for Artist004";
ok $artist1->cds->count eq 3, "Got Right number of CDs for Artist1";
ok $artist2->cds->count eq 0, "Got Right number of CDs for Artist2";
ok $artist3->cds->count eq 1, "Got Right number of CDs for Artist3";
- ok $undef->cds->count eq 1, "Got Right number of CDs for Artist4";
+ ok $undef->cds->count eq 1, "Got Right number of CDs for Artist4";
ARTIST1CDS: {
isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
## Find the expected information?
isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
## Find the expected information?
## Create the expected children sub objects?
ok( $crap->cds->count == 0, "got Expected Number of Cds");
- ok( $girl->cds->count == 2, "got Expected Number of Cds");
+ ok( $girl->cds->count == 2, "got Expected Number of Cds");
ok( $damn->cds->count == 3, "got Expected Number of Cds");
ok( $formerly->cds->count == 1, "got Expected Number of Cds");
BELONGS_TO_NO_PKs: {
- ## Test from a belongs_to perspective, should create artist first,
+ ## Test from a belongs_to perspective, should create artist first,
## then CD with artistid. This test we let the system automatically
## create the PK's. Chances are good you'll use it this way mostly.
title => 'Some CD4',
year => '1997',
artist => { name => 'Fred BloggsD'},
- },
+ },
];
my ($cdA, $cdB) = $cd_rs->populate($cds);
BELONGS_TO_WITH_PKs: {
- ## Test from a belongs_to perspective, should create artist first,
+ ## Test from a belongs_to perspective, should create artist first,
## then CD with artistid. This time we try setting the PK's
my $aid = $art_rs->get_column('artistid')->max || 0;
{
title => 'Some CD3',
year => '1997',
- artist => { artistid=> ++$aid, name => 'Fred BloggsC'},
+ artist => { artistid=> ++$aid, name => 'Fred BloggsE'},
},
{
title => 'Some CD4',
year => '1997',
- artist => { artistid=> ++$aid, name => 'Fred BloggsD'},
- },
+ artist => { artistid=> ++$aid, name => 'Fred BloggsF'},
+ },
];
my ($cdA, $cdB) = $cd_rs->populate($cds);
isa_ok($cdA, 'DBICTest::CD', 'Created CD');
isa_ok($cdA->artist, 'DBICTest::Artist', 'Set Artist');
- is($cdA->artist->name, 'Fred BloggsC', 'Set Artist to FredC');
+ is($cdA->artist->name, 'Fred BloggsE', 'Set Artist to FredE');
isa_ok($cdB, 'DBICTest::CD', 'Created CD');
isa_ok($cdB->artist, 'DBICTest::Artist', 'Set Artist');
- is($cdB->artist->name, 'Fred BloggsD', 'Set Artist to FredD');
+ is($cdB->artist->name, 'Fred BloggsF', 'Set Artist to FredF');
ok($cdB->artist->artistid == $aid, "Got Expected Artist ID");
}
## Did it use the condition in the resultset?
cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
- }
+ }
}
VOID_CONTEXT: {
- ## All these tests check the ability to use populate without asking for
+ ## All these tests check the ability to use populate without asking for
## any returned resultsets. This uses bulk_insert as much as possible
## in order to increase speed.
cds => [
{ title => 'VOID_PK_My parents sold me to a record company' ,year => 2005 },
{ title => 'VOID_PK_Why Am I So Ugly?', year => 2006 },
- { title => 'VOID_PK_I Got Surgery and am now Popular', year => 2007 }
+ { title => 'VOID_PK_I Got Surgery and am now Popular', year => 2007 }
],
},
{
isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $undef, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $undef, 'DBICTest::Artist', "Got 'Artist'");
## Find the expected information?
ok( $crap->name eq 'VOID_PK_Manufactured Crap', "Got Correct name 'VOID_PK_Manufactured Crap' for result object");
ok( $girl->name eq 'VOID_PK_Angsty-Whiny Girl', "Got Correct name for result object");
- ok( $damn->name eq 'VOID_PK_Like I Give a Damn', "Got Correct name for result object");
+ ok( $damn->name eq 'VOID_PK_Like I Give a Damn', "Got Correct name for result object");
ok( $formerly->name eq 'VOID_PK_Formerly Named', "Got Correct name for result object");
- ok( !defined $undef->name, "Got Correct name 'is undef' for result object");
+ ok( !defined $undef->name, "Got Correct name 'is undef' for result object");
## Create the expected children sub objects?
ok( $crap->can('cds'), "Has cds relationship");
ok( $girl->can('cds'), "Has cds relationship");
ok( $damn->can('cds'), "Has cds relationship");
ok( $formerly->can('cds'), "Has cds relationship");
- ok( $undef->can('cds'), "Has cds relationship");
+ ok( $undef->can('cds'), "Has cds relationship");
ok( $crap->cds->count == 0, "got Expected Number of Cds");
- ok( $girl->cds->count == 2, "got Expected Number of Cds");
+ ok( $girl->cds->count == 2, "got Expected Number of Cds");
ok( $damn->cds->count == 3, "got Expected Number of Cds");
ok( $formerly->cds->count == 1, "got Expected Number of Cds");
ok( $undef->cds->count == 1, "got Expected Number of Cds");
BELONGS_TO_WITH_PKs: {
- ## Test from a belongs_to perspective, should create artist first,
+ ## Test from a belongs_to perspective, should create artist first,
## then CD with artistid. This time we try setting the PK's
my $aid = $art_rs->get_column('artistid')->max || 0;
BELONGS_TO_NO_PKs: {
- ## Test from a belongs_to perspective, should create artist first,
+ ## Test from a belongs_to perspective, should create artist first,
## then CD with artistid.
my $cds = [
title => 'Some CD5BB',
year => '1997',
artist => { name => undef},
- },
+ },
];
$cd_rs->populate($cds);
## with the parent having many children and let the keys be automatic
my $artists = [
- {
+ {
name => 'VOID_Angsty-Whiny Girl',
cds => [
{ title => 'VOID_My First CD', year => 2006 },
{ title => 'VOID_Yet More Tweeny-Pop crap', year => 2007 },
- ],
- },
+ ],
+ },
{
name => 'VOID_Manufactured Crap',
},
cds => [
{ title => 'VOID_My parents sold me to a record company' ,year => 2005 },
{ title => 'VOID_Why Am I So Ugly?', year => 2006 },
- { title => 'VOID_I Got Surgery and am now Popular', year => 2007 }
+ { title => 'VOID_I Got Surgery and am now Popular', year => 2007 }
],
},
- {
+ {
name => 'VOID_Formerly Named',
cds => [
{ title => 'VOID_One Hit Wonder', year => 2006 },
- ],
- },
+ ],
+ },
];
## Get the result row objects.
isa_ok( $crap, 'DBICTest::Artist', "Got 'Artist'");
isa_ok( $girl, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
- isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $damn, 'DBICTest::Artist', "Got 'Artist'");
+ isa_ok( $formerly, 'DBICTest::Artist', "Got 'Artist'");
## Find the expected information?
ok( $crap->name eq 'VOID_Manufactured Crap', "Got Correct name for result object");
ok( $girl->name eq 'VOID_Angsty-Whiny Girl', "Got Correct name for result object");
- ok( $damn->name eq 'VOID_Like I Give a Damn', "Got Correct name for result object");
+ ok( $damn->name eq 'VOID_Like I Give a Damn', "Got Correct name for result object");
ok( $formerly->name eq 'VOID_Formerly Named', "Got Correct name for result object");
## Create the expected children sub objects?
ok( $formerly->can('cds'), "Has cds relationship");
ok( $crap->cds->count == 0, "got Expected Number of Cds");
- ok( $girl->cds->count == 2, "got Expected Number of Cds");
+ ok( $girl->cds->count == 2, "got Expected Number of Cds");
ok( $damn->cds->count == 3, "got Expected Number of Cds");
ok( $formerly->cds->count == 1, "got Expected Number of Cds");
## Did it use the condition in the resultset?
cmp_ok( $more_crap->rank, '==', 42, "Got Correct rank for result object");
- }
+ }
}
ARRAYREF_OF_ARRAYREF_STYLE: {
my ($cooler, $lamer) = $restricted_art_rs->populate([
[qw/artistid name/],
[1003, 'Cooler'],
- [1004, 'Lamer'],
+ [1004, 'Lamer'],
]);
is $cooler->name, 'Cooler', 'Correct Name';
- is $lamer->name, 'Lamer', 'Correct Name';
+ is $lamer->name, 'Lamer', 'Correct Name';
cmp_ok $cooler->rank, '==', 42, 'Correct Rank';
## Did it use the condition in the resultset?
cmp_ok( $mega_lamer->rank, '==', 42, "Got Correct rank for result object");
- }
+ }
VOID_CONTEXT_WITH_COND_FROM_RS: {
}
}
+ok(eval { $art_rs->populate([]); 1 }, "Empty populate runs but does nothing");
+
done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema;
+
+throws_ok {$schema->source()} qr/\Qsource() expects a source name/, 'Empty args for source caught';
+
+done_testing();
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-unshift(@INC, './t/lib');
-
-plan tests => 4;
+use lib 't/lib';
+use DBICTest;
my $warnings;
eval {
my $rset_a = DBICTest::Schema->resultset('Artist');
isa_ok($rset_a, 'DBIx::Class::ResultSet');
+done_testing;
use Test::More;
use lib qw(t/lib);
+use DBICTest;
plan tests => 4;
my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/;
{
- my @w;
+ my @w;
local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
my $code = gen_code ( suffix => 1 );
eval "$code";
}
{
- my @w;
+ my @w;
local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
my $code = gen_code ( suffix => 2 );
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use lib qw(t/lib);
+use DBICTest;
+use ViewDeps;
+use ViewDepsBad;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' .
+ DBIx::Class::Optional::Dependencies->req_missing_for('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
+}
+
+use_ok('DBIx::Class::ResultSource::View');
+
+#################### SANITY
+
+my $view = DBIx::Class::ResultSource::View->new;
+
+isa_ok( $view, 'DBIx::Class::ResultSource', 'A new view' );
+isa_ok( $view, 'DBIx::Class', 'A new view also' );
+
+can_ok( $view, $_ ) for qw/new from deploy_depends_on/;
+
+#################### DEPS
+{
+ my $schema
+ = ViewDeps->connect( DBICTest->_database (quote_char => '"') );
+ ok( $schema, 'Connected to ViewDeps schema OK' );
+
+#################### DEPLOY
+
+ $schema->deploy( { add_drop_table => 1 } );
+
+#################### DOES ORDERING WORK?
+
+ my $sqlt_object = $schema->{sqlt};
+
+ is_deeply(
+ [ map { $_->name } $sqlt_object->get_views ],
+ [qw/
+ a_name_artists
+ track_number_fives
+ year_2010_cds
+ ab_name_artists
+ year_2010_cds_with_many_tracks
+ aba_name_artists
+ aba_name_artists_and_2010_cds_with_many_tracks
+ /],
+ "SQLT view order triumphantly matches our order."
+ );
+
+#################### AND WHAT ABOUT USING THE SCHEMA?
+
+ lives_ok( sub { $schema->resultset($_)->next }, "Query on $_ succeeds" )
+ for grep {
+ $schema->resultset($_)
+ ->result_source->isa('DBIx::Class::ResultSource::View')
+ } @{ [ $schema->sources ] };
+}
+
+#################### AND WHAT ABOUT A BAD DEPS CHAIN IN A VIEW?
+
+{
+ my $schema2
+ = ViewDepsBad->connect( DBICTest->_database ( quote_char => '"') );
+ ok( $schema2, 'Connected to ViewDepsBad schema OK' );
+
+#################### DEPLOY2
+
+ warnings_exist { $schema2->deploy( { add_drop_table => 1 } ) }
+ [qr/no such table: main.aba_name_artists/],
+ "Deploying the bad schema produces a warning: aba_name_artists was not created.";
+
+#################### DOES ORDERING WORK 2?
+
+ my $sqlt_object2 = $schema2->{sqlt};
+
+ is_deeply(
+ [ map { $_->name } $sqlt_object2->get_views ],
+ [qw/
+ a_name_artists
+ track_number_fives
+ year_2010_cds
+ ab_name_artists
+ year_2010_cds_with_many_tracks
+ aba_name_artists_and_2010_cds_with_many_tracks
+ aba_name_artists
+ /],
+ "SQLT view order triumphantly matches our order."
+ );
+
+#################### AND WHAT ABOUT USING THE SCHEMA2?
+
+ lives_ok( sub { $schema2->resultset($_)->next }, "Query on $_ succeeds" )
+ for grep {
+ $schema2->resultset($_)
+ ->result_source->isa('DBIx::Class::ResultSource::View')
+ } grep { !/AbaNameArtistsAnd2010CDsWithManyTracks/ }
+ @{ [ $schema2->sources ] };
+
+ throws_ok { $schema2->resultset('AbaNameArtistsAnd2010CDsWithManyTracks')->next }
+ qr/no such table: aba_name_artists_and_2010_cds_with_many_tracks/,
+ "Query on AbaNameArtistsAnd2010CDsWithManyTracks throws, because the table does not exist"
+ ;
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use DBIx::Class::Carp;
+use lib 't/lib';
+use DBICTest;
+
+warnings_exist {
+ DBIx::Class::frobnicate();
+} [
+ qr/carp1/,
+ qr/carp2/,
+], 'expected warnings from carp_once';
+
+done_testing;
+
+sub DBIx::Class::frobnicate {
+ DBIx::Class::branch1();
+ DBIx::Class::branch2();
+}
+
+sub DBIx::Class::branch1 { carp_once 'carp1' }
+sub DBIx::Class::branch2 { carp_once 'carp2' }
+++ /dev/null
-use strict;
-use warnings;
-no warnings qw/once/;
-
-use Test::More;
-use lib qw(t/lib);
-use Scalar::Util; # load before we break require()
-
-use_ok 'DBIx::Class::Optional::Dependencies';
-
-my $sqlt_dep = DBIx::Class::Optional::Dependencies->req_list_for ('deploy');
-is_deeply (
- [ keys %$sqlt_dep ],
- [ 'SQL::Translator' ],
- 'Correct deploy() dependency list',
-);
-
-# make module loading impossible, regardless of actual libpath contents
-@INC = (sub { die('Optional Dep Test') } );
-
-ok (
- ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps missing',
-);
-
-like (
- DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
- qr/^SQL::Translator \>\= \d/,
- 'expected missing string contents',
-);
-
-like (
- DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy')->{'SQL::Translator'},
- qr/Optional Dep Test/,
- 'custom exception found in errorlist',
-);
-
-
-#make it so module appears loaded
-$INC{'SQL/Translator.pm'} = 1;
-$SQL::Translator::VERSION = 999;
-
-ok (
- ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps missing cached properly',
-);
-
-#reset cache
-%DBIx::Class::Optional::Dependencies::req_availability_cache = ();
-
-
-ok (
- DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
- 'deploy() deps present',
-);
-
-is (
- DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
- '',
- 'expected null missing string',
-);
-
-is_deeply (
- DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy'),
- {},
- 'expected empty errorlist',
-);
-
-
-done_testing;
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-
-my $tests = 3;
-plan tests => $tests;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
+$schema->storage->sql_maker->quote_char('"');
+
my $rs = $schema->resultset ('Artist');
my $last_obj = $rs->search ({}, { order_by => { -desc => 'artistid' }, rows => 1})->single;
my $last_id = $last_obj ? $last_obj->artistid : 0;
+
+my ($sql, @bind);
+my $orig_debugobj = $schema->storage->debugobj;
+my $orig_debug = $schema->storage->debug;
+
+$schema->storage->debugobj (DBIC::DebugObj->new (\$sql, \@bind) );
+$schema->storage->debug (1);
+
my $obj;
-eval { $obj = $rs->create ({}) };
-my $err = $@;
+lives_ok { $obj = $rs->create ({}) } 'Default insert successful';
+
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'INSERT INTO "artist" DEFAULT VALUES',
+ [],
+ 'Default-value insert correct SQL',
+);
ok ($obj, 'Insert defaults ( $rs->create ({}) )' );
-SKIP: {
- skip "Default insert failed: $err", $tests-1 if $err;
- # this should be picked up without calling the DB again
- is ($obj->artistid, $last_id + 1, 'Autoinc PK works');
+# this should be picked up without calling the DB again
+is ($obj->artistid, $last_id + 1, 'Autoinc PK works');
- # for this we need to refresh
- $obj->discard_changes;
- is ($obj->rank, 13, 'Default value works');
-}
+# for this we need to refresh
+$obj->discard_changes;
+is ($obj->rank, 13, 'Default value works');
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+$schema->storage->sql_maker->quote_char('"');
+
+my $rs = $schema->resultset ('Artist');
+
+my $obj;
+lives_ok { $obj = $rs->create ({ name => 'artistA' }) } 'Default insert successful';
+is ($obj->rank, undef, 'Without retrieve_on_insert, check rank');
+
+$rs->result_source->add_columns(
+ '+rank' => { retrieve_on_insert => 1 }
+);
+
+lives_ok { $obj = $rs->create ({ name => 'artistB' }) } 'Default insert successful';
+is ($obj->rank, 13, 'With retrieve_on_insert, check rank');
+
+done_testing;
use Test::More;
use Test::Exception;
+use lib 't/lib';
+use DBICTest;
+
throws_ok (
sub {
package BuggyTable;
use base 'DBIx::Class::Core';
__PACKAGE__->table('buggy_table');
- __PACKAGE__->columns qw/this doesnt work as expected/;
+ __PACKAGE__->columns( qw/this doesnt work as expected/ );
},
qr/\bcolumns\(\) is a read-only/,
'columns() error when apparently misused',
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-
-plan tests => 3;
-
-my @warnings;
-
-{
- local $SIG{__WARN__} = sub { push(@warnings, $_[0]); };
- require DBICTest::Plain;
-}
-
-like($warnings[0], qr/compose_connection deprecated as of 0\.08000/,
- 'deprecation warning emitted ok');
-cmp_ok(@warnings, '==', 1, 'no unexpected warnings');
-cmp_ok(DBICTest::Plain->resultset('Test')->count, '>', 0, 'count is valid');
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+
+use DBICTest;
+my $schema = DBICTest->init_schema;
+
+throws_ok (sub {
+ $schema->txn_do (sub { die 'lol' } );
+}, 'DBIx::Class::Exception', 'a DBIC::Exception object thrown');
+
+throws_ok (sub {
+ $schema->txn_do (sub { die [qw/lol wut/] });
+}, qr/ARRAY\(0x/, 'An arrayref thrown');
+
+is_deeply (
+ $@,
+ [qw/ lol wut /],
+ 'Exception-arrayref contents preserved',
+);
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
-plan tests => 9;
-
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
# which might need updating at some future time to be some other
# exception-generating statement:
-sub throwex { $schema->resultset("Artist")->search(1,1,1); }
+my $throw = sub { $schema->resultset("Artist")->search(1,1,1) };
my $ex_regex = qr/Odd number of arguments to search/;
# Basic check, normal exception
-eval { throwex };
-my $e = $@; # like() seems to stringify $@
-like($@, $ex_regex);
+throws_ok \&$throw, $ex_regex;
+
+my $e = $@;
# Re-throw the exception with rethrow()
-eval { $e->rethrow };
+throws_ok { $e->rethrow }
+ $ex_regex;
isa_ok( $@, 'DBIx::Class::Exception' );
-like($@, $ex_regex);
# Now lets rethrow via exception_action
$schema->exception_action(sub { die @_ });
-eval { throwex };
-like($@, $ex_regex);
+throws_ok \&$throw, $ex_regex;
+#
+# This should have never worked!!!
+#
# Now lets suppress the error
$schema->exception_action(sub { 1 });
-eval { throwex };
-ok(!$@, "Suppress exception");
+throws_ok \&$throw,
+ qr/exception_action handler .+ did \*not\* result in an exception.+original error: $ex_regex/;
# Now lets fall through and let croak take back over
$schema->exception_action(sub { return });
-eval { throwex };
-like($@, $ex_regex);
+throws_ok {
+ warnings_are \&$throw,
+ qr/exception_action handler installed .+ returned false instead throwing an exception/;
+} $ex_regex;
+
+# again to see if no warning
+throws_ok {
+ warnings_are \&$throw,
+ [];
+} $ex_regex;
+
# Whacky useless exception class
{
# Try the exception class
$schema->exception_action(sub { DBICTest::Exception->throw(@_) });
-eval { throwex };
-like($@, qr/DBICTest::Exception is handling this: $ex_regex/);
+throws_ok \&$throw,
+ qr/DBICTest::Exception is handling this: $ex_regex/;
# While we're at it, lets throw a custom exception through Storage::DBI
-eval { $schema->storage->throw_exception('floob') };
-like($@, qr/DBICTest::Exception is handling this: floob/);
-
-
-# This usage is a bit unusual but it was actually seen in the wild
-eval {
-
- my $dbh = $schema->storage->dbh;
- undef $schema;
-
- $dbh->do ('glaring_syntax_error;');
-};
-like($@, qr/DBI Exception.+do failed/, 'Exception thrown even after $storage is destroyed');
+throws_ok { $schema->storage->throw_exception('floob') }
+ qr/DBICTest::Exception is handling this: floob/;
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
use lib qw(t/lib);
use DBICTest; # do not remove even though it is not used
-plan tests => 8;
-
my $warnings;
eval {
local $SIG{__WARN__} = sub { $warnings .= shift };
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_namespaces;
};
-ok(!$@) or diag $@;
-like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+ok(!$@, 'load_namespaces doesnt die') or diag $@;
+like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/, 'Found warning about extra ResultSet classes');
+
+like($warnings, qr/load_namespaces found ResultSet class DBICNSTest::ResultSet::D that does not subclass DBIx::Class::ResultSet/, 'Found warning about ResultSets with incorrect subclass');
my $source_a = DBICNSTest->source('A');
isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
for my $moniker (qw/A B/) {
my $class = "DBICNSTest::Result::$moniker";
- ok(!defined($class->result_source_instance->source_name));
+ ok(!defined($class->result_source_instance->source_name), "Source name of $moniker not defined");
}
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
+use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest; # do not remove even though it is not used
-plan tests => 7;
-
-my $warnings;
-eval {
- local $SIG{__WARN__} = sub { $warnings .= shift };
- package DBICNSTestOther;
- use base qw/DBIx::Class::Schema/;
- __PACKAGE__->load_namespaces(
- result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
- resultset_namespace => '+DBICNSTest::RSet',
- );
-};
-ok(!$@) or diag $@;
-like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+lives_ok (sub {
+ warnings_exist ( sub {
+ package DBICNSTestOther;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->load_namespaces(
+ result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
+ resultset_namespace => '+DBICNSTest::RSet',
+ );
+ },
+ qr/load_namespaces found ResultSet class C with no corresponding Result class/,
+ );
+});
my $source_a = DBICNSTestOther->source('A');
isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
my $source_d = DBICNSTestOther->source('D');
isa_ok($source_d, 'DBIx::Class::ResultSource::Table');
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-#!/usr/bin/perl
-
use strict;
use warnings;
use lib 't/lib';
-use DBICTest; # do not remove even though it is not used
+use DBICTest; # do not remove even though it is not used
use Test::More tests => 8;
sub _chk_warning {
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Time::HiRes qw/gettimeofday/;
+
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used
+
+our $src_count = 100;
+
+for (1 .. $src_count) {
+ eval <<EOM or die $@;
+
+ package DBICTest::NS::Stress::Schema::Result::T$_;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table($_);
+ __PACKAGE__->add_columns (
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ data => { data_type => 'varchar', size => 255 },
+ );
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->add_unique_constraint(['data']);
+
+EOM
+}
+
+{
+ package DBICTest::NS::Stress::Schema;
+
+ use base qw/DBIx::Class::Schema/;
+
+ sub _findallmod {
+ return $_[1] eq ( __PACKAGE__ . '::Result' )
+ ? ( map { __PACKAGE__ . "::Result::T$_" } 1 .. $::src_count )
+ : ()
+ ;
+ }
+}
+
+is (DBICTest::NS::Stress::Schema->sources, 0, 'Start with no sources');
+
+
+note gettimeofday . ":\tload_namespaces start";
+DBICTest::NS::Stress::Schema->load_namespaces;
+note gettimeofday . ":\tload_namespaces finished";
+
+is (DBICTest::NS::Stress::Schema->sources, $src_count, 'All sources attached');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Warn;
+
+use lib qw(t/lib);
+use DBICTest;
+
+warnings_exist { DBICTest->init_schema( compose_connection => 1, sqlite_use_file => 1 ) }
+ [
+ qr/compose_connection deprecated as of 0\.08000/,
+ qr/\QDBIx::Class::ResultSetProxy is DEPRECATED/,
+ ],
+ 'got expected deprecation warnings'
+;
+
+cmp_ok(DBICTest->resultset('Artist')->count, '>', 0, 'count is valid');
+
+# cleanup globals so we do not trigger the leaktest
+for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
+ $_->class_resolver(undef);
+ $_->resultset_instance(undef);
+ $_->result_source_instance(undef);
+}
+{
+ no warnings qw/redefine once/;
+ *DBICTest::schema = sub {};
+}
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
+use Test::Warn;
use lib qw(t/lib);
+use DBICTest;
-BEGIN {
- eval { require Class::Inspector };
- if ($@ =~ m{Can.t locate Class/Inspector.pm}) {
- plan skip_all => "ResultSetManager requires Class::Inspector";
- } else {
- plan tests => 4;
- }
-}
-
-BEGIN {
- local $SIG{__WARN__} = sub {};
- require DBIx::Class::ResultSetManager;
-}
-
-use DBICTest::ResultSetManager; # uses Class::Inspector
+warnings_exist { require DBICTest::ResultSetManager }
+ [
+ qr/\QDBIx::Class::ResultSetManager never left experimental status/,
+ ],
+ 'found deprecation warning'
+;
my $schema = DBICTest::ResultSetManager->compose_namespace('DB');
my $rs = $schema->resultset('Foo');
ok( $rs->can('bar'), 'Foo resultset class has bar method' );
isa_ok( $rs, 'DBICTest::ResultSetManager::Foo::_resultset', 'Foo resultset class is correct' );
is( $rs->bar, 'good', 'bar method works' );
+
+done_testing;
use warnings;
use Test::More;
-# README: If you set the env var to a number greater than 10,
-# we will use that many children
+use lib qw(t/lib);
+use DBICTest;
+use DBIx::Class::Optional::Dependencies ();
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-my $num_children = $ENV{DBICTEST_FORK_STRESS};
+my $main_pid = $$;
-plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test'
- unless $num_children;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
. ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
+# README: If you set the env var to a number greater than 10,
+# we will use that many children
+my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-plan tests => $num_children + 6;
-
-use lib qw(t/lib);
-
-use_ok('DBICTest::Schema');
-
-my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1 });
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 });
my $parent_rs;
$pid = $$;
- my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
- my $row = $parent_rs->next;
- if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
- $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
+ my $work = sub {
+ my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
+ my $row = $parent_rs->next;
+ $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) })
+ if($row && $row->get_column('artist') =~ /^(?:123|456)$/);
+ };
+
+ # try with and without transactions
+ if ((@pids % 3) == 1) {
+ my $guard = $schema->txn_scope_guard;
+ $work->();
+ $guard->commit;
+ }
+ elsif ((@pids % 3) == 2) {
+ $schema->txn_do ($work);
+ }
+ else {
+ $work->();
}
+
sleep(3);
- exit;
+ exit 0;
}
ok(1, "past forking");
-waitpid($_,0) for(@pids);
+for (@pids) {
+ waitpid($_,0);
+ ok (! $?, "Child $_ exitted cleanly");
+};
ok(1, "past waiting");
ok(1, "Made it to the end");
-$schema->storage->dbh->do("DROP TABLE cd");
+done_testing;
+
+END {
+ $schema->storage->dbh->do("DROP TABLE cd") if ($schema and $main_pid == $$);
+ undef $schema;
+}
--- /dev/null
+use Config;
+BEGIN {
+ unless ($Config{useithreads}) {
+ print "1..0 # SKIP your perl does not support ithreads\n";
+ exit 0;
+ }
+}
+use threads;
+
+use strict;
+use warnings;
+use Test::More;
+
+plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
+ if $] < '5.008005';
+
+use lib qw(t/lib);
+use DBICTest;
+
+# README: If you set the env var to a number greater than 10,
+# we will use that many children
+my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
+if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
+ $num_children = 10;
+}
+
+my $schema = DBICTest->init_schema(no_deploy => 1);
+isa_ok ($schema, 'DBICTest::Schema');
+
+my @threads;
+push @threads, threads->create(sub {
+ my $rsrc = $schema->source('Artist');
+ undef $schema;
+ isa_ok ($rsrc->schema, 'DBICTest::Schema');
+ my $s2 = $rsrc->schema->clone;
+
+ sleep 1; # without this many tasty crashes
+}) for (1.. $num_children);
+ok(1, "past spawning");
+
+$_->join for @threads;
+ok(1, "past joining");
+
+done_testing;
+use Config;
+BEGIN {
+ unless ($Config{useithreads}) {
+ print "1..0 # SKIP your perl does not support ithreads\n";
+ exit 0;
+ }
+}
+use threads;
+
use strict;
use warnings;
+
use Test::More;
-use Config;
+use Test::Exception;
-# README: If you set the env var to a number greater than 10,
-# we will use that many children
+plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
+ if $] < '5.008005';
-BEGIN {
- plan skip_all => 'Your perl does not support ithreads'
- if !$Config{useithreads};
-}
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
-use threads;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-my $num_children = $ENV{DBICTEST_THREAD_STRESS};
-
-plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
- unless $num_children;
-
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
. ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-diag 'It is normal to see a series of "Scalars leaked: ..." messages during this test';
-
+# README: If you set the env var to a number greater than 10,
+# we will use that many children
+my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-plan tests => $num_children + 5;
-
-use lib qw(t/lib);
-
use_ok('DBICTest::Schema');
-my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
my $parent_rs;
-eval {
+lives_ok (sub {
my $dbh = $schema->storage->dbh;
{
$parent_rs = $schema->resultset('CD')->search({ year => 1901 });
$parent_rs->next;
-};
-ok(!$@) or diag "Creation eval failed: $@";
+}, 'populate successfull');
my @children;
while(@children < $num_children) {
if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
$schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) });
}
- sleep(3);
+ sleep(1); # tasty crashes without this
};
die "Thread creation failed: $! $@" if !defined $newthread;
push(@children, $newthread);
ok(1, "Made it to the end");
$schema->storage->dbh->do("DROP TABLE cd");
+
+done_testing;
-use strict;
-use warnings;
-use Test::More;
-use Config;
-
# README: If you set the env var to a number greater than 10,
# we will use that many children
+use Config;
BEGIN {
- plan skip_all => 'Your perl does not support ithreads'
- if !$Config{useithreads};
+ unless ($Config{useithreads}) {
+ print "1..0 # SKIP your perl does not support ithreads\n";
+ exit 0;
+ }
}
-
use threads;
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-my $num_children = $ENV{DBICTEST_THREAD_STRESS};
+use strict;
+use warnings;
-plan skip_all => 'Set $ENV{DBICTEST_THREAD_STRESS} to run this test'
- unless $num_children;
+use Test::More;
+
+plan skip_all => 'DBIC does not actively support threads before perl 5.8.5'
+ if $] < '5.008005';
+use DBIx::Class::Optional::Dependencies ();
+use Scalar::Util 'weaken';
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
. ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
-diag 'It is normal to see a series of "Scalars leaked: ..." messages during this test';
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
+my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1;
if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
$num_children = 10;
}
-plan tests => $num_children + 5;
-
-use lib qw(t/lib);
-
use_ok('DBICTest::Schema');
-my $schema = DBICTest::Schema->connection($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1, RaiseError => 1, PrintError => 0 });
my $parent_rs;
my $newthread = async {
my $tid = threads->tid;
- # my $dbh = $schema->storage->dbh;
-
+ weaken(my $weak_schema = $schema);
+ weaken(my $weak_parent_rs = $parent_rs);
$schema->txn_do(sub {
- my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
- my $row = $parent_rs->next;
+ my $child_rs = $weak_schema->resultset('CD')->search({ year => 1901 });
+ my $row = $weak_parent_rs->next;
if($row && $row->get_column('artist') =~ /^(?:123|456)$/) {
- $schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) });
+ $weak_schema->resultset('CD')->create({ title => "test success $tid", artist => $tid, year => scalar(@children) });
}
});
- sleep(3);
+ sleep(1); # tasty crashes without this
};
die "Thread creation failed: $! $@" if !defined $newthread;
push(@children, $newthread);
ok(1, "Made it to the end");
$schema->storage->dbh->do("DROP TABLE cd");
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-
-use lib qw(t/lib);
-
-BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs: ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_cycle')
- unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_cycle') );
-}
-
-use DBICTest;
-use DBICTest::Schema;
-use Scalar::Util ();
-
-import Test::Memory::Cycle;
-
-my $weak;
-
-{
- my $s = $weak->{schema} = DBICTest->init_schema;
- memory_cycle_ok($s, 'No cycles in schema');
-
- my $rs = $weak->{resultset} = $s->resultset ('Artist');
- memory_cycle_ok($rs, 'No cycles in resultset');
-
- my $rsrc = $weak->{resultsource} = $rs->result_source;
- memory_cycle_ok($rsrc, 'No cycles in resultsource');
-
- my $row = $weak->{row} = $rs->first;
- memory_cycle_ok($row, 'No cycles in row');
-
- Scalar::Util::weaken ($_) for values %$weak;
- memory_cycle_ok($weak, 'No cycles in weak object collection');
-}
-
-for (keys %$weak) {
- ok (! $weak->{$_}, "No $_ leaks");
-}
-
-done_testing;
--- /dev/null
+# work around brain damage in PPerl (yes, it has to be a global)
+$SIG{__WARN__} = sub {
+ warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/
+} if ($ENV{DBICTEST_IN_PERSISTENT_ENV});
+
+# the persistent environments run with this flag first to see if
+# we will run at all (e.g. it will fail if $^X doesn't match)
+exit 0 if $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY};
+
+# Do the override as early as possible so that CORE::bless doesn't get compiled away
+# We will replace $bless_override only if we are in author mode
+my $bless_override;
+BEGIN {
+ $bless_override = sub {
+ CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() );
+ };
+ *CORE::GLOBAL::bless = sub { goto $bless_override };
+}
+
+use strict;
+use warnings;
+use Test::More;
+
+my $TB = Test::More->builder;
+if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
+ # without this explicit close older TBs warn in END after a ->reset
+ if ($TB->VERSION < 1.005) {
+ close ($TB->$_) for (qw/output failure_output todo_output/);
+ }
+
+ # if I do not do this, I get happy sigpipes on new TB, no idea why
+ # (the above close-and-forget doesn't work - new TB does *not* reopen
+ # its handles automatically anymore)
+ else {
+ for (qw/failure_output todo_output/) {
+ close $TB->$_;
+ open ($TB->$_, '>&', *STDERR);
+ }
+
+ close $TB->output;
+ open ($TB->output, '>&', *STDOUT);
+ }
+
+ # so done_testing can work on every persistent pass
+ $TB->reset;
+}
+
+use lib qw(t/lib);
+use DBICTest::RunMode;
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/;
+use DBIx::Class;
+use B 'svref_2object';
+BEGIN {
+ plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
+ if DBIx::Class::_ENV_::PEEPEENESS;
+}
+
+# this is what holds all weakened refs to be checked for leakage
+my $weak_registry = {};
+
+# whether or to invoke IC::DT
+my $has_dt;
+
+# Skip the heavy-duty leak tracing when just doing an install
+unless (DBICTest::RunMode->is_plain) {
+
+ # redefine the bless override so that we can catch each and every object created
+ no warnings qw/redefine once/;
+ no strict qw/refs/;
+
+ $bless_override = sub {
+
+ my $obj = CORE::bless(
+ $_[0], (@_ > 1) ? $_[1] : do {
+ my ($class, $fn, $line) = caller();
+ fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line")
+ if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x;
+ $class;
+ }
+ );
+
+ # unicode is tricky, and now we happen to invoke it early via a
+ # regex in connection()
+ return $obj if (ref $obj) =~ /^utf8/;
+
+ # Test Builder is now making a new object for every pass/fail (que bloat?)
+ # and as such we can't really store any of its objects (since it will
+ # re-populate the registry while checking it, ewwww!)
+ return $obj if (ref $obj) =~ /^TB2::/;
+
+ # weaken immediately to avoid weird side effects
+ return populate_weakregistry ($weak_registry, $obj );
+ };
+
+ require Try::Tiny;
+ for my $func (qw/try catch finally/) {
+ my $orig = \&{"Try::Tiny::$func"};
+ *{"Try::Tiny::$func"} = sub (&;@) {
+ populate_weakregistry( $weak_registry, $_[0] );
+ goto $orig;
+ }
+ }
+
+ # Some modules are known to install singletons on-load
+ # Load them and empty the registry
+
+ # this loads the DT armada
+ $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite');
+
+ require Errno;
+ require DBI;
+ require DBD::SQLite;
+ require FileHandle;
+
+ %$weak_registry = ();
+}
+
+my @compose_ns_classes;
+{
+ use_ok ('DBICTest');
+
+ my $schema = DBICTest->init_schema;
+ my $rs = $schema->resultset ('Artist');
+ my $storage = $schema->storage;
+
+ @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations};
+
+ ok ($storage->connected, 'we are connected');
+
+ my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work
+ ok ($row_obj, 'row from db');
+
+ # txn_do to invoke more codepaths
+ my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub {
+
+ my $artist = $schema->resultset('Artist')->create ({
+ name => 'foo artist',
+ cds => [{
+ title => 'foo cd',
+ year => 1984,
+ tracks => [
+ { title => 't1' },
+ { title => 't2' },
+ ],
+ genre => { name => 'mauve' },
+ }],
+ });
+
+ my $pg = $rs->search({}, { rows => 1})->page(2)->pager;
+
+ my $pg_wcount = $rs->page(4)->pager->total_entries (66);
+
+ return ($artist, $pg, $pg_wcount);
+ });
+
+ # more codepaths - error handling in txn_do
+ {
+ eval { $schema->txn_do ( sub {
+ $storage->_dbh->begin_work;
+ fail ('how did we get so far?!');
+ } ) };
+
+ eval { $schema->txn_do ( sub {
+ $schema->txn_do ( sub {
+ die "It's called EXCEPTION";
+ fail ('how did we get so far?!');
+ } );
+ fail ('how did we get so far?!');
+ } ) };
+ like( $@, qr/It\'s called EXCEPTION/, 'Exception correctly propagated in nested txn_do' );
+ }
+
+ # dbh_do codepath
+ my ($rs_bind_circref, $cond_rowobj) = $schema->storage->dbh_do ( sub {
+ my $row = $_[0]->schema->resultset('Artist')->new({});
+ my $rs = $_[0]->schema->resultset('Artist')->search({
+ name => $row, # this is deliberately bogus, see FIXME below!
+ });
+ return ($rs, $row);
+ });
+
+ is ($pager->next_page, 3, 'There is one more page available');
+
+ # based on 66 per 10 pages
+ is ($pager_explicit_count->last_page, 7, 'Correct last page');
+
+ # do some population (invokes some extra codepaths)
+ # also exercise the guard code and the manual txn control
+ {
+ my $guard = $schema->txn_scope_guard;
+ # populate with bindvars
+ $rs->populate([{ name => 'James Bound' }]);
+ $guard->commit;
+
+ $schema->txn_begin;
+ # populate mixed
+ $rs->populate([{ name => 'James Rebound', rank => \ '11' }]);
+ $schema->txn_commit;
+
+ $schema->txn_begin;
+ # and without bindvars
+ $rs->populate([{ name => \ '"James Unbound"' }]);
+ $schema->txn_rollback;
+ }
+
+ # prefetching
+ my $cds_rs = $schema->resultset('CD');
+ my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' });
+ my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' });
+ my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] });
+
+ # implicit pref
+ my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' });
+
+ # get_column
+ my $getcol_rs = $cds_rs->get_column('me.cdid');
+ my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid');
+
+ # fire the column getters
+ my @throwaway = $pref_getcol_rs->all;
+
+ my $base_collection = {
+ resultset => $rs,
+
+ pref_precursor => $cds_rs,
+
+ pref_rs_single => $cds_with_artist,
+ pref_rs_multi => $cds_with_tracks,
+ pref_rs_nested => $cds_with_stuff,
+
+ pref_rs_implicit => $cds_with_impl_artist,
+
+ pref_row_single => $cds_with_artist->next,
+ pref_row_multi => $cds_with_tracks->next,
+ pref_row_nested => $cds_with_stuff->next,
+
+ # even though this does not leak Storable croaks on it :(((
+ #pref_row_implicit => $cds_with_impl_artist->next,
+
+ get_column_rs_plain => $getcol_rs,
+ get_column_rs_pref => $pref_getcol_rs,
+
+ # twice so that we make sure only one H::M object spawned
+ chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ),
+ chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ),
+
+ row_object => $row_obj,
+
+ mc_row_object => $mc_row_obj,
+
+ result_source => $rs->result_source,
+
+ result_source_handle => $rs->result_source->handle,
+
+ pager_explicit_count => $pager_explicit_count,
+
+ leaky_resultset => $rs_bind_circref,
+ leaky_resultset_cond => $cond_rowobj,
+ leaky_resultset_member => $rs_bind_circref->next,
+ };
+
+ require Storable;
+ %$base_collection = (
+ %$base_collection,
+ refrozen => Storable::dclone( $base_collection ),
+ rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ),
+ pref_row_implicit => $cds_with_impl_artist->next,
+ schema => $schema,
+ storage => $storage,
+ sql_maker => $storage->sql_maker,
+ dbh => $storage->_dbh,
+ fresh_pager => $rs->page(5)->pager,
+ pager => $pager,
+ );
+
+ if ($has_dt) {
+ my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event');
+
+ my $now = DateTime->now;
+ for (1..5) {
+ $base_collection->{"icdt_row_$_"} = $rs->create({
+ created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ),
+ starts_at => $now->clone->add(days => $_),
+ });
+ }
+
+ # re-search
+ my @dummy = $rs->all;
+ }
+
+ # dbh's are created in XS space, so pull them separately
+ for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) {
+ $base_collection->{"DBI handle $_"} = $_;
+ }
+
+ SKIP: {
+ if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) {
+ Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection')
+ }
+ else {
+ skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1;
+ }
+ }
+
+ populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
+ for keys %$base_collection;
+}
+
+# check that "phantom-chaining" works - we never lose track of the original $schema
+# and have access to the entire tree without leaking anything
+{
+ my $phantom;
+ for (
+ sub { DBICTest->init_schema( sqlite_use_file => 0 ) },
+ sub { shift->source('Artist') },
+ sub { shift->resultset },
+ sub { shift->result_source },
+ sub { shift->schema },
+ sub { shift->resultset('Artist') },
+ sub { shift->find_or_create({ name => 'detachable' }) },
+ sub { shift->result_source },
+ sub { shift->schema },
+ sub { shift->clone },
+ sub { shift->resultset('CD') },
+ sub { shift->next },
+ sub { shift->artist },
+ sub { shift->search_related('cds') },
+ sub { shift->next },
+ sub { shift->search_related('artist') },
+ sub { shift->result_source },
+ sub { shift->resultset },
+ sub { shift->create({ name => 'detached' }) },
+ sub { shift->update({ name => 'reattached' }) },
+ sub { shift->discard_changes },
+ sub { shift->delete },
+ sub { shift->insert },
+ ) {
+ $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) );
+ }
+
+ ok( $phantom->in_storage, 'Properly deleted/reinserted' );
+ is( $phantom->name, 'reattached', 'Still correct name' );
+}
+
+# Naturally we have some exceptions
+my $cleared;
+for my $slot (keys %$weak_registry) {
+ if ($slot =~ /^Test::Builder/) {
+ # T::B 2.0 has result objects and other fancyness
+ delete $weak_registry->{$slot};
+ }
+ elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) {
+ # Moo keeps globals around, this is normal
+ delete $weak_registry->{$slot};
+ }
+ elsif ($slot =~ /^SQL::Translator/) {
+ # SQLT is a piece of shit, leaks all over
+ delete $weak_registry->{$slot};
+ }
+ elsif ($slot =~ /^Hash::Merge/) {
+ # only clear one object of a specific behavior - more would indicate trouble
+ delete $weak_registry->{$slot}
+ unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
+ }
+ elsif (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and $slot =~ /^__TxnScopeGuard__FIXUP__/) {
+ delete $weak_registry->{$slot}
+ }
+ elsif ($slot =~ /^DateTime::TimeZone/) {
+ # DT is going through a refactor it seems - let it leak zones for now
+ delete $weak_registry->{$slot};
+ }
+}
+
+# every result class has a result source instance as classdata
+# make sure these are all present and distinct before ignoring
+# (distinct means only 1 reference)
+for my $rs_class (
+ 'DBICTest::BaseResult',
+ @compose_ns_classes,
+ map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
+) {
+ # need to store the SVref and examine it separately, to push the rsrc instance off the pad
+ my $SV = svref_2object($rs_class->result_source_instance);
+ is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" );
+
+ # ignore it
+ delete $weak_registry->{$rs_class->result_source_instance};
+}
+
+# Schema classes also hold sources, but these are clones, since
+# each source contains the schema (or schema class name in this case)
+# Hence the clone so that the same source can be registered with
+# multiple schemas
+for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) {
+
+ my $SV = svref_2object(DBICTest::Schema->source($moniker));
+ is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" );
+
+ delete $weak_registry->{DBICTest::Schema->source($moniker)};
+}
+
+# FIXME !!!
+# There is an actual strong circular reference taking place here, but because
+# half of it is in XS no leaktracer sees it, and Devel::FindRef is equally
+# stumped when trying to trace the origin. The problem is:
+#
+# $cond_object --> result_source --> schema --> storage --> $dbh --> {cached_kids}
+# ^ /
+# \-------- bound value on prepared/cached STH <-----------/
+#
+TODO: {
+ local $TODO = 'Not sure how to fix this yet, an entanglment could be an option';
+ my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref};
+ ok(! defined $r, 'We no longer leak!')
+ or $r->result_source(undef);
+}
+
+assert_empty_weakregistry ($weak_registry);
+
+# we got so far without a failure - this is a good thing
+# now let's try to rerun this script under a "persistent" environment
+# this is ugly and dirty but we do not yet have a Test::Embedded or
+# similar
+
+# set up -I
+require Config;
+$ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+($ENV{PATH}) = $ENV{PATH} =~ /(.+)/;
+
+
+my $persistence_tests = {
+ PPerl => {
+ cmd => [qw/pperl --prefork=1/, __FILE__],
+ },
+ 'CGI::SpeedyCGI' => {
+ cmd => [qw/speedy -- -t5/, __FILE__],
+ },
+};
+
+# scgi is smart and will auto-reap after -t amount of seconds
+# pperl needs an actual killer :(
+$persistence_tests->{PPerl}{termcmd} = [
+ $persistence_tests->{PPerl}{cmd}[0],
+ '--kill',
+ @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ],
+];
+
+SKIP: {
+ skip 'Test already in a persistent loop', 1
+ if $ENV{DBICTEST_IN_PERSISTENT_ENV};
+
+ skip 'Main test failed - skipping persistent env tests', 1
+ unless $TB->is_passing;
+
+ local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1;
+
+ require IPC::Open2;
+
+ for my $type (keys %$persistence_tests) { SKIP: {
+ skip "$type module not found", 1
+ unless eval "require $type";
+
+ my @cmd = @{$persistence_tests->{$type}{cmd}};
+
+ # since PPerl is racy and sucks - just prime the "server"
+ {
+ local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1;
+ system(@cmd);
+ sleep 1;
+
+ # see if the thing actually runs, if not - might as well bail now
+ skip "Something is wrong with $type ($!)", 1
+ if system(@cmd);
+ }
+
+ for (1,2,3) {
+ note ("Starting run in persistent env ($type pass $_)");
+ IPC::Open2::open2(my $out, undef, @cmd);
+ my @out_lines;
+ while (my $ln = <$out>) {
+ next if $ln =~ /^\s*$/;
+ push @out_lines, " $ln";
+ last if $ln =~ /^\d+\.\.\d+$/; # this is persistence, we need to terminate reading on our end
+ }
+ print $_ for @out_lines;
+ close $out;
+ wait;
+ ok (!$?, "Run in persistent env ($type pass $_): exit $?");
+ ok (scalar @out_lines, "Run in persistent env ($type pass $_): got output");
+ }
+
+ ok (! system (@{$persistence_tests->{$type}{termcmd}}), "killed $type server instance")
+ if $persistence_tests->{$type}{termcmd};
+ }}
+}
+
+done_testing;
+
+# just an extra precaution in case we blew away from the SKIP - since there are no
+# PID files to go by (man does pperl really suck :(
+END {
+ unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
+ close $_ for (*STDIN, *STDOUT, *STDERR);
+ local $?; # otherwise test will inherit $? of the system()
+ system (@{$persistence_tests->{PPerl}{termcmd}});
+ }
+}
--- /dev/null
+# Use a require override instead of @INC munging (less common)
+# Do the override as early as possible so that CORE::require doesn't get compiled away
+# We will add the hook in a bit, got to load some regular stuff
+
+my $test_hook;
+BEGIN {
+ unshift @INC, 't/lib';
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = $_[0]->();
+ $test_hook->($_[1]) if $test_hook;
+ return $res;
+ });
+}
+
+use strict;
+use warnings;
+use Test::More;
+use DBICTest::Util 'stacktrace';
+
+# Package::Stash::XS is silly and fails if a require hook contains regular
+# expressions on perl < 5.8.7. Load the damned thing if the case
+BEGIN {
+ require Package::Stash if $] < 5.008007;
+}
+
+my $expected_core_modules;
+
+BEGIN {
+ $expected_core_modules = { map { $_ => 1 } qw/
+ strict
+ warnings
+
+ base
+ mro
+ overload
+ Exporter
+
+ B
+ locale
+
+ namespace::clean
+ Try::Tiny
+ Context::Preserve
+ Sub::Name
+
+ Scalar::Util
+ List::Util
+ Hash::Merge
+ Data::Compare
+
+ DBI
+ DBI::Const::GetInfoType
+ SQL::Abstract
+
+ Carp
+
+ Class::Accessor::Grouped
+ Class::C3::Componentised
+ Moo
+ Sub::Quote
+ /, $] < 5.010 ? ( 'Class::C3', 'MRO::Compat' ) : () }; # this is special-cased in DBIx/Class.pm
+
+ $test_hook = sub {
+
+ my $req = $_[0];
+ $req =~ s/\.pm$//;
+ $req =~ s/\//::/g;
+
+ return if $req =~ /^DBIx::Class|^DBICTest::/;
+
+ my $up = 1;
+ my @caller;
+ do { @caller = caller($up++) } while (
+ @caller and (
+ # exclude our test suite, known "module require-rs" and eval frames
+ $caller[1] =~ /^ t [\/\\] /x
+ or
+ $caller[0] =~ /^ (?: base | parent | Class::C3::Componentised | Module::Inspector) $/x
+ or
+ $caller[3] eq '(eval)',
+ )
+ );
+
+ # exclude everything where the current namespace does not match the called function
+ # (this works around very weird XS-induced require callstack corruption)
+ if (
+ !$expected_core_modules->{$req}
+ and
+ @caller
+ and
+ $caller[0] =~ /^DBIx::Class/
+ and
+ (caller($up))[3] =~ /\Q$caller[0]/
+ ) {
+ fail ("Unexpected require of '$req' by $caller[0] ($caller[1] line $caller[2])");
+
+ diag( 'Require invoked' . stacktrace() ) if $ENV{TEST_VERBOSE};
+ }
+ };
+}
+
+use lib 't/lib';
+use DBICTest;
+
+# these envvars bring in more stuff
+delete $ENV{$_} for qw/
+ DBICTEST_SQLT_DEPLOY
+ DBIC_TRACE
+/;
+
+my $schema = DBICTest->init_schema;
+is ($schema->resultset('Artist')->next->name, 'Caterwauler McCrae');
+
+# check if anything we were expecting didn't actually load
+my $nl;
+for (keys %$expected_core_modules) {
+ my $mod = "$_.pm";
+ $mod =~ s/::/\//g;
+ unless ($INC{$mod}) {
+ my $err = sprintf "Expected DBIC core module %s never loaded - %s needs adjustment", $_, __FILE__;
+ if (DBICTest::RunMode->is_smoker or DBICTest::RunMode->is_author) {
+ fail ($err)
+ }
+ else {
+ diag "\n" unless $nl++;
+ diag $err;
+ }
+ }
+}
+
+done_testing;
-#!perl -T
+#!/usr/bin/env perl -T
# the above line forces Test::Harness into taint-mode
+# DO NOT REMOVE
use strict;
use warnings;
-use Test::More;
-BEGIN { plan tests => 7 }
-
-package DBICTest::Taint::Classes;
+# When in taint mode, PERL5LIB is ignored (but *not* unset)
+# Put it back in INC so that local-lib users can actually
+# run this test
+use Config;
+BEGIN {
+ for (map { defined $ENV{$_} ? $ENV{$_} : () } (qw/PERLLIB PERL5LIB/) ) { # we unshift, so reverse precedence
+ my ($envvar) = ($_ =~ /^(.+)$/); # untaint
+ unshift @INC, map { length($_) ? $_ : () } (split /\Q$Config{path_sep}\E/, $envvar);
+ }
+}
use Test::More;
use Test::Exception;
-
use lib qw(t/lib);
-use base qw/DBIx::Class::Schema/;
+use DBICTest;
-lives_ok (sub {
- __PACKAGE__->load_classes(qw/Manual/);
- ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
- __PACKAGE__->_unregister_source (qw/Manual/);
-}, 'Loading classes with explicit load_classes worked in taint mode' );
+throws_ok (
+ sub { $ENV{PATH} . (kill (0)) },
+ qr/Insecure dependency in kill/,
+ 'taint mode active'
+);
-lives_ok (sub {
- __PACKAGE__->load_classes();
- ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
- ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
-}, 'Loading classes with Module::Find/load_classes worked in taint mode' );
+{
+ package DBICTest::Taint::Classes;
+ use Test::More;
+ use Test::Exception;
-package DBICTest::Taint::Namespaces;
+ use base qw/DBIx::Class::Schema/;
-use Test::More;
-use Test::Exception;
+ lives_ok (sub {
+ __PACKAGE__->load_classes(qw/Manual/);
+ ok( __PACKAGE__->source('Manual'), 'The Classes::Manual source has been registered' );
+ __PACKAGE__->_unregister_source (qw/Manual/);
+ }, 'Loading classes with explicit load_classes worked in taint mode' );
-use lib qw(t/lib);
-use base qw/DBIx::Class::Schema/;
+ lives_ok (sub {
+ __PACKAGE__->load_classes();
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Auto source has been registered' );
+ ok( __PACKAGE__->source('Auto'), 'The Classes::Manual source has been re-registered' );
+ }, 'Loading classes with Module::Find/load_classes worked in taint mode' );
+}
+
+{
+ package DBICTest::Taint::Namespaces;
+
+ use Test::More;
+ use Test::Exception;
+
+ use base qw/DBIx::Class::Schema/;
-lives_ok (sub {
- __PACKAGE__->load_namespaces();
- ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
-}, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
+ lives_ok (sub {
+ __PACKAGE__->load_namespaces();
+ ok( __PACKAGE__->source('Test'), 'The Namespaces::Test source has been registered' );
+ }, 'Loading classes with Module::Find/load_namespaces worked in taint mode' );
+}
-1;
+done_testing;
--- /dev/null
+BEGIN {
+ if ($] < 5.010) {
+
+ # Pre-5.10 perls pollute %INC on unsuccesfull module
+ # require, making it appear as if the module is already
+ # loaded on subsequent require()s
+ # Can't seem to find the exact RT/perldelta entry
+ #
+ # The reason we can't just use a sane, clean loader, is because
+ # if a Module require()s another module the %INC will still
+ # get filled with crap and we are back to square one. A global
+ # fix is really the only way for this test, as we try to load
+ # each available module separately, and have no control (nor
+ # knowledge) over their common dependencies.
+ #
+ # we want to do this here, in the very beginning, before even
+ # warnings/strict are loaded
+
+ unshift @INC, 't/lib';
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = eval { $_[0]->() };
+ if ($@ ne '') {
+ delete $INC{$_[1]};
+ die $@;
+ }
+ return $res;
+ } );
+ }
+}
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 't/lib';
+use DBICTest;
+
+use File::Find;
+use File::Spec;
+use B qw/svref_2object/;
+use Package::Stash;
+
+# makes sure we can load at least something
+use DBIx::Class;
+use DBIx::Class::Carp;
+
+my @modules = grep {
+ my ($mod) = $_ =~ /(.+)/;
+
+ # not all modules are loadable at all times
+ do {
+ # trap deprecation warnings and whatnot
+ local $SIG{__WARN__} = sub {};
+ eval "require $mod";
+ } ? $mod : do {
+ SKIP: { skip "Failed require of $mod: " . ($@ =~ /^(.+?)$/m)[0], 1 };
+ (); # empty RV for @modules
+ };
+
+} find_modules();
+
+# have an exception table for old and/or weird code we are not sure
+# we *want* to clean in the first place
+my $skip_idx = { map { $_ => 1 } (
+ (grep { /^DBIx::Class::CDBICompat/ } @modules), # too crufty to touch
+ 'SQL::Translator::Producer::DBIx::Class::File', # ditto
+
+ # not sure how to handle type libraries
+ 'DBIx::Class::Storage::DBI::Replicated::Types',
+ 'DBIx::Class::Admin::Types',
+
+ # G::L::D is unclean, but we never inherit from it
+ 'DBIx::Class::Admin::Descriptive',
+ 'DBIx::Class::Admin::Usage',
+
+ # this subclass is expected to inherit whatever crap comes
+ # from the parent
+ 'DBIx::Class::ResultSet::Pager',
+
+ # this is not part of the inheritance tree (plus is a temporary fix anyway)
+ 'DBIx::Class::GlobalDestruction',
+
+ # Moo does not name its generated methods, fix pending
+ 'DBIx::Class::Storage::BlockRunner',
+) };
+
+my $has_cmop = eval { require Class::MOP };
+
+# can't use Class::Inspector for the mundane parts as it does not
+# distinguish imports from anything else, what a crock of...
+# Class::MOP is not always available either - hence just do it ourselves
+
+my $seen; #inheritance means we will see the same method multiple times
+
+for my $mod (@modules) {
+ SKIP: {
+ skip "$mod exempt from namespace checks",1 if $skip_idx->{$mod};
+
+ my %all_method_like = (map
+ { %{Package::Stash->new($_)->get_all_symbols('CODE')} }
+ (reverse @{mro::get_linear_isa($mod)})
+ );
+
+ my %parents = map { $_ => 1 } @{mro::get_linear_isa($mod)};
+
+ my %roles;
+ if ($has_cmop and my $mc = Class::MOP::class_of($mod)) {
+ if ($mc->can('calculate_all_roles_with_inheritance')) {
+ $roles{$_->name} = 1 for ($mc->calculate_all_roles_with_inheritance);
+ }
+ }
+
+ for my $name (keys %all_method_like) {
+
+ next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN() and $name =~ /^carp(?:_unique|_once)?$/ );
+
+ # overload is a funky thing - it is not cleaned, and its imports are named funny
+ next if $name =~ /^\(/;
+
+ my $gv = svref_2object($all_method_like{$name})->GV;
+ my $origin = $gv->STASH->NAME;
+
+ TODO: {
+ local $TODO;
+ if ($name =~ /^__CAG_/) {
+ $TODO = 'CAG does not clean its BEGIN constants';
+ }
+
+ is ($gv->NAME, $name, "Properly named $name method at $origin" . ($origin eq $mod
+ ? ''
+ : " (inherited by $mod)"
+ ));
+ }
+
+ next if $seen->{"${origin}:${name}"}++;
+
+ if ($origin eq $mod) {
+ pass ("$name is a native $mod method");
+ }
+ elsif ($roles{$origin}) {
+ pass ("${mod}::${name} came from consumption of role $origin");
+ }
+ elsif ($parents{$origin}) {
+ pass ("${mod}::${name} came from proper parent-class $origin");
+ }
+ else {
+ my $via;
+ for (reverse @{mro::get_linear_isa($mod)} ) {
+ if ( ($_->can($name)||'') eq $all_method_like{$name} ) {
+ $via = $_;
+ last;
+ }
+ }
+ fail ("${mod}::${name} appears to have entered inheritance chain by import into "
+ . ($via || 'UNKNOWN')
+ );
+ }
+ }
+
+ next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+
+ # some common import names (these should never ever be methods)
+ for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) {
+ if ($mod->can($f)) {
+ my $via;
+ for (reverse @{mro::get_linear_isa($mod)} ) {
+ if ( ($_->can($f)||'') eq $all_method_like{$f} ) {
+ $via = $_;
+ last;
+ }
+ }
+ fail ("Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at "
+ . ($via || 'UNKNOWN')
+ );
+ }
+ else {
+ pass ("Import $f not leaked into method list of $mod");
+ }
+ }
+ }
+}
+
+sub find_modules {
+ my @modules;
+
+ find({
+ wanted => sub {
+ -f $_ or return;
+ s/\.pm$// or return;
+ s/^ (?: lib | blib . (?:lib|arch) ) . //x;
+ push @modules, join ('::', File::Spec->splitdir($_));
+ },
+ no_chdir => 1,
+ }, (-e 'blib' ? 'blib' : 'lib') );
+
+ return sort @modules;
+}
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-use Test::More;
-
-# XXX obviously, the guts of this test haven't been written yet --blblack
-
-use lib qw(t/lib);
-
-plan skip_all => 'Set $ENV{DBICTEST_STORAGE_STRESS} to run this test'
- . ' (it is very resource intensive!)'
- unless $ENV{DBICTEST_STORAGE_STRESS};
-
-my $NKIDS = 20;
-my $CYCLES = 5;
-my @KILL_RATES = qw/0 0.001 0.01 0.1 0.2 0.5 0.75 1.0/;
-
-# Stress the storage with these parameters...
-sub stress_storage {
- my ($connect_info, $num_kids, $cycles, $kill_rate) = @_;
-
- foreach my $cycle (1..$cycles) {
- my $schema = DBICTest::Schema->connection(@$connect_info, { AutoCommit => 1 });
- foreach my $kidno (1..$num_kids) {
- ok(1);
- }
- }
-}
-
-# Get a set of connection information -
-# whatever the user has supplied for the vendor-specific tests
-sub get_connect_infos {
- my @connect_infos;
- foreach my $db_prefix (qw/PG MYSQL DB2 MSSQL ORA/) {
- my @conn_info = @ENV{
- map { "DBICTEST_${db_prefix}_${_}" } qw/DSN USER PASS/
- };
- push(@connect_infos, \@conn_info) if $conn_info[0];
- }
- \@connect_infos;
-}
-
-my $connect_infos = get_connect_infos();
-
-plan skip_all => 'This test needs some non-sqlite connect info!'
- unless @$connect_infos;
-
-plan tests => (1 * @$connect_infos * $NKIDS * $CYCLES * @KILL_RATES) + 1;
-
-use_ok('DBICTest::Schema');
-
-foreach my $connect_info (@$connect_infos) {
- foreach my $kill_rate (@KILL_RATES) {
- stress_storage($connect_info, $NKIDS, $CYCLES, $kill_rate);
- }
-}
my $schema = DBICTest->init_schema();
-eval { require DateTime::Format::SQLite };
-my $NO_DTFM = $@ ? 1 : 0;
-
my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
is(@art, 3, "Three artists returned");
is(scalar(keys(%fake_dirty)), 1, '1 fake dirty column');
ok(grep($_ eq 'name', keys(%fake_dirty)), 'name is fake dirty');
+ok($art->update, 'Update run');
+
my $record_jp = $schema->resultset("Artist")->search(undef, { join => 'cds' })->search(undef, { prefetch => 'cds' })->next;
ok($record_jp, "prefetch on same rel okay");
is($art->in_storage, 0, "It knows it's dead");
+lives_ok { $art->update } 'No changes so update should be OK';
+
dies_ok ( sub { $art->delete }, "Can't delete twice");
is($art->name, 'We Are In Rehab', 'But the object is still live');
is($new_again->ID, 'DBICTest::Artist|artist|artistid=4', 'unique object id generated correctly');
-# test that store_column is called once for create() for non sequence columns
+# test that store_column is called once for create() for non sequence columns
{
ok(my $artist = $schema->resultset('Artist')->create({name => 'store_column test'}));
is($artist->name, 'X store_column test'); # used to be 'X X store...'
$artist->delete;
}
-# Test backwards compatibility
-{
- my $warnings = '';
- local $SIG{__WARN__} = sub { $warnings .= $_[0] };
+# deprecation of rolled-out search
+warnings_exist {
+ $schema->resultset('Artist')->search_rs(id => 4)
+} qr/\Qsearch( %condition ) is deprecated/, 'Deprecation warning on ->search( %condition )';
- my $artist_by_hash = $schema->resultset('Artist')->find(artistid => 4);
- is($artist_by_hash->name, 'Man With A Spoon', 'Retrieved correctly');
- is($artist_by_hash->ID, 'DBICTest::Artist|artist|artistid=4', 'unique object id generated correctly');
- like($warnings, qr/deprecated/, 'warned about deprecated find usage');
-}
+# this has been warning for 4 years, killing
+throws_ok {
+ $schema->resultset('Artist')->find(artistid => 4);
+} qr|expects either a column/value hashref, or a list of values corresponding to the columns of the specified unique constraint|;
is($schema->resultset("Artist")->count, 4, 'count ok');
$cd = $schema->resultset("CD")->search({ title => 'Spoonful of bees' }, { columns => ['title'] })->next;
is($cd->title, 'Spoonful of bees', 'subset of columns returned correctly');
-$cd = $schema->resultset("CD")->search(undef, { include_columns => [ 'artist.name' ], join => [ 'artist' ] })->find(1);
+$cd = $schema->resultset("CD")->search(undef, { include_columns => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1);
is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
# check if new syntax +columns also works for this
-$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ 'artist.name' ], join => [ 'artist' ] })->find(1);
+$cd = $schema->resultset("CD")->search(undef, { '+columns' => [ { name => 'artist.name' } ], join => [ 'artist' ] })->find(1);
is($cd->title, 'Spoonful of bees', 'Correct CD returned with include');
is($cd->get_column('name'), 'Caterwauler McCrae', 'Additional column returned');
$new->update_or_insert;
is( $schema->resultset("Track")->find(100)->title, 'Insert or Update - updated', 'update_or_insert update ok');
-# get_inflated_columns w/relation and accessor alias
SKIP: {
- skip "This test requires DateTime::Format::SQLite", 8 if $NO_DTFM;
+ skip "Tests require " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite'), 13
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
+
+ # test get_inflated_columns with objects
+ my $event = $schema->resultset('Event')->search->first;
+ my %edata = $event->get_inflated_columns;
+ is($edata{'id'}, $event->id, 'got id');
+ isa_ok($edata{'starts_at'}, 'DateTime', 'start_at is DateTime object');
+ isa_ok($edata{'created_on'}, 'DateTime', 'create_on DateTime object');
+ is($edata{'starts_at'}, $event->starts_at, 'got start date');
+ is($edata{'created_on'}, $event->created_on, 'got created date');
+
+ # get_inflated_columns w/relation and accessor alias
isa_ok($new->updated_date, 'DateTime', 'have inflated object via accessor');
my %tdata = $new->get_inflated_columns;
is($tdata{'trackid'}, 100, 'got id');
group_by => [ qw/position title/ ]
}
);
- is($tcount->count, 13, 'multiple column COUNT DISTINCT using column syntax ok');
+ is($tcount->count, 13, 'multiple column COUNT DISTINCT using column syntax ok');
}
my $tag_rs = $schema->resultset('Tag')->search(
]
});
- $rs->update({ name => 'Test _cond_for_update_delete' });
+ $rs->update({ rank => 6134 });
my $art;
$art = $schema->resultset("Artist")->find(1);
- is($art->name, 'Test _cond_for_update_delete', 'updated first artist name');
+ is($art->rank, 6134, 'updated first artist rank');
$art = $schema->resultset("Artist")->find(2);
- is($art->name, 'Test _cond_for_update_delete', 'updated second artist name');
+ is($art->rank, 6134, 'updated second artist rank');
}
# test source_name
my @artsn = $schema->resultset('SourceNameArtists')->search({}, { order_by => 'name DESC' });
is(@artsn, 4, "Four artists returned");
-
+
# make sure subclasses that don't set source_name are ok
ok($schema->source('ArtistSubclass'), 'ArtistSubclass exists');
}
my $typeinfo = $schema->source("Artist")->column_info('artistid');
is($typeinfo->{data_type}, 'INTEGER', 'column_info ok');
$schema->source("Artist")->column_info('artistid');
- ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info flag set');
+ ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info loaded flag set');
+}
+
+# test columns_info
+{
+ $schema->source("Artist")->{_columns}{'artistid'} = {};
+ $schema->source("Artist")->column_info_from_storage(1);
+ $schema->source("Artist")->{_columns_info_loaded} = 0;
+
+ is_deeply (
+ $schema->source('Artist')->columns_info,
+ {
+ artistid => {
+ data_type => "INTEGER",
+ default_value => undef,
+ is_nullable => 0,
+ size => undef
+ },
+ charfield => {
+ data_type => "char",
+ default_value => undef,
+ is_nullable => 1,
+ size => 10
+ },
+ name => {
+ data_type => "varchar",
+ default_value => undef,
+ is_nullable => 1,
+ is_numeric => 0,
+ size => 100
+ },
+ rank => {
+ data_type => "integer",
+ default_value => 13,
+ is_nullable => 0,
+ size => undef
+ },
+ },
+ 'columns_info works',
+ );
+
+ ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info loaded flag set');
+
+ is_deeply (
+ $schema->source('Artist')->columns_info([qw/artistid rank/]),
+ {
+ artistid => {
+ data_type => "INTEGER",
+ default_value => undef,
+ is_nullable => 0,
+ size => undef
+ },
+ rank => {
+ data_type => "integer",
+ default_value => 13,
+ is_nullable => 0,
+ size => undef
+ },
+ },
+ 'limited columns_info works',
+ );
}
# test source_info
ok(! exists $priv_columns->{'genreid'}, 'genreid purged from _columns');
}
-# test get_inflated_columns with objects
-SKIP: {
- skip "This test requires DateTime::Format::SQLite", 5 if $NO_DTFM;
- my $event = $schema->resultset('Event')->search->first;
- my %edata = $event->get_inflated_columns;
- is($edata{'id'}, $event->id, 'got id');
- isa_ok($edata{'starts_at'}, 'DateTime', 'start_at is DateTime object');
- isa_ok($edata{'created_on'}, 'DateTime', 'create_on DateTime object');
- is($edata{'starts_at'}, $event->starts_at, 'got start date');
- is($edata{'created_on'}, $event->created_on, 'got created date');
-}
-
# test resultsource->table return value when setting
{
my $class = $schema->class('Event');
is($en_row->encoded, 'amliw', 'insert does not encode again');
}
+#make sure multicreate encoding still works
+{
+ my $empl_rs = $schema->resultset('Employee');
+
+ my $empl = $empl_rs->create ({
+ name => 'Secret holder',
+ secretkey => {
+ encoded => 'CAN HAZ',
+ },
+ });
+ is($empl->secretkey->encoded, 'ZAH NAC', 'correctly encoding on multicreate');
+
+ my $empl2 = $empl_rs->create ({
+ name => 'Same secret holder',
+ secretkey => {
+ encoded => 'CAN HAZ',
+ },
+ });
+ is($empl2->secretkey->encoded, 'ZAH NAC', 'correctly encoding on preexisting multicreate');
+
+ $empl_rs->create ({
+ name => 'cat1',
+ secretkey => {
+ encoded => 'CHEEZBURGER',
+ keyholders => [
+ {
+ name => 'cat2',
+ },
+ {
+ name => 'cat3',
+ },
+ ],
+ },
+ });
+
+ is($empl_rs->find({name => 'cat1'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl1');
+ is($empl_rs->find({name => 'cat2'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl2');
+ is($empl_rs->find({name => 'cat3'})->secretkey->encoded, 'REGRUBZEEHC', 'correct secret in database for empl3');
+
+}
+
+# make sure that obsolete handle-based source tracking continues to work for the time being
+{
+ my $handle = $schema->source('Artist')->handle;
+
+ my $rowdata = { $schema->resultset('Artist')->next->get_columns };
+
+ my $rs = DBIx::Class::ResultSet->new($handle);
+ my $rs_result = $rs->next;
+ isa_ok( $rs_result, 'DBICTest::Artist' );
+ is_deeply (
+ { $rs_result->get_columns },
+ $rowdata,
+ 'Correct columns retrieved (rset/source link healthy)'
+ );
+
+ my $row = DBICTest::Artist->new({ -source_handle => $handle });
+ is_deeply(
+ { $row->get_columns },
+ {},
+ 'No columns yet'
+ );
+
+ # store_column to fool the _orig_ident tracker
+ $row->store_column('artistid', $rowdata->{artistid});
+ $row->in_storage(1);
+
+ $row->discard_changes;
+ is_deeply(
+ { $row->get_columns },
+ $rowdata,
+ 'Storage refetch successful'
+ );
+}
+
# make sure we got rid of the compat shims
SKIP: {
skip "Remove in 0.082", 3 if $DBIx::Class::VERSION < 0.082;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Warn;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
-plan tests => 20;
-
my $art = $schema->resultset("Artist")->find(4);
ok(!defined($art), 'Find on primary id: artist not found');
my @cd = $schema->resultset("CD")->find(6);
$art = $artist_rs->find({ name => 'some other name' }, { key => 'primary' });
ok($art, 'Artist found by key in the resultset');
+# collapsing and non-collapsing are separate codepaths, thus the separate tests
+
+
$artist_rs = $schema->resultset("Artist");
-warning_is {
- $artist_rs->find({}, { key => 'primary' })
-} "DBIx::Class::ResultSet::find(): Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single"
+
+warnings_exist {
+ $artist_rs->find({})
+} qr/\QDBIx::Class::ResultSet::find(): Query returned more than one row. SQL that returns multiple rows is DEPRECATED for ->find and ->single/
=> "Non-unique find generated a cursor inexhaustion warning";
+throws_ok {
+ $artist_rs->find({}, { key => 'primary' })
+} qr/Unable to satisfy requested constraint 'primary'/;
+
+for (1, 0) {
+ warnings_like
+ sub {
+ $artist_rs->find({ artistid => undef }, { key => 'primary' })
+ },
+ $_ ? [
+ qr/undef values supplied for requested unique constraint.+almost certainly not what you wanted/,
+ ] : [],
+ 'One warning on NULL conditions for constraint'
+ ;
+}
+
+
$artist_rs = $schema->resultset("Artist")->search({}, { prefetch => 'cds' });
-warning_is {
+
+warnings_exist {
+ $artist_rs->find({})
+} qr/\QDBIx::Class::ResultSet::find(): Query returned more than one row/, "Non-unique find generated a cursor inexhaustion warning";
+
+throws_ok {
$artist_rs->find({}, { key => 'primary' })
-} "DBIx::Class::ResultSet::find(): Query returned more than one row", "Non-unique find generated a cursor inexhaustion warning";
+} qr/Unable to satisfy requested constraint 'primary'/;
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More tests => 2;
use lib qw(t/lib);
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+lives_ok {
+ DBICTest::Schema->load_classes('PunctuatedColumnName')
+} 'registered columns with weird names';
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
# XXX: Is storage->dbh the only way to get a dbh?
$schema->storage->txn_begin;
for (10..15) {
- $schema->resultset("Artist")->create( {
+ $schema->resultset("Artist")->create( {
artistid => $_,
name => "artist number $_",
} );
} );
}
$schema->storage->txn_rollback;
-($artist) = $schema->resultset("Artist")->search( artistid => 25 );
+($artist) = $schema->resultset("Artist")->search({ artistid => 25 });
is($artist, undef, "Rollback ok");
is_deeply (
'Correctly retrieve column info (no size or is_nullable)'
);
-TODO: {
- local $TODO = 'All current versions of SQLite seem to mis-report is_nullable';
-
+{
is_deeply (
get_storage_column_info ($schema->storage, 'artist', qw/size/),
{
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
-use Test::More qw(no_plan);
+use Test::More;
use lib qw(t/lib);
use DBICTest;
+use Storable qw/dclone/;
my $schema = DBICTest->init_schema();
+is ($schema->resultset("CD")->count, 5, 'Initial count sanity check');
+
+my $qcnt;
+$schema->storage->debugcb(sub { $qcnt++ });
+$schema->storage->debug (1);
+
+my $rs = $schema->resultset("CD");
+
# first page
-my $it = $schema->resultset("CD")->search(
+$qcnt = 0;
+my $it = $rs->search(
{},
{ order_by => 'title',
rows => 3,
page => 1 }
);
+my $pager = $it->pager;
+is ($qcnt, 0, 'No queries on rs/pager creation');
-is( $it->pager->entries_on_this_page, 3, "entries_on_this_page ok" );
+is ($pager->entries_per_page, 3, 'Pager created with correct entries_per_page');
+ok ($pager->current_page(-1), 'Set nonexistent page');
+is ($pager->current_page, 1, 'Page set behaves correctly');
+ok ($pager->current_page(2), 'Set 2nd page');
-is( $it->pager->next_page, 2, "next_page ok" );
+is ($qcnt, 0, 'No queries on total_count-independent methods');
-is( $it->count, 3, "count on paged rs ok" );
+is( $it->pager->entries_on_this_page, 2, "entries_on_this_page ok for page 2" );
-is( $it->pager->total_entries, 5, "total_entries ok" );
+is ($qcnt, 1, 'Count fired to get pager page entries');
+
+$qcnt = 0;
+is ($pager->previous_page, 1, 'Correct previous_page');
+is ($pager->next_page, undef, 'No more pages');
+is ($qcnt, 0, 'No more counts - amount of entries cached in pager');
+
+is( $it->count, 3, "count on paged rs ok" );
+is ($qcnt, 1, 'An $rs->count still fires properly');
is( $it->next->title, "Caterwaulin' Blues", "iterator->next ok" );
is( $it->next, undef, "next past end of page ok" );
+
# second page, testing with array
-my @page2 = $schema->resultset("CD")->search(
+my @page2 = $rs->search(
{},
{ order_by => 'title',
rows => 3,
is( $page2[0]->title, "Generic Manufactured Singles", "second page first title ok" );
# page a standard resultset
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ order_by => 'title',
rows => 3 }
is( $page->next->title, "Generic Manufactured Singles", "second page of standard resultset ok" );
+
# test software-based limit paging
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ order_by => 'title',
rows => 3,
is( $it->next->title, "Generic Manufactured Singles", "software iterator->next ok" );
# test paging with chained searches
-$it = $schema->resultset("CD")->search(
+$it = $rs->search(
{},
{ rows => 2,
page => 2 }
is( $it->count, 2, "chained searches paging ok" );
-my $p = sub { $schema->resultset("CD")->page(1)->pager->entries_per_page; };
-
-is($p->(), 10, 'default rows is 10');
-
-$schema->default_resultset_attributes({ rows => 5 });
-
-is($p->(), 5, 'default rows is 5');
-
# test page with offset
-$it = $schema->resultset('CD')->search({}, {
+$it = $rs->search({}, {
rows => 2,
page => 2,
offset => 1,
order_by => 'cdid'
});
-my $row = $schema->resultset('CD')->search({}, {
- order_by => 'cdid',
+my $row = $rs->search({}, {
+ order_by => 'cdid',
offset => 3,
rows => 1
})->single;
is($row->cdid, $it->first->cdid, 'page with offset');
+
+
+# test pager on non-title page behavior
+$qcnt = 0;
+$it = $rs->search({}, { rows => 3 })->page (2);
+ok ($it->pager);
+is ($qcnt, 0, 'No count on past-first-page pager instantiation');
+
+is ($it->pager->current_page, 2, 'Page set properby by $rs');
+is( $it->pager->total_entries, 5, 'total_entries correct' );
+
+$rs->create ({ artist => 1, title => 'MOAR!', year => 2010 });
+is( $it->count, 3, 'Dynamic count on filling up page' );
+$rs->create ({ artist => 1, title => 'MOAR!!!', year => 2011 });
+is( $it->count, 3, 'Count still correct (does not overflow' );
+
+$qcnt = 0;
+is( $it->pager->total_entries, 5, 'total_entries properly cached at old value' );
+is ($qcnt, 0, 'No queries');
+
+# test fresh pager with explicit total count assignment
+$qcnt = 0;
+$pager = $rs->search({}, { rows => 4 })->page (2)->pager;
+$pager->total_entries (13);
+
+is ($pager->current_page, 2, 'Correct start page');
+is ($pager->next_page, 3, 'One more page');
+is ($pager->last_page, 4, 'And one more page');
+is ($pager->previous_page, 1, 'One page in front');
+
+is ($qcnt, 0, 'No queries with explicitly sey total count');
+
+# test cached resultsets
+my $init_cnt = $rs->count;
+
+$it = $rs->search({}, { rows => 3, cache => 1 })->page(2);
+is ($it->count, 3, '3 rows');
+is (scalar $it->all, 3, '3 objects');
+
+isa_ok($it->pager,'Data::Page','Get a pager back ok');
+is($it->pager->total_entries,7);
+is($it->pager->current_page,2);
+is($it->pager->entries_on_this_page,3);
+
+$it = $it->page(3);
+is ($it->count, 1, 'One row');
+is (scalar $it->all, 1, 'One object');
+
+isa_ok($it->pager,'Data::Page','Get a pager back ok');
+is($it->pager->total_entries,7);
+is($it->pager->current_page,3);
+is($it->pager->entries_on_this_page,1);
+
+
+$it->delete;
+is ($rs->count, $init_cnt - 1, 'One row deleted as expected');
+
+is ($it->count, 1, 'One row (cached)');
+is (scalar $it->all, 1, 'One object (cached)');
+
+# test fresh rs creation with modified defaults
+my $p = sub { $schema->resultset('CD')->page(1)->pager->entries_per_page; };
+
+is($p->(), 10, 'default rows is 10');
+
+$schema->default_resultset_attributes({ rows => 5 });
+
+is($p->(), 5, 'default rows is 5');
+
+# does serialization work (preserve laziness, while preserving state if exits)
+$qcnt = 0;
+$it = $rs->search(
+ {},
+ { order_by => 'title',
+ rows => 5,
+ page => 2 }
+);
+$pager = $it->pager;
+is ($qcnt, 0, 'No queries on rs/pager creation');
+
+$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
+
+is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2" );
+
+is ($qcnt, 1, 'Count fired to get pager page entries');
+
+$rs->create({ title => 'bah', artist => 1, year => 2011 });
+
+$qcnt = 0;
+$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
+
+is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2, even though underlying count changed" );
+
+is ($qcnt, 0, 'No count fired on pre-existing total count');
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
+
+use DBI::Const::GetInfoType;
+use Scalar::Util qw/weaken/;
+use DBIx::Class::Optional::Dependencies ();
+
use lib qw(t/lib);
use DBICTest;
-use DBI::Const::GetInfoType;
use DBIC::SqlMakerTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
#warn "$dsn $user $pass";
#'dbi:mysql:host=localhost;database=dbic_test', 'dbic_test', '');
-# make sure sqlt_type overrides work (::Storage::DBI::mysql does this)
+# make sure sqlt_type overrides work (::Storage::DBI::mysql does this)
{
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
$it->next;
is( $it->next, undef, "next past end of resultset ok" );
+# Limit with select-lock
+lives_ok {
+ $schema->txn_do (sub {
+ isa_ok (
+ $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}),
+ 'DBICTest::Schema::Artist',
+ );
+ });
+} 'Limited FOR UPDATE select works';
+
+# shared-lock
+lives_ok {
+ $schema->txn_do (sub {
+ isa_ok (
+ $schema->resultset('Artist')->find({artistid => 1}, {for => 'shared'}),
+ 'DBICTest::Schema::Artist',
+ );
+ });
+} 'LOCK IN SHARE MODE select works';
+
my $test_type_info = {
'artistid' => {
'data_type' => 'INT',
]);
#
-# try a distinct + prefetch on tables with identically named columns
+# try a distinct + prefetch on tables with identically named columns
# (mysql doesn't seem to like subqueries with equally named columns)
#
}
SKIP: {
- my $mysql_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} );
- skip "Cannot determine MySQL server version", 1 if !$mysql_version;
-
- my ($v1, $v2, $v3) = $mysql_version =~ /^(\d+)\.(\d+)(?:\.(\d+))?/;
- skip "Cannot determine MySQL server version", 1 if !$v1 || !defined($v2);
+ my $norm_version = $schema->storage->_server_info->{normalized_dbms_version}
+ or skip "Cannot determine MySQL server version", 1;
- $v3 ||= 0;
-
- if( ($v1 < 5) || ($v1 == 5 && $v2 == 0 && $v3 <= 3) ) {
+ if ($norm_version < 5.000003_01) {
$test_type_info->{charfield}->{data_type} = 'VARCHAR';
}
);
}
+{
+ # Test support for straight joins
+ my $cdsrc = $schema->source('CD');
+ my $artrel_info = $cdsrc->relationship_info ('artist');
+ $cdsrc->add_relationship(
+ 'straight_artist',
+ $artrel_info->{class},
+ $artrel_info->{cond},
+ { %{$artrel_info->{attrs}}, join_type => 'straight' },
+ );
+ is_same_sql_bind (
+ $cdsrc->resultset->search({}, { prefetch => 'straight_artist' })->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
+ straight_artist.artistid, straight_artist.name, straight_artist.rank, straight_artist.charfield
+ FROM cd me
+ STRAIGHT_JOIN artist straight_artist ON straight_artist.artistid = me.artist
+ )',
+ [],
+ 'straight joins correctly supported for mysql'
+ );
+}
+
## Can we properly deal with the null search problem?
##
## Only way is to do a SET SQL_AUTO_IS_NULL = 0; on connect
# check for proper grouped counts
{
- my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, { on_connect_call => 'set_strict_mode' });
+ my $ansi_schema = DBICTest::Schema->connect ($dsn, $user, $pass, {
+ on_connect_call => 'set_strict_mode',
+ quote_char => '`',
+ });
my $rs = $ansi_schema->resultset('CD');
my $years;
'grouped count correct',
);
}, 'Grouped count does not throw');
+
+ lives_ok( sub {
+ $ansi_schema->resultset('Owners')->search({}, {
+ join => 'books', group_by => [ 'me.id', 'books.id' ]
+ })->count();
+ }, 'count on grouped columns with the same name does not throw');
}
ZEROINSEARCH: {
'Zero-year groups successfully',
);
- # convoluted search taken verbatim from list
+ # convoluted search taken verbatim from list
my $restrict_rs = $rs->search({ -and => [
year => { '!=', 0 },
year => { '!=', undef }
);
}
-## If find() is the first query after connect()
-## DBI::Storage::sql_maker() will be called before
-## _determine_driver() and so the ::SQLHacks class for MySQL
-## will not be used
+# make sure find hooks determine driver
+{
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema->resultset("Artist")->find(4);
+ isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL');
+}
+
+# make sure the mysql_auto_reconnect buggery is avoided
+{
+ local $ENV{MOD_PERL} = 'boogiewoogie';
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ ok (! $schema->storage->_get_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect unset regardless of ENV' );
+
+ # Make sure hardcore forking action still works even if mysql_auto_reconnect
+ # is true (test inspired by ether)
+
+ my $schema_autorecon = DBICTest::Schema->connect($dsn, $user, $pass, { mysql_auto_reconnect => 1 });
+ my $orig_dbh = $schema_autorecon->storage->_get_dbh;
+ weaken $orig_dbh;
+
+ ok ($orig_dbh, 'Got weak $dbh ref');
+ ok ($orig_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect is properly set if explicitly requested' );
-my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
-$schema2->resultset("Artist")->find(4);
-isa_ok($schema2->storage->sql_maker, 'DBIx::Class::SQLAHacks::MySQL');
+ my $rs = $schema_autorecon->resultset('Artist');
+
+ my ($parent_in, $child_out);
+ pipe( $parent_in, $child_out ) or die "Pipe open failed: $!";
+ my $pid = fork();
+ if (! defined $pid ) {
+ die "fork() failed: $!"
+ }
+ elsif ($pid) {
+ close $child_out;
+
+ # sanity check
+ $schema_autorecon->storage->dbh_do(sub {
+ is ($_[1], $orig_dbh, 'Storage holds correct $dbh in parent');
+ });
+
+ # kill our $dbh
+ $schema_autorecon->storage->_dbh(undef);
+
+ TODO: {
+ local $TODO = "Perl $] is known to leak like a sieve"
+ if DBIx::Class::_ENV_::PEEPEENESS();
+
+ ok (! defined $orig_dbh, 'Parent $dbh handle is gone');
+ }
+ }
+ else {
+ close $parent_in;
+
+ #simulate a subtest to not confuse the parent TAP emission
+ my $tb = Test::More->builder;
+ $tb->reset;
+ for (qw/output failure_output todo_output/) {
+ close $tb->$_;
+ open ($tb->$_, '>&', $child_out);
+ }
+
+ # wait for parent to kill its $dbh
+ sleep 1;
+
+ # try to do something dbic-esque
+ $rs->create({ name => "Hardcore Forker $$" });
+
+ TODO: {
+ local $TODO = "Perl $] is known to leak like a sieve"
+ if DBIx::Class::_ENV_::PEEPEENESS();
+
+ ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone');
+ }
+
+ done_testing;
+ exit 0;
+ }
+
+ while (my $ln = <$parent_in>) {
+ print " $ln";
+ }
+ wait;
+ ok(!$?, 'Child subtests passed');
+
+ ok ($rs->find({ name => "Hardcore Forker $pid" }), 'Expected row created');
+}
done_testing;
use Test::More;
use Test::Exception;
+use Sub::Name;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_pg');
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => <<EOM unless $dsn && $user;
-Set \$ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
-( NOTE: This test drops and creates tables called 'artist', 'casecheck',
- 'array_test' and 'sequence_test' as well as following sequences:
- 'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq''. as well as following
- schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3',
- 'dbic_t_schema_4', and 'dbic_t_schema_5'
-)
+plan skip_all => <<'EOM' unless $dsn && $user;
+Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
+( NOTE: This test drops and creates tables called 'artist', 'cd',
+'timestamp_primary_key_test', 'track', 'casecheck', 'array_test' and
+'sequence_test' as well as following sequences: 'pkid1_seq', 'pkid2_seq' and
+'nonpkid_seq'. as well as following schemas: 'dbic_t_schema',
+'dbic_t_schema_2', 'dbic_t_schema_3', 'dbic_t_schema_4', and 'dbic_t_schema_5')
EOM
### load any test classes that are defined further down in the file via BEGIN blocks
our @test_classes; #< array that will be pushed into by test classes defined in this file
DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
-
### pre-connect tests (keep each test separate as to make sure rebless() runs)
-{
- my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+ {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
- ok (!$s->storage->_dbh, 'definitely not connected');
+ ok (!$s->storage->_dbh, 'definitely not connected');
- # Check that datetime_parser returns correctly before we explicitly connect.
- SKIP: {
- eval { require DateTime::Format::Pg };
- skip "DateTime::Format::Pg required", 2 if $@;
+ # Check that datetime_parser returns correctly before we explicitly connect.
+ SKIP: {
+ skip (
+ "Pg parser detection test needs " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg'),
+ 2
+ ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg');
- my $store = ref $s->storage;
- is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
+ my $store = ref $s->storage;
+ is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
- my $parser = $s->storage->datetime_parser;
- is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
+ my $parser = $s->storage->datetime_parser;
+ is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
+ }
+
+ ok (!$s->storage->_dbh, 'still not connected');
}
- ok (!$s->storage->_dbh, 'still not connected');
-}
+ {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+ # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
+ ok (!$s->storage->_dbh, 'definitely not connected');
+ is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
+ ok (!$s->storage->_dbh, 'still not connected');
+ }
+
+# test LIMIT support
{
- my $s = DBICTest::Schema->connect($dsn, $user, $pass);
- # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
- ok (!$s->storage->_dbh, 'definitely not connected');
- is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
- ok (!$s->storage->_dbh, 'still not connected');
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ drop_test_schema($schema);
+ create_test_schema($schema);
+ for (1..6) {
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+ }
+ my $it = $schema->resultset('Artist')->search( {},
+ { rows => 3,
+ offset => 2,
+ order_by => 'artistid' }
+ );
+ is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 6 artists
+ is( $it->next->name, "Artist 3", "iterator->next ok" );
+ $it->next;
+ $it->next;
+ $it->next;
+ is( $it->next, undef, "next past end of resultset ok" );
+
+ # Limit with select-lock
+ lives_ok {
+ $schema->txn_do (sub {
+ isa_ok (
+ $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}),
+ 'DBICTest::Schema::Artist',
+ );
+ });
+ } 'Limited FOR UPDATE select works';
}
+# check if we indeed do support stuff
+my $test_server_supports_insert_returning = do {
+
+ my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
+ die "Unparseable Pg server version: $si->{dbms_version}\n"
+ unless $si->{normalized_dbms_version};
+
+ $si->{normalized_dbms_version} < 8.002 ? 0 : 1;
+};
+is (
+ DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
+ $test_server_supports_insert_returning,
+ 'insert returning capability guessed correctly'
+);
+
+my $schema;
+for my $use_insert_returning ($test_server_supports_insert_returning
+ ? (0,1)
+ : (0)
+) {
+
+ no warnings qw/once redefine/;
+ my $old_connection = DBICTest::Schema->can('connection');
+ local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+ my $s = shift->$old_connection(@_);
+ $s->storage->_use_insert_returning ($use_insert_returning);
+ $s;
+ };
+
+### test capability override
+ {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+
+ ok (!$s->storage->_dbh, 'definitely not connected');
+
+ ok (
+ ! ($s->storage->_use_insert_returning xor $use_insert_returning),
+ 'insert returning capability set correctly',
+ );
+ ok (!$s->storage->_dbh, 'still not connected (capability override works)');
+ }
+
### connect, create postgres-specific test schema
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema->storage->ensure_connected;
-drop_test_schema($schema);
-create_test_schema($schema);
+ drop_test_schema($schema);
+ create_test_schema($schema);
### begin main tests
-
# run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
# discovery
-run_apk_tests($schema); #< older set of auto-pk tests
-run_extended_apk_tests($schema); #< new extended set of auto-pk tests
+ run_apk_tests($schema); #< older set of auto-pk tests
+ run_extended_apk_tests($schema); #< new extended set of auto-pk tests
+### type_info tests
+ my $test_type_info = {
+ 'artistid' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ 'size' => 4,
+ },
+ 'name' => {
+ 'data_type' => 'character varying',
+ 'is_nullable' => 1,
+ 'size' => 100,
+ 'default_value' => undef,
+ },
+ 'rank' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ 'size' => 4,
+ 'default_value' => 13,
+ },
+ 'charfield' => {
+ 'data_type' => 'character',
+ 'is_nullable' => 1,
+ 'size' => 10,
+ 'default_value' => undef,
+ },
+ 'arrayfield' => {
+ 'data_type' => 'integer[]',
+ 'is_nullable' => 1,
+ 'size' => undef,
+ 'default_value' => undef,
+ },
+ };
+ my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
+ my $artistid_defval = delete $type_info->{artistid}->{default_value};
+ like($artistid_defval,
+ qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
+ 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
+ is_deeply($type_info, $test_type_info,
+ 'columns_info_for - column data types');
-### type_info tests
-my $test_type_info = {
- 'artistid' => {
- 'data_type' => 'integer',
- 'is_nullable' => 0,
- 'size' => 4,
- },
- 'name' => {
- 'data_type' => 'character varying',
- 'is_nullable' => 1,
- 'size' => 100,
- 'default_value' => undef,
- },
- 'rank' => {
- 'data_type' => 'integer',
- 'is_nullable' => 0,
- 'size' => 4,
- 'default_value' => 13,
-
- },
- 'charfield' => {
- 'data_type' => 'character',
- 'is_nullable' => 1,
- 'size' => 10,
- 'default_value' => undef,
- },
- 'arrayfield' => {
- 'data_type' => 'integer[]',
- 'is_nullable' => 1,
- 'size' => undef,
- 'default_value' => undef,
- },
-};
-my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
-my $artistid_defval = delete $type_info->{artistid}->{default_value};
-like($artistid_defval,
- qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
- 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
-is_deeply($type_info, $test_type_info,
- 'columns_info_for - column data types');
+####### Array tests
+ BEGIN {
+ package DBICTest::Schema::ArrayTest;
+ push @main::test_classes, __PACKAGE__;
+ use strict;
+ use warnings;
+ use base 'DBICTest::BaseResult';
-####### Array tests
+ __PACKAGE__->table('dbic_t_schema.array_test');
+ __PACKAGE__->add_columns(qw/id arrayfield/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
-BEGIN {
- package DBICTest::Schema::ArrayTest;
- push @main::test_classes, __PACKAGE__;
+ }
+ SKIP: {
+ skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
- use strict;
- use warnings;
- use base 'DBIx::Class::Core';
+ my $arr_rs = $schema->resultset('ArrayTest');
- __PACKAGE__->table('dbic_t_schema.array_test');
- __PACKAGE__->add_columns(qw/id arrayfield/);
- __PACKAGE__->column_info_from_storage(1);
- __PACKAGE__->set_primary_key('id');
+ lives_ok {
+ $arr_rs->create({
+ arrayfield => [1, 2],
+ });
+ } 'inserting arrayref as pg array data';
-}
-SKIP: {
- skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
+ lives_ok {
+ $arr_rs->update({
+ arrayfield => [3, 4],
+ });
+ } 'updating arrayref as pg array data';
- lives_ok {
- $schema->resultset('ArrayTest')->create({
- arrayfield => [1, 2],
+ $arr_rs->create({
+ arrayfield => [5, 6],
});
- } 'inserting arrayref as pg array data';
- lives_ok {
- $schema->resultset('ArrayTest')->update({
- arrayfield => [3, 4],
- });
- } 'updating arrayref as pg array data';
+ lives_ok {
+ $schema->populate('ArrayTest', [
+ [ qw/arrayfield/ ],
+ [ [0,0] ],
+ ]);
+ } 'inserting arrayref using void ctx populate';
- $schema->resultset('ArrayTest')->create({
- arrayfield => [5, 6],
- });
+ # Search using arrays
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { -value => [3,4] } })->first->arrayfield,
+ [3,4],
+ 'Array value matches'
+ );
+ } 'searching by arrayref';
- my $count;
- lives_ok {
- $count = $schema->resultset('ArrayTest')->search({
- arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
- })->count;
- } 'comparing arrayref to pg array data does not blow up';
- is($count, 1, 'comparing arrayref to pg array data gives correct result');
-}
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { '=' => { -value => [3,4] }} })->first->arrayfield,
+ [3,4],,
+ 'Array value matches explicit equal'
+ );
+ } 'searching by arrayref (explicit equal sign)';
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { '>' => { -value => [3,1] }} })->first->arrayfield,
+ [3,4],
+ 'Array value matches greater than'
+ );
+ } 'searching by arrayref (greater than)';
+ lives_ok {
+ is (
+ $arr_rs->search({ arrayfield => { '>' => { -value => [3,7] }} })->count,
+ 1,
+ 'Greater than search found [5,6]',
+ );
+ } 'searching by arrayref (greater than)';
+
+ # Find using arrays
+ lives_ok {
+ is_deeply (
+ $arr_rs->find({ arrayfield => { -value => [3,4] } })->arrayfield,
+ [3,4],
+ 'Array value matches implicit equal'
+ );
+ } 'find by arrayref';
-########## Case check
+ lives_ok {
+ is_deeply (
+ $arr_rs->find({ arrayfield => { '=' => { -value => [3,4] }} })->arrayfield,
+ [3,4],
+ 'Array value matches explicit equal'
+ );
+ } 'find by arrayref (equal)';
+
+ # test inferred condition for creation
+ TODO: for my $cond (
+ { -value => [3,4] },
+ \[ '= ?' => [arrayfield => [3, 4]] ],
+ ) {
+ local $TODO = 'No introspection of complex conditions :(';
+ my $arr_rs_cond = $arr_rs->search({ arrayfield => $cond });
-BEGIN {
- package DBICTest::Schema::Casecheck;
- push @main::test_classes, __PACKAGE__;
+ my $row = $arr_rs_cond->create({});
+ is_deeply ($row->arrayfield, [3,4], 'Array value taken from $rs condition');
+ $row->discard_changes;
+ is_deeply ($row->arrayfield, [3,4], 'Array value made it to storage');
+ }
+ }
- use strict;
- use warnings;
- use base 'DBIx::Class::Core';
+########## Case check
- __PACKAGE__->table('dbic_t_schema.casecheck');
- __PACKAGE__->add_columns(qw/id name NAME uc_name/);
- __PACKAGE__->column_info_from_storage(1);
- __PACKAGE__->set_primary_key('id');
-}
+ BEGIN {
+ package DBICTest::Schema::Casecheck;
+ push @main::test_classes, __PACKAGE__;
-my $name_info = $schema->source('Casecheck')->column_info( 'name' );
-is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
+ use strict;
+ use warnings;
+ use base 'DBIx::Class::Core';
-my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
-is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
+ __PACKAGE__->table('dbic_t_schema.casecheck');
+ __PACKAGE__->add_columns(qw/id name NAME uc_name/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
+ }
+
+ my $name_info = $schema->source('Casecheck')->column_info( 'name' );
+ is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
-my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
-is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
+ my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
+ is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
+ my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
+ is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
+## Test ResultSet->update
+my $artist = $schema->resultset('Artist')->first;
+my $cds = $artist->cds_unordered->search({
+ year => { '!=' => 2010 }
+}, { prefetch => 'liner_notes' });
+lives_ok { $cds->update({ year => '2010' }) } 'Update on prefetched rs';
## Test SELECT ... FOR UPDATE
-SKIP: {
- if(eval "require Sys::SigAction" && !$@) {
- Sys::SigAction->import( 'set_sig_handler' );
- }
- else {
- skip "Sys::SigAction is not available", 6;
- }
+ SKIP: {
+ if(eval { require Sys::SigAction }) {
+ Sys::SigAction->import( 'set_sig_handler' );
+ }
+ else {
+ skip "Sys::SigAction is not available", 6;
+ }
- my ($timed_out, $artist2);
+ my ($timed_out, $artist2);
- for my $t (
- {
- # Make sure that an error was raised, and that the update failed
- update_lock => 1,
- test_sub => sub {
- ok($timed_out, "update from second schema times out");
- ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
+ for my $t (
+ {
+ # Make sure that an error was raised, and that the update failed
+ update_lock => 1,
+ test_sub => sub {
+ ok($timed_out, "update from second schema times out");
+ ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
+ },
},
- },
- {
- # Make sure that an error was NOT raised, and that the update succeeded
- update_lock => 0,
- test_sub => sub {
- ok(! $timed_out, "update from second schema DOES NOT timeout");
- ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+ {
+ # Make sure that an error was NOT raised, and that the update succeeded
+ update_lock => 0,
+ test_sub => sub {
+ ok(! $timed_out, "update from second schema DOES NOT timeout");
+ ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+ },
},
- },
- ) {
- # create a new schema
- my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
- $schema2->source("Artist")->name("dbic_t_schema.artist");
-
- $schema->txn_do( sub {
- my $artist = $schema->resultset('Artist')->search(
- {
- artistid => 1
- },
- $t->{update_lock} ? { for => 'update' } : {}
- )->first;
- is($artist->artistid, 1, "select returns artistid = 1");
-
- $timed_out = 0;
- eval {
- my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
- alarm(2);
- $artist2 = $schema2->resultset('Artist')->find(1);
- $artist2->name('fooey');
- $artist2->update;
- alarm(0);
- };
- $timed_out = $@ =~ /DBICTestTimeout/;
- });
+ ) {
+ # create a new schema
+ my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema2->source("Artist")->name("dbic_t_schema.artist");
+
+ $schema->txn_do( sub {
+ my $rs = $schema->resultset('Artist')->search(
+ {
+ artistid => 1
+ },
+ $t->{update_lock} ? { for => 'update' } : {}
+ );
+ ok ($rs->count, 'Count works');
+
+ my $artist = $rs->next;
+ is($artist->artistid, 1, "select returns artistid = 1");
+
+ $timed_out = 0;
+ eval {
+ my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
+ alarm(2);
+ $artist2 = $schema2->resultset('Artist')->find(1);
+ $artist2->name('fooey');
+ $artist2->update;
+ alarm(0);
+ };
+ $timed_out = $@ =~ /DBICTestTimeout/;
+ });
- $t->{test_sub}->();
- }
-}
+ $t->{test_sub}->();
+ }
+ }
######## other older Auto-pk tests
-$schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
-for (1..5) {
- my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
- is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
- is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
- is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
+ $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
+ for (1..5) {
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+ is($st->pkid1, $_, "Auto-PK for sequence without default: First primary key");
+ is($st->pkid2, $_ + 9, "Auto-PK for sequence without default: Second primary key");
+ is($st->nonpkid, $_ + 19, "Auto-PK for sequence without default: Non-primary key");
+ }
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+ is($st->pkid1, 55, "Auto-PK for sequence without default: First primary key set manually");
+
+
+######## test non-serial auto-pk
+
+ if ($schema->storage->_use_insert_returning) {
+ $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
+ my $row = $schema->resultset('TimestampPrimaryKey')->create({});
+ ok $row->id;
+ }
+
+######## test with_deferred_fk_checks
+
+ $schema->source('CD')->name('dbic_t_schema.cd');
+ $schema->source('Track')->name('dbic_t_schema.track');
+ lives_ok {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
+ });
+ $schema->resultset('CD')->create({
+ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
+ });
+ });
+ } 'with_deferred_fk_checks code survived';
+
+ is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
+ 'code in with_deferred_fk_checks worked';
+
+ throws_ok {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+ } qr/constraint/i, 'with_deferred_fk_checks is off';
}
-my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
-is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
done_testing;
-exit;
-
END {
return unless $schema;
drop_test_schema($schema);
- eapk_drop_all( $schema)
+ eapk_drop_all($schema);
+ undef $schema;
};
$dbh->do("CREATE SCHEMA dbic_t_schema");
$dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
+
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.timestamp_primary_key_test (
+ id timestamp default current_timestamp
+)
+EOS
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.cd (
+ cdid int PRIMARY KEY,
+ artist int,
+ title varchar(255),
+ year varchar(4),
+ genreid int,
+ single_track int
+)
+EOS
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.track (
+ trackid int,
+ cd int REFERENCES dbic_t_schema.cd(cdid) DEFERRABLE,
+ position int,
+ title varchar(255),
+ last_updated_on date,
+ last_updated_at date
+)
+EOS
+
$dbh->do(<<EOS);
CREATE TABLE dbic_t_schema.sequence_test (
pkid1 integer
for my $stat (
'DROP SCHEMA dbic_t_schema_5 CASCADE',
- 'DROP SEQUENCE public.artist_artistid_seq',
+ 'DROP SEQUENCE public.artist_artistid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_4 CASCADE',
'DROP SCHEMA dbic_t_schema CASCADE',
- 'DROP SEQUENCE pkid1_seq',
- 'DROP SEQUENCE pkid2_seq',
- 'DROP SEQUENCE nonpkid_seq',
+ 'DROP SEQUENCE pkid1_seq CASCADE',
+ 'DROP SEQUENCE pkid2_seq CASCADE',
+ 'DROP SEQUENCE nonpkid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_2 CASCADE',
'DROP SCHEMA dbic_t_schema_3 CASCADE',
) {
my $search_path_save = eapk_get_search_path($schema);
eapk_drop_all($schema);
+ %seqs = ();
# make the test schemas and sequences
$schema->storage->dbh_do(sub {
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use DBIx::Class::Optional::Dependencies ();
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
+
+my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
+ unless ($dsn && $dbuser);
+
+my $schema = DBICTest::Schema->connect($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
+
+if ($schema->storage->_server_info->{normalized_dbms_version} >= 9.0) {
+ if (not try { DBD::Pg->VERSION('2.17.2') }) {
+ plan skip_all =>
+ 'DBD::Pg < 2.17.2 does not work with Pg >= 9.0 BYTEA columns';
+ }
+}
+elsif (not try { DBD::Pg->VERSION('2.9.2') }) {
+ plan skip_all =>
+ 'DBD::Pg < 2.9.2 does not work with BYTEA columns';
+}
+
+my $dbh = $schema->storage->dbh;
+
+{
+ local $SIG{__WARN__} = sub {};
+ $dbh->do('DROP TABLE IF EXISTS bindtype_test');
+
+ # the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id serial NOT NULL PRIMARY KEY,
+ bytea bytea NULL,
+ blob bytea NULL,
+ clob text NULL,
+ a_memo text NULL
+ );
+ ],{ RaiseError => 1, PrintError => 1 });
+}
+
+$schema->storage->debug(0); # these tests spew up way too much stuff, disable trace
+
+my $big_long_string = "\x00\x01\x02 abcd" x 125000;
+
+my $new;
+# test inserting a row
+{
+ $new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
+
+ ok($new->id, "Created a bytea row");
+ ok($new->bytea eq $big_long_string, "Set the blob correctly.");
+}
+
+# test retrieval of the bytea column
+{
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ ok($row->get_column('bytea') eq $big_long_string, "Created the blob correctly.");
+}
+
+{
+ my $rs = $schema->resultset('BindType')->search({ bytea => $big_long_string });
+
+ # search on the bytea column (select)
+ {
+ my $row = $rs->first;
+ is($row ? $row->id : undef, $new->id, "Found the row searching on the bytea column.");
+ }
+
+ # search on the bytea column (update)
+ {
+ my $new_big_long_string = $big_long_string . "2";
+ $schema->txn_do(sub {
+ $rs->update({ bytea => $new_big_long_string });
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ ok( ($row ? $row->get_column('bytea') : '') eq $new_big_long_string,
+ "Updated the row correctly (searching on the bytea column)."
+ );
+ $schema->txn_rollback;
+ });
+ }
+
+ # search on the bytea column (delete)
+ {
+ $schema->txn_do(sub {
+ $rs->delete;
+ my $row = $schema->resultset('BindType')->find({ id => $new->id });
+ is($row, undef, "Deleted the row correctly (searching on the bytea column).");
+ $schema->txn_rollback;
+ });
+ }
+
+ # create with blob from $rs
+ $new = $rs->create({});
+ ok($new->bytea eq $big_long_string, 'Object has bytea value from $rs');
+ $new->discard_changes;
+ ok($new->bytea eq $big_long_string, 'bytea value made it to db');
+}
+
+# test inserting a row via populate() (bindtype propagation through execute_for_fetch)
+# use a new $dbh to ensure no leakage due to prepare_cached
+{
+ my $cnt = 4;
+
+ $schema->storage->_dbh(undef);
+ my $rs = $schema->resultset('BindType');
+ $rs->delete;
+
+ $rs->populate([
+ [qw/id bytea/],
+ map { [
+ \[ '?', [ {} => $_ ] ],
+ "pop_${_}_" . $big_long_string,
+ ]} (1 .. $cnt)
+ ]);
+
+ is($rs->count, $cnt, 'All rows were correctly inserted');
+ for (1..$cnt) {
+ my $r = $rs->find({ bytea => "pop_${_}_" . $big_long_string });
+ is ($r->id, $_, "Row $_ found after find() on the blob");
+
+ }
+}
+
+done_testing;
+
+eval { $schema->storage->dbh_do(sub { $_[1]->do("DROP TABLE bindtype_test") } ) };
+
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use Sub::Name;
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
+# optional:
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
+ unless ($dsn && $user && $pass);
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
{
package # hide from PAUSE
DBICTest::Schema::ArtistFQN;
use base 'DBIx::Class::Core';
__PACKAGE__->table(
- defined $ENV{DBICTEST_ORA_USER}
- ? $ENV{DBICTEST_ORA_USER} . '.artist'
- : 'artist'
+ $ENV{DBICTEST_ORA_USER}
+ ? (uc $ENV{DBICTEST_ORA_USER}) . '.artist'
+ : '??_no_user_??'
);
__PACKAGE__->add_columns(
- 'artistid' => {
- data_type => 'integer',
- is_auto_increment => 1,
- },
- 'name' => {
- data_type => 'varchar',
- size => 100,
- is_nullable => 1,
- },
+ 'artistid' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'name' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+ 'autoinc_col' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'default_value_col' => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 0,
+ retrieve_on_insert => 1,
+ }
);
- __PACKAGE__->set_primary_key('artistid');
+ __PACKAGE__->set_primary_key(qw/ artistid autoinc_col /);
1;
}
-use strict;
-use warnings;
-
-use Test::Exception;
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
+DBICTest::Schema->load_classes('ArtistFQN');
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+# This is in Core now, but it's here just to test that it doesn't break
+DBICTest::Schema::Artist->load_components('PK::Auto');
+# These are compat shims for PK::Auto...
+DBICTest::Schema::CD->load_components('PK::Auto::Oracle');
+DBICTest::Schema::Track->load_components('PK::Auto::Oracle');
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
- 'Warning: This test drops and creates tables called \'artist\', \'cd\', \'track\' and \'sequence_test\''.
- ' as well as following sequences: \'pkid1_seq\', \'pkid2_seq\' and \'nonpkid_seq\''
- unless ($dsn && $user && $pass);
-DBICTest::Schema->load_classes('ArtistFQN');
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
-
-my $dbh = $schema->storage->dbh;
-
-eval {
- $dbh->do("DROP SEQUENCE artist_seq");
- $dbh->do("DROP SEQUENCE cd_seq");
- $dbh->do("DROP SEQUENCE pkid1_seq");
- $dbh->do("DROP SEQUENCE pkid2_seq");
- $dbh->do("DROP SEQUENCE nonpkid_seq");
- $dbh->do("DROP TABLE artist");
- $dbh->do("DROP TABLE sequence_test");
- $dbh->do("DROP TABLE track");
- $dbh->do("DROP TABLE cd");
+# check if we indeed do support stuff
+my $v = do {
+ my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
+ $si->{normalized_dbms_version}
+ or die "Unparseable Oracle server version: $si->{dbms_version}\n";
};
-$dbh->do("CREATE SEQUENCE artist_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE cd_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE pkid1_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0");
-$dbh->do("CREATE SEQUENCE nonpkid_seq START WITH 20 MAXVALUE 999999 MINVALUE 0");
-
-$dbh->do("CREATE TABLE artist (artistid NUMBER(12), name VARCHAR(255), rank NUMBER(38), charfield VARCHAR2(10))");
-$dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))");
-
-$dbh->do("CREATE TABLE sequence_test (pkid1 NUMBER(12), pkid2 NUMBER(12), nonpkid NUMBER(12), name VARCHAR(255))");
-$dbh->do("ALTER TABLE sequence_test ADD (CONSTRAINT sequence_test_constraint PRIMARY KEY (pkid1, pkid2))");
-
-$dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4), genreid NUMBER(12), single_track NUMBER(12))");
-$dbh->do("ALTER TABLE cd ADD (CONSTRAINT cd_pk PRIMARY KEY (cdid))");
-
-$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12) REFERENCES cd(cdid) DEFERRABLE, position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at DATE, small_dt DATE)");
-
-$dbh->do(qq{
- CREATE OR REPLACE TRIGGER artist_insert_trg
- BEFORE INSERT ON artist
- FOR EACH ROW
- BEGIN
- IF :new.artistid IS NULL THEN
- SELECT artist_seq.nextval
- INTO :new.artistid
- FROM DUAL;
- END IF;
- END;
-});
-$dbh->do(qq{
- CREATE OR REPLACE TRIGGER cd_insert_trg
- BEFORE INSERT ON cd
- FOR EACH ROW
- BEGIN
- IF :new.cdid IS NULL THEN
- SELECT cd_seq.nextval
- INTO :new.cdid
- FROM DUAL;
- END IF;
- END;
-});
-{
- # Swiped from t/bindtype_columns.t to avoid creating my own Resultset.
+my $test_server_supports_only_orajoins = $v < 9;
- local $SIG{__WARN__} = sub {};
- eval { $dbh->do('DROP TABLE bindtype_test') };
-
- $dbh->do(qq[
- CREATE TABLE bindtype_test
- (
- id integer NOT NULL PRIMARY KEY,
- bytea integer NULL,
- blob blob NULL,
- clob clob NULL
- )
- ],{ RaiseError => 1, PrintError => 1 });
+# TODO find out which version supports the RETURNING syntax
+# 8i (8.1) has it and earlier docs are a 404 on oracle.com
+my $test_server_supports_insert_returning = $v >= 8.001;
+
+is (
+ DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
+ $test_server_supports_insert_returning,
+ 'insert returning capability guessed correctly'
+);
+
+##########
+# the recyclebin (new for 10g) sometimes comes in the way
+my $on_connect_sql = $v >= 10 ? ["ALTER SESSION SET recyclebin = OFF"] : [];
+
+# iterate all tests on following options
+my @tryopt = (
+ { on_connect_do => $on_connect_sql },
+ { quote_char => '"', on_connect_do => $on_connect_sql },
+);
+
+# keep a database handle open for cleanup
+my ($dbh, $dbh2);
+
+my $schema;
+for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (0) ) {
+ for my $force_ora_joins ($test_server_supports_only_orajoins ? (0) : (0,1) ) {
+
+ no warnings qw/once redefine/;
+ my $old_connection = DBICTest::Schema->can('connection');
+ local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+ my $s = shift->$old_connection (@_);
+ $s->storage->_use_insert_returning ($use_insert_returning);
+ $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins;
+ $s;
+ };
+
+ for my $opt (@tryopt) {
+ # clean all cached sequences from previous run
+ for (map { values %{DBICTest::Schema->source($_)->columns_info} } (qw/Artist CD Track/) ) {
+ delete $_->{sequence};
+ }
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt);
+
+ $dbh = $schema->storage->dbh;
+ my $q = $schema->storage->sql_maker->quote_char || '';
+
+ do_creates($dbh, $q);
+
+ _run_tests($schema, $opt);
+ }
+ }
}
-# This is in Core now, but it's here just to test that it doesn't break
-$schema->class('Artist')->load_components('PK::Auto');
-# These are compat shims for PK::Auto...
-$schema->class('CD')->load_components('PK::Auto::Oracle');
-$schema->class('Track')->load_components('PK::Auto::Oracle');
+sub _run_tests {
+ my ($schema, $opt) = @_;
-# test primary key handling
-my $new = $schema->resultset('Artist')->create({ name => 'foo' });
-is($new->artistid, 1, "Oracle Auto-PK worked");
+ my $q = $schema->storage->sql_maker->quote_char || '';
-my $cd = $schema->resultset('CD')->create({ artist => 1, title => 'EP C', year => '2003' });
-is($cd->cdid, 1, "Oracle Auto-PK worked - using scalar ref as table name");
+# test primary key handling with multiple triggers
+ my ($new, $seq);
-# test again with fully-qualified table name
-$new = $schema->resultset('ArtistFQN')->create( { name => 'bar' } );
-is( $new->artistid, 2, "Oracle Auto-PK worked with fully-qualified tablename" );
+ my $new_artist = $schema->resultset('Artist')->create({ name => 'foo' });
+ my $new_cd = $schema->resultset('CD')->create({ artist => 1, title => 'EP C', year => '2003' });
-# test rel names over the 30 char limit
-my $query = $schema->resultset('Artist')->search({
- artistid => 1
-}, {
- prefetch => 'cds_very_very_very_long_relationship_name'
-});
-
-lives_and {
- is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
-} 'query with rel name over 30 chars survived and worked';
-
-# rel name over 30 char limit with user condition
-# This requires walking the SQLA data structure.
-{
- local $TODO = 'user condition on rel longer than 30 chars';
+ SKIP: {
+ skip 'not detecting sequences when using INSERT ... RETURNING', 4
+ if $schema->storage->_use_insert_returning;
+
+ is($new_artist->artistid, 1, "Oracle Auto-PK worked for standard sqlt-like trigger");
+ $seq = $new_artist->result_source->column_info('artistid')->{sequence};
+ $seq = $$seq if ref $seq;
+ like ($seq, qr/\.${q}artist_pk_seq${q}$/, 'Correct PK sequence selected for sqlt-like trigger');
+
+ is($new_cd->cdid, 1, 'Oracle Auto-PK worked - using scalar ref as table name/custom weird trigger');
+ $seq = $new_cd->result_source->column_info('cdid')->{sequence};
+ $seq = $$seq if ref $seq;
+ like ($seq, qr/\.${q}cd_seq${q}$/, 'Correct PK sequence selected for custom trigger');
+ }
+
+# test PKs again with fully-qualified table name
+ my $artistfqn_rs = $schema->resultset('ArtistFQN');
+ my $artist_rsrc = $artistfqn_rs->result_source;
+
+ delete $artist_rsrc->column_info('artistid')->{sequence};
+ $new = $artistfqn_rs->create( { name => 'bar' } );
+
+ is_deeply( {map { $_ => $new->$_ } $artist_rsrc->primary_columns},
+ { artistid => 2, autoinc_col => 2},
+ "Oracle Multi-Auto-PK worked with fully-qualified tablename" );
+
+
+ delete $artist_rsrc->column_info('artistid')->{sequence};
+ $new = $artistfqn_rs->create( { name => 'bar', autoinc_col => 1000 } );
+
+ is( $new->artistid, 3, "Oracle Auto-PK worked with fully-qualified tablename" );
+ is( $new->autoinc_col, 1000, "Oracle Auto-Inc overruled with fully-qualified tablename");
+
+
+ is( $new->default_value_col, 'default_value', $schema->storage->_use_insert_returning
+ ? 'Check retrieve_on_insert on default_value_col with INSERT ... RETURNING'
+ : 'Check retrieve_on_insert on default_value_col without INSERT ... RETURNING'
+ );
- $query = $schema->resultset('Artist')->search({
- 'cds_very_very_very_long_relationship_name.title' => 'EP C'
+ SKIP: {
+ skip 'not detecting sequences when using INSERT ... RETURNING', 1
+ if $schema->storage->_use_insert_returning;
+
+ $seq = $new->result_source->column_info('artistid')->{sequence};
+ $seq = $$seq if ref $seq;
+ like ($seq, qr/\.${q}artist_pk_seq${q}$/, 'Correct PK sequence selected for sqlt-like trigger');
+ }
+
+
+# test LIMIT support
+ for (1..6) {
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+ }
+ my $it = $schema->resultset('Artist')->search( { name => { -like => 'Artist %' } }, {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ });
+
+ is( $it->count, 2, "LIMIT count past end of RS ok" );
+ is( $it->next->name, "Artist 5", "iterator->next ok" );
+ is( $it->next->name, "Artist 6", "iterator->next ok" );
+ is( $it->next, undef, "next past end of resultset ok" );
+
+# test identifiers over the 30 char limit
+ lives_ok {
+ my @results = $schema->resultset('CD')->search(undef, {
+ prefetch => 'very_long_artist_relationship',
+ rows => 3,
+ offset => 0,
+ })->all;
+ ok( scalar @results > 0, 'limit with long identifiers returned something');
+ } 'limit with long identifiers executed successfully';
+
+
+# test rel names over the 30 char limit
+ my $query = $schema->resultset('Artist')->search({
+ artistid => 1
}, {
prefetch => 'cds_very_very_very_long_relationship_name'
});
lives_and {
is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
- } 'query with rel name over 30 chars and user condition survived and worked';
-}
-
-# test join with row count ambiguity
+ } 'query with rel name over 30 chars survived and worked';
-my $track = $schema->resultset('Track')->create({ trackid => 1, cd => 1,
- position => 1, title => 'Track1' });
-my $tjoin = $schema->resultset('Track')->search({ 'me.title' => 'Track1'},
- { join => 'cd',
- rows => 2 }
-);
+# test rel names over the 30 char limit using group_by and join
+ {
+ my @group_cols = ( 'me.name' );
+ my $query = $schema->resultset('Artist')->search({
+ artistid => 1
+ }, {
+ select => \@group_cols,
+ as => [map { /^\w+\.(\w+)$/ } @group_cols],
+ join => [qw( cds_very_very_very_long_relationship_name )],
+ group_by => \@group_cols,
+ });
-ok(my $row = $tjoin->next);
+ lives_and {
+ my @got = $query->get_column('name')->all();
+ is_deeply \@got, [$new_artist->name];
+ } 'query with rel name over 30 chars worked on join, group_by for me col';
-is($row->title, 'Track1', "ambiguous column ok");
+ lives_and {
+ is $query->count(), 1
+ } 'query with rel name over 30 chars worked on join, group_by, count for me col';
+ }
+ {
+ my @group_cols = ( 'cds_very_very_very_long_relationship_name.title' );
+ my $query = $schema->resultset('Artist')->search({
+ artistid => 1
+ }, {
+ select => \@group_cols,
+ as => [map { /^\w+\.(\w+)$/ } @group_cols],
+ join => [qw( cds_very_very_very_long_relationship_name )],
+ group_by => \@group_cols,
+ });
-# check count distinct with multiple columns
-my $other_track = $schema->resultset('Track')->create({ trackid => 2, cd => 1, position => 1, title => 'Track2' });
+ lives_and {
+ my @got = $query->get_column('title')->all();
+ is_deeply \@got, [$new_cd->title];
+ } 'query with rel name over 30 chars worked on join, group_by for long rel col';
-my $tcount = $schema->resultset('Track')->search(
- {},
- {
- select => [ qw/position title/ ],
- distinct => 1,
+ lives_and {
+ is $query->count(), 1
+ } 'query with rel name over 30 chars worked on join, group_by, count for long rel col';
}
-);
-is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
-$tcount = $schema->resultset('Track')->search(
- {},
+ # rel name over 30 char limit with user condition
+ # This requires walking the SQLA data structure.
{
- columns => [ qw/position title/ ],
- distinct => 1,
- }
-);
-is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
+ $query = $schema->resultset('Artist')->search({
+ 'cds_very_very_very_long_relationship_name.title' => 'EP C'
+ }, {
+ prefetch => 'cds_very_very_very_long_relationship_name'
+ });
-$tcount = $schema->resultset('Track')->search(
- {},
- {
- group_by => [ qw/position title/ ]
+ lives_and {
+ is $query->first->cds_very_very_very_long_relationship_name->first->cdid, 1
+ } 'query with rel name over 30 chars and user condition survived and worked';
}
-);
-is($tcount->count, 2, 'multiple column COUNT DISTINCT using column syntax ok');
-# test LIMIT support
-for (1..6) {
- $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
-}
-my $it = $schema->resultset('Artist')->search( {},
- { rows => 3,
- offset => 3,
- order_by => 'artistid' }
-);
-is( $it->count, 3, "LIMIT count ok" );
-is( $it->next->name, "Artist 2", "iterator->next ok" );
-$it->next;
-$it->next;
-is( $it->next, undef, "next past end of resultset ok" );
-{
- my $rs = $schema->resultset('Track')->search( undef, { columns=>[qw/trackid position/], group_by=> [ qw/trackid position/ ] , rows => 2, offset=>1 });
- my @results = $rs->all;
- is( scalar @results, 1, "Group by with limit OK" );
-}
+# test join with row count ambiguity
+ my $cd = $schema->resultset('CD')->next;
+ my $track = $cd->create_related('tracks', { position => 1, title => 'Track1'} );
+ my $tjoin = $schema->resultset('Track')->search({ 'me.title' => 'Track1'}, {
+ join => 'cd', rows => 2
+ });
+
+ ok(my $row = $tjoin->next);
+
+ is($row->title, 'Track1', "ambiguous column ok");
+
+
+
+# check count distinct with multiple columns
+ my $other_track = $schema->resultset('Track')->create({ cd => $cd->cdid, position => 1, title => 'Track2' });
+
+ my $tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ select => [ qw/position title/ ],
+ distinct => 1,
+ }
+ );
+ is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
+
+ $tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ columns => [ qw/position title/ ],
+ distinct => 1,
+ }
+ );
+ is($tcount->count, 2, 'multiple column COUNT DISTINCT ok');
+
+ $tcount = $schema->resultset('Track')->search(
+ {},
+ {
+ group_by => [ qw/position title/ ]
+ }
+ );
+ is($tcount->count, 2, 'multiple column COUNT DISTINCT using column syntax ok');
+
+
+# check group_by
+ my $g_rs = $schema->resultset('Track')->search( undef, { columns=>[qw/trackid position/], group_by=> [ qw/trackid position/ ] , rows => 2, offset => 1 });
+ is( scalar $g_rs->all, 1, "Group by with limit OK" );
+
# test with_deferred_fk_checks
-lives_ok {
- $schema->storage->with_deferred_fk_checks(sub {
- $schema->resultset('Track')->create({
- trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
- });
- $schema->resultset('CD')->create({
- artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
+ lives_ok {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
+ });
+ $schema->resultset('CD')->create({
+ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
+ });
});
- });
-} 'with_deferred_fk_checks code survived';
+ } 'with_deferred_fk_checks code survived';
-is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
- 'code in with_deferred_fk_checks worked';
+ is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
+ 'code in with_deferred_fk_checks worked';
+
+ throws_ok {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+ } qr/constraint/i, 'with_deferred_fk_checks is off';
-throws_ok {
- $schema->resultset('Track')->create({
- trackid => 1, cd => 9999, position => 1, title => 'Track1'
- });
-} qr/constraint/i, 'with_deferred_fk_checks is off';
# test auto increment using sequences WITHOUT triggers
-for (1..5) {
+ for (1..5) {
my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
-}
-my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
-is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
+ }
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+ is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
-SKIP: {
- my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
- $binstr{'large'} = $binstr{'small'} x 1024;
- my $maxloblen = length $binstr{'large'};
- note "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
- local $dbh->{'LongReadLen'} = $maxloblen;
+# test populate (identity, success and error handling)
+ my $art_rs = $schema->resultset('Artist');
- my $rs = $schema->resultset('BindType');
- my $id = 0;
+ my $seq_pos = $art_rs->get_column('artistid')->max;
+ ok($seq_pos, 'Starting with something in the artist table');
- if ($DBD::Oracle::VERSION eq '1.23') {
- throws_ok { $rs->create({ id => 1, blob => $binstr{large} }) }
- qr/broken/,
- 'throws on blob insert with DBD::Oracle == 1.23';
- skip 'buggy BLOB support in DBD::Oracle 1.23', 7;
- }
+ my $pop_rs = $schema->resultset('Artist')->search(
+ { name => { -like => 'pop_art_%' } },
+ { order_by => 'artistid' }
+ );
- foreach my $type (qw( blob clob )) {
- foreach my $size (qw( small large )) {
- $id++;
+ $art_rs->delete;
+ lives_ok {
+ $pop_rs->populate([
+ map { +{ name => "pop_art_$_" } }
+ (1,2,3)
+ ]);
+
+ is_deeply (
+ [ $pop_rs->get_column('artistid')->all ],
+ [ map { $seq_pos + $_ } (1,2,3) ],
+ 'Sequence works after empty-table insertion'
+ );
+ } 'Populate without identity does not throw';
+
+ lives_ok {
+ $pop_rs->populate([
+ map { +{ artistid => $_, name => "pop_art_$_" } }
+ (1,2,3)
+ ]);
+
+ is_deeply (
+ [ $pop_rs->get_column('artistid')->all ],
+ [ 1,2,3, map { $seq_pos + $_ } (1,2,3) ],
+ 'Explicit id population works'
+ );
+ } 'Populate with identity does not throw';
+
+ throws_ok {
+ $pop_rs->populate([
+ map { +{ artistid => $_, name => "pop_art_$_" } }
+ (200, 1, 300)
+ ]);
+ } qr/unique constraint.+populate slice.+name => "pop_art_1"/s, 'Partially failed populate throws';
+
+ is_deeply (
+ [ $pop_rs->get_column('artistid')->all ],
+ [ 1,2,3, map { $seq_pos + $_ } (1,2,3) ],
+ 'Partially failed populate did not alter table contents'
+ );
- lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
- "inserted $size $type without dying";
+# test complex join (exercise orajoins)
+ lives_ok {
+ my @hri = $schema->resultset('CD')->search(
+ { 'artist.name' => 'pop_art_1', 'me.cdid' => { '!=', 999} },
+ { join => 'artist', prefetch => 'tracks', rows => 4, order_by => 'tracks.trackid' }
+ )->hri_dump->all;
+
+ my $expect = [{
+ artist => 1,
+ cdid => 1,
+ genreid => undef,
+ single_track => undef,
+ title => "EP C",
+ tracks => [
+ {
+ cd => 1,
+ last_updated_at => undef,
+ last_updated_on => undef,
+ position => 1,
+ title => "Track1",
+ trackid => 1
+ },
+ {
+ cd => 1,
+ last_updated_at => undef,
+ last_updated_on => undef,
+ position => 1,
+ title => "Track2",
+ trackid => 2
+ },
+ ],
+ year => 2003
+ }];
+
+ is_deeply (
+ \@hri,
+ $expect,
+ 'Correct set of data prefetched',
+ );
+
+ } 'complex prefetch ok';
+
+# test sequence detection from a different schema
+ SKIP: {
+ TODO: {
+ skip ((join '',
+ 'Set DBICTEST_ORA_EXTRAUSER_DSN, _USER and _PASS to a *DIFFERENT* Oracle user',
+ ' to run the cross-schema sequence detection test.'),
+ 1) unless $dsn2 && $user2 && $user2 ne $user;
+
+ skip 'not detecting cross-schema sequence name when using INSERT ... RETURNING', 1
+ if $schema->storage->_use_insert_returning;
+
+ # Oracle8i Reference Release 2 (8.1.6)
+ # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a76961/ch294.htm#993
+ # Oracle Database Reference 10g Release 2 (10.2)
+ # http://download.oracle.com/docs/cd/B19306_01/server.102/b14237/statviews_2107.htm#sthref1297
+ local $TODO = "On Oracle8i all_triggers view is empty, i don't yet know why..."
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+
+ my $schema2 = $schema->connect($dsn2, $user2, $pass2, $opt);
+ my $dbh2 = $schema2->storage->dbh;
+
+ # create identically named tables/sequences in the other schema
+ do_creates($dbh2, $q);
+
+ # grand select privileges to the 2nd user
+ $dbh->do("GRANT INSERT ON ${q}artist${q} TO " . uc $user2);
+ $dbh->do("GRANT SELECT ON ${q}artist${q} TO " . uc $user2);
+ $dbh->do("GRANT SELECT ON ${q}artist_pk_seq${q} TO " . uc $user2);
+ $dbh->do("GRANT SELECT ON ${q}artist_autoinc_seq${q} TO " . uc $user2);
+
+ # test with a fully qualified table (user1/schema prepended)
+ my $rs2 = $schema2->resultset('ArtistFQN');
+ delete $rs2->result_source->column_info('artistid')->{sequence};
+
+ lives_and {
+ my $row = $rs2->create({ name => 'From Different Schema' });
+ ok $row->artistid;
+ } 'used autoinc sequence across schemas';
+
+ # now quote the sequence name (do_creates always uses an lc name)
+ my $q_seq = $q
+ ? '"artist_pk_seq"'
+ : '"ARTIST_PK_SEQ"'
+ ;
+ delete $rs2->result_source->column_info('artistid')->{sequence};
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_pk${q}
+ BEFORE INSERT ON ${q}artist${q}
+ FOR EACH ROW
+ BEGIN
+ IF :new.${q}artistid${q} IS NULL THEN
+ SELECT $q_seq.nextval
+ INTO :new.${q}artistid${q}
+ FROM DUAL;
+ END IF;
+ END;
+ });
- ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
- }
- }
+
+ lives_and {
+ my $row = $rs2->create({ name => 'From Different Schema With Quoted Sequence' });
+ ok $row->artistid;
+ } 'used quoted autoinc sequence across schemas';
+
+ is_deeply $rs2->result_source->column_info('artistid')->{sequence},
+ \( (uc $user) . ".$q_seq"),
+ 'quoted sequence name correctly extracted';
+
+ # try an insert operation on the default user2 artist
+ my $art1 = $schema->resultset('Artist');
+ my $art2 = $schema2->resultset('Artist');
+ my $art1_count = $art1->count || 0;
+ my $art2_count = $art2->count;
+
+ is( $art2_count, 0, 'No artists created yet in second schema' );
+
+ delete $art2->result_source->column_info('artistid')->{sequence};
+ my $new_art = $art2->create({ name => '2nd best' });
+
+ is ($art1->count, $art1_count, 'No new rows in main schema');
+ is ($art2->count, 1, 'One artist create in 2nd schema');
+
+ is( $new_art->artistid, 1, 'Expected first PK' );
+
+ do_clean ($dbh2);
+ }}
+
+ do_clean ($dbh);
}
done_testing;
+sub do_creates {
+ my ($dbh, $q) = @_;
+
+ do_clean($dbh);
+
+ $dbh->do("CREATE SEQUENCE ${q}artist_autoinc_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE ${q}artist_pk_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE ${q}cd_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE ${q}track_seq${q} START WITH 1 MAXVALUE 999999 MINVALUE 0");
+
+ $dbh->do("CREATE SEQUENCE ${q}nonpkid_seq${q} START WITH 20 MAXVALUE 999999 MINVALUE 0");
+ # this one is always quoted as per manually specified sequence =>
+ $dbh->do('CREATE SEQUENCE "pkid1_seq" START WITH 1 MAXVALUE 999999 MINVALUE 0');
+ # this one is always unquoted as per manually specified sequence =>
+ $dbh->do("CREATE SEQUENCE pkid2_seq START WITH 10 MAXVALUE 999999 MINVALUE 0");
+
+ $dbh->do("CREATE TABLE ${q}artist${q} (${q}artistid${q} NUMBER(12), ${q}name${q} VARCHAR(255),${q}default_value_col${q} VARCHAR(255) DEFAULT 'default_value', ${q}autoinc_col${q} NUMBER(12), ${q}rank${q} NUMBER(38), ${q}charfield${q} VARCHAR2(10))");
+ $dbh->do("ALTER TABLE ${q}artist${q} ADD (CONSTRAINT ${q}artist_pk${q} PRIMARY KEY (${q}artistid${q}))");
+
+ $dbh->do("CREATE TABLE ${q}sequence_test${q} (${q}pkid1${q} NUMBER(12), ${q}pkid2${q} NUMBER(12), ${q}nonpkid${q} NUMBER(12), ${q}name${q} VARCHAR(255))");
+ $dbh->do("ALTER TABLE ${q}sequence_test${q} ADD (CONSTRAINT ${q}sequence_test_constraint${q} PRIMARY KEY (${q}pkid1${q}, ${q}pkid2${q}))");
+
+ # table cd will be unquoted => Oracle will see it as uppercase
+ $dbh->do("CREATE TABLE cd (${q}cdid${q} NUMBER(12), ${q}artist${q} NUMBER(12), ${q}title${q} VARCHAR(255), ${q}year${q} VARCHAR(4), ${q}genreid${q} NUMBER(12), ${q}single_track${q} NUMBER(12))");
+ $dbh->do("ALTER TABLE cd ADD (CONSTRAINT ${q}cd_pk${q} PRIMARY KEY (${q}cdid${q}))");
+
+ $dbh->do("CREATE TABLE ${q}track${q} (${q}trackid${q} NUMBER(12), ${q}cd${q} NUMBER(12) REFERENCES CD(${q}cdid${q}) DEFERRABLE, ${q}position${q} NUMBER(12), ${q}title${q} VARCHAR(255), ${q}last_updated_on${q} DATE, ${q}last_updated_at${q} DATE)");
+ $dbh->do("ALTER TABLE ${q}track${q} ADD (CONSTRAINT ${q}track_pk${q} PRIMARY KEY (${q}trackid${q}))");
+
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_auto${q}
+ BEFORE INSERT ON ${q}artist${q}
+ FOR EACH ROW
+ BEGIN
+ IF :new.${q}autoinc_col${q} IS NULL THEN
+ SELECT ${q}artist_autoinc_seq${q}.nextval
+ INTO :new.${q}autoinc_col${q}
+ FROM DUAL;
+ END IF;
+ END;
+ });
+
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER ${q}artist_insert_trg_pk${q}
+ BEFORE INSERT ON ${q}artist${q}
+ FOR EACH ROW
+ BEGIN
+ IF :new.${q}artistid${q} IS NULL THEN
+ SELECT ${q}artist_pk_seq${q}.nextval
+ INTO :new.${q}artistid${q}
+ FROM DUAL;
+ END IF;
+ END;
+ });
+
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER ${q}cd_insert_trg${q}
+ BEFORE INSERT OR UPDATE ON cd
+ FOR EACH ROW
+
+ DECLARE
+ tmpVar NUMBER;
+
+ BEGIN
+ tmpVar := 0;
+
+ IF :new.${q}cdid${q} IS NULL THEN
+ SELECT ${q}cd_seq${q}.nextval
+ INTO tmpVar
+ FROM dual;
+
+ :new.${q}cdid${q} := tmpVar;
+ END IF;
+ END;
+ });
+
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER ${q}track_insert_trg${q}
+ BEFORE INSERT ON ${q}track${q}
+ FOR EACH ROW
+ BEGIN
+ IF :new.${q}trackid${q} IS NULL THEN
+ SELECT ${q}track_seq${q}.nextval
+ INTO :new.${q}trackid${q}
+ FROM DUAL;
+ END IF;
+ END;
+ });
+}
+
# clean up our mess
-END {
- if($schema && ($dbh = $schema->storage->dbh)) {
- $dbh->do("DROP SEQUENCE artist_seq");
- $dbh->do("DROP SEQUENCE cd_seq");
- $dbh->do("DROP SEQUENCE pkid1_seq");
- $dbh->do("DROP SEQUENCE pkid2_seq");
- $dbh->do("DROP SEQUENCE nonpkid_seq");
- $dbh->do("DROP TABLE artist");
- $dbh->do("DROP TABLE sequence_test");
- $dbh->do("DROP TABLE track");
- $dbh->do("DROP TABLE cd");
- $dbh->do("DROP TABLE bindtype_test");
- }
+sub do_clean {
+
+ my $dbh = shift || return;
+
+ for my $q ('', '"') {
+ my @clean = (
+ "DROP TRIGGER ${q}track_insert_trg${q}",
+ "DROP TRIGGER ${q}cd_insert_trg${q}",
+ "DROP TRIGGER ${q}artist_insert_trg_auto${q}",
+ "DROP TRIGGER ${q}artist_insert_trg_pk${q}",
+ "DROP SEQUENCE ${q}nonpkid_seq${q}",
+ "DROP SEQUENCE ${q}pkid2_seq${q}",
+ "DROP SEQUENCE ${q}pkid1_seq${q}",
+ "DROP SEQUENCE ${q}track_seq${q}",
+ "DROP SEQUENCE ${q}cd_seq${q}",
+ "DROP SEQUENCE ${q}artist_autoinc_seq${q}",
+ "DROP SEQUENCE ${q}artist_pk_seq${q}",
+ "DROP TABLE ${q}bindtype_test${q}",
+ "DROP TABLE ${q}sequence_test${q}",
+ "DROP TABLE ${q}track${q}",
+ "DROP TABLE ${q}cd${q}",
+ "DROP TABLE ${q}artist${q}",
+ );
+ eval { $dbh -> do ($_) } for @clean;
+ }
}
+END {
+ for ($dbh, $dbh2) {
+ next unless $_;
+ local $SIG{__WARN__} = sub {};
+ do_clean($_);
+ }
+ undef $dbh;
+ undef $dbh2;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use Sub::Name;
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
+ unless ($dsn && $user && $pass);
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
+my $v = do {
+ my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
+ $si->{normalized_dbms_version}
+ or die "Unparseable Oracle server version: $si->{dbms_version}\n";
+};
+
+##########
+# the recyclebin (new for 10g) sometimes comes in the way
+my $on_connect_sql = $v >= 10 ? ["ALTER SESSION SET recyclebin = OFF"] : [];
+
+# iterate all tests on following options
+my @tryopt = (
+ { on_connect_do => $on_connect_sql },
+ { quote_char => '"', on_connect_do => $on_connect_sql },
+);
+
+# keep a database handle open for cleanup
+my $dbh;
+
+my $schema;
+for my $opt (@tryopt) {
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opt);
+
+ $dbh = $schema->storage->dbh;
+ my $q = $schema->storage->sql_maker->quote_char || '';
+
+ do_creates($dbh, $q);
+
+ _run_blob_tests($schema, $opt);
+}
+
+sub _run_blob_tests {
+SKIP: {
+TODO: {
+ my ($schema, $opt) = @_;
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = (length $binstr{'large'}) + 5;
+ note "Localizing LongReadLen to $maxloblen to avoid truncation of test data";
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+
+ if ($DBD::Oracle::VERSION eq '1.23') {
+ throws_ok { $rs->create({ id => 1, blob => $binstr{large} }) }
+ qr/broken/,
+ 'throws on blob insert with DBD::Oracle == 1.23';
+ skip 'buggy BLOB support in DBD::Oracle 1.23', 1;
+ }
+
+ my $q = $schema->storage->sql_maker->quote_char || '';
+ local $TODO = 'Something is confusing column bindtype assignment when quotes are active'
+ . ': https://rt.cpan.org/Ticket/Display.html?id=64206'
+ if $q;
+
+ # so we can disable BLOB mega-output
+ my $orig_debug = $schema->storage->debug;
+
+ my $id;
+ foreach my $size (qw( small large )) {
+ $id++;
+
+ local $schema->storage->{debug} = $size eq 'large'
+ ? 0
+ : $orig_debug
+ ;
+
+ my $str = $binstr{$size};
+ lives_ok {
+ $rs->create( { 'id' => $id, blob => "blob:$str", clob => "clob:$str" } )
+ } "inserted $size without dying";
+
+ my %kids = %{$schema->storage->_dbh->{CachedKids}};
+ my @objs = $rs->search({ blob => "blob:$str", clob => "clob:$str" })->all;
+ is_deeply (
+ $schema->storage->_dbh->{CachedKids},
+ \%kids,
+ 'multi-part LOB equality query was not cached',
+ ) if $size eq 'large';
+ is @objs, 1, 'One row found matching on both LOBs';
+ ok (try { $objs[0]->blob }||'' eq "blob:$str", 'blob inserted/retrieved correctly');
+ ok (try { $objs[0]->clob }||'' eq "clob:$str", 'clob inserted/retrieved correctly');
+
+ TODO: {
+ local $TODO = '-like comparison on blobs not tested before ora 10 (fails on 8i)'
+ if $schema->storage->_server_info->{normalized_dbms_version} < 10;
+
+ lives_ok {
+ @objs = $rs->search({ clob => { -like => 'clob:%' } })->all;
+ ok (@objs, 'rows found matching CLOB with a LIKE query');
+ } 'Query with like on blob succeeds';
+ }
+
+ ok(my $subq = $rs->search(
+ { blob => "blob:$str", clob => "clob:$str" },
+ {
+ from => \ "(SELECT * FROM ${q}bindtype_test${q} WHERE ${q}id${q} != ?) ${q}me${q}",
+ bind => [ [ undef => 12345678 ] ],
+ }
+ )->get_column('id')->as_query);
+
+ @objs = $rs->search({ id => { -in => $subq } })->all;
+ is (@objs, 1, 'One row found matching on both LOBs as a subquery');
+
+ lives_ok {
+ $rs->search({ id => $id, blob => "blob:$str", clob => "clob:$str" })
+ ->update({ blob => 'updated blob', clob => 'updated clob' });
+ } 'blob UPDATE with blobs in WHERE clause survived';
+
+ @objs = $rs->search({ blob => "updated blob", clob => 'updated clob' })->all;
+ is @objs, 1, 'found updated row';
+ ok (try { $objs[0]->blob }||'' eq "updated blob", 'blob updated/retrieved correctly');
+ ok (try { $objs[0]->clob }||'' eq "updated clob", 'clob updated/retrieved correctly');
+
+ lives_ok {
+ $rs->search({ id => $id })
+ ->update({ blob => 're-updated blob', clob => 're-updated clob' });
+ } 'blob UPDATE without blobs in WHERE clause survived';
+
+ @objs = $rs->search({ blob => 're-updated blob', clob => 're-updated clob' })->all;
+ is @objs, 1, 'found updated row';
+ ok (try { $objs[0]->blob }||'' eq 're-updated blob', 'blob updated/retrieved correctly');
+ ok (try { $objs[0]->clob }||'' eq 're-updated clob', 'clob updated/retrieved correctly');
+
+ lives_ok {
+ $rs->search({ blob => "re-updated blob", clob => "re-updated clob" })
+ ->delete;
+ } 'blob DELETE with WHERE clause survived';
+ @objs = $rs->search({ blob => "re-updated blob", clob => 're-updated clob' })->all;
+ is @objs, 0, 'row deleted successfully';
+ }
+
+ $schema->storage->debug ($orig_debug);
+}}
+
+ do_clean ($dbh);
+}
+
+done_testing;
+
+sub do_creates {
+ my ($dbh, $q) = @_;
+
+ do_clean($dbh);
+
+ $dbh->do("CREATE TABLE ${q}bindtype_test${q} (${q}id${q} integer NOT NULL PRIMARY KEY, ${q}bytea${q} integer NULL, ${q}blob${q} blob NULL, ${q}blob2${q} blob NULL, ${q}clob${q} clob NULL, ${q}clob2${q} clob NULL, ${q}a_memo${q} integer NULL)");
+}
+
+# clean up our mess
+sub do_clean {
+
+ my $dbh = shift || return;
+
+ for my $q ('', '"') {
+ my @clean = (
+ "DROP TABLE ${q}bindtype_test${q}",
+ );
+ eval { $dbh -> do ($_) } for @clean;
+ }
+}
+
+END {
+ if ($dbh) {
+ local $SIG{__WARN__} = sub {};
+ do_clean($dbh);
+ undef $dbh;
+ }
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest::RunMode;
+use DBIC::SqlMakerTest;
+
+use DBIx::Class::SQLMaker::LimitDialects;
+my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype,
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
+ unless ($dsn && $user && $pass);
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_oracle')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_oracle');
+
+use DBICTest::Schema::Artist;
+BEGIN {
+ DBICTest::Schema::Artist->add_column('parentid');
+
+ DBICTest::Schema::Artist->has_many(
+ children => 'DBICTest::Schema::Artist',
+ { 'foreign.parentid' => 'self.artistid' }
+ );
+
+ DBICTest::Schema::Artist->belongs_to(
+ parent => 'DBICTest::Schema::Artist',
+ { 'foreign.artistid' => 'self.parentid' }
+ );
+}
+
+use DBICTest;
+use DBICTest::Schema;
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+note "Oracle Version: " . $schema->storage->_server_info->{dbms_version};
+
+my $dbh = $schema->storage->dbh;
+do_creates($dbh);
+
+### test hierarchical queries
+{
+ $schema->resultset('Artist')->create ({
+ name => 'root',
+ rank => 1,
+ cds => [],
+ children => [
+ {
+ name => 'child1',
+ rank => 2,
+ children => [
+ {
+ name => 'grandchild',
+ rank => 3,
+ cds => [
+ {
+ title => "grandchilds's cd" ,
+ year => '2008',
+ tracks => [
+ {
+ position => 1,
+ title => 'Track 1 grandchild',
+ }
+ ],
+ }
+ ],
+ children => [
+ {
+ name => 'greatgrandchild',
+ rank => 3,
+ }
+ ],
+ }
+ ],
+ },
+ {
+ name => 'child2',
+ rank => 3,
+ },
+ ],
+ });
+
+ $schema->resultset('Artist')->create({
+ name => 'cycle-root',
+ children => [
+ {
+ name => 'cycle-child1',
+ children => [ { name => 'cycle-grandchild' } ],
+ },
+ {
+ name => 'cycle-child2'
+ },
+ ],
+ });
+
+ $schema->resultset('Artist')->find({ name => 'cycle-root' })
+ ->update({ parentid => { -ident => 'artistid' } });
+
+ # select the whole tree
+ {
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ )',
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
+ );
+ is_deeply (
+ [ $rs->get_column ('name')->all ],
+ [ qw/root child1 grandchild greatgrandchild child2/ ],
+ 'got artist tree',
+ );
+
+ is_same_sql_bind (
+ $rs->count_rs->as_query,
+ '(
+ SELECT COUNT( * )
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ )',
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
+ );
+
+ is( $rs->count, 5, 'Connect By count ok' );
+ }
+
+ # use order siblings by statement
+ SKIP: {
+ # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/state21b.htm#2066123
+ skip q{Oracle8i doesn't support ORDER SIBLINGS BY}, 1
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ order_siblings_by => { -desc => 'name' },
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ ORDER SIBLINGS BY name DESC
+ )',
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
+ );
+
+ is_deeply (
+ [ $rs->get_column ('name')->all ],
+ [ qw/root child2 child1 grandchild greatgrandchild/ ],
+ 'Order Siblings By ok',
+ );
+ }
+
+ # get the root node
+ {
+ my $rs = $schema->resultset('Artist')->search({ parentid => undef }, {
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ WHERE ( parentid IS NULL )
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ )',
+ [ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'] ],
+ );
+
+ is_deeply(
+ [ $rs->get_column('name')->all ],
+ [ 'root' ],
+ 'found root node',
+ );
+ }
+
+ # combine a connect by with a join
+ SKIP: {
+ # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/state21b.htm#2066123
+ skip q{Oracle8i doesn't support connect by with join}, 1
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+
+ my $rs = $schema->resultset('Artist')->search(
+ {'cds.title' => { -like => '%cd'} },
+ {
+ join => 'cds',
+ start_with => { 'me.name' => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ }
+ );
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ LEFT JOIN cd cds ON cds.artist = me.artistid
+ WHERE ( cds.title LIKE ? )
+ START WITH me.name = ?
+ CONNECT BY parentid = PRIOR artistid
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 }
+ => '%cd'],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
+ );
+
+ is_deeply(
+ [ $rs->get_column('name')->all ],
+ [ 'grandchild' ],
+ 'Connect By with a join result name ok'
+ );
+
+ is_same_sql_bind (
+ $rs->count_rs->as_query,
+ '(
+ SELECT COUNT( * )
+ FROM artist me
+ LEFT JOIN cd cds ON cds.artist = me.artistid
+ WHERE ( cds.title LIKE ? )
+ START WITH me.name = ?
+ CONNECT BY parentid = PRIOR artistid
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'cds.title', 'sqlt_size' => 100 }
+ => '%cd'],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'me.name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
+ );
+
+ is( $rs->count, 1, 'Connect By with a join; count ok' );
+ }
+
+ # combine a connect by with order_by
+ {
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ order_by => { -asc => [ 'LEVEL', 'name' ] },
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ ORDER BY LEVEL ASC, name ASC
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ ],
+ );
+
+
+ # Don't use "$rs->get_column ('name')->all" they build a query arround the $rs.
+ # If $rs has a order by, the order by is in the subquery and this doesn't work with Oracle 8i.
+ # TODO: write extra test and fix order by handling on Oracle 8i
+ is_deeply (
+ [ map { $_->[1] } $rs->cursor->all ],
+ [ qw/root child1 child2 grandchild greatgrandchild/ ],
+ 'Connect By with a order_by - result name ok (without get_column)'
+ );
+
+ SKIP: {
+ skip q{Connect By with a order_by - result name ok (with get_column), Oracle8i doesn't support order by in a subquery},1
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+ is_deeply (
+ [ $rs->get_column ('name')->all ],
+ [ qw/root child1 child2 grandchild greatgrandchild/ ],
+ 'Connect By with a order_by - result name ok (with get_column)'
+ );
+ }
+ }
+
+
+ # limit a connect by
+ SKIP: {
+ skip q{Oracle8i doesn't support order by in a subquery}, 1
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ order_by => [ { -asc => 'name' }, { -desc => 'artistid' } ],
+ rows => 2,
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM (
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ ORDER BY name ASC, artistid DESC
+ ) me
+ WHERE ROWNUM <= ?
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'], [ $ROWS => 2 ],
+ ],
+ );
+
+ is_deeply (
+ [ $rs->get_column ('name')->all ],
+ [qw/child1 child2/],
+ 'LIMIT a Connect By query - correct names'
+ );
+
+ is_same_sql_bind (
+ $rs->count_rs->as_query,
+ '(
+ SELECT COUNT( * )
+ FROM (
+ SELECT me.artistid
+ FROM (
+ SELECT me.artistid
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ ) me
+ WHERE ROWNUM <= ?
+ ) me
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ [ $ROWS => 2 ],
+ ],
+ );
+
+ is( $rs->count, 2, 'Connect By; LIMIT count ok' );
+ }
+
+ # combine a connect_by with group_by and having
+ # add some bindvals to make sure things still work
+ {
+ my $rs = $schema->resultset('Artist')->search({}, {
+ select => \[ 'COUNT(rank) + ?', [ __cbind => 3 ] ],
+ as => 'cnt',
+ start_with => { name => 'root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ group_by => \[ 'rank + ? ', [ __gbind => 1] ],
+ having => \[ 'count(rank) < ?', [ cnt => 2 ] ],
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT COUNT(rank) + ?
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY parentid = PRIOR artistid
+ GROUP BY( rank + ? ) HAVING count(rank) < ?
+ )',
+ [
+ [ { dbic_colname => '__cbind' }
+ => 3 ],
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'root'],
+ [ { dbic_colname => '__gbind' }
+ => 1 ],
+ [ { dbic_colname => 'cnt' }
+ => 2 ],
+ ],
+ );
+
+ is_deeply (
+ [ $rs->get_column ('cnt')->all ],
+ [4, 4],
+ 'Group By a Connect By query - correct values'
+ );
+ }
+
+ # select the whole cycle tree without nocylce
+ {
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'cycle-root' },
+ connect_by => { parentid => { -prior => { -ident => 'artistid' } } },
+ });
+
+ # ORA-01436: CONNECT BY loop in user data
+ throws_ok { $rs->get_column ('name')->all } qr/ORA-01436/,
+ "connect by initify loop detection without nocycle";
+ }
+
+ # select the whole cycle tree with nocylce
+ SKIP: {
+ # http://download.oracle.com/docs/cd/A87860_01/doc/server.817/a85397/expressi.htm#1023748
+ skip q{Oracle8i doesn't support connect by nocycle}, 1
+ if $schema->storage->_server_info->{normalized_dbms_version} < 9;
+
+ my $rs = $schema->resultset('Artist')->search({}, {
+ start_with => { name => 'cycle-root' },
+ '+select' => \ 'CONNECT_BY_ISCYCLE',
+ '+as' => [ 'connector' ],
+ connect_by_nocycle => { parentid => { -prior => { -ident => 'artistid' } } },
+ });
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.artistid, me.name, me.rank, me.charfield, me.parentid, CONNECT_BY_ISCYCLE
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY NOCYCLE parentid = PRIOR artistid
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'cycle-root'],
+ ],
+ );
+ is_deeply (
+ [ $rs->get_column ('name')->all ],
+ [ qw/cycle-root cycle-child1 cycle-grandchild cycle-child2/ ],
+ 'got artist tree with nocycle (name)',
+ );
+ is_deeply (
+ [ $rs->get_column ('connector')->all ],
+ [ qw/1 0 0 0/ ],
+ 'got artist tree with nocycle (CONNECT_BY_ISCYCLE)',
+ );
+
+ is_same_sql_bind (
+ $rs->count_rs->as_query,
+ '(
+ SELECT COUNT( * )
+ FROM artist me
+ START WITH name = ?
+ CONNECT BY NOCYCLE parentid = PRIOR artistid
+ )',
+ [
+ [ { 'sqlt_datatype' => 'varchar', 'dbic_colname' => 'name', 'sqlt_size' => 100 }
+ => 'cycle-root'],
+ ],
+ );
+
+ is( $rs->count, 4, 'Connect By Nocycle count ok' );
+ }
+}
+
+done_testing;
+
+sub do_creates {
+ my $dbh = shift;
+
+ eval {
+ $dbh->do("DROP SEQUENCE artist_autoinc_seq");
+ $dbh->do("DROP SEQUENCE artist_pk_seq");
+ $dbh->do("DROP SEQUENCE cd_seq");
+ $dbh->do("DROP SEQUENCE track_seq");
+ $dbh->do("DROP TABLE artist");
+ $dbh->do("DROP TABLE track");
+ $dbh->do("DROP TABLE cd");
+ };
+
+ $dbh->do("CREATE SEQUENCE artist_pk_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE cd_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+ $dbh->do("CREATE SEQUENCE track_seq START WITH 1 MAXVALUE 999999 MINVALUE 0");
+
+ $dbh->do("CREATE TABLE artist (artistid NUMBER(12), parentid NUMBER(12), name VARCHAR(255), autoinc_col NUMBER(12), rank NUMBER(38), charfield VARCHAR2(10))");
+ $dbh->do("ALTER TABLE artist ADD (CONSTRAINT artist_pk PRIMARY KEY (artistid))");
+
+ $dbh->do("CREATE TABLE cd (cdid NUMBER(12), artist NUMBER(12), title VARCHAR(255), year VARCHAR(4), genreid NUMBER(12), single_track NUMBER(12))");
+ $dbh->do("ALTER TABLE cd ADD (CONSTRAINT cd_pk PRIMARY KEY (cdid))");
+
+ $dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12) REFERENCES cd(cdid) DEFERRABLE, position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at DATE, small_dt DATE)");
+ $dbh->do("ALTER TABLE track ADD (CONSTRAINT track_pk PRIMARY KEY (trackid))");
+
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER artist_insert_trg_pk
+ BEFORE INSERT ON artist
+ FOR EACH ROW
+ BEGIN
+ IF :new.artistid IS NULL THEN
+ SELECT artist_pk_seq.nextval
+ INTO :new.artistid
+ FROM DUAL;
+ END IF;
+ END;
+ });
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER cd_insert_trg
+ BEFORE INSERT OR UPDATE ON cd
+ FOR EACH ROW
+
+ DECLARE
+ tmpVar NUMBER;
+
+ BEGIN
+ tmpVar := 0;
+
+ IF :new.cdid IS NULL THEN
+ SELECT cd_seq.nextval
+ INTO tmpVar
+ FROM dual;
+
+ :new.cdid := tmpVar;
+ END IF;
+ END;
+ });
+ $dbh->do(qq{
+ CREATE OR REPLACE TRIGGER track_insert_trg
+ BEFORE INSERT ON track
+ FOR EACH ROW
+ BEGIN
+ IF :new.trackid IS NULL THEN
+ SELECT track_seq.nextval
+ INTO :new.trackid
+ FROM DUAL;
+ END IF;
+ END;
+ });
+}
+
+# clean up our mess
+END {
+ if ($schema and my $dbh = $schema->storage->dbh) {
+ eval { $dbh->do($_) } for (
+ 'DROP SEQUENCE artist_pk_seq',
+ 'DROP SEQUENCE cd_seq',
+ 'DROP SEQUENCE track_seq',
+ 'DROP TABLE artist',
+ 'DROP TABLE track',
+ 'DROP TABLE cd',
+ );
+ };
+ undef $schema;
+}
use Test::More;
use Test::Exception;
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_${_}" } qw/DSN USER PASS/};
#warn "$dsn $user $pass";
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+my $name_sep = $schema->storage->_dbh_get_info('SQL_QUALIFIER_NAME_SEPARATOR');
+
my $dbh = $schema->storage->dbh;
+# test RNO and name_sep detection
+
+is $schema->storage->sql_maker->name_sep, $name_sep,
+ 'name_sep detection';
+
+my $have_rno = try {
+ $dbh->selectrow_array(
+"SELECT row_number() OVER (ORDER BY 1) FROM sysibm${name_sep}sysdummy1"
+ );
+ 1;
+};
+
+is $schema->storage->sql_maker->limit_dialect,
+ ($have_rno ? 'RowNumberOver' : 'FetchFirst'),
+ 'limit_dialect detection';
+
eval { $dbh->do("DROP TABLE artist") };
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
is( $lim->count, 2, 'ROWS+OFFSET count ok' );
is( $lim->all, 2, 'Number of ->all objects matches count' );
+# Limit with select-lock
+TODO: {
+ local $TODO = "Seems we can't SELECT ... FOR ... on subqueries";
+ lives_ok {
+ $schema->txn_do (sub {
+ isa_ok (
+ $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}),
+ 'DBICTest::Schema::Artist',
+ );
+ });
+ } 'Limited FOR UPDATE select works';
+}
+
# test iterator
$lim->reset;
is( $lim->next->artistid, 101, "iterator->next ok" );
is( $lim->next->artistid, 102, "iterator->next ok" );
is( $lim->next, undef, "next past end of resultset ok" );
+# test FetchFirst limit dialect syntax
+{
+ local $schema->storage->sql_maker->{limit_dialect} = 'FetchFirst';
+
+ my $lim = $ars->search({}, {
+ rows => 3,
+ offset => 2,
+ order_by => 'artistid',
+ });
+
+ is $lim->count, 3, 'fetch first limit count ok';
+
+ is $lim->all, 3, 'fetch first number of ->all objects matches count';
+
+ is $lim->next->artistid, 3, 'iterator->next ok';
+ is $lim->next->artistid, 66, 'iterator->next ok';
+ is $lim->next->artistid, 101, 'iterator->next ok';
+ is $lim->next, undef, 'iterator->next past end of resultset ok';
+}
my $test_type_info = {
'artistid' => {
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
use strict;
-use warnings;
+use warnings;
use Test::More;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_db2_400')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_db2_400');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_DB2_400_${_}" } qw/DSN USER PASS/};
#warn "$dsn $user $pass";
'charfield' => {
'data_type' => 'CHAR',
'is_nullable' => 1,
- 'size' => 10
+ 'size' => 10
},
};
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
use Test::More;
use Test::Exception;
+use Try::Tiny;
+use DBIx::Class::SQLMaker::LimitDialects;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_odbc')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_odbc');
+
+my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype;
+my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
+{
+ my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version};
+ ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') );
+}
+
DBICTest::Schema->load_classes('ArtistGUID');
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
{
- my $schema2 = $schema->connect ($schema->storage->connect_info);
+ my $schema2 = $schema->connect (@{$schema->storage->connect_info});
ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected');
}
+$schema->storage->_dbh->disconnect;
-$schema->storage->dbh_do (sub {
- my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE artist") };
- $dbh->do(<<'SQL');
-CREATE TABLE artist (
- artistid INT IDENTITY NOT NULL,
- name VARCHAR(100),
- rank INT NOT NULL DEFAULT '13',
- charfield CHAR(10) NULL,
- primary key(artistid)
-)
-SQL
-});
-
-my %seen_id;
-
-my @opts = (
- { on_connect_call => 'use_dynamic_cursors' },
- {},
+lives_ok {
+ $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
+} '_ping works';
+
+my %opts = (
+ use_mars =>
+ { opts => { on_connect_call => 'use_mars' } },
+ use_dynamic_cursors =>
+ { opts => { on_connect_call => 'use_dynamic_cursors' },
+ required => $schema->storage->_using_freetds ? 0 : 1,
+ },
+ use_server_cursors =>
+ { opts => { on_connect_call => 'use_server_cursors' } },
+ plain =>
+ { opts => {}, required => 1 },
);
-my $new;
-# test Auto-PK with different options
-for my $opts (@opts) {
+for my $opts_name (keys %opts) {
SKIP: {
+ my $opts = $opts{$opts_name}{opts};
$schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
- eval {
+ try {
$schema->storage->ensure_connected
- };
- if ($@ =~ /dynamic cursors/) {
- skip
-'Dynamic Cursors not functional, tds_version 8.0 or greater required if using'.
-' FreeTDS', 1;
}
+ catch {
+ if ($opts{$opts_name}{required}) {
+ BAIL_OUT "on_connect_call option '$opts_name' is not functional: $_";
+ }
+ else {
+ skip
+ "on_connect_call option '$opts_name' not functional in this configuration: $_",
+ 1
+ ;
+ }
+ };
- $schema->resultset('Artist')->search({ name => 'foo' })->delete;
-
- $new = $schema->resultset('Artist')->create({ name => 'foo' });
-
- ok($new->artistid > 0, "Auto-PK worked");
- }
-}
-
-$seen_id{$new->artistid}++;
-
-# test LIMIT support
-for (1..6) {
- $new = $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
- is ( $seen_id{$new->artistid}, undef, "id for Artist $_ is unique" );
- $seen_id{$new->artistid}++;
-}
-
-my $it = $schema->resultset('Artist')->search( {}, {
- rows => 3,
- order_by => 'artistid',
-});
-
-is( $it->count, 3, "LIMIT count ok" );
-is( $it->next->name, "foo", "iterator->next ok" );
-$it->next;
-is( $it->next->name, "Artist 2", "iterator->next ok" );
-is( $it->next, undef, "next past end of resultset ok" );
-
-# test GUID columns
-
-$schema->storage->dbh_do (sub {
- my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE artist") };
- $dbh->do(<<'SQL');
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist") };
+ $dbh->do(<<'SQL');
CREATE TABLE artist (
- artistid UNIQUEIDENTIFIER NOT NULL,
+ artistid INT IDENTITY NOT NULL,
name VARCHAR(100),
rank INT NOT NULL DEFAULT '13',
charfield CHAR(10) NULL,
- a_guid UNIQUEIDENTIFIER,
primary key(artistid)
)
SQL
-});
+ });
-# start disconnected to make sure insert works on an un-reblessed storage
-$schema = DBICTest::Schema->connect($dsn, $user, $pass);
+# test Auto-PK
+ $schema->resultset('Artist')->search({ name => 'foo' })->delete;
-my $row;
-lives_ok {
- $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
-} 'created a row with a GUID';
+ my $new = $schema->resultset('Artist')->create({ name => 'foo' });
-ok(
- eval { $row->artistid },
- 'row has GUID PK col populated',
-);
-diag $@ if $@;
+ ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name");
-ok(
- eval { $row->a_guid },
- 'row has a GUID col with auto_nextval populated',
-);
-diag $@ if $@;
+# Test multiple active statements
+ SKIP: {
+ skip 'not a multiple active statements configuration', 1
+ if $opts_name eq 'plain';
-my $row_from_db = $schema->resultset('ArtistGUID')
- ->search({ name => 'mtfnpy' })->first;
+ $schema->storage->ensure_connected;
-is $row_from_db->artistid, $row->artistid,
- 'PK GUID round trip';
+ lives_ok {
-is $row_from_db->a_guid, $row->a_guid,
- 'NON-PK GUID round trip';
+ no warnings 'redefine';
+ local *DBI::connect = sub { die "NO RECONNECTS!!!" };
-# test MONEY type
-$schema->storage->dbh_do (sub {
- my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE money_test") };
- $dbh->do(<<'SQL');
-CREATE TABLE money_test (
- id INT IDENTITY PRIMARY KEY,
- amount MONEY NULL
-)
-SQL
-});
+ my $artist_rs = $schema->resultset('Artist');
-my $rs = $schema->resultset('Money');
+ $artist_rs->delete;
-lives_ok {
- $row = $rs->create({ amount => 100 });
-} 'inserted a money value';
+ $artist_rs->create({ name => "Artist$_" }) for (1..3);
-cmp_ok $rs->find($row->id)->amount, '==', 100, 'money value round-trip';
+ my $forward = $artist_rs->search({},
+ { order_by => { -asc => 'artistid' } });
+ my $backward = $artist_rs->search({},
+ { order_by => { -desc => 'artistid' } });
-lives_ok {
- $row->update({ amount => 200 });
-} 'updated a money value';
+ my @map = (
+ [qw/Artist1 Artist3/], [qw/Artist2 Artist2/], [qw/Artist3 Artist1/]
+ );
+ my @result;
-cmp_ok $rs->find($row->id)->amount, '==', 200,
- 'updated money value round-trip';
+ while (my $forward_row = $forward->next) {
+ my $backward_row = $backward->next;
+ push @result, [$forward_row->name, $backward_row->name];
+ }
-lives_ok {
- $row->update({ amount => undef });
-} 'updated a money value to NULL';
+ is_deeply \@result, \@map, "multiple active statements in $opts_name";
+
+ $artist_rs->delete;
-is $rs->find($row->id)->amount, undef,'updated money value to NULL round-trip';
+ is($artist_rs->count, 0, '$dbh still viable');
+ } "Multiple active statements survive $opts_name";
+ }
+
+# Test populate
-$schema->storage->dbh_do (sub {
- my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE owners") };
- eval { $dbh->do("DROP TABLE books") };
- $dbh->do(<<'SQL');
+ {
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE owners") };
+ eval { $dbh->do("DROP TABLE books") };
+ $dbh->do(<<'SQL');
CREATE TABLE books (
id INT IDENTITY (1, 1) NOT NULL,
source VARCHAR(100),
name VARCHAR(100),
)
SQL
+ });
+
+ lives_ok ( sub {
+ # start a new connection, make sure rebless works
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
+ $schema->populate ('Owners', [
+ [qw/id name /],
+ [qw/1 wiggle/],
+ [qw/2 woggle/],
+ [qw/3 boggle/],
+ [qw/4 fRIOUX/],
+ [qw/5 fRUE/],
+ [qw/6 fREW/],
+ [qw/7 fROOH/],
+ [qw/8 fISMBoC/],
+ [qw/9 station/],
+ [qw/10 mirror/],
+ [qw/11 dimly/],
+ [qw/12 face_to_face/],
+ [qw/13 icarus/],
+ [qw/14 dream/],
+ [qw/15 dyrstyggyr/],
+ ]);
+ }, 'populate with PKs supplied ok' );
+
+
+ lives_ok (sub {
+ # start a new connection, make sure rebless works
+ # test an insert with a supplied identity, followed by one without
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
+ for (2, 1) {
+ my $id = $_ * 20 ;
+ $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" });
+ $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) });
+ }
+ }, 'create with/without PKs ok' );
+
+ is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' );
+
+ lives_ok ( sub {
+ # start a new connection, make sure rebless works
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
+ $schema->populate ('BooksInLibrary', [
+ [qw/source owner title /],
+ [qw/Library 1 secrets0/],
+ [qw/Library 1 secrets1/],
+ [qw/Eatery 1 secrets2/],
+ [qw/Library 2 secrets3/],
+ [qw/Library 3 secrets4/],
+ [qw/Eatery 3 secrets5/],
+ [qw/Library 4 secrets6/],
+ [qw/Library 5 secrets7/],
+ [qw/Eatery 5 secrets8/],
+ [qw/Library 6 secrets9/],
+ [qw/Library 7 secrets10/],
+ [qw/Eatery 7 secrets11/],
+ [qw/Library 8 secrets12/],
+ ]);
+ }, 'populate without PKs supplied ok' );
+ }
-});
-
-lives_ok ( sub {
- # start a new connection, make sure rebless works
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
- $schema->populate ('Owners', [
- [qw/id name /],
- [qw/1 wiggle/],
- [qw/2 woggle/],
- [qw/3 boggle/],
- [qw/4 fRIOUX/],
- [qw/5 fRUE/],
- [qw/6 fREW/],
- [qw/7 fROOH/],
- [qw/8 fISMBoC/],
- [qw/9 station/],
- [qw/10 mirror/],
- [qw/11 dimly/],
- [qw/12 face_to_face/],
- [qw/13 icarus/],
- [qw/14 dream/],
- [qw/15 dyrstyggyr/],
- ]);
-}, 'populate with PKs supplied ok' );
-
-
-lives_ok (sub {
- # start a new connection, make sure rebless works
- # test an insert with a supplied identity, followed by one without
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
- for (2, 1) {
- my $id = $_ * 20 ;
- $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" });
- $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) });
- }
-}, 'create with/without PKs ok' );
-
-is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' );
-
-lives_ok ( sub {
- # start a new connection, make sure rebless works
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
- $schema->populate ('BooksInLibrary', [
- [qw/source owner title /],
- [qw/Library 1 secrets0/],
- [qw/Library 1 secrets1/],
- [qw/Eatery 1 secrets2/],
- [qw/Library 2 secrets3/],
- [qw/Library 3 secrets4/],
- [qw/Eatery 3 secrets5/],
- [qw/Library 4 secrets6/],
- [qw/Library 5 secrets7/],
- [qw/Eatery 5 secrets8/],
- [qw/Library 6 secrets9/],
- [qw/Library 7 secrets10/],
- [qw/Eatery 7 secrets11/],
- [qw/Library 8 secrets12/],
- ]);
-}, 'populate without PKs supplied ok' );
-
-# plain ordered subqueries throw
-throws_ok (sub {
- $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query
-}, qr/ordered subselect encountered/, 'Ordered Subselect detection throws ok');
-
-# make sure ordered subselects *somewhat* work
-{
- my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
+# test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible)
+ for my $dialect (
+ 'Top',
+ ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9
+ ? ('RowNumberOver')
+ : ()
+ ,
+ ) {
+ for my $quoted (0, 1) {
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ limit_dialect => $dialect,
+ %$opts,
+ $quoted
+ ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' )
+ : ()
+ ,
+ });
+
+ my $test_type = "Dialect:$dialect Quoted:$quoted";
+
+ # basic limit support
+ TODO: {
+ my $art_rs = $schema->resultset ('Artist');
+ $art_rs->delete;
+ $art_rs->create({ name => 'Artist ' . $_ }) for (1..6);
+
+ my $it = $schema->resultset('Artist')->search( {}, {
+ rows => 4,
+ offset => 3,
+ order_by => 'artistid',
+ });
+
+ is( $it->count, 3, "$test_type: LIMIT count ok" );
+
+ local $TODO = "Top-limit does not work when your limit ends up past the resultset"
+ if $dialect eq 'Top';
+
+ is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" );
+ $it->next;
+ is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" );
+ is( $it->next, undef, "$test_type: next past end of resultset ok" );
+ }
+
+ # plain ordered subqueries throw
+ throws_ok (sub {
+ $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query
+ }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok");
+
+ # make sure ordered subselects *somewhat* work
+ {
+ my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
+ my $sealed_owners = $owners->as_subselect_rs;
+
+ is_deeply (
+ [ map { $_->name } ($sealed_owners->all) ],
+ [ map { $_->name } ($owners->all) ],
+ "$test_type: Sort preserved from within a subquery",
+ );
+ }
+
+ # still even with lost order of IN, we should be getting correct
+ # sets
+ {
+ my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
+ my $corelated_owners = $owners->result_source->resultset->search (
+ {
+ id => { -in => $owners->get_column('id')->as_query },
+ },
+ {
+ order_by => 'name' #reorder because of what is shown above
+ },
+ );
+
+ is (
+ join ("\x00", map { $_->name } ($corelated_owners->all) ),
+ join ("\x00", map { $_->name } ($owners->all) ),
+ "$test_type: With an outer order_by, everything still matches",
+ );
+ }
+
+ # make sure right-join-side single-prefetch ordering limit works
+ {
+ my $rs = $schema->resultset ('BooksInLibrary')->search (
+ {
+ 'owner.name' => { '!=', 'woggle' },
+ },
+ {
+ prefetch => 'owner',
+ order_by => 'owner.name',
+ }
+ );
+ # this is the order in which they should come from the above query
+ my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/;
+
+ is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset");
+ is_deeply (
+ [map { $_->owner->name } ($rs->all) ],
+ \@owner_names,
+ "$test_type: Prefetched rows were properly ordered"
+ );
+
+ my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1});
+ is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset");
+ is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset");
+
+ my $queries;
+ my $orig_debug = $schema->storage->debug;
+ $schema->storage->debugcb(sub { $queries++; });
+ $schema->storage->debug(1);
+
+ is_deeply (
+ [map { $_->owner->name } ($limited_rs->all) ],
+ [@owner_names[2 .. 7]],
+ "$test_type: Prefetch-limited rows were properly ordered"
+ );
+ is ($queries, 1, "$test_type: Only one query with prefetch");
+
+ $schema->storage->debugcb(undef);
+ $schema->storage->debug($orig_debug);
+
+ is_deeply (
+ [map { $_->name } ($limited_rs->search_related ('owner')->all) ],
+ [@owner_names[2 .. 7]],
+ "$test_type: Rows are still properly ordered after search_related",
+ );
+ }
+
+ # try a ->has_many direction with duplicates
+ my $owners = $schema->resultset ('Owners')->search (
+ {
+ 'books.id' => { '!=', undef },
+ 'me.name' => { '!=', 'somebogusstring' },
+ },
+ {
+ prefetch => 'books',
+ order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation
+ group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by
+ rows => 3, # 8 results total
+ unsafe_subselect_ok => 1,
+ },
+ );
+
+ my ($sql, @bind) = @${$owners->page(3)->as_query};
+ # not testing the SQL as it is quite different between top/rno
+ is_same_bind (
+ \@bind,
+ [
+ [ { dbic_colname => 'test' }
+ => 'xxx' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' }
+ => 'somebogusstring' ],
+
+ ($dialect eq 'Top'
+ ? [ { dbic_colname => 'test' } => 'xxx' ] # the extra re-order bind
+ : ([ $OFFSET => 7 ], [ $TOTAL => 9 ]) # parameterised RNO
+ ),
+
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' }
+ => 'somebogusstring' ],
+ [ { dbic_colname => 'test' }
+ => 'xxx' ],
+ ],
+ );
+
+ is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows");
+ is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count");
+
+ is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count");
+ TODO: {
+ local $TODO = "Top-limit does not work when your limit ends up past the resultset"
+ if $dialect eq 'Top';
+ is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows");
+ is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs");
+ }
+
+
+ # try a ->belongs_to direction (no select collapse, group_by should work)
+ my $books = $schema->resultset ('BooksInLibrary')->search (
+ {
+ 'owner.name' => [qw/wiggle woggle/],
+ },
+ {
+ distinct => 1,
+ having => \['1 = ?', [ test => 1 ] ], #test having propagation
+ prefetch => 'owner',
+ rows => 2, # 3 results total
+ order_by => [{ -desc => 'me.owner' }, 'me.id'],
+ unsafe_subselect_ok => 1,
+ },
+ );
+
+ ($sql, @bind) = @${$books->page(3)->as_query};
+ # not testing the SQL as it is quite different between top/rno
+ is_same_bind (
+ \@bind,
+ [
+ # inner
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'wiggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'woggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
+ [ { dbic_colname => 'test' }
+ => '1' ],
+
+ # rno(?)
+ $dialect ne 'Top' ? ( [ $OFFSET => 5 ], [ $TOTAL => 6 ] ) : (),
+ # outer
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'wiggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
+ => 'woggle' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
+ ],
+ );
+
+ is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows");
+ is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count");
+
+ is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count");
+ TODO: {
+ local $TODO = "Top-limit does not work when your limit ends up past the resultset"
+ if $dialect eq 'Top';
+ is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows");
+ is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs");
+ }
+ }
+ }
- my $al = $owners->current_source_alias;
- my $sealed_owners = $owners->result_source->resultset->search (
- {},
+
+# test GUID columns
{
- alias => $al,
- from => [{
- -alias => $al,
- -source_handle => $owners->result_source->handle,
- $al => $owners->as_query,
- }],
- },
- );
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<'SQL');
+CREATE TABLE artist_guid (
+ artistid UNIQUEIDENTIFIER NOT NULL,
+ name VARCHAR(100),
+ rank INT NOT NULL DEFAULT '13',
+ charfield CHAR(10) NULL,
+ a_guid UNIQUEIDENTIFIER,
+ primary key(artistid)
+)
+SQL
+ });
- is_deeply (
- [ map { $_->name } ($sealed_owners->all) ],
- [ map { $_->name } ($owners->all) ],
- 'Sort preserved from within a subquery',
- );
-}
+ # start disconnected to make sure insert works on an un-reblessed storage
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
-TODO: {
- local $TODO = "This porbably will never work, but it isn't critical either afaik";
+ my $row;
+ lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+ } 'created a row with a GUID';
- my $book_owner_ids = $schema->resultset ('BooksInLibrary')
- ->search ({}, { join => 'owner', distinct => 1, order_by => 'owner.name', unsafe_subselect_ok => 1 })
- ->get_column ('owner');
+ ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+ );
+ diag $@ if $@;
- my $book_owners = $schema->resultset ('Owners')->search ({
- id => { -in => $book_owner_ids->as_query }
- });
+ ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+ );
+ diag $@ if $@;
- is_deeply (
- [ map { $_->id } ($book_owners->all) ],
- [ $book_owner_ids->all ],
- 'Sort is preserved across IN subqueries',
- );
-}
+ my $row_from_db = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first;
-# This is known not to work - thus the negative test
-{
- my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
- my $corelated_owners = $owners->result_source->resultset->search (
- {
- id => { -in => $owners->get_column('id')->as_query },
- },
- {
- order_by => 'name' #reorder because of what is shown above
- },
- );
-
- cmp_ok (
- join ("\x00", map { $_->name } ($corelated_owners->all) ),
- 'ne',
- join ("\x00", map { $_->name } ($owners->all) ),
- 'Sadly sort not preserved from within a corelated subquery',
- );
-
- cmp_ok (
- join ("\x00", sort map { $_->name } ($corelated_owners->all) ),
- 'ne',
- join ("\x00", sort map { $_->name } ($owners->all) ),
- 'Which in fact gives a completely wrong dataset',
- );
-}
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip';
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip';
+ }
-# make sure right-join-side single-prefetch ordering limit works
-{
- my $rs = $schema->resultset ('BooksInLibrary')->search (
- {
- 'owner.name' => { '!=', 'woggle' },
- },
+# test MONEY type
{
- prefetch => 'owner',
- order_by => 'owner.name',
- }
- );
- # this is the order in which they should come from the above query
- my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/;
-
- is ($rs->all, 8, 'Correct amount of objects from right-sorted joined resultset');
- is_deeply (
- [map { $_->owner->name } ($rs->all) ],
- \@owner_names,
- 'Rows were properly ordered'
- );
-
- my $limited_rs = $rs->search ({}, {rows => 7, offset => 2, unsafe_subselect_ok => 1});
- is ($limited_rs->count, 6, 'Correct count of limited right-sorted joined resultset');
- is ($limited_rs->count_rs->next, 6, 'Correct count_rs of limited right-sorted joined resultset');
-
- my $queries;
- $schema->storage->debugcb(sub { $queries++; });
- $schema->storage->debug(1);
-
- is_deeply (
- [map { $_->owner->name } ($limited_rs->all) ],
- [@owner_names[2 .. 7]],
- 'Limited rows were properly ordered'
- );
- is ($queries, 1, 'Only one query with prefetch');
-
- $schema->storage->debugcb(undef);
- $schema->storage->debug(0);
-
-
- is_deeply (
- [map { $_->name } ($limited_rs->search_related ('owner')->all) ],
- [@owner_names[2 .. 7]],
- 'Rows are still properly ordered after search_related'
- );
-}
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE money_test") };
+ $dbh->do(<<'SQL');
+CREATE TABLE money_test (
+ id INT IDENTITY PRIMARY KEY,
+ amount MONEY NULL
+)
+SQL
+ });
+ TODO: {
+ my $freetds_and_dynamic_cursors = 1
+ if $opts_name eq 'use_dynamic_cursors' &&
+ $schema->storage->_using_freetds;
-#
-# try a prefetch on tables with identically named columns
-#
+ local $TODO =
+'these tests fail on freetds with dynamic cursors for some reason'
+ if $freetds_and_dynamic_cursors;
+ local $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1
+ if $freetds_and_dynamic_cursors;
-# set quote char - make sure things work while quoted
-$schema->storage->_sql_maker->{quote_char} = [qw/[ ]/];
-$schema->storage->_sql_maker->{name_sep} = '.';
+ my $rs = $schema->resultset('Money');
+ my $row;
-{
- # try a ->has_many direction
- my $owners = $schema->resultset ('Owners')->search (
- {
- 'books.id' => { '!=', undef },
- 'me.name' => { '!=', 'somebogusstring' },
- },
- {
- prefetch => 'books',
- order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation
- rows => 3, # 8 results total
- unsafe_subselect_ok => 1,
- },
- );
+ lives_ok {
+ $row = $rs->create({ amount => 100 });
+ } 'inserted a money value';
- my ($sql, @bind) = @${$owners->page(3)->as_query};
- is_deeply (
- \@bind,
- [ ([ 'me.name' => 'somebogusstring' ], [ test => 'xxx' ]) x 2 ], # double because of the prefetch subq
- );
+ cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100,
+ 'money value round-trip');
- is ($owners->page(1)->all, 3, 'has_many prefetch returns correct number of rows');
- is ($owners->page(1)->count, 3, 'has-many prefetch returns correct count');
+ lives_ok {
+ $row->update({ amount => 200 });
+ } 'updated a money value';
- is ($owners->page(3)->all, 2, 'has_many prefetch returns correct number of rows');
- is ($owners->page(3)->count, 2, 'has-many prefetch returns correct count');
- is ($owners->page(3)->count_rs->next, 2, 'has-many prefetch returns correct count_rs');
+ cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200,
+ 'updated money value round-trip');
+ lives_ok {
+ $row->update({ amount => undef });
+ } 'updated a money value to NULL';
- # try a ->belongs_to direction (no select collapse, group_by should work)
- my $books = $schema->resultset ('BooksInLibrary')->search (
- {
- 'owner.name' => [qw/wiggle woggle/],
- },
- {
- distinct => 1,
- having => \['1 = ?', [ test => 1 ] ], #test having propagation
- prefetch => 'owner',
- rows => 2, # 3 results total
- order_by => { -desc => 'me.owner' },
- unsafe_subselect_ok => 1,
- },
- );
-
- ($sql, @bind) = @${$books->page(3)->as_query};
- is_deeply (
- \@bind,
- [
- # inner
- [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ], [ test => '1' ],
- # outer
- [ 'owner.name' => 'wiggle' ], [ 'owner.name' => 'woggle' ], [ source => 'Library' ],
- ],
- );
-
- is ($books->page(1)->all, 2, 'Prefetched grouped search returns correct number of rows');
- is ($books->page(1)->count, 2, 'Prefetched grouped search returns correct count');
-
- is ($books->page(2)->all, 1, 'Prefetched grouped search returns correct number of rows');
- is ($books->page(2)->count, 1, 'Prefetched grouped search returns correct count');
- is ($books->page(2)->count_rs->next, 1, 'Prefetched grouped search returns correct count_rs');
+ is try { $rs->find($row->id)->amount }, undef,
+ 'updated money value to NULL round-trip';
+ }
+ }
+ }
}
done_testing;
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
- for qw/artist money_test books owners/;
+ for qw/artist artist_guid money_test books owners/;
}
+ undef $schema;
}
# vim:sw=2 sts=2
use strict;
-use warnings;
+use warnings;
no warnings 'uninitialized';
use Test::More;
use Test::Exception;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
-
-my $TESTS = 66 + 2;
-
if (not ($dsn && $user)) {
- plan skip_all =>
- 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' .
- "\nWarning: This test drops and creates the tables " .
- "'artist', 'money_test' and 'bindtype_test'";
-} else {
- plan tests => $TESTS*2 + 1;
-}
+ plan skip_all => join ' ',
+ 'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test.',
+ 'Warning: This test drops and creates the tables:',
+ "'artist', 'money_test' and 'bindtype_test'",
+ ;
+};
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase');
my @storage_types = (
'DBI::Sybase::ASE',
if ($storage_idx == 0 &&
$schema->storage->isa('DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars')) {
-# no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS)
- my $tb = Test::More->builder;
- $tb->skip('no placeholders') for 1..$TESTS;
+ # no placeholders in this version of Sybase or DBD::Sybase (or using FreeTDS)
+ skip "Skipping entire test for $storage_type - no placeholder support", 1;
next;
}
# test primary key handling
my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+ like $new->artistid, qr/^\d+\z/, 'Auto-PK returned a number';
ok($new->artistid > 0, "Auto-PK worked");
$seen_id{$new->artistid}++;
# mostly stolen from the blob stuff Nniuq wrote for t/73oracle.t
SKIP: {
skip 'TEXT/IMAGE support does not work with FreeTDS', 22
- if $schema->storage->using_freetds;
+ if $schema->storage->_using_freetds;
my $dbh = $schema->storage->_dbh;
{
eval { $dbh->do('DROP TABLE bindtype_test') };
$dbh->do(qq[
- CREATE TABLE bindtype_test
+ CREATE TABLE bindtype_test
(
- id INT IDENTITY PRIMARY KEY,
- bytea IMAGE NULL,
- blob IMAGE NULL,
- clob TEXT NULL
+ id INT IDENTITY PRIMARY KEY,
+ bytea IMAGE NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo IMAGE NULL
)
],{ RaiseError => 1, PrintError => 0 });
}
$binstr{'large'} = $binstr{'small'} x 1024;
my $maxloblen = length $binstr{'large'};
-
- if (not $schema->storage->using_freetds) {
+
+ if (not $schema->storage->_using_freetds) {
$dbh->{'LongReadLen'} = $maxloblen * 2;
} else {
$dbh->do("set textsize ".($maxloblen * 2));
lives_ok {
$rs->populate([
{
- bytea => 1,
blob => $binstr{large},
clob => $new_str,
},
{
- bytea => 1,
blob => $binstr{large},
clob => $new_str,
},
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
{
id => 2,
bytea => 1,
blob => $binstr{large},
clob => $new_str,
+ a_memo => 2,
},
]);
} 'insert_bulk with blobs and explicit identity does NOT die';
$row = $rs->create({ amount => 100 });
} 'inserted a money value';
- is eval { $rs->find($row->id)->amount }, 100, 'money value round-trip';
+ cmp_ok eval { $rs->find($row->id)->amount }, '==', 100,
+ 'money value round-trip';
lives_ok {
$row->update({ amount => 200 });
} 'updated a money value';
- is eval { $rs->find($row->id)->amount },
- 200, 'updated money value round-trip';
+ cmp_ok eval { $rs->find($row->id)->amount }, '==', 200,
+ 'updated money value round-trip';
lives_ok {
$row->update({ amount => undef });
} 'updated a money value to NULL';
- my $null_amount = eval { $rs->find($row->id)->amount };
- ok(
- (($null_amount == undef) && (not $@)),
- 'updated money value to NULL round-trip'
- );
- diag $@ if $@;
+ lives_and {
+ my $null_amount = $rs->find($row->id)->amount;
+ is $null_amount, undef;
+ } 'updated money value to NULL round-trip';
# Test computed columns and timestamps
$schema->storage->dbh_do (sub {
id INT IDENTITY PRIMARY KEY,
a_computed_column AS getdate(),
a_timestamp timestamp,
- charfield VARCHAR(20) DEFAULT 'foo'
+ charfield VARCHAR(20) DEFAULT 'foo'
)
SQL
});
is $ping_count, 0, 'no pings';
+# if tests passed and did so under a non-C lang - let's rerun the test
+if (Test::Builder->new->is_passing and $ENV{LANG} and $ENV{LANG} ne 'C') {
+ my $oldlang = $ENV{LANG};
+ local $ENV{LANG} = 'C';
+
+ pass ("Your lang is set to $oldlang - retesting with C");
+
+ local $ENV{PATH};
+ my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__);
+
+ # this is cheating, and may even hang here and there (testing on windows passed fine)
+ # will be replaced with Test::SubExec::Noninteractive in due course
+ require IPC::Open2;
+ IPC::Open2::open2(my $out, undef, @cmd);
+ while (my $ln = <$out>) {
+ print " $ln";
+ }
+
+ wait;
+ ok (! $?, "Wstat $? from: @cmd");
+}
+
+done_testing;
+
# clean up our mess
END {
if (my $dbh = eval { $schema->storage->_dbh }) {
eval { $dbh->do("DROP TABLE $_") }
for qw/artist bindtype_test money_test computed_column_test/;
}
+
+ undef $schema;
}
use Test::More;
use Test::Exception;
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_ado')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_ado');
+
+# Example DSN (from frew):
+# dbi:ADO:PROVIDER=sqlncli10;SERVER=tcp:172.24.2.10;MARS Connection=True;Initial Catalog=CIS;UID=cis_web;PWD=...;DataTypeCompatibility=80;
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+DBICTest::Schema->load_classes(qw/VaryingMAX ArtistGUID/);
+
+my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+$binstr{'large'} = $binstr{'small'} x 1024;
+
+my $maxloblen = length $binstr{'large'};
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1,
+ LongReadLen => $maxloblen,
+});
+
$schema->storage->ensure_connected;
-isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server' );
+isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server');
+
+my $ver = $schema->storage->_server_info->{normalized_dbms_version};
+
+ok $ver, 'can introspect DBMS version';
+
+# 2005 and greater
+is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'),
+ 'correct limit dialect detected';
$schema->storage->dbh_do (sub {
my ($storage, $dbh) = @_;
- eval { $dbh->do("DROP TABLE artist") };
+ try { local $^W = 0; $dbh->do("DROP TABLE artist") };
$dbh->do(<<'SQL');
CREATE TABLE artist (
artistid INT IDENTITY NOT NULL,
SQL
});
-my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist_guid (
+ artistid UNIQUEIDENTIFIER NOT NULL,
+ name VARCHAR(100),
+ rank INT NULL,
+ charfield CHAR(10) NULL,
+ a_guid UNIQUEIDENTIFIER,
+ primary key(artistid)
+)
+SQL
+});
+
+my $have_max = $ver >= 9; # 2005 and greater
+
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") };
+ $dbh->do("
+CREATE TABLE varying_max_test (
+ id INT IDENTITY NOT NULL,
+" . ($have_max ? "
+ varchar_max VARCHAR(MAX),
+ nvarchar_max NVARCHAR(MAX),
+ varbinary_max VARBINARY(MAX),
+" : "
+ varchar_max TEXT,
+ nvarchar_max NTEXT,
+ varbinary_max IMAGE,
+") . "
+ primary key(id)
+)");
+});
+
+my $ars = $schema->resultset('Artist');
+
+my $new = $ars->create({ name => 'foo' });
ok($new->artistid > 0, 'Auto-PK worked');
# make sure select works
# test large column list in select
$found = $schema->resultset('Artist')->search({ name => 'foo' }, {
- select => ['artistid', 'name', map "'foo' foo_$_", 0..50],
- as => ['artistid', 'name', map "foo_$_", 0..50],
+ select => ['artistid', 'name', map \"'foo' foo_$_", 0..50],
+ as => ['artistid', 'name', map "foo_$_", 0..50],
})->first;
is $found->artistid, $new->artistid, 'select with big column list';
is $found->get_column('foo_50'), 'foo', 'last item in big column list';
my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' });
while ($rs1->next) {
- ok eval { $rs2->next }, 'multiple active cursors';
+ ok try { $rs2->next }, 'multiple active cursors';
}
# test bug where ADO blows up if the first bindparam is shorter than the second
'Artist 12',
'longer bindparam';
+# test explicit key spec
+$new = $ars->create ({ name => 'bar', artistid => 66 });
+is($new->artistid, 66, 'Explicit PK worked');
+$new->discard_changes;
+is($new->artistid, 66, 'Explicit PK assigned');
+
+# test basic transactions
+$schema->txn_do(sub {
+ $ars->create({ name => 'transaction_commit' });
+});
+ok($ars->search({ name => 'transaction_commit' })->first,
+ 'transaction committed');
+$ars->search({ name => 'transaction_commit' })->delete,
+throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'transaction_rollback' });
+ die 'rolling back';
+ });
+} qr/rolling back/, 'rollback executed';
+is $ars->search({ name => 'transaction_rollback' })->first, undef,
+ 'transaction rolled back';
+
+# test two-phase commit and inner transaction rollback from nested transactions
+$schema->txn_do(sub {
+ $ars->create({ name => 'in_outer_transaction' });
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction' });
+ });
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction visible in outer transaction');
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction_rolling_back' });
+ die 'rolling back inner transaction';
+ });
+ } qr/rolling back inner transaction/, 'inner transaction rollback executed';
+});
+ok($ars->search({ name => 'in_outer_transaction' })->first,
+ 'commit from outer transaction');
+ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction');
+is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
+ undef,
+ 'rollback from inner transaction';
+$ars->search({ name => 'in_outer_transaction' })->delete;
+$ars->search({ name => 'in_inner_transaction' })->delete;
+
+# test populate
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+});
+
+# test populate with explicit key
+lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+});
+
+# count what we did so far
+is ($ars->count, 18, 'Simple count works');
+
+# test empty insert
+my $current_artistid = $ars->search({}, {
+ select => [ { max => 'artistid' } ], as => ['artistid']
+})->first->artistid;
+
+my $row;
+lives_ok { $row = $ars->create({}) }
+ 'empty insert works';
+
+$row->discard_changes;
+
+is $row->artistid, $current_artistid+1,
+ 'empty insert generated correct PK';
+
+# test that autoinc column still works after empty insert
+ $row = $ars->create({ name => 'after_empty_insert' });
+
+ is $row->artistid, $current_artistid+2,
+ 'autoincrement column functional aftear empty insert';
+
+my $rs = $schema->resultset('VaryingMAX');
+
+foreach my $size (qw/small large/) {
+ my $orig_debug = $schema->storage->debug;
+
+ $schema->storage->debug(0) if $size eq 'large';
+
+ my $str = $binstr{$size};
+ my $row;
+ lives_ok {
+ $row = $rs->create({
+ varchar_max => $str, nvarchar_max => $str, varbinary_max => $str
+ });
+ } "created $size VARXXX(MAX) LOBs";
+
+ lives_ok {
+ $row->discard_changes;
+ } 're-selected just-inserted LOBs';
+
+ cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches';
+ cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches';
+ cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches';
+
+ $schema->storage->debug($orig_debug);
+}
+
+# test regular blobs
+
+try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') };
+$schema->storage->dbh->do(qq[
+CREATE TABLE bindtype_test
+(
+ id INT IDENTITY NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo NTEXT NULL
+)
+],{ RaiseError => 1, PrintError => 1 });
+
+$rs = $schema->resultset('BindType');
+my $id = 0;
+
+foreach my $type (qw( blob clob a_memo )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying" or next;
+
+ my $from_db = eval { $rs->find($id)->$type } || '';
+ diag $@ if $@;
+
+ ok($from_db eq $binstr{$size}, "verified inserted $size $type" )
+ or do {
+ my $hexdump = sub {
+ join '', map sprintf('%02X', ord), split //, shift
+ };
+ diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...',
+ substr($hexdump->($from_db),-255);
+ diag 'Size: ', length($from_db);
+ diag 'Expected Size: ', length($binstr{$size});
+ diag 'Expected: ', "\n",
+ substr($hexdump->($binstr{$size}), 0, 255),
+ "...", substr($hexdump->($binstr{$size}),-255);
+ };
+ }
+}
+# test IMAGE update
+lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{small} });
+} 'updated IMAGE to small binstr without dying';
+
+lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{large} });
+} 'updated IMAGE to large binstr without dying';
+
+# test GUIDs
+lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+} 'created a row with a GUID';
+
+ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+);
+diag $@ if $@;
+
+my $guid = try { $row->artistid }||'';
+
+ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces')
+ or diag "GUID is: $guid";
+
+ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+);
+diag $@ if $@;
+
+my $row_from_db = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first;
+
+is try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->search->next)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->search->next)';
+
+$row_from_db = try { $schema->resultset('ArtistGUID')
+ ->find($row->artistid) };
+
+is try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->find)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->find)';
+
+($row_from_db) = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all;
+
+is try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->search->all)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->search->all)';
+
+lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({
+ artistid => '70171270-4822-4450-81DF-921F99BA3C06',
+ name => 'explicit_guid',
+ });
+} 'created a row with explicit PK GUID';
+
+is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06',
+ 'row has correct PK GUID';
+
+lives_ok {
+ $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' });
+} "updated row's PK GUID";
+
+is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07',
+ 'row has correct PK GUID';
+
+lives_ok {
+ $row->delete;
+} 'deleted the row';
+
+lives_ok {
+ $schema->resultset('ArtistGUID')->populate([{
+ artistid => '70171270-4822-4450-81DF-921F99BA3C06',
+ name => 'explicit_guid',
+ }]);
+} 'created a row with explicit PK GUID via ->populate in void context';
+
done_testing;
# clean up our mess
END {
- if (my $dbh = eval { $schema->storage->_dbh }) {
- eval { $dbh->do("DROP TABLE $_") }
- for qw/artist/;
+ local $SIG{__WARN__} = sub {};
+ if (my $dbh = try { $schema->storage->_dbh }) {
+ (try { $dbh->do("DROP TABLE $_") })
+ for qw/artist artist_guid varying_max_test bindtype_test/;
}
+
+ undef $schema;
}
# vim:sw=2 sts=2
use Test::More;
use Test::Exception;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
#warn "$dsn $user $pass";
plan skip_all => 'Set $ENV{DBICTEST_INFORMIX_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
+ unless $dsn;
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1
+});
my $dbh = $schema->storage->dbh;
eval { $dbh->do("DROP TABLE artist") };
-
$dbh->do("CREATE TABLE artist (artistid SERIAL, name VARCHAR(255), charfield CHAR(10), rank INTEGER DEFAULT 13);");
+eval { $dbh->do("DROP TABLE cd") };
+$dbh->do(<<EOS);
+CREATE TABLE cd (
+ cdid int PRIMARY KEY,
+ artist int,
+ title varchar(255),
+ year varchar(4),
+ genreid int,
+ single_track int
+)
+EOS
+eval { $dbh->do("DROP TABLE track") };
+$dbh->do(<<EOS);
+CREATE TABLE track (
+ trackid int,
+ cd int REFERENCES cd(cdid),
+ position int,
+ title varchar(255),
+ last_updated_on date,
+ last_updated_at date,
+ small_dt date
+)
+EOS
my $ars = $schema->resultset('Artist');
is ( $ars->count, 0, 'No rows at first' );
is( $lim->next->artistid, 102, "iterator->next ok" );
is( $lim->next, undef, "next past end of resultset ok" );
+# test savepoints
+throws_ok {
+ $schema->txn_do(sub {
+ eval {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_savepoint' });
+ die "rolling back savepoint";
+ });
+ };
+ ok ((not $ars->search({ name => 'in_savepoint' })->first),
+ 'savepoint rolled back');
+ $ars->create({ name => 'in_outer_txn' });
+ die "rolling back outer txn";
+ });
+} qr/rolling back outer txn/,
+ 'correct exception for rollback';
+
+ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+ 'outer txn rolled back');
+
+######## test with_deferred_fk_checks
+lives_ok {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
+ });
+ $schema->resultset('CD')->create({
+ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
+ });
+ });
+} 'with_deferred_fk_checks code survived';
+
+is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
+ 'code in with_deferred_fk_checks worked';
+
+throws_ok {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+} qr/constraint/i, 'with_deferred_fk_checks is off';
done_testing;
# clean up our mess
END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
+ my $dbh = eval { $schema->storage->_dbh };
+ $dbh->do("DROP TABLE artist") if $dbh;
+ undef $schema;
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SQLANYWHERE_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Test needs ' .
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere_odbc'))
+ unless
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere_odbc')
+ or
+ (not $dsn || $dsn2);
+
+DBICTest::Schema->load_classes('ArtistGUID');
+
+# tests stolen from 748informix.t
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_SQLANYWHERE_DSN} and/or $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN},
+_USER and _PASS to run these tests
+EOF
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my $schema;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1
+ });
+
+ my $guard = Scope::Guard->new(sub{ cleanup($schema) });
+
+ my $dbh = $schema->storage->dbh;
+
+ eval { $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid INT IDENTITY PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT DEFAULT 13
+ )
+EOF
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# test savepoints
+ throws_ok {
+ $schema->txn_do(sub {
+ eval {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_savepoint' });
+ die "rolling back savepoint";
+ });
+ };
+ ok ((not $ars->search({ name => 'in_savepoint' })->first),
+ 'savepoint rolled back');
+ $ars->create({ name => 'in_outer_txn' });
+ die "rolling back outer txn";
+ });
+ } qr/rolling back outer txn/,
+ 'correct exception for rollback';
+
+ ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+ 'outer txn rolled back');
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+ my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( $lim->next->artistid, 101, "iterator->next ok" );
+ is( $lim->next->artistid, 102, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ {
+ local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
+
+ lives_ok { $ars->create({}) }
+ 'empty insert works';
+ }
+
+# test blobs (stolen from 73oracle.t)
+ eval { $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob LONG BINARY NULL,
+ clob LONG VARCHAR NULL,
+ a_memo INT NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+ local $schema->storage->{debug} = 0;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
+ }
+ }
+
+ my @uuid_types = qw/uniqueidentifier uniqueidentifierstr/;
+
+# test uniqueidentifiers (and the cursor_class).
+
+ for my $uuid_type (@uuid_types) {
+ local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
+ = $uuid_type;
+
+ local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
+ = $uuid_type;
+
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist_guid (
+ artistid $uuid_type NOT NULL,
+ name VARCHAR(100),
+ rank INT NOT NULL DEFAULT '13',
+ charfield CHAR(10) NULL,
+ a_guid $uuid_type,
+ primary key(artistid)
+)
+SQL
+ });
+
+ local $TODO = 'something wrong with uniqueidentifierstr over ODBC'
+ if $dsn =~ /:ODBC:/ && $uuid_type eq 'uniqueidentifierstr';
+
+ my $row;
+ lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+ } 'created a row with a GUID';
+
+ ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+ );
+ diag $@ if $@;
+
+ ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+ );
+ diag $@ if $@;
+
+ my $row_from_db = try { $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first }
+ catch { diag $_ };
+
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->search->next)';
+
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->next)';
+
+ $row_from_db = try { $schema->resultset('ArtistGUID')
+ ->find($row->artistid) }
+ catch { diag $_ };
+
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->find)';
+
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->find)';
+
+ ($row_from_db) = try { $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all }
+ catch { diag $_ };
+
+ is try { $row_from_db->artistid }, $row->artistid,
+ 'PK GUID round trip (via ->search->all)';
+
+ is try { $row_from_db->a_guid }, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->all)';
+ }
+}
+
+done_testing;
+
+sub cleanup {
+ my $schema = shift;
+ eval { $schema->storage->dbh->do("DROP TABLE $_") }
+ for qw/artist artist_guid bindtype_test/;
+}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-use lib qw(t/lib);
-use DBICTest;
-
-# tests stolen from 748informix.t
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
-my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => <<'EOF' unless $dsn || $dsn2;
-Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN},
-_USER and _PASS to run these tests
-EOF
-
-my @info = (
- [ $dsn, $user, $pass ],
- [ $dsn2, $user2, $pass2 ],
-);
-
-my @handles_to_clean;
-
-foreach my $info (@info) {
- my ($dsn, $user, $pass) = @$info;
-
- next unless $dsn;
-
- my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
- auto_savepoint => 1
- });
-
- my $dbh = $schema->storage->dbh;
-
- push @handles_to_clean, $dbh;
-
- eval { $dbh->do("DROP TABLE artist") };
-
- $dbh->do(<<EOF);
- CREATE TABLE artist (
- artistid INT IDENTITY PRIMARY KEY,
- name VARCHAR(255) NULL,
- charfield CHAR(10) NULL,
- rank INT DEFAULT 13
- )
-EOF
-
- my $ars = $schema->resultset('Artist');
- is ( $ars->count, 0, 'No rows at first' );
-
-# test primary key handling
- my $new = $ars->create({ name => 'foo' });
- ok($new->artistid, "Auto-PK worked");
-
-# test explicit key spec
- $new = $ars->create ({ name => 'bar', artistid => 66 });
- is($new->artistid, 66, 'Explicit PK worked');
- $new->discard_changes;
- is($new->artistid, 66, 'Explicit PK assigned');
-
-# test savepoints
- eval {
- $schema->txn_do(sub {
- eval {
- $schema->txn_do(sub {
- $ars->create({ name => 'in_savepoint' });
- die "rolling back savepoint";
- });
- };
- ok ((not $ars->search({ name => 'in_savepoint' })->first),
- 'savepoint rolled back');
- $ars->create({ name => 'in_outer_txn' });
- die "rolling back outer txn";
- });
- };
-
- like $@, qr/rolling back outer txn/,
- 'correct exception for rollback';
-
- ok ((not $ars->search({ name => 'in_outer_txn' })->first),
- 'outer txn rolled back');
-
-# test populate
- lives_ok (sub {
- my @pop;
- for (1..2) {
- push @pop, { name => "Artist_$_" };
- }
- $ars->populate (\@pop);
- });
-
-# test populate with explicit key
- lives_ok (sub {
- my @pop;
- for (1..2) {
- push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
- }
- $ars->populate (\@pop);
- });
-
-# count what we did so far
- is ($ars->count, 6, 'Simple count works');
-
-# test LIMIT support
- my $lim = $ars->search( {},
- {
- rows => 3,
- offset => 4,
- order_by => 'artistid'
- }
- );
- is( $lim->count, 2, 'ROWS+OFFSET count ok' );
- is( $lim->all, 2, 'Number of ->all objects matches count' );
-
-# test iterator
- $lim->reset;
- is( $lim->next->artistid, 101, "iterator->next ok" );
- is( $lim->next->artistid, 102, "iterator->next ok" );
- is( $lim->next, undef, "next past end of resultset ok" );
-
-# test empty insert
- {
- local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0;
-
- lives_ok { $ars->create({}) }
- 'empty insert works';
- }
-
-# test blobs (stolen from 73oracle.t)
- eval { $dbh->do('DROP TABLE bindtype_test') };
- $dbh->do(qq[
- CREATE TABLE bindtype_test
- (
- id INT NOT NULL PRIMARY KEY,
- bytea INT NULL,
- blob LONG BINARY NULL,
- clob LONG VARCHAR NULL
- )
- ],{ RaiseError => 1, PrintError => 1 });
-
- my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
- $binstr{'large'} = $binstr{'small'} x 1024;
-
- my $maxloblen = length $binstr{'large'};
- local $dbh->{'LongReadLen'} = $maxloblen;
-
- my $rs = $schema->resultset('BindType');
- my $id = 0;
-
- foreach my $type (qw( blob clob )) {
- foreach my $size (qw( small large )) {
- $id++;
-
-# turn off horrendous binary DBIC_TRACE output
- local $schema->storage->{debug} = 0;
-
- lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
- "inserted $size $type without dying";
-
- ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
- }
- }
-}
-
-done_testing;
-
-# clean up our mess
-END {
- foreach my $dbh (@handles_to_clean) {
- eval { $dbh->do("DROP TABLE $_") } for qw/artist bindtype_test/;
- }
-}
use strict;
-use warnings;
+use warnings;
# use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else
BEGIN {
use Test::More;
use Test::Exception;
+use Scalar::Util 'weaken';
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn);
-my @storage_types = (
- 'DBI::Sybase::Microsoft_SQL_Server',
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_sybase')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_sybase');
+
+{
+ my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version};
+ ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') );
+}
+
+my $schema;
+
+my $testdb_supports_placeholders = DBICTest::Schema->connect($dsn, $user, $pass)
+ ->storage
+ ->_supports_typeless_placeholders;
+my @test_storages = (
+ $testdb_supports_placeholders ? 'DBI::Sybase::Microsoft_SQL_Server' : (),
'DBI::Sybase::Microsoft_SQL_Server::NoBindVars',
);
-my $storage_idx = -1;
-my $schema;
-my $NUMBER_OF_TESTS_IN_BLOCK = 18;
-for my $storage_type (@storage_types) {
- $storage_idx++;
+for my $storage_type (@test_storages) {
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass);
- $schema = DBICTest::Schema->clone;
+ if ($storage_type =~ /NoBindVars\z/) {
+ # since we want to use the nobindvar - disable the capability so the
+ # rebless happens to the correct class
+ $schema->storage->_use_typeless_placeholders (0);
+ }
- $schema->connection($dsn, $user, $pass);
+ local $ENV{DBIC_MSSQL_FREETDS_LOWVER_NOWARN} = 1; # disable nobindvars warning
- if ($storage_idx != 0) { # autodetect
- no warnings 'redefine';
- local *DBIx::Class::Storage::DBI::_typeless_placeholders_supported =
- sub { 0 };
-# $schema->storage_type("::$storage_type");
- $schema->storage->ensure_connected;
- }
- else {
- $schema->storage->ensure_connected;
- }
+ $schema->storage->ensure_connected;
- if ($storage_idx == 0 && ref($schema->storage) =~ /NoBindVars\z/) {
- my $tb = Test::More->builder;
- $tb->skip('no placeholders') for 1..$NUMBER_OF_TESTS_IN_BLOCK;
- next;
+ if ($storage_type =~ /NoBindVars\z/) {
+ is $schema->storage->disable_sth_caching, 1,
+ 'prepare_cached disabled for NoBindVars';
}
isa_ok($schema->storage, "DBIx::Class::Storage::$storage_type");
-# start disconnected to test reconnection
- $schema->storage->_dbh->disconnect;
+ SKIP: {
+ skip 'This version of DBD::Sybase segfaults on disconnect', 1 if DBD::Sybase->VERSION < 1.08;
+
+ # start disconnected to test _ping
+ $schema->storage->_dbh->disconnect;
- my $dbh;
- lives_ok (sub {
- $dbh = $schema->storage->dbh;
- }, 'reconnect works');
+ lives_ok {
+ $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
+ } '_ping works';
+ }
+
+ my $dbh = $schema->storage->dbh;
$dbh->do("IF OBJECT_ID('artist', 'U') IS NOT NULL
DROP TABLE artist");
amount MONEY NULL
)
SQL
-
- });
+ });
my $rs = $schema->resultset('Money');
+ weaken(my $rs_cp = $rs); # nested closure refcounting is an utter mess in perl
my $row;
lives_ok {
is $rs->find($row->id)->amount,
undef, 'updated money value to NULL round-trip';
- $rs->create({ amount => 300 }) for (1..3);
-
- # test multiple active statements
- lives_ok {
- my $artist_rs = $schema->resultset('Artist');
- while (my $row = $rs->next) {
- my $artist = $artist_rs->next;
- }
- $rs->reset;
- } 'multiple active statements';
-
$rs->delete;
# test simple transaction with commit
lives_ok {
$schema->txn_do(sub {
- $rs->create({ amount => 400 });
+ $rs_cp->create({ amount => 300 });
});
} 'simple transaction';
- cmp_ok $rs->first->amount, '==', 400, 'committed';
- $rs->reset;
+ cmp_ok $rs->first->amount, '==', 300, 'committed';
+ $rs->reset;
$rs->delete;
# test rollback
throws_ok {
$schema->txn_do(sub {
- $rs->create({ amount => 400 });
+ $rs_cp->create({ amount => 700 });
die 'mtfnpy';
});
} qr/mtfnpy/, 'simple failed txn';
is $rs->first, undef, 'rolled back';
+
$rs->reset;
+ $rs->delete;
+
+ # test multiple active statements
+ {
+ $rs->create({ amount => 800 + $_ }) for 1..3;
+
+ my @map = (
+ [ 'Artist 1', '801.00' ],
+ [ 'Artist 2', '802.00' ],
+ [ 'Artist 3', '803.00' ]
+ );
+
+ my $artist_rs = $schema->resultset('Artist')->search({
+ name => { -like => 'Artist %' }
+ });;
+
+ my $i = 0;
+
+ while (my $money_row = $rs->next) {
+ my $artist_row = $artist_rs->next;
+
+ is_deeply [ $artist_row->name, $money_row->amount ], $map[$i++],
+ 'multiple active statements';
+ }
+ $rs->reset;
+ $rs->delete;
+ }
+
+ # test transaction handling on a disconnected handle
+ my $wrappers = {
+ no_transaction => sub { shift->() },
+ txn_do => sub { my $code = shift; $schema->txn_do(sub { $code->() } ) },
+ txn_begin => sub { $schema->txn_begin; shift->(); $schema->txn_commit },
+ txn_guard => sub { my $g = $schema->txn_scope_guard; shift->(); $g->commit },
+ };
+ for my $wrapper (keys %$wrappers) {
+ $rs->delete;
+
+ # a reconnect should trigger on next action
+ $schema->storage->_get_dbh->disconnect;
+
+
+ lives_and {
+ $wrappers->{$wrapper}->( sub {
+ $rs_cp->create({ amount => 900 + $_ }) for 1..3;
+ });
+ is $rs->count, 3;
+ } "transaction on disconnected handle with $wrapper wrapper";
+ }
+
+ TODO: {
+ local $TODO = 'Transaction handling with multiple active statements will '
+ .'need eager cursor support.';
+
+ # test transaction handling on a disconnected handle with multiple active
+ # statements
+ my $wrappers = {
+ no_transaction => sub { shift->() },
+ txn_do => sub { my $code = shift; $schema->txn_do(sub { $code->() } ) },
+ txn_begin => sub { $schema->txn_begin; shift->(); $schema->txn_commit },
+ txn_guard => sub { my $g = $schema->txn_scope_guard; shift->(); $g->commit },
+ };
+ for my $wrapper (keys %$wrappers) {
+ $rs->reset;
+ $rs->delete;
+ $rs->create({ amount => 1000 + $_ }) for (1..3);
+
+ my $artist_rs = $schema->resultset('Artist')->search({
+ name => { -like => 'Artist %' }
+ });;
+
+ $rs->next;
+
+ my $map = [ ['Artist 1', '1002.00'], ['Artist 2', '1003.00'] ];
+
+ weaken(my $a_rs_cp = $artist_rs);
+
+ lives_and {
+ my @results;
+ $wrappers->{$wrapper}->( sub {
+ while (my $money = $rs_cp->next) {
+ my $artist = $a_rs_cp->next;
+ push @results, [ $artist->name, $money->amount ];
+ };
+ });
+
+ is_deeply \@results, $map;
+ } "transactions with multiple active statement with $wrapper wrapper";
+ }
+ }
+
+ # test RNO detection when version detection fails
+ SKIP: {
+ my $storage = $schema->storage;
+ my $version = $storage->_server_info->{normalized_dbms_version};
+
+ skip 'could not detect SQL Server version', 1 if not defined $version;
+
+ my $have_rno = $version >= 9 ? 1 : 0;
+
+ local $storage->{_dbh_details}{info} = {}; # delete cache
+
+ my $rno_detected =
+ ($storage->sql_limit_dialect eq 'RowNumberOver') ? 1 : 0;
+
+ ok (($have_rno == $rno_detected),
+ 'row_number() over support detected correctly');
+ }
+
+ {
+ my $schema = DBICTest::Schema->clone;
+ $schema->connection($dsn, $user, $pass);
+
+ like $schema->storage->sql_maker->{limit_dialect},
+ qr/^(?:Top|RowNumberOver)\z/,
+ 'sql_maker is correct on unconnected schema';
+ }
}
# test op-induced autoconnect
is ($artist->id, 1, 'Artist retrieved successfully');
}, 'Query-induced autoconnect works');
+# test AutoCommit=0
+{
+ local $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} = 1;
+ my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 0 });
+
+ my $rs = $schema2->resultset('Money');
+
+ $rs->delete;
+ $schema2->txn_commit;
+
+ is $rs->count, 0, 'initially empty'
+ || diag ('Found row with amount ' . $_->amount) for $rs->all;
+
+ $rs->create({ amount => 3000 });
+ $schema2->txn_rollback;
+
+ is $rs->count, 0, 'rolled back in AutoCommit=0'
+ || diag ('Found row with amount ' . $_->amount) for $rs->all;
+
+ $rs->create({ amount => 4000 });
+ $schema2->txn_commit;
+
+ cmp_ok $rs->first->amount, '==', 4000, 'committed in AutoCommit=0';
+}
+
done_testing;
# clean up our mess
$dbh->do("IF OBJECT_ID('cd', 'U') IS NOT NULL DROP TABLE cd");
$dbh->do("IF OBJECT_ID('money_test', 'U') IS NOT NULL DROP TABLE money_test");
}
+
+ undef $schema;
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use DBIx::Class::Optional::Dependencies ();
+use Scope::Guard ();
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+my $env2optdep = {
+ DBICTEST_FIREBIRD => 'test_rdbms_firebird',
+ DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase',
+ DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc',
+};
+
+plan skip_all => join (' ',
+ 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}',
+ 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},',
+ '_USER and _PASS to run these tests.',
+
+ 'WARNING: this test creates and drops the tables "artist", "bindtype_test" and',
+ '"sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"',
+ 'and "nonpkid_seq" and the trigger "artist_bi".',
+) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep;
+
+# tests stolen from 749sybase_asa.t
+
+# Example DSNs:
+# dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb
+# dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb
+
+# Example ODBC DSN:
+# dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/hlaghdb.fdb
+
+my $schema;
+
+for my $prefix (keys %$env2optdep) { SKIP: {
+
+ my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
+
+ next unless $dsn;
+
+ skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
+ unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1,
+ quote_names => 1,
+ ($dsn !~ /ODBC/ ? (on_connect_call => 'use_softcommit') : ()),
+ });
+ my $dbh = $schema->storage->dbh;
+
+ my $sg = Scope::Guard->new(sub { cleanup($schema) });
+
+ eval { $dbh->do(q[DROP TABLE "artist"]) };
+ $dbh->do(<<EOF);
+ CREATE TABLE "artist" (
+ "artistid" INT PRIMARY KEY,
+ "name" VARCHAR(255),
+ "charfield" CHAR(10),
+ "rank" INT DEFAULT 13
+ )
+EOF
+ eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) };
+ $dbh->do('CREATE GENERATOR "gen_artist_artistid"');
+ eval { $dbh->do('DROP TRIGGER "artist_bi"') };
+ $dbh->do(<<EOF);
+ CREATE TRIGGER "artist_bi" FOR "artist"
+ ACTIVE BEFORE INSERT POSITION 0
+ AS
+ BEGIN
+ IF (NEW."artistid" IS NULL) THEN
+ NEW."artistid" = GEN_ID("gen_artist_artistid",1);
+ END
+EOF
+ eval { $dbh->do('DROP TABLE "sequence_test"') };
+ $dbh->do(<<EOF);
+ CREATE TABLE "sequence_test" (
+ "pkid1" INT NOT NULL,
+ "pkid2" INT NOT NULL,
+ "nonpkid" INT,
+ "name" VARCHAR(255)
+ )
+EOF
+ $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")');
+ eval { $dbh->do('DROP GENERATOR "pkid1_seq"') };
+ eval { $dbh->do('DROP GENERATOR pkid2_seq') };
+ eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') };
+ $dbh->do('CREATE GENERATOR "pkid1_seq"');
+ $dbh->do('CREATE GENERATOR pkid2_seq');
+ $dbh->do('SET GENERATOR pkid2_seq TO 9');
+ $dbh->do('CREATE GENERATOR "nonpkid_seq"');
+ $dbh->do('SET GENERATOR "nonpkid_seq" TO 19');
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+# test auto increment using generators WITHOUT triggers
+ for (1..5) {
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+ is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key");
+ is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key");
+ is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key");
+ }
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+ is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
+
+# test transaction commit
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_transaction' });
+ });
+ ok (($ars->search({ name => 'in_transaction' })->first),
+ 'transaction committed');
+ is $schema->storage->_dbh->{AutoCommit}, 1,
+ '$dbh->{AutoCommit} is correct after transaction commit';
+
+ $ars->search({ name => 'in_transaction' })->delete;
+
+# test savepoints
+ throws_ok {
+ $schema->txn_do(sub {
+ eval {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_savepoint' });
+ die "rolling back savepoint";
+ });
+ };
+ ok ((not $ars->search({ name => 'in_savepoint' })->first),
+ 'savepoint rolled back');
+ $ars->create({ name => 'in_outer_txn' });
+ die "rolling back outer txn";
+ });
+ } qr/rolling back outer txn/,
+ 'correct exception for rollback';
+
+ is $schema->storage->_dbh->{AutoCommit}, 1,
+ '$dbh->{AutoCommit} is correct after transaction rollback';
+
+ ok ((not $ars->search({ name => 'in_outer_txn' })->first),
+ 'outer txn rolled back');
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# row update
+ lives_ok {
+ $new->update({ name => 'baz' })
+ } 'update survived';
+ $new->discard_changes;
+ is $new->name, 'baz', 'row updated';
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test ResultSet UPDATE
+ lives_and {
+ $ars->search({ name => 'foo' })->update({ rank => 4 });
+
+ is eval { $ars->search({ name => 'foo' })->first->rank }, 4;
+ } 'Can update a column';
+
+ my ($updated) = $schema->resultset('Artist')->search({name => 'foo'});
+ is eval { $updated->rank }, 4, 'and the update made it to the database';
+
+# test LIMIT support
+ my $lim = $ars->search( {},
+ {
+ rows => 3,
+ offset => 4,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( eval { $lim->next->artistid }, 101, "iterator->next ok" );
+ is( eval { $lim->next->artistid }, 102, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test bug in paging
+ my $paged = $ars->search({ name => { -like => 'Artist%' } }, {
+ page => 1,
+ rows => 2,
+ order_by => 'artistid',
+ });
+
+ my $row;
+ lives_ok {
+ $row = $paged->next;
+ } 'paged query survived';
+
+ is try { $row->artistid }, 5, 'correct row from paged query';
+
+ # DBD bug - if any unfinished statements are present during
+ # DDL manipulation (test blobs below)- a segfault will occur
+ $paged->reset;
+
+# test nested cursors
+ {
+ my $rs1 = $ars->search({}, { order_by => { -asc => 'artistid' }});
+
+ my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, {
+ order_by => { -desc => 'artistid' }
+ });
+
+ is $rs2->next->artistid, 1, 'nested cursors';
+ }
+
+# test empty insert
+ lives_and {
+ my $row = $ars->create({});
+ ok $row->artistid;
+ } 'empty insert works';
+
+# test inferring the generator from the trigger source and using it with
+# auto_nextval
+ {
+ local $ars->result_source->column_info('artistid')->{auto_nextval} = 1;
+
+ lives_and {
+ my $row = $ars->create({ name => 'introspecting generator' });
+ ok $row->artistid;
+ } 'inferring generator from trigger source works';
+ }
+
+# test blobs (stolen from 73oracle.t)
+ eval { $dbh->do('DROP TABLE "bindtype_test"') };
+ $dbh->do(q[
+ CREATE TABLE "bindtype_test"
+ (
+ "id" INT PRIMARY KEY,
+ "bytea" INT,
+ "blob" BLOB,
+ "clob" BLOB SUB_TYPE TEXT,
+ "a_memo" INT
+ )
+ ]);
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+ local $dbh->{'LongReadLen'} = $maxloblen;
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob )) {
+ foreach my $size (qw( small large )) {
+ $id++;
+
+# turn off horrendous binary DBIC_TRACE output
+ local $schema->storage->{debug} = 0;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying";
+
+ my $got = $rs->find($id)->$type;
+
+ my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift };
+
+ ok($got eq $binstr{$size}, "verified inserted $size $type" )
+ or do {
+ diag "For " . (ref $schema->storage) . "\n";
+ diag "Got blob:\n";
+ diag $hexdump->(substr($got,0,50));
+ diag "Expecting blob:\n";
+ diag $hexdump->(substr($binstr{$size},0,50));
+ };
+ }
+ }
+}}
+
+done_testing;
+
+# clean up our mess
+
+sub cleanup {
+ my $schema = shift;
+
+ my $dbh;
+ eval {
+ $schema->storage->disconnect; # to avoid object FOO is in use errors
+ $dbh = $schema->storage->dbh;
+ };
+ return unless $dbh;
+
+ eval { $dbh->do('DROP TRIGGER "artist_bi"') };
+ diag $@ if $@;
+
+ foreach my $generator (qw/
+ "gen_artist_artistid"
+ "pkid1_seq"
+ pkid2_seq
+ "nonpkid_seq"
+ /) {
+ eval { $dbh->do(qq{DROP GENERATOR $generator}) };
+ diag $@ if $@;
+ }
+
+ foreach my $table (qw/artist sequence_test/) {
+ eval { $dbh->do(qq[DROP TABLE "$table"]) };
+ diag $@ if $@;
+ }
+
+ eval { $dbh->do(q{DROP TABLE "bindtype_test"}) };
+ diag $@ if $@;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::DebugObj ();
+use DBIC::SqlMakerTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Test needs ' .
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado'))
+ unless
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado')
+ or
+ (not $dsn || $dsn2);
+
+DBICTest::Schema->load_classes('ArtistGUID');
+
+# Example DSNs (32bit only):
+# dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb
+# dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb
+# dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False'
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.
+Warning: this test drops and creates the tables 'artist', 'cd', 'bindtype_test' and 'artist_guid'.
+EOF
+
+my @info = (
+ [ $dsn, $user || '', $pass || '' ],
+ [ $dsn2, $user2 || '', $pass2 || '' ],
+);
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+# Check that we can connect without any options.
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ lives_ok {
+ $schema->storage->ensure_connected;
+ } 'connection without any options';
+
+ my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+ $binstr{'large'} = $binstr{'small'} x 1024;
+
+ my $maxloblen = length $binstr{'large'};
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ quote_names => 1,
+ auto_savepoint => 1,
+ LongReadLen => $maxloblen,
+ });
+
+ my $guard = Scope::Guard->new(sub { cleanup($schema) });
+
+ my $dbh = $schema->storage->dbh;
+
+ # turn off warnings for OLE exception from ADO about nonexistant table
+ eval { local $^W = 0; $dbh->do("DROP TABLE artist") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE artist (
+ artistid AUTOINCREMENT PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT NULL
+ )
+EOF
+
+ my $ars = $schema->resultset('Artist');
+ is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+ my $new = $ars->create({ name => 'foo' });
+ ok($new->artistid, "Auto-PK worked");
+
+ my $first_artistid = $new->artistid;
+
+# test explicit key spec
+ $new = $ars->create ({ name => 'bar', artistid => 66 });
+ is($new->artistid, 66, 'Explicit PK worked');
+ $new->discard_changes;
+ is($new->artistid, 66, 'Explicit PK assigned');
+
+# test joins
+ eval { local $^W = 0; $dbh->do("DROP TABLE cd") };
+
+ $dbh->do(<<EOF);
+ CREATE TABLE cd (
+ cdid AUTOINCREMENT PRIMARY KEY,
+ artist INTEGER NULL,
+ title VARCHAR(255) NULL,
+ [year] CHAR(4) NULL,
+ genreid INTEGER NULL,
+ single_track INTEGER NULL
+ )
+EOF
+
+ $dbh->do(<<EOF);
+ CREATE TABLE track (
+ trackid AUTOINCREMENT PRIMARY KEY,
+ cd INTEGER REFERENCES cd(cdid),
+ [position] INTEGER,
+ title VARCHAR(255),
+ last_updated_on DATETIME,
+ last_updated_at DATETIME
+ )
+EOF
+
+ my $cd = $schema->resultset('CD')->create({
+ artist => $first_artistid,
+ title => 'Some Album',
+ });
+
+# one-step join
+ my $joined_artist = $schema->resultset('Artist')->search({
+ artistid => $first_artistid,
+ }, {
+ join => [ 'cds' ],
+ '+select' => [ 'cds.title' ],
+ '+as' => [ 'cd_title' ],
+ })->next;
+
+ is $joined_artist->get_column('cd_title'), 'Some Album',
+ 'one-step join works';
+
+# two-step join
+ my $track = $schema->resultset('Track')->create({
+ cd => $cd->cdid,
+ position => 1,
+ title => 'my track',
+ });
+
+ my ($sql, @bind);
+
+ my $joined_track = try {
+ local $schema->storage->{debug} = 1;
+ local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
+
+ $schema->resultset('Artist')->search({
+ artistid => $first_artistid,
+ }, {
+ join => [{ cds => 'tracks' }],
+ '+select' => [ 'tracks.title' ],
+ '+as' => [ 'track_title' ],
+ })->next;
+ }
+ catch {
+ diag "Could not execute two-step left join: $_";
+ };
+
+ s/^'//, s/'\z// for @bind;
+
+ is_same_sql_bind(
+ $sql,
+ \@bind,
+ 'SELECT [me].[artistid], [me].[name], [me].[rank], [me].[charfield], [tracks].[title] FROM ( ( [artist] [me] LEFT JOIN cd [cds] ON [cds].[artist] = [me].[artistid] ) LEFT JOIN [track] [tracks] ON [tracks].[cd] = [cds].[cdid] ) WHERE ( [artistid] = ? )',
+ [1],
+ 'correct SQL for two-step left join',
+ );
+
+ is try { $joined_track->get_column('track_title') }, 'my track',
+ 'two-step left join works';
+
+ ($sql, @bind) = ();
+
+ $joined_artist = try {
+ local $schema->storage->{debug} = 1;
+ local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
+
+ $schema->resultset('Track')->search({
+ trackid => $track->trackid,
+ }, {
+ join => [{ cd => 'artist' }],
+ '+select' => [ 'artist.name' ],
+ '+as' => [ 'artist_name' ],
+ })->next;
+ }
+ catch {
+ diag "Could not execute two-step inner join: $_";
+ };
+
+ s/^'//, s/'\z// for @bind;
+
+ is_same_sql_bind(
+ $sql,
+ \@bind,
+ 'SELECT [me].[trackid], [me].[cd], [me].[position], [me].[title], [me].[last_updated_on], [me].[last_updated_at], [artist].[name] FROM ( ( [track] [me] INNER JOIN cd [cd] ON [cd].[cdid] = [me].[cd] ) INNER JOIN [artist] [artist] ON [artist].[artistid] = [cd].[artist] ) WHERE ( [trackid] = ? )',
+ [$track->trackid],
+ 'correct SQL for two-step inner join',
+ );
+
+ is try { $joined_artist->get_column('artist_name') }, 'foo',
+ 'two-step inner join works';
+
+# test basic transactions
+ $schema->txn_do(sub {
+ $ars->create({ name => 'transaction_commit' });
+ });
+ ok($ars->search({ name => 'transaction_commit' })->first,
+ 'transaction committed');
+ $ars->search({ name => 'transaction_commit' })->delete,
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'transaction_rollback' });
+ die 'rolling back';
+ });
+ } qr/rolling back/, 'rollback executed';
+ is $ars->search({ name => 'transaction_rollback' })->first, undef,
+ 'transaction rolled back';
+
+# test two-phase commit and inner transaction rollback from nested transactions
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_outer_transaction' });
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction' });
+ });
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction visible in outer transaction');
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction_rolling_back' });
+ die 'rolling back inner transaction';
+ });
+ } qr/rolling back inner transaction/, 'inner transaction rollback executed';
+ });
+ ok($ars->search({ name => 'in_outer_transaction' })->first,
+ 'commit from outer transaction');
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction');
+ is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
+ undef,
+ 'rollback from inner transaction';
+ $ars->search({ name => 'in_outer_transaction' })->delete;
+ $ars->search({ name => 'in_inner_transaction' })->delete;
+
+# test populate
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_$_" };
+ }
+ $ars->populate (\@pop);
+ });
+
+# test populate with explicit key
+ lives_ok (sub {
+ my @pop;
+ for (1..2) {
+ push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+ }
+ $ars->populate (\@pop);
+ });
+
+# count what we did so far
+ is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+# not testing offset because access only supports TOP
+ my $lim = $ars->search( {},
+ {
+ rows => 2,
+ offset => 0,
+ order_by => 'artistid'
+ }
+ );
+ is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+ is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+ $lim->reset;
+ is( $lim->next->artistid, 1, "iterator->next ok" );
+ is( $lim->next->artistid, 66, "iterator->next ok" );
+ is( $lim->next, undef, "next past end of resultset ok" );
+
+# test empty insert
+ my $current_artistid = $ars->search({}, {
+ select => [ { max => 'artistid' } ], as => ['artistid']
+ })->first->artistid;
+
+ my $row;
+ lives_ok { $row = $ars->create({}) }
+ 'empty insert works';
+
+ $row->discard_changes;
+
+ is $row->artistid, $current_artistid+1,
+ 'empty insert generated correct PK';
+
+# test that autoinc column still works after empty insert
+ $row = $ars->create({ name => 'after_empty_insert' });
+
+ is $row->artistid, $current_artistid+2,
+ 'autoincrement column functional aftear empty insert';
+
+# test blobs (stolen from 73oracle.t)
+
+# turn off horrendous binary DBIC_TRACE output
+ {
+ local $schema->storage->{debug} = 0;
+
+ eval { local $^W = 0; $dbh->do('DROP TABLE bindtype_test') };
+ $dbh->do(qq[
+ CREATE TABLE bindtype_test
+ (
+ id INT NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo MEMO NULL
+ )
+ ],{ RaiseError => 1, PrintError => 1 });
+
+ my $rs = $schema->resultset('BindType');
+ my $id = 0;
+
+ foreach my $type (qw( blob clob a_memo )) {
+ foreach my $size (qw( small large )) {
+ SKIP: {
+ skip 'TEXT columns not cast to MEMO over ODBC', 2
+ if $type eq 'clob' && $size eq 'large' && $dsn =~ /:ODBC:/;
+
+ $id++;
+
+ lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+ "inserted $size $type without dying" or next;
+
+ my $from_db = eval { $rs->find($id)->$type } || '';
+ diag $@ if $@;
+
+ ok($from_db eq $binstr{$size}, "verified inserted $size $type" )
+ or do {
+ my $hexdump = sub {
+ join '', map sprintf('%02X', ord), split //, shift
+ };
+ diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...',
+ substr($hexdump->($from_db),-255);
+ diag 'Size: ', length($from_db);
+ diag 'Expected Size: ', length($binstr{$size});
+ diag 'Expected: ', "\n",
+ substr($hexdump->($binstr{$size}), 0, 255),
+ "...", substr($hexdump->($binstr{$size}),-255);
+ };
+ }
+ }
+ }
+# test IMAGE update
+ lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{small} });
+ } 'updated IMAGE to small binstr without dying';
+
+ lives_ok {
+ $rs->search({ id => 0 })->update({ blob => $binstr{large} });
+ } 'updated IMAGE to large binstr without dying';
+ }
+
+# test GUIDs (and the cursor GUID fixup stuff for ADO)
+
+ require Data::GUID;
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+ local $schema->source('ArtistGUID')->column_info('artistid')->{data_type}
+ = 'guid';
+
+ local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type}
+ = 'guid';
+
+ $schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist_guid (
+ artistid GUID NOT NULL,
+ name VARCHAR(100),
+ rank INT NULL,
+ charfield CHAR(10) NULL,
+ a_guid GUID,
+ primary key(artistid)
+)
+SQL
+ });
+
+ lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
+ } 'created a row with a GUID';
+
+ ok(
+ eval { $row->artistid },
+ 'row has GUID PK col populated',
+ );
+ diag $@ if $@;
+
+ ok(
+ eval { $row->a_guid },
+ 'row has a GUID col with auto_nextval populated',
+ );
+ diag $@ if $@;
+
+ my $row_from_db = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->first;
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->search->next)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->next)';
+
+ $row_from_db = $schema->resultset('ArtistGUID')
+ ->find($row->artistid);
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->find)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->find)';
+
+ ($row_from_db) = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all;
+
+ is $row_from_db->artistid, $row->artistid,
+ 'PK GUID round trip (via ->search->all)';
+
+ is $row_from_db->a_guid, $row->a_guid,
+ 'NON-PK GUID round trip (via ->search->all)';
+}
+
+done_testing;
+
+sub cleanup {
+ my $schema = shift;
+
+ if (my $storage = eval { $schema->storage }) {
+ # cannot drop a table if it has been used, have to reconnect first
+ $schema->storage->disconnect;
+ local $^W = 0; # for ADO OLE exceptions
+ $schema->storage->dbh->do("DROP TABLE $_")
+ for qw/artist track cd bindtype_test artist_guid/;
+ }
+}
+
+# vim:sts=2 sw=2:
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use Test::Warn;
+use Config;
+
+use lib qw(t/lib);
+use DBICTest;
+
+# savepoints test
+{
+ my $schema = DBICTest->init_schema(auto_savepoint => 1);
+
+ my $ars = $schema->resultset('Artist');
+
+ # test two-phase commit and inner transaction rollback from nested transactions
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_outer_transaction' });
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction' });
+ });
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction visible in outer transaction');
+ throws_ok {
+ $schema->txn_do(sub {
+ $ars->create({ name => 'in_inner_transaction_rolling_back' });
+ die 'rolling back inner transaction';
+ });
+ } qr/rolling back inner transaction/, 'inner transaction rollback executed';
+ $ars->create({ name => 'in_outer_transaction2' });
+ });
+
+ ok($ars->search({ name => 'in_outer_transaction' })->first,
+ 'commit from outer transaction');
+ ok($ars->search({ name => 'in_outer_transaction2' })->first,
+ 'second commit from outer transaction');
+ ok($ars->search({ name => 'in_inner_transaction' })->first,
+ 'commit from inner transaction');
+ is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
+ undef,
+ 'rollback from inner transaction';
+}
+
+my $schema = DBICTest->init_schema();
+
+# make sure the side-effects of RT#67581 do not result in data loss
+my $row;
+warnings_exist { $row = $schema->resultset('Artist')->create ({ name => 'alpha rank', rank => 'abc' }) }
+ [qr/Non-numeric value supplied for column 'rank' despite the numeric datatype/],
+ 'proper warning on string insertion into an numeric column'
+;
+$row->discard_changes;
+is ($row->rank, 'abc', 'proper rank inserted into database');
+
+# and make sure we do not lose actual bigints
+{
+ package DBICTest::BigIntArtist;
+ use base 'DBICTest::Schema::Artist';
+ __PACKAGE__->table('artist');
+ __PACKAGE__->add_column(bigint => { data_type => 'bigint' });
+}
+$schema->register_class(BigIntArtist => 'DBICTest::BigIntArtist');
+$schema->storage->dbh_do(sub {
+ $_[1]->do('ALTER TABLE artist ADD COLUMN bigint BIGINT');
+});
+
+# test upper/lower boundaries for sqlite and some values inbetween
+# range is -(2**63) .. 2**63 - 1
+for my $bi (qw/
+ -9223372036854775808
+ -9223372036854775807
+ -8694837494948124658
+ -6848440844435891639
+ -5664812265578554454
+ -5380388020020483213
+ -2564279463598428141
+ 2442753333597784273
+ 4790993557925631491
+ 6773854980030157393
+ 7627910776496326154
+ 8297530189347439311
+ 9223372036854775806
+ 9223372036854775807
+/) {
+ $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi });
+ is ($row->bigint, $bi, "value in object correct ($bi)");
+
+ TODO: {
+ local $TODO = 'This perl does not seem to have 64bit int support - DBI roundtrip of large int will fail'
+ unless $Config{ivsize} >= 8;
+
+ $row->discard_changes;
+ is ($row->bigint, $bi, "value in database correct ($bi)");
+ }
+}
+
+done_testing;
+
+# vim:sts=2 sw=2:
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $orig_debug = $schema->storage->debug;
# test the abstract join => SQL generator
-my $sa = new DBIx::Class::SQLAHacks;
+my $sa = new DBIx::Class::SQLMaker;
my @j = (
{ child => 'person' },
'join 5 (SCALAR reference for ON statement) ok'
);
-my @j6 = (
- { child => 'person' },
- [ { father => 'person' }, { 'father.person_id' => { '!=', '42' } }, ],
- [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ],
-);
-$match = qr/HASH reference arguments are not supported in JOINS/;
-eval { $sa->_recurse_from(@j6) };
-like( $@, $match, 'join 6 (HASH reference for ON statement dies) ok' );
-
my $rs = $schema->resultset("CD")->search(
{ 'year' => 2001, 'artist.name' => 'Caterwauler McCrae' },
{ from => [ { 'me' => 'cd' },
[ 4, 7 ],
[ 4, 8 ],
]);
-
- sub cd_count {
- return $schema->resultset("CD")->count;
- }
- sub tk_count {
- return $schema->resultset("TwoKeys")->count;
- }
-
- is(cd_count(), 8, '8 rows in table cd');
- is(tk_count(), 7, '7 rows in table twokeys');
-
- sub artist1 {
- return $schema->resultset("CD")->search(
- { 'artist.name' => 'Caterwauler McCrae' },
- { join => [qw/artist/]}
- );
- }
- sub artist2 {
- return $schema->resultset("CD")->search(
- { 'artist.name' => 'Random Boy Band' },
- { join => [qw/artist/]}
- );
- }
-
- is( artist1()->count, 3, '3 Caterwauler McCrae CDs' );
- ok( artist1()->delete, 'Successfully deleted 3 CDs' );
- is( artist1()->count, 0, '0 Caterwauler McCrae CDs' );
- is( artist2()->count, 2, '3 Random Boy Band CDs' );
- ok( artist2()->update( { 'artist' => 1 } ) );
- is( artist2()->count, 0, '0 Random Boy Band CDs' );
- is( artist1()->count, 2, '2 Caterwauler McCrae CDs' );
+
+ my $cd_count = sub { $schema->resultset("CD")->count };
+ my $tk_count = sub { $schema->resultset("TwoKeys")->count };
+
+ is($cd_count->(), 8, '8 rows in table cd');
+ is($tk_count->(), 7, '7 rows in table twokeys');
+
+ my $artist1_rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+ );
+
+ my $artist2_rs = $schema->resultset("CD")->search(
+ { 'artist.name' => 'Random Boy Band' },
+ { join => [qw/artist/]}
+ );
+
+ is( $artist1_rs->count, 3, '3 Caterwauler McCrae CDs' );
+ ok( $artist1_rs->delete, 'Successfully deleted 3 CDs' );
+ is( $artist1_rs->count, 0, '0 Caterwauler McCrae CDs' );
+ is( $artist2_rs->count, 2, '3 Random Boy Band CDs' );
+ ok( $artist2_rs->update( { 'artist' => 1 } ) );
+ is( $artist2_rs->count, 0, '0 Random Boy Band CDs' );
+ is( $artist1_rs->count, 2, '2 Caterwauler McCrae CDs' );
# test update on multi-column-pk
- sub tk1 {
- return $schema->resultset("TwoKeys")->search(
- {
- 'artist.name' => { like => '%Boy Band' },
- 'cd.title' => 'Greatest Hits',
- },
- { join => [qw/artist cd/] }
- );
- }
- sub tk2 {
- return $schema->resultset("TwoKeys")->search(
- { 'artist.name' => 'Caterwauler McCrae' },
- { join => [qw/artist/]}
- );
- }
- is( tk2()->count, 2, 'TwoKeys count == 2' );
- is( tk1()->count, 2, 'TwoKeys count == 2' );
- ok( tk1()->update( { artist => 1 } ) );
- is( tk1()->count, 0, 'TwoKeys count == 0' );
- is( tk2()->count, 4, '2 Caterwauler McCrae CDs' );
- ok( tk2()->delete, 'Successfully deleted 4 CDs' );
- is(cd_count(), 5, '5 rows in table cd');
- is(tk_count(), 3, '3 rows in table twokeys');
+ my $tk1_rs = $schema->resultset("TwoKeys")->search(
+ {
+ 'artist.name' => { like => '%Boy Band' },
+ 'cd.title' => 'Greatest Hits',
+ },
+ { join => [qw/artist cd/] }
+ );
+
+ my $tk2_rs = $schema->resultset("TwoKeys")->search(
+ { 'artist.name' => 'Caterwauler McCrae' },
+ { join => [qw/artist/]}
+ );
+
+ is( $tk2_rs->count, 2, 'TwoKeys count == 2' );
+ is( $tk1_rs->count, 2, 'TwoKeys count == 2' );
+ ok( $tk1_rs->update( { artist => 1 } ) );
+ is( $tk1_rs->count, 0, 'TwoKeys count == 0' );
+ is( $tk2_rs->count, 4, '2 Caterwauler McCrae CDs' );
+ ok( $tk2_rs->delete, 'Successfully deleted 4 CDs' );
+ is($cd_count->(), 5, '5 rows in table cd');
+ is($tk_count->(), 3, '3 rows in table twokeys');
}
done_testing;
is_same_sql_bind (
$rs->as_query,
- '(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, me.cdid, me.title, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)',
+ '(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, artist.name FROM cd me JOIN artist artist ON artist.artistid = me.artist)',
[],
'Use of columns attribute results in proper sql'
);
'columns/select/as fold properly on sub-searches',
);
+# *very* esoteric use-case, yet valid (the "empty" object should not be undef):
+$rs = $schema->resultset('Artist');
+$rs->create({ artistid => 69, name => 'Ranetki' });
+
+my $relations_or_1_count =
+ $rs->search_related('cds')->count
+ +
+ $rs->search({ 'cds.cdid' => undef }, { join => 'cds' })->count
+;
+
+my $weird_rs = $rs->search({}, {
+ order_by => { -desc => [ 'me.artistid', 'cds.cdid' ] },
+ columns => [{ cd_title => 'cds.title', cd_year => 'cds.year' }],
+ join => 'cds',
+});
+
+my $weird_rs_hri = $weird_rs->search({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' });
+
+for my $rs ($weird_rs, $weird_rs_hri) {
+ is ($rs->count, $relations_or_1_count, 'count on rhs data injection matches');
+
+ my @all;
+ while (my $r = $rs->next) {
+ push @all, $r;
+ }
+
+ is (scalar @all, $relations_or_1_count, 'object count on rhs data injection matches');
+ is_deeply (
+ ( $rs->result_class eq 'DBIx::Class::ResultClass::HashRefInflator'
+ ? \@all
+ : [ map { +{$_->get_columns} } @all ]
+ ),
+ [
+ {
+ cd_title => undef,
+ cd_year => undef,
+ },
+ {
+ cd_title => "Come Be Depressed With Us",
+ cd_year => 1998,
+ },
+ {
+ cd_title => "Generic Manufactured Singles",
+ cd_year => 2001,
+ },
+ {
+ cd_title => "Caterwaulin' Blues",
+ cd_year => 1997,
+ },
+ {
+ cd_title => "Forkful of bees",
+ cd_year => 2001,
+ },
+ {
+ cd_title => "Spoonful of bees",
+ cd_year => 1999,
+ },
+ ],
+ 'Correct data retrieved'
+ );
+
+ is_deeply( [ $rs->all ], \@all, '->all matches' );
+}
+
done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-eval "use DBD::SQLite";
-plan skip_all => 'needs DBD::SQLite for testing' if $@;
-plan tests => 4;
-
cmp_ok($schema->resultset("CD")->count({ 'artist.name' => 'Caterwauler McCrae' },
{ join => 'artist' }),
'==', 3, 'Count by has_a ok');
{ join => [ qw/tags liner_notes/ ] } ),
'==', 2, "Mixed count ok");
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use warnings;
use Test::More;
+use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
[ qw/primary track_cd_position track_cd_title/ ],
'Track source has three unique constraints'
);
+is_deeply(
+ [ sort $schema->source('Tag')->unique_constraint_names ],
+ [ qw/primary tagid_cd tagid_cd_tag tags_tagid_tag tags_tagid_tag_cd/ ],
+ 'Tag source has five unique constraints (from add_unique_constraings)'
+);
my $artistid = 1;
my $title = 'UNIQUE Constraint';
is($cd8->title, $cd1->title, 'title is correct');
is($cd8->year, $cd1->year, 'year is correct');
+# Add an extra row to potentially confuse the query
+$schema->resultset('CD')->create ({
+ artist => 2,
+ title => $title,
+ year => 2022,
+});
my $cd9 = $artist->cds->update_or_create(
{
cdid => $cd1->cdid,
my $artist = $schema->resultset('Artist')->next;
my ($sql, @bind);
+ my $old_debugobj = $schema->storage->debugobj;
+ my $old_debug = $schema->storage->debug;
$schema->storage->debugobj(DBIC::DebugObj->new(\$sql, \@bind)),
$schema->storage->debug(1);
[qw/'1'/],
);
- $schema->storage->debug(0);
- $schema->storage->debugobj(undef);
+ $schema->storage->debug($old_debug);
+ $schema->storage->debugobj($old_debugobj);
}
+{
+ throws_ok {
+ eval <<'MOD' or die $@;
+ package # hide from PAUSE
+ DBICTest::Schema::UniqueConstraintWarningTest;
+
+ use base qw/DBIx::Class::Core/;
+
+ __PACKAGE__->table('dummy');
+
+ __PACKAGE__->add_column(qw/ foo bar /);
+
+ __PACKAGE__->add_unique_constraint(
+ constraint1 => [qw/ foo /],
+ constraint2 => [qw/ bar /],
+ );
+
+ 1;
+MOD
+ } qr/\Qadd_unique_constraint() does not accept multiple constraints, use add_unique_constraints() instead\E/,
+ 'add_unique_constraint throws when more than one constraint specified';
+}
+# make sure NULL is not considered condition-deterministic
+my $art_rs = $schema->resultset('Artist')->search({}, { order_by => 'artistid' });
+$art_rs->create ({ artistid => $_ + 640, name => "Outranked $_" }) for (1..2);
+warnings_are {
+ is(
+ $art_rs->find ({ artistid => 642, rank => 13, charfield => undef })->name,
+ 'Outranked 2',
+ 'Correct artist retrieved with find'
+ );
+
+ is (
+ $art_rs->search({ charfield => undef })->find ({ artistid => 642, rank => 13 })->name,
+ 'Outranked 2',
+ 'Correct artist retrieved with find'
+ );
+} [], 'no warnings';
+
done_testing;
+
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Warn;
-use Test::Exception;
-use lib qw(t/lib);
-use DBICTest;
-
-my $schema = DBICTest->init_schema();
-
-my $code = sub {
- my ($artist, @cd_titles) = @_;
-
- $artist->create_related('cds', {
- title => $_,
- year => 2006,
- }) foreach (@cd_titles);
-
- return $artist->cds->all;
-};
-
-# Test checking of parameters
-{
- throws_ok (sub {
- (ref $schema)->txn_do(sub{});
- }, qr/storage/, "can't call txn_do without storage");
-
- throws_ok ( sub {
- $schema->txn_do('');
- }, qr/must be a CODE reference/, '$coderef parameter check ok');
-}
-
-# Test successful txn_do() - scalar context
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my @titles = map {'txn_do test CD ' . $_} (1..5);
- my $artist = $schema->resultset('Artist')->find(1);
- my $count_before = $artist->cds->count;
- my $count_after = $schema->txn_do($code, $artist, @titles);
- is($count_after, $count_before+5, 'successful txn added 5 cds');
- is($artist->cds({
- title => "txn_do test CD $_",
- })->first->year, 2006, "new CD $_ year correct") for (1..5);
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
-}
-
-# Test successful txn_do() - list context
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my @titles = map {'txn_do test CD ' . $_} (6..10);
- my $artist = $schema->resultset('Artist')->find(1);
- my $count_before = $artist->cds->count;
- my @cds = $schema->txn_do($code, $artist, @titles);
- is(scalar @cds, $count_before+5, 'added 5 CDs and returned in list context');
- is($artist->cds({
- title => "txn_do test CD $_",
- })->first->year, 2006, "new CD $_ year correct") for (6..10);
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
-}
-
-# Test nested successful txn_do()
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my $nested_code = sub {
- my ($schema, $artist, $code) = @_;
-
- my @titles1 = map {'nested txn_do test CD ' . $_} (1..5);
- my @titles2 = map {'nested txn_do test CD ' . $_} (6..10);
-
- $schema->txn_do($code, $artist, @titles1);
- $schema->txn_do($code, $artist, @titles2);
- };
-
- my $artist = $schema->resultset('Artist')->find(2);
- my $count_before = $artist->cds->count;
-
- lives_ok (sub {
- $schema->txn_do($nested_code, $schema, $artist, $code);
- }, 'nested txn_do succeeded');
-
- is($artist->cds({
- title => 'nested txn_do test CD '.$_,
- })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
- is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs');
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
-}
-
-my $fail_code = sub {
- my ($artist) = @_;
- $artist->create_related('cds', {
- title => 'this should not exist',
- year => 2005,
- });
- die "the sky is falling";
-};
-
-# Test failed txn_do()
-{
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my $artist = $schema->resultset('Artist')->find(3);
-
- throws_ok (sub {
- $schema->txn_do($fail_code, $artist);
- }, qr/the sky is falling/, 'failed txn_do threw an exception');
-
- my $cd = $artist->cds({
- title => 'this should not exist',
- year => 2005,
- })->first;
- ok(!defined($cd), q{failed txn_do didn't change the cds table});
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
-}
-
-# do the same transaction again
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my $artist = $schema->resultset('Artist')->find(3);
-
- throws_ok (sub {
- $schema->txn_do($fail_code, $artist);
- }, qr/the sky is falling/, 'failed txn_do threw an exception');
-
- my $cd = $artist->cds({
- title => 'this should not exist',
- year => 2005,
- })->first;
- ok(!defined($cd), q{failed txn_do didn't change the cds table});
-
- is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
-}
-
-# Test failed txn_do() with failed rollback
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my $artist = $schema->resultset('Artist')->find(3);
-
- # Force txn_rollback() to throw an exception
- no warnings 'redefine';
- no strict 'refs';
-
- # die in rollback, but maintain sanity for further tests ...
- local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{
- my $storage = shift;
- $storage->{transaction_depth}--;
- die 'FAILED';
- };
-
- throws_ok (
- sub {
- $schema->txn_do($fail_code, $artist);
- },
- qr/the sky is falling.+Rollback failed/s,
- 'txn_rollback threw a rollback exception (and included the original exception'
- );
-
- my $cd = $artist->cds({
- title => 'this should not exist',
- year => 2005,
- })->first;
- isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }.
- q{changed the cds table});
- $cd->delete; # Rollback failed
- $cd = $artist->cds({
- title => 'this should not exist',
- year => 2005,
- })->first;
- ok(!defined($cd), q{deleted the failed txn's cd});
- $schema->storage->_dbh->rollback;
-}
-
-# Test nested failed txn_do()
-{
- is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
-
- my $nested_fail_code = sub {
- my ($schema, $artist, $code1, $code2) = @_;
-
- my @titles = map {'nested txn_do test CD ' . $_} (1..5);
-
- $schema->txn_do($code1, $artist, @titles); # successful txn
- $schema->txn_do($code2, $artist); # failed txn
- };
-
- my $artist = $schema->resultset('Artist')->find(3);
-
- throws_ok ( sub {
- $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
- }, qr/the sky is falling/, 'nested failed txn_do threw exception');
-
- ok(!defined($artist->cds({
- title => 'nested txn_do test CD '.$_,
- year => 2006,
- })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5);
- my $cd = $artist->cds({
- title => 'this should not exist',
- year => 2005,
- })->first;
- ok(!defined($cd), q{failed txn_do didn't add failed txn's cd});
-}
-
-# Grab a new schema to test txn before connect
-{
- my $schema2 = DBICTest->init_schema(no_deploy => 1);
- lives_ok (sub {
- $schema2->txn_begin();
- $schema2->txn_begin();
- }, 'Pre-connection nested transactions.');
-
- # although not connected DBI would still warn about rolling back at disconnect
- $schema2->txn_rollback;
- $schema2->txn_rollback;
- $schema2->storage->disconnect;
-}
-$schema->storage->disconnect;
-
-# Test txn_scope_guard
-{
- my $schema = DBICTest->init_schema();
-
- is($schema->storage->transaction_depth, 0, "Correct transaction depth");
- my $artist_rs = $schema->resultset('Artist');
- throws_ok {
- my $guard = $schema->txn_scope_guard;
-
-
- $artist_rs->create({
- name => 'Death Cab for Cutie',
- made_up_column => 1,
- });
-
- $guard->commit;
- } qr/No such column made_up_column .*? at .*?81transactions.t line \d+/s, "Error propogated okay";
-
- ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
-
- my $inner_exception = ''; # set in inner() below
- throws_ok (sub {
- outer($schema, 1);
- }, qr/$inner_exception/, "Nested exceptions propogated");
-
- ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
-
- lives_ok (sub {
- warnings_exist ( sub {
- # The 0 arg says don't die, just let the scope guard go out of scope
- # forcing a txn_rollback to happen
- outer($schema, 0);
- }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');
- ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
- }, 'rollback successful withot exception');
-
- sub outer {
- my ($schema) = @_;
-
- my $guard = $schema->txn_scope_guard;
- $schema->resultset('Artist')->create({
- name => 'Death Cab for Cutie',
- });
- inner(@_);
- }
-
- sub inner {
- my ($schema, $fatal) = @_;
-
- my $inner_guard = $schema->txn_scope_guard;
- is($schema->storage->transaction_depth, 2, "Correct transaction depth");
-
- my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
-
- eval {
- $artist->cds->create({
- title => 'Plans',
- year => 2005,
- $fatal ? ( foo => 'bar' ) : ()
- });
- };
- if ($@) {
- # Record what got thrown so we can test it propgates out properly.
- $inner_exception = $@;
- die $@;
- }
-
- # inner guard should commit without consequences
- $inner_guard->commit;
- }
-}
-
-# make sure the guard does not eat exceptions
-{
- my $schema = DBICTest->init_schema();
- throws_ok (sub {
- my $guard = $schema->txn_scope_guard;
- $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-
- $schema->storage->disconnect; # this should freak out the guard rollback
-
- die 'Deliberate exception';
- }, qr/Deliberate exception.+Rollback failed/s);
-}
-
-# make sure it warns *big* on failed rollbacks
-{
- my $schema = DBICTest->init_schema();
-
- # something is really confusing Test::Warn here, no time to debug
-=begin
- warnings_exist (
- sub {
- my $guard = $schema->txn_scope_guard;
- $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-
- $schema->storage->disconnect; # this should freak out the guard rollback
- },
- [
- qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
- qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
- ],
- 'proper warnings generated on out-of-scope+rollback failure'
- );
-=cut
-
- my @want = (
- qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
- qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
- );
-
- my @w;
- local $SIG{__WARN__} = sub {
- if (grep {$_[0] =~ $_} (@want)) {
- push @w, $_[0];
- }
- else {
- warn $_[0];
- }
- };
- {
- my $guard = $schema->txn_scope_guard;
- $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-
- $schema->storage->disconnect; # this should freak out the guard rollback
- }
-
- is (@w, 2, 'Both expected warnings found');
-}
-
-# make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
-{
- my $factory = DBICTest->init_schema (AutoCommit => 0);
- cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
- my $dbh = $factory->storage->dbh;
-
- ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
- my $schema = DBICTest::Schema->connect (sub { $dbh });
-
-
- lives_ok ( sub {
- my $guard = $schema->txn_scope_guard;
- $schema->resultset('CD')->delete;
- $guard->commit;
- }, 'No attempt to start a transaction with scope guard');
-
- is ($schema->resultset('CD')->count, 0, 'Deletion successful');
-}
-
-# make sure AutoCommit => 0 on external handles behaves correctly with txn_do
-{
- my $factory = DBICTest->init_schema (AutoCommit => 0);
- cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
- my $dbh = $factory->storage->dbh;
-
- ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
- my $schema = DBICTest::Schema->connect (sub { $dbh });
-
-
- lives_ok ( sub {
- $schema->txn_do (sub { $schema->resultset ('CD')->delete });
- }, 'No attempt to start a atransaction with txn_do');
-
- is ($schema->resultset('CD')->count, 0, 'Deletion successful');
-}
-
-done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 4;
my $artist = $schema->resultset('Artist')->find(1);
my $artist_cds = $artist->search_related('cds');
-my $cover_band = $artist->copy;
+my $cover_band = $artist->copy ({name => $artist->name . '_cover' });
my $cover_cds = $cover_band->search_related('cds');
cmp_ok($cover_band->id, '!=', $artist->id, 'ok got new column id...');
cmp_ok($cover_cds->search_related('tags')->count, '==',
$artist_cds->search_related('tags')->count , 'duplicated count ok');
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-use Storable qw(dclone freeze thaw);
+use Storable qw(dclone freeze nfreeze thaw);
+use Scalar::Util qw/refaddr/;
-my $schema = DBICTest->init_schema();
+sub ref_ne {
+ my ($refa, $refb) = map { refaddr $_ or die "$_ is not a reference!" } @_[0,1];
+ cmp_ok (
+ $refa,
+ '!=',
+ $refb,
+ sprintf ('%s (0x%07x != 0x%07x)',
+ $_[2],
+ $refa,
+ $refb,
+ ),
+ );
+}
+
+my $schema = DBICTest->init_schema;
my %stores = (
dclone_method => sub { return $schema->dclone($_[0]) },
- dclone_func => sub { return dclone($_[0]) },
+ dclone_func => sub {
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+ return dclone($_[0])
+ },
"freeze/thaw_method" => sub {
- my $ice = $schema->freeze($_[0]);
- return $schema->thaw($ice);
+ my $ice = $schema->freeze($_[0]);
+ return $schema->thaw($ice);
},
- "freeze/thaw_func" => sub {
- thaw(freeze($_[0]));
+ "nfreeze/thaw_func" => sub {
+ my $ice = freeze($_[0]);
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+ return thaw($ice);
},
+
+ "freeze/thaw_func (cdbi legacy)" => sub {
+ # this one is special-cased to leak the $schema all over
+ # the same way as cdbi-compat does
+ DBICTest::Artist->result_source_instance->schema($schema);
+ DBICTest::CD->result_source_instance->schema($schema);
+
+ my $fire = thaw(freeze($_[0]));
+
+ # clean up the mess
+ $_->result_source_instance->schema(undef)
+ for map { $schema->class ($_) } $schema->sources;
+
+ return $fire;
+ },
+
);
-plan tests => (11 * keys %stores);
+if ($ENV{DBICTEST_MEMCACHED}) {
+ if (DBIx::Class::Optional::Dependencies->req_ok_for ('test_memcached')) {
+ my $memcached = Cache::Memcached->new(
+ { servers => [ $ENV{DBICTEST_MEMCACHED} ] }
+ );
+
+ my $key = 'tmp_dbic_84serialize_memcached_test';
+
+ $stores{memcached} = sub {
+ $memcached->set( $key, $_[0], 60 );
+ local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+ return $memcached->get($key);
+ };
+ }
+ else {
+ SKIP: {
+ skip 'Memcached tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_memcached'), 1;
+ }
+ }
+}
+else {
+ SKIP: {
+ skip 'Set $ENV{DBICTEST_MEMCACHED} to run the memcached serialization tests', 1;
+ }
+}
+
+
for my $name (keys %stores) {
+
my $store = $stores{$name};
my $copy;
my $artist = $schema->resultset('Artist')->find(1);
-
- # Test that the procedural versions will work if there's a registered
- # schema as with CDBICompat objects and that the methods work
- # without.
- if( $name =~ /func/ ) {
- $artist->result_source_instance->schema($schema);
- DBICTest::CD->result_source_instance->schema($schema);
- }
- else {
- $artist->result_source_instance->schema(undef);
- DBICTest::CD->result_source_instance->schema(undef);
- }
lives_ok { $copy = $store->($artist) } "serialize row object lives: $name";
+ ref_ne($copy, $artist, 'Simple row cloned');
is_deeply($copy, $artist, "serialize row object works: $name");
my $cd_rs = $artist->search_related("cds");
- # test that a result source can be serialized as well
-
- $cd_rs->_resolved_attrs; # this builds up the {from} attr
+ # test that a live result source can be serialized as well
+ is( $cd_rs->count, 3, '3 CDs in database');
+ ok( $cd_rs->next, 'Advance cursor' );
lives_ok {
$copy = $store->($cd_rs);
+
+ ref_ne($copy, $artist, 'Simple row cloned');
+
is_deeply (
[ $copy->all ],
[ $cd_rs->all ],
for my $key (keys %$artist) {
next if $key eq 'related_resultsets';
next if $key eq '_inflated_column';
+
+ ref_ne($copy->{$key}, $artist->{$key}, "Simple row internals cloned '$key'")
+ if ref $artist->{$key};
+
is_deeply($copy->{$key}, $artist->{$key},
- qq[serialize with related_resultset "$key"]);
+ qq[serialize with related_resultset '$key']);
}
- ok eval { $copy->discard_changes; 1 } or diag $@;
+ lives_ok(
+ sub { $copy->discard_changes }, "Discard changes works: $name"
+ ) or diag $@;
is($copy->id, $artist->id, "IDs still match ");
+
+
+ # Test resultsource with cached rows
+ my $query_count;
+ $cd_rs = $cd_rs->search ({}, { cache => 1 });
+
+ my $orig_debug = $schema->storage->debug;
+ $schema->storage->debug(1);
+ $schema->storage->debugcb(sub { $query_count++ } );
+
+ # this will hit the database once and prime the cache
+ my @cds = $cd_rs->all;
+
+ lives_ok {
+ $copy = $store->($cd_rs);
+ ref_ne($copy, $cd_rs, 'Cached resultset cloned');
+ is_deeply (
+ [ $copy->all ],
+ [ $cd_rs->all ],
+ "serialize cached resultset works: $name",
+ );
+
+ is ($copy->count, $cd_rs->count, 'Cached count identical');
+ } "serialize cached resultset lives: $name";
+
+ is ($query_count, 1, 'Only one db query fired');
+
+ $schema->storage->debug($orig_debug);
+ $schema->storage->debugcb(undef);
+}
+
+# test schema-less detached thaw
+{
+ my $artist = $schema->resultset('Artist')->find(1);
+
+ $artist = dclone $artist;
+
+ is( $artist->name, 'Caterwauler McCrae', 'getting column works' );
+
+ ok( $artist->update, 'Non-dirty update noop' );
+
+ ok( $artist->name( 'Beeeeeeees' ), 'setting works' );
+
+ ok( $artist->is_column_changed( 'name' ), 'Column dirtyness works' );
+ ok( $artist->is_changed, 'object dirtyness works' );
+
+ my $rs = $artist->result_source->resultset;
+ $rs->set_cache([ $artist ]);
+
+ is( $rs->count, 1, 'Synthetic resultset count works' );
+
+ my $exc = qr/Unable to perform storage-dependent operations with a detached result source.+use \$schema->thaw/;
+
+ throws_ok { $artist->update }
+ $exc,
+ 'Correct exception on row op'
+ ;
+
+ throws_ok { $artist->discard_changes }
+ $exc,
+ 'Correct exception on row op'
+ ;
+
+ throws_ok { $rs->find(1) }
+ $exc,
+ 'Correct exception on rs op'
+ ;
}
+
+done_testing;
use Test::Warn;
use lib qw(t/lib);
use DBICTest;
+use DBIC::DebugObj;
-warning_like (
+{
+ package A::Comp;
+ use base 'DBIx::Class';
+ sub store_column { shift->next::method (@_) };
+ 1;
+}
+
+{
+ package A::SubComp;
+ use base 'A::Comp';
+
+ 1;
+}
+
+warnings_are (
+ sub {
+ local $ENV{DBIC_UTF8COLUMNS_OK} = 1;
+ package A::Test1;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [],
+ 'no spurious warnings issued',
+);
+
+warnings_like (
sub {
- package A::Comp;
- use base 'DBIx::Class';
+ package A::Test1Loud;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
sub store_column { shift->next::method (@_) };
1;
+ },
+ [qr/Use of DBIx::Class::UTF8Columns is strongly discouraged/],
+ 'issued deprecation warning',
+);
+
- package A::Test;
+my $test1_mro;
+my $idx = 0;
+for (@{mro::get_linear_isa ('A::Test1')} ) {
+ $test1_mro->{$_} = $idx++;
+}
+
+cmp_ok ($test1_mro->{'A::SubComp'}, '<', $test1_mro->{'A::Comp'}, 'mro of Test1 correct (A::SubComp before A::Comp)' );
+cmp_ok ($test1_mro->{'A::Comp'}, '<', $test1_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test1 correct (A::Comp before UTF8Col)' );
+cmp_ok ($test1_mro->{'DBIx::Class::UTF8Columns'}, '<', $test1_mro->{'DBIx::Class::Core'}, 'mro of Test1 correct (UTF8Col before Core)' );
+cmp_ok ($test1_mro->{'DBIx::Class::Core'}, '<', $test1_mro->{'DBIx::Class::Row'}, 'mro of Test1 correct (Core before Row)' );
+
+warnings_like (
+ sub {
+ package A::Test2;
use base 'DBIx::Class::Core';
__PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
+ sub store_column { shift->next::method (@_) };
+ 1;
+ },
+ [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/],
+ 'incorrect order warning issued (violator defines)',
+);
+
+warnings_like (
+ sub {
+ package A::Test3;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp));
+ sub store_column { shift->next::method (@_) };
1;
},
- qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding store_column \(A::Comp\)/,
- 'incorrect order warning issued',
+ [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::SubComp \(via A::Comp\)\)/],
+ 'incorrect order warning issued (violator inherits)',
);
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->utf8_columns('title');
Class::C3->reinitialize();
-my $cd = $schema->resultset('CD')->create( { artist => 1, title => "weird\x{466}stuff", year => '2048' } );
+# as per http://search.cpan.org/dist/Test-Simple/lib/Test/More.pm#utf8
+binmode (Test::More->builder->$_, ':utf8') for qw/output failure_output todo_output/;
+
+my $bytestream_title = my $utf8_title = "weird \x{466} stuff";
+utf8::encode($bytestream_title);
+cmp_ok ($bytestream_title, 'ne', $utf8_title, 'unicode/raw differ (sanity check)');
+
+my $storage = $schema->storage;
+my ($sql, @bind);
+my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
+my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
+$storage->debugobj ($debugobj);
+$storage->debug (1);
+
+my $cd = $schema->resultset('CD')->create( { artist => 1, title => $utf8_title, year => '2048' } );
+
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
+
+# bind values are always alphabetically ordered by column, thus [1]
+# the single quotes are an artefact of the debug-system
+TODO: {
+ local $TODO = "This has been broken since rev 1191, Mar 2006";
+ is ($bind[1], "'$bytestream_title'", 'INSERT: raw bytes sent to the database');
+}
+
+# this should be using the cursor directly, no inflation/processing of any sort
+my ($raw_db_title) = $schema->resultset('CD')
+ ->search ($cd->ident_condition)
+ ->get_column('title')
+ ->_resultset
+ ->cursor
+ ->next;
-ok( utf8::is_utf8( $cd->title ), 'got title with utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store title without utf8' );
+is ($raw_db_title, $bytestream_title, 'INSERT: raw bytes retrieved from database');
-ok(! utf8::is_utf8( $cd->year ), 'got year without utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{year} ), 'store year without utf8' );
+for my $reloaded (0, 1) {
+ my $test = $reloaded ? 'reloaded' : 'stored';
+ $cd->discard_changes if $reloaded;
+
+ ok( utf8::is_utf8( $cd->title ), "got $test title with utf8 flag" );
+ ok(! utf8::is_utf8( $cd->{_column_data}{title} ), "in-object $test title without utf8" );
+
+ ok(! utf8::is_utf8( $cd->year ), "got $test year without utf8 flag" );
+ ok(! utf8::is_utf8( $cd->{_column_data}{year} ), "in-object $test year without utf8" );
+}
$cd->title('nonunicode');
-ok(! utf8::is_utf8( $cd->title ), 'got title without utf8 flag' );
-ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less chars' );
+ok(! utf8::is_utf8( $cd->title ), 'update title without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'store utf8-less title' );
+
+$cd->update;
+$cd->discard_changes;
+ok(! utf8::is_utf8( $cd->title ), 'reloaded title without utf8 flag' );
+ok(! utf8::is_utf8( $cd->{_column_data}{title} ), 'reloaded utf8-less title' );
+
+$bytestream_title = $utf8_title = "something \x{219} else";
+utf8::encode($bytestream_title);
+
+
+$storage->debugobj ($debugobj);
+$storage->debug (1);
+
+$cd->update ({ title => $utf8_title });
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
-my $v_utf8 = "\x{219}";
+is ($bind[0], "'$bytestream_title'", 'UPDATE: raw bytes sent to the database');
+($raw_db_title) = $schema->resultset('CD')
+ ->search ($cd->ident_condition)
+ ->get_column('title')
+ ->_resultset
+ ->cursor
+ ->next;
+is ($raw_db_title, $bytestream_title, 'UPDATE: raw bytes retrieved from database');
-$cd->update ({ title => $v_utf8 });
-$cd->title($v_utf8);
+$cd->discard_changes;
+$cd->title($utf8_title);
ok( !$cd->is_column_changed('title'), 'column is not dirty after setting the same unicode value' );
-$cd->update ({ title => $v_utf8 });
+$cd->update ({ title => $utf8_title });
$cd->title('something_else');
ok( $cd->is_column_changed('title'), 'column is dirty after setting to something completely different');
TODO: {
local $TODO = 'There is currently no way to propagate aliases to inflate_result()';
- $cd = $schema->resultset('CD')->find ({ title => $v_utf8 }, { select => 'title', as => 'name' });
+ $cd = $schema->resultset('CD')->find ({ title => $utf8_title }, { select => 'title', as => 'name' });
ok (utf8::is_utf8( $cd->get_column ('name') ), 'utf8 flag propagates via as');
}
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Warn;
$cd->update;
-is($queries, 1, 'liner_notes (might_have) not prefetched - do not load
+is($queries, 1, 'liner_notes (might_have) not prefetched - do not load
liner_notes on update');
$schema->storage->debug($sdebug);
$cd2->update;
-is($queries, 1, 'liner_notes (might_have) prefetched - do not load
+is($queries, 1, 'liner_notes (might_have) prefetched - do not load
liner_notes on update');
warning_like {
{
local $ENV{DBIC_DONT_VALIDATE_RELS} = 1;
- warning_is {
+ warning_is {
DBICTest::Schema::Bookmark->might_have(
slinky => 'DBICTest::Schema::Link',
{ "foreign.id" => "self.link" },
use lib qw(t/lib);
use DBICTest;
+use Scalar::Util 'blessed';
+
BEGIN {
require DBIx::Class;
plan skip_all =>
return $self->next::method(@_);
}
-my $schema = DBICTest->init_schema (no_deploy => 1);
-
# Check deployment statements ctx sensitivity
{
+ my $schema = DBICTest->init_schema (no_deploy => 1);
my $not_first_table_creation_re = qr/CREATE TABLE fourkeys_to_twokeys/;
-
my $statements = $schema->deployment_statements;
like (
$statements,
);
}
+{
+ # use our own throw-away schema, since we'll be deploying twice
+ my $schema = DBICTest->init_schema (no_deploy => 1);
+
+ my $deploy_hook_called = 0;
+ $custom_deployment_statements_called = 0;
+
+ # add a temporary sqlt_deploy_hook to a source
+ local $DBICTest::Schema::Track::hook_cb = sub {
+ my ($class, $sqlt_table) = @_;
+
+ $deploy_hook_called = 1;
+
+ is ($class, 'DBICTest::Track', 'Result class passed to plain hook');
+
+ is (
+ $sqlt_table->schema->translator->producer_type,
+ join ('::', 'SQL::Translator::Producer', $schema->storage->sqlt_type),
+ 'Production type passed to translator object',
+ );
+ };
+
+ my $component_deploy_hook_called = 0;
+ local $DBICTest::DeployComponent::hook_cb = sub {
+ $component_deploy_hook_called = 1;
+ };
+
+ $schema->deploy; # do not remove, this fires the is() test in the callback above
+ ok($deploy_hook_called, 'deploy hook got called');
+ ok($custom_deployment_statements_called, '->deploy used the schemas deploy_statements method');
+ ok($component_deploy_hook_called, 'component deploy hook got called');
+}
+my $schema = DBICTest->init_schema (no_deploy => 1);
{
my $deploy_hook_called = 0;
+ $custom_deployment_statements_called = 0;
+ my $sqlt_type = $schema->storage->sqlt_type;
# replace the sqlt calback with a custom version ading an index
$schema->source('Track')->sqlt_deploy_callback(sub {
is (
$sqlt_table->schema->translator->producer_type,
- join ('::', 'SQL::Translator::Producer', $schema->storage->sqlt_type),
+ join ('::', 'SQL::Translator::Producer', $sqlt_type),
'Production type passed to translator object',
);
- if ($schema->storage->sqlt_type eq 'SQLite' ) {
+ if ($sqlt_type eq 'SQLite' ) {
$sqlt_table->add_index( name => 'track_title', fields => ['title'] )
or die $sqlt_table->error;
}
}
-my $translator = SQL::Translator->new(
+my $translator = SQL::Translator->new(
parser_args => {
'DBIx::Schema' => $schema,
},
{
'display' => 'twokeys->cd',
'name' => 'twokeys_fk_cd', 'index_name' => 'twokeys_idx_cd',
- 'selftable' => 'twokeys', 'foreigntable' => 'cd',
- 'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
+ 'selftable' => 'twokeys', 'foreigntable' => 'cd',
+ 'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
'noindex' => 1,
on_delete => '', on_update => '', deferrable => 0,
},
{
'display' => 'twokeys->artist',
'name' => 'twokeys_fk_artist', 'index_name' => 'twokeys_idx_artist',
- 'selftable' => 'twokeys', 'foreigntable' => 'artist',
+ 'selftable' => 'twokeys', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'fourkeys_to_twokeys->twokeys',
'name' => 'fourkeys_to_twokeys_fk_t_artist_t_cd', 'index_name' => 'fourkeys_to_twokeys_idx_t_artist_t_cd',
- 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
- 'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
+ 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
+ 'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye',
'name' => 'fourkeys_to_twokeys_fk_f_foo_f_bar_f_hello_f_goodbye',
- 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
+ 'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)],
- 'foreigncols' => [qw(foo bar hello goodbye)],
+ 'foreigncols' => [qw(foo bar hello goodbye)],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
],
{
'display' => 'cd_to_producer->cd',
'name' => 'cd_to_producer_fk_cd', 'index_name' => 'cd_to_producer_idx_cd',
- 'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
+ 'selftable' => 'cd_to_producer', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'cd_to_producer->producer',
'name' => 'cd_to_producer_fk_producer', 'index_name' => 'cd_to_producer_idx_producer',
- 'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
+ 'selftable' => 'cd_to_producer', 'foreigntable' => 'producer',
'selfcols' => ['producer'], 'foreigncols' => ['producerid'],
on_delete => '', on_update => '', deferrable => 1,
},
{
'display' => 'self_ref_alias->self_ref for self_ref',
'name' => 'self_ref_alias_fk_self_ref', 'index_name' => 'self_ref_alias_idx_self_ref',
- 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
+ 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['self_ref'], 'foreigncols' => ['id'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'self_ref_alias->self_ref for alias',
'name' => 'self_ref_alias_fk_alias', 'index_name' => 'self_ref_alias_idx_alias',
- 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
+ 'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref',
'selfcols' => ['alias'], 'foreigncols' => ['id'],
on_delete => '', on_update => '', deferrable => 1,
},
{
'display' => 'cd->artist',
'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist',
- 'selftable' => 'cd', 'foreigntable' => 'artist',
+ 'selftable' => 'cd', 'foreigntable' => 'artist',
'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'artist_undirected_map->artist for id1',
'name' => 'artist_undirected_map_fk_id1', 'index_name' => 'artist_undirected_map_idx_id1',
- 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
+ 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id1'], 'foreigncols' => ['artistid'],
on_delete => 'RESTRICT', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'artist_undirected_map->artist for id2',
'name' => 'artist_undirected_map_fk_id2', 'index_name' => 'artist_undirected_map_idx_id2',
- 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
+ 'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist',
'selfcols' => ['id2'], 'foreigncols' => ['artistid'],
on_delete => '', on_update => '', deferrable => 1,
},
{
'display' => 'track->cd',
'name' => 'track_fk_cd', 'index_name' => 'track_idx_cd',
- 'selftable' => 'track', 'foreigntable' => 'cd',
+ 'selftable' => 'track', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'treelike->treelike for parent',
'name' => 'treelike_fk_parent', 'index_name' => 'treelike_idx_parent',
- 'selftable' => 'treelike', 'foreigntable' => 'treelike',
+ 'selftable' => 'treelike', 'foreigntable' => 'treelike',
'selfcols' => ['parent'], 'foreigncols' => ['id'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
'name' => 'twokeytreelike_fk_parent1_parent2', 'index_name' => 'twokeytreelike_idx_parent1_parent2',
- 'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
+ 'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike',
'selfcols' => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
on_delete => '', on_update => '', deferrable => 1,
},
{
'display' => 'tags->cd',
'name' => 'tags_fk_cd', 'index_name' => 'tags_idx_cd',
- 'selftable' => 'tags', 'foreigntable' => 'cd',
+ 'selftable' => 'tags', 'foreigntable' => 'cd',
'selfcols' => ['cd'], 'foreigncols' => ['cdid'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'bookmark->link',
'name' => 'bookmark_fk_link', 'index_name' => 'bookmark_idx_link',
- 'selftable' => 'bookmark', 'foreigntable' => 'link',
+ 'selftable' => 'bookmark', 'foreigntable' => 'link',
'selfcols' => ['link'], 'foreigncols' => ['id'],
on_delete => 'SET NULL', on_update => 'CASCADE', deferrable => 1,
},
{
'display' => 'forceforeign->artist',
'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist',
- 'selftable' => 'forceforeign', 'foreigntable' => 'artist',
- 'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
+ 'selftable' => 'forceforeign', 'foreigntable' => 'artist',
+ 'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
'noindex' => 1,
on_delete => '', on_update => '', deferrable => 1,
},
skip ('Artist sqlt_deploy_hook is only called with an SQLite backend', 1)
if $schema->storage->sqlt_type ne 'SQLite';
- ok( ( grep
+ ok( ( grep
{ $_->name eq 'artist_name_hookidx' }
$tschema->get_table('artist')->get_indices
), 'sqlt_deploy_hook fired within a resultsource');
CAND_INDEX:
for my $cand_index ( $table->get_indices ) {
-
+
next CAND_INDEX if $index->{name} && $cand_index->name ne $index->{name}
|| $index->{type} && $cand_index->type ne $index->{type};
# vim: filetype=perl
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
$employee->group_id(1);
$employee->update;
ok(
- check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
- "overloaded update 3"
+ check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
+ "overloaded update 3"
);
$employee = $employees->search({group_id=>4})->first;
$employee->update({group_id=>2});
ok(
- check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
- "overloaded update 4"
+ check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
+ "overloaded update 4"
);
$employee = $employees->search({group_id=>4})->first;
$employee->group_id(1);
$employee->position(3);
$employee->update;
ok(
- check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
- "overloaded update 5"
+ check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
+ "overloaded update 5"
);
$employee = $employees->search({group_id=>4})->first;
$employee->group_id(2);
$employee->position(undef);
$employee->update;
ok(
- check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
- "overloaded update 6"
+ check_rs($employees->search_rs({group_id=>2})) && check_rs($employees->search_rs({group_id=>4})),
+ "overloaded update 6"
);
$employee = $employees->search({group_id=>4})->first;
$employee->update({group_id=>1,position=>undef});
ok(
- check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
- "overloaded update 7"
+ check_rs($employees->search_rs({group_id=>1})) && check_rs($employees->search_rs({group_id=>4})),
+ "overloaded update 7"
);
+$employee->group_id(2);
+$employee->name('E of the month');
+$employee->update({ employee_id => 666, position => 2 });
+is_deeply(
+ { $employee->get_columns },
+ {
+ employee_id => 666,
+ encoded => undef,
+ group_id => 2,
+ group_id_2 => undef,
+ group_id_3 => undef,
+ name => "E of the month",
+ position => 2
+ },
+ 'combined update() worked correctly'
+);
+is_deeply(
+ { $employee->get_columns },
+ { $employee->get_from_storage->get_columns },
+ 'object matches database state',
+);
+
+#####
# multicol tests begin here
+#####
+
DBICTest::Employee->grouping_column(['group_id_2', 'group_id_3']);
$employees->delete();
foreach my $group_id_2 (1..4) {
$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
$employee->group_id_2(1);
$employee->update;
-ok(
+ok(
check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
- && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})),
- "overloaded multicol update 1"
+ && check_rs($employees->search_rs({group_id_2=>1, group_id_3=>1})),
+ "overloaded multicol update 1"
);
$employee = $employees->search({group_id_2=>4, group_id_3=>1})->first;
$employee->update({group_id_2=>2});
ok( check_rs($employees->search_rs({group_id_2=>4, group_id_3=>1}))
- && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>1})),
- "overloaded multicol update 2"
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>1})),
+ "overloaded multicol update 2"
);
$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
$employee->update();
ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
&& check_rs($employees->search_rs({group_id_2=>1, group_id_3=>3})),
- "overloaded multicol update 3"
+ "overloaded multicol update 3"
);
$employee = $employees->search({group_id_2=>3, group_id_3=>1})->first;
$employee->update({group_id_2=>2, group_id_3=>3});
ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>1}))
- && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>3})),
- "overloaded multicol update 4"
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>3})),
+ "overloaded multicol update 4"
);
$employee = $employees->search({group_id_2=>3, group_id_3=>2})->first;
$employee->update({group_id_2=>2, group_id_3=>4, position=>2});
ok( check_rs($employees->search_rs({group_id_2=>3, group_id_3=>2}))
- && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>4})),
- "overloaded multicol update 5"
+ && check_rs($employees->search_rs({group_id_2=>2, group_id_3=>4})),
+ "overloaded multicol update 5"
);
sub hammer_rs {
# test distinct propagation
is_deeply (
- [$rs->search ({}, { distinct => 1 })->get_column ('year')->all],
- [$rs_year->func('distinct')],
+ [sort $rs->search ({}, { distinct => 1 })->get_column ('year')->all],
+ [sort $rs_year->func('distinct')],
'distinct => 1 is passed through properly',
);
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
is(scalar(@{$merge_rs_2->{attrs}->{join}}), 1, 'only one join kept when inherited');
my $merge_rs_2_cd = $merge_rs_2->next;
-eval {
+lives_ok (sub {
my @rs_with_prefetch = $schema->resultset('TreeLike')
->search(
prefetch => [ 'parent', { 'children' => 'parent' } ],
});
-};
-
-ok(!$@, "pathological prefetch ok");
+}, 'pathological prefetch ok');
my $rs = $schema->resultset("Artist")->search({}, { join => 'twokeys' });
my $second_search_rs = $rs->search({ 'cds_2.cdid' => '2' }, { join =>
is(scalar(@{$second_search_rs->{attrs}->{join}}), 3, 'both joins kept');
ok($second_search_rs->next, 'query on double joined rel runs okay');
+# test joinmap pruner
+lives_ok ( sub {
+ my $rs = $schema->resultset('Artwork')->search (
+ {
+ },
+ {
+ distinct => 1,
+ join => [
+ { artwork_to_artist => 'artist' },
+ { cd => 'artist' },
+ ],
+ },
+ );
+
+ is_same_sql_bind (
+ $rs->count_rs->as_query,
+ '(
+ SELECT COUNT( * )
+ FROM (
+ SELECT me.cd_id
+ FROM cd_artwork me
+ JOIN cd cd ON cd.cdid = me.cd_id
+ JOIN artist artist_2 ON artist_2.artistid = cd.artist
+ GROUP BY me.cd_id
+ ) me
+ )',
+ [],
+ );
+
+ ok (defined $rs->count);
+});
+
+# make sure multiplying endpoints do not lose heir join-path
+lives_ok (sub {
+ my $rs = $schema->resultset('CD')->search (
+ { },
+ { join => { artwork => 'images' } },
+ )->get_column('cdid');
+
+ is_same_sql_bind (
+ $rs->as_query,
+ '(
+ SELECT me.cdid
+ FROM cd me
+ LEFT JOIN cd_artwork artwork
+ ON artwork.cd_id = me.cdid
+ LEFT JOIN images images
+ ON images.artwork_id = artwork.cd_id
+ )',
+ [],
+ );
+
+ # execution
+ $rs->next;
+});
+
done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $a = 'artist';
my $b = 'cd';
my $expected = [ 'artist', 'cd' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist' ];
my $b = [ 'cd' ];
my $expected = [ 'artist', 'cd' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd' ];
my $b = [ 'cd' ];
my $expected = [ 'artist', 'cd' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'artist' ];
my $b = [ 'artist', 'cd' ];
my $expected = [ 'artist', 'artist', 'cd' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd' ];
my $b = [ 'artist', 'artist' ];
my $expected = [ 'artist', 'cd', 'artist' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'twokeys' ];
my $b = [ 'cds', 'cds' ];
my $expected = [ 'twokeys', 'cds', 'cds' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = 'artist';
my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = [ 'artist', 'cd' ];
my $expected = [ 'artist', 'cd', { 'artist' => 'manager' } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = { 'artist' => 'manager' };
my $expected = [ 'artist', 'cd', { 'artist' => [ 'manager' ] } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = { 'artist' => 'agent' };
my $expected = [ { 'artist' => 'agent' }, 'cd', { 'artist' => 'manager' } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = { 'artist' => { 'manager' => 'artist' } };
my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => 'artist' } ] } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = { 'artist' => { 'manager' => [ 'artist', 'label' ] } };
my $expected = [ 'artist', 'cd', { 'artist' => [ { 'manager' => [ 'artist', 'label' ] } ] } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd', { 'artist' => 'manager' } ];
my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd', { 'artist' => 'manager' } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ 'artist', 'cd' ];
my $b = { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } };
my $expected = [ { 'artist' => { 'tour_manager' => [ 'venue', 'roadie' ] } }, 'cd' ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
my $a = [ { 'artist' => 'manager' }, 'cd' ];
my $b = [ 'artist', { 'artist' => 'manager' } ];
my $expected = [ { 'artist' => 'manager' }, 'cd', { 'artist' => 'manager' } ];
- my $result = $rs->_merge_attr($a, $b);
+ my $result = $rs->_merge_joinpref_attr($a, $b);
is_deeply( $result, $expected );
}
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
+use DBIC::DebugObj;
{ # Fake storage driver for sqlite with autocast
package DBICTest::SQLite::AutoCast;
'tracks.last_updated_at' => { '!=', undef },
'tracks.last_updated_on' => { '<', 2009 },
'tracks.position' => 4,
- 'tracks.single_track' => \[ '= ?', [ single_track => [1, 2, 3 ] ] ],
+ 'me.single_track' => \[ '= ?', [ single_track => 1 ] ],
}, { join => 'tracks' });
-my $bind = [
- [ cdid => 5 ],
- [ 'tracks.last_updated_on' => 2009 ],
- [ 'tracks.position' => 4 ],
- [ 'single_track' => [ 1, 2, 3] ],
-];
+my ($sql, @bind);
+my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
+my $storage = $schema->storage;
+my ($orig_debug, $orig_debugobj) = ($storage->debug, $storage->debugobj);
+$storage->debugobj ($debugobj);
+$storage->debug (1);
+# the quoting is a debugobj thing, not dbic-internals
+my $bind = [ map { "'$_'" } qw/
+ 5 1 2009 4
+/];
+
+$rs->all;
is_same_sql_bind (
- $rs->as_query,
- '(
+ $sql,
+ \@bind,
+ '
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE
cdid > ?
+ AND me.single_track = ?
AND tracks.last_updated_at IS NOT NULL
AND tracks.last_updated_on < ?
AND tracks.position = ?
- AND tracks.single_track = ?
- )',
+ ',
$bind,
'expected sql with casting off',
);
$schema->storage->auto_cast (1);
+$rs->all;
is_same_sql_bind (
- $rs->as_query,
- '(
+ $sql,
+ \@bind,
+ '
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
LEFT JOIN track tracks ON tracks.cd = me.cdid
WHERE
cdid > CAST(? AS INT)
+ AND me.single_track = CAST(? AS INT)
AND tracks.last_updated_at IS NOT NULL
AND tracks.last_updated_on < CAST (? AS DateTime)
AND tracks.position = ?
- AND tracks.single_track = CAST(? AS INT)
- )',
+ ',
$bind,
'expected sql with casting on',
);
+$storage->debugobj ($orig_debugobj);
+$storage->debug ($orig_debug);
+
done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-# Copied from 71mysql.t, manually using NoBindVars. This is to give that code
-# wider testing, since virtually nobody who regularly runs the test suite
-# is using DBD::Sybase+FreeTDS+MSSQL -- blblack
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-use DBI::Const::GetInfoType;
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
-
-#warn "$dsn $user $pass";
-
-plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $user);
-
-plan tests => 4;
-
-{ # Fake storage driver for mysql + no bind variables
- package DBIx::Class::Storage::DBI::MySQLNoBindVars;
- use Class::C3;
- use base qw/
- DBIx::Class::Storage::DBI::NoBindVars
- DBIx::Class::Storage::DBI::mysql
- /;
- $INC{'DBIx/Class/Storage/DBI/MySQLNoBindVars.pm'} = 1;
-}
-
-# XXX Class::C3 doesn't like some of the Storage stuff happening late...
-Class::C3::reinitialize();
-
-my $schema = DBICTest::Schema->clone;
-$schema->storage_type('::DBI::MySQLNoBindVars');
-$schema->connection($dsn, $user, $pass);
-
-my $dbh = $schema->storage->dbh;
-
-$dbh->do("DROP TABLE IF EXISTS artist;");
-
-$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");
-
-$schema->class('Artist')->load_components('PK::Auto');
-
-# test primary key handling
-my $new = $schema->resultset('Artist')->create({ name => 'foo' });
-ok($new->artistid, "Auto-PK worked");
-
-# test LIMIT support
-for (1..6) {
- $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
-}
-my $it = $schema->resultset('Artist')->search( {},
- { rows => 3,
- offset => 2,
- order_by => 'artistid' }
-);
-is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists
-is( $it->next->name, "Artist 2", "iterator->next ok" );
-$it->next;
-$it->next;
-is( $it->next, undef, "next past end of resultset ok" );
-
-# clean up our mess
-END {
- my $dbh = eval { $schema->storage->_dbh };
- $dbh->do("DROP TABLE artist") if $dbh;
-}
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-my $schema = DBICTest->init_schema();
-
-plan tests => 10;
-
# Test various uses of passing an object to find, create, and update on a single
# rel accessor
{
+ my $schema = DBICTest->init_schema();
my $artist = $schema->resultset("Artist")->find(1);
my $cd = $schema->resultset("CD")->find_or_create({
is($track->get_column('cd'), $another_cd->cdid, 'track matches another CD after update');
}
-$schema = DBICTest->init_schema();
{
- my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
- my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
+ my $schema = DBICTest->init_schema();
+ my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
+ my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
- ok(!defined($cd->get_column('genreid')), 'genreid is NULL'); #no accessor was defined for this column
- ok(!defined($cd->genre), 'genre accessor returns undef');
+ ok(!defined($cd->get_column('genreid')), 'genreid is NULL'); #no accessor was defined for this column
+ ok(!defined($cd->genre), 'genre accessor returns undef');
}
-$schema = DBICTest->init_schema();
-
{
- my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
- my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' });
- my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 });
+ my $schema = DBICTest->init_schema();
+ my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
+ my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' });
+ my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 });
- dies_ok { $cd->genre } 'genre accessor throws without column';
+ dies_ok { $cd->genre } 'genre accessor throws without column';
}
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
-#!/usr/bin/perl
-
use strict;
use warnings;
+
use Test::More;
use Test::Warn;
use Test::Exception;
use Path::Class;
use File::Copy;
+use Time::HiRes qw/time sleep/;
+
+use lib qw(t/lib);
+use DBICTest;
-#warn "$dsn $user $pass";
my ($dsn, $user, $pass);
BEGIN {
plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
unless ($dsn);
- eval { require Time::HiRes }
- || plan skip_all => 'Test needs Time::HiRes';
- Time::HiRes->import(qw/time sleep/);
-
require DBIx::Class;
plan skip_all =>
'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy');
+
+ plan skip_all =>
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql');
}
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
+# this is just to grab a lock
+{
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+}
use_ok('DBICVersion_v1');
my $version_table_name = 'dbix_class_schema_versions';
my $old_table_name = 'SchemaVersions';
-my $ddl_dir = dir ('t', 'var');
-mkdir ($ddl_dir) unless -d $ddl_dir;
+my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$");
+$ddl_dir->mkpath unless -d $ddl_dir;
my $fn = {
v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'),
warnings_exist (
sub { $schema_v2->create_ddl_dir('MySQL', '2.0', $ddl_dir, '1.0') },
[
- qr/Overwriting existing DDL file - $fn->{v2}/,
- qr/Overwriting existing diff file - $fn->{trans_v12}/,
+ qr/Overwriting existing DDL file - \Q$fn->{v2}\E/,
+ qr/Overwriting existing diff file - \Q$fn->{trans_v12}\E/,
],
'An overwrite warning generated for both the DDL and the diff',
);
# attempt v1 -> v3 upgrade
{
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v3->upgrade();
is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
}
+# Now, try a v1 -> v3 upgrade with a file that has comments strategically placed in it.
+# First put the v1 schema back again...
+{
+ # drop all the tables...
+ eval { $schema_v1->storage->dbh->do('drop table ' . $version_table_name) };
+ eval { $schema_v1->storage->dbh->do('drop table ' . $old_table_name) };
+ eval { $schema_v1->storage->dbh->do('drop table TestVersion') };
+
+ {
+ local $DBICVersion::Schema::VERSION = '1.0';
+ $schema_v1->deploy;
+ }
+ is($schema_v1->get_db_version(), '1.0', 'get_db_version 1.0 ok');
+}
+
+# add a "harmless" comment before one of the statements.
+{
+ my ($perl) = $^X =~ /(.+)/;
+ local $ENV{PATH};
+ system( qq($perl -pi.bak -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23}) );
+}
+
+# Then attempt v1 -> v3 upgrade
+{
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
+ $schema_v3->upgrade();
+ is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0');
+
+ # make sure that the column added after the comment is actually added.
+ lives_ok ( sub {
+ $schema_v3->storage->dbh->do('select ExtraColumn from TestVersion');
+ }, 'new column created');
+}
+
+
# check behaviour of DBIC_NO_VERSION_CHECK env var and ignore_version connect attr
{
my $schema_version = DBICVersion::Schema->connect($dsn, $user, $pass);
$schema_v2->deploy;
}
- local $SIG{__WARN__} = sub { warn if $_[0] !~ /Attempting upgrade\.$/ };
+ local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
$schema_v2->upgrade();
is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');
};
-unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
- unlink $_ for (values %$fn);
+# Check that it Schema::Versioned deals with new/all forms of connect arguments.
+{
+ my $get_db_version_run = 0;
+
+ no warnings qw/once redefine/;
+ local *DBIx::Class::Schema::Versioned::get_db_version = sub {
+ $get_db_version_run = 1;
+ return $_[0]->schema_version;
+ };
+
+ # Make sure the env var isn't whats triggering it
+ local $ENV{DBIC_NO_VERSION_CHECK} = 0;
+
+ DBICVersion::Schema->connect({
+ dsn => $dsn,
+ user => $user,
+ pass => $pass,
+ ignore_version => 1
+ });
+
+ ok($get_db_version_run == 0, "attributes pulled from hashref connect_info");
+ $get_db_version_run = 0;
+
+ DBICVersion::Schema->connect( $dsn, $user, $pass, { ignore_version => 1 } );
+ ok($get_db_version_run == 0, "attributes pulled from list connect_info");
+}
+
+END {
+ unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
+ $ddl_dir->rmtree;
+ }
}
done_testing;
use strict;
use warnings;
-# 6 tests
-
use Test::More;
+use Test::Exception;
+
use lib qw(t/lib);
use DBICTest;
-plan skip_all => "DateTime required" unless eval { require DateTime };
-eval "use DateTime::Format::Strptime";
-plan skip_all => 'DateTime::Format::Strptime required' if $@;
-plan 'no_plan';
-use Test::Exception;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
+}
my $schema = DBICTest->init_schema();
my $artist_rs = $schema->resultset('Artist');
is($artist->name, undef);
}
-
-1;
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
{
my $cd_rc = $schema->resultset("CD")->result_class;
-
+
throws_ok {
$schema->resultset("Artist")
->search_rs({}, {result_class => "IWillExplode"})
my $cd_rs3 = $schema->resultset("Artist")->search_rs({},{})->related_resultset('cds');
is($cd_rs->result_class, $cd_rc, 'Correct cd3 result_class');
-
+
isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
}
{
my $cd_rc = $schema->resultset("CD")->result_class;
-
+
my $artist_rs = $schema->resultset("Artist")
->search_rs({}, {result_class => "IWillExplode"})->search({artistid => 1});
is($artist_rs->result_class, 'IWillExplode', 'Correct artist result_class');
-
+
my $cd_rs = $artist_rs->related_resultset('cds');
is($cd_rs->result_class, $cd_rc, 'Correct cd result_class');
-
- isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
+
+ isa_ok(eval{ $cd_rs->find(1) }, $cd_rc, 'Inflated into correct cd result_class');
isa_ok(eval{ $cd_rs->search({ cdid => 1 })->first }, $cd_rc, 'Inflated into correct cd result_class');
}
use warnings;
use Test::More;
+use DBIx::Class::Optional::Dependencies ();
+
+my $env2optdep = {
+ DBICTEST_PG => 'rdbms_pg',
+ DBICTEST_MYSQL => 'test_rdbms_mysql',
+};
+
+plan skip_all => join (' ',
+ 'Set $ENV{DBICTEST_PG_DSN} and/or $ENV{DBICTEST_MYSQL_DSN} _USER and _PASS to run these tests.',
+) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep;
+
use lib qw(t/lib);
use DBICTest;
use DBICTest::Stats;
-my ($create_sql, $dsn, $user, $pass);
-
-if ($ENV{DBICTEST_PG_DSN}) {
- ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
+my $schema;
- $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
-} elsif ($ENV{DBICTEST_MYSQL_DSN}) {
- ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
+for my $prefix (keys %$env2optdep) { SKIP: {
+ my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
- $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
-} else {
- plan skip_all => 'Set DBICTEST_(PG|MYSQL)_DSN _USER and _PASS if you want to run savepoint tests';
-}
+ skip ("Skipping tests with $prefix: set \$ENV{${prefix}_DSN} _USER and _PASS", 1)
+ unless $dsn;
-plan tests => 16;
+ skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
+ unless DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
-my $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
+ $schema = DBICTest::Schema->connect ($dsn,$user,$pass,{ auto_savepoint => 1 });
-my $stats = DBICTest::Stats->new;
+ my $create_sql;
+ $schema->storage->ensure_connected;
+ if ($schema->storage->isa('DBIx::Class::Storage::DBI::Pg')) {
+ $create_sql = "CREATE TABLE artist (artistid serial PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10))";
+ $schema->storage->dbh->do('SET client_min_messages=WARNING');
+ }
+ elsif ($schema->storage->isa('DBIx::Class::Storage::DBI::mysql')) {
+ $create_sql = "CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), rank INTEGER NOT NULL DEFAULT '13', charfield CHAR(10)) ENGINE=InnoDB";
+ }
+ else {
+ skip( 'Untested driver ' . $schema->storage, 1 );
+ }
-$schema->storage->debugobj($stats);
+ note "Testing $prefix";
-$schema->storage->debug(1);
+ my $stats = DBICTest::Stats->new;
+ $schema->storage->debugobj($stats);
+ $schema->storage->debug(1);
-{
- local $SIG{__WARN__} = sub {};
- $schema->storage->dbh->do ('DROP TABLE IF EXISTS artist');
- $schema->storage->dbh->do ($create_sql);
-}
+ $schema->storage->dbh->do ('DROP TABLE IF EXISTS artist');
+ $schema->storage->dbh->do ($create_sql);
-$schema->resultset('Artist')->create({ name => 'foo' });
+ $schema->resultset('Artist')->create({ name => 'foo' });
-$schema->txn_begin;
+ $schema->txn_begin;
-my $arty = $schema->resultset('Artist')->find(1);
+ my $arty = $schema->resultset('Artist')->find(1);
-my $name = $arty->name;
+ my $name = $arty->name;
-# First off, test a generated savepoint name
-$schema->svp_begin;
+ # First off, test a generated savepoint name
+ $schema->svp_begin;
-cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
+ cmp_ok($stats->{'SVP_BEGIN'}, '==', 1, 'Statistics svp_begin tickled');
-$arty->update({ name => 'Jheephizzy' });
+ $arty->update({ name => 'Jheephizzy' });
-$arty->discard_changes;
+ $arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
+ cmp_ok($arty->name, 'eq', 'Jheephizzy', 'Name changed');
-# Rollback the generated name
-# Active: 0
-$schema->svp_rollback;
+ # Rollback the generated name
+ # Active: 0
+ $schema->svp_rollback;
-cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
+ cmp_ok($stats->{'SVP_ROLLBACK'}, '==', 1, 'Statistics svp_rollback tickled');
-$arty->discard_changes;
+ $arty->discard_changes;
-cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
+ cmp_ok($arty->name, 'eq', $name, 'Name rolled back');
-$arty->update({ name => 'Jheephizzy'});
+ $arty->update({ name => 'Jheephizzy'});
-# Active: 0 1
-$schema->svp_begin('testing1');
+ # Active: 0 1
+ $schema->svp_begin('testing1');
-$arty->update({ name => 'yourmom' });
+ $arty->update({ name => 'yourmom' });
-# Active: 0 1 2
-$schema->svp_begin('testing2');
+ # Active: 0 1 2
+ $schema->svp_begin('testing2');
-$arty->update({ name => 'gphat' });
-$arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'gphat', 'name changed');
-# Active: 0 1 2
-# Rollback doesn't DESTROY the savepoint, it just rolls back to the value
-# at it's conception
-$schema->svp_rollback('testing2');
-$arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted');
+ $arty->update({ name => 'gphat' });
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'gphat', 'name changed');
+ # Active: 0 1 2
+ # Rollback doesn't DESTROY the savepoint, it just rolls back to the value
+ # at it's conception
+ $schema->svp_rollback('testing2');
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'yourmom', 'testing2 reverted');
-# Active: 0 1 2 3
-$schema->svp_begin('testing3');
-$arty->update({ name => 'coryg' });
-# Active: 0 1 2 3 4
-$schema->svp_begin('testing4');
-$arty->update({ name => 'watson' });
+ # Active: 0 1 2 3
+ $schema->svp_begin('testing3');
+ $arty->update({ name => 'coryg' });
+ # Active: 0 1 2 3 4
+ $schema->svp_begin('testing4');
+ $arty->update({ name => 'watson' });
-# Release 3, which implicitly releases 4
-# Active: 0 1 2
-$schema->svp_release('testing3');
-$arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'watson', 'release left data');
-# This rolls back savepoint 2
-# Active: 0 1 2
-$schema->svp_rollback;
-$arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2');
+ # Release 3, which implicitly releases 4
+ # Active: 0 1 2
+ $schema->svp_release('testing3');
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'watson', 'release left data');
+ # This rolls back savepoint 2
+ # Active: 0 1 2
+ $schema->svp_rollback;
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'yourmom', 'rolled back to 2');
-# Rollback the original savepoint, taking us back to the beginning, implicitly
-# rolling back savepoint 1 and 2
-$schema->svp_rollback('savepoint_0');
-$arty->discard_changes;
-cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start');
+ # Rollback the original savepoint, taking us back to the beginning, implicitly
+ # rolling back savepoint 1 and 2
+ $schema->svp_rollback('savepoint_0');
+ $arty->discard_changes;
+ cmp_ok($arty->name, 'eq', 'foo', 'rolled back to start');
-$schema->txn_commit;
+ $schema->txn_commit;
-# And now to see if txn_do will behave correctly
+ # And now to see if txn_do will behave correctly
+ $schema->txn_do (sub {
+ my $artycp = $arty;
-$schema->txn_do (sub {
$schema->txn_do (sub {
- $arty->name ('Muff');
-
- $arty->update;
- });
+ $artycp->name ('Muff');
+ $artycp->update;
+ });
eval {
$schema->txn_do (sub {
- $arty->name ('Moff');
-
- $arty->update;
-
- $arty->discard_changes;
-
- is($arty->name,'Moff','Value updated in nested transaction');
-
- $schema->storage->dbh->do ("GUARANTEED TO PHAIL");
- });
+ $artycp->name ('Moff');
+ $artycp->update;
+ $artycp->discard_changes;
+ is($artycp->name,'Moff','Value updated in nested transaction');
+ $schema->storage->dbh->do ("GUARANTEED TO PHAIL");
+ });
};
ok ($@,'Nested transaction failed (good)');
$arty->update;
});
-$arty->discard_changes;
+ $arty->discard_changes;
+
+ is($arty->name,'Miff','auto_savepoint worked');
-is($arty->name,'Miff','auto_savepoint worked');
+ cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created');
-cmp_ok($stats->{'SVP_BEGIN'},'==',7,'Correct number of savepoints created');
+ cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released');
-cmp_ok($stats->{'SVP_RELEASE'},'==',3,'Correct number of savepoints released');
+ cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
-cmp_ok($stats->{'SVP_ROLLBACK'},'==',5,'Correct number of savepoint rollbacks');
+ $schema->storage->dbh->do ("DROP TABLE artist");
+}}
-END { $schema->storage->dbh->do ("DROP TABLE artist") if defined $schema }
+done_testing;
+END {
+ eval { $schema->storage->dbh->do ("DROP TABLE artist") } if defined $schema;
+ undef $schema;
+}
use Test::More;
use Test::Exception;
+use Scalar::Util ();
+
use lib qw(t/lib);
use DBICTest;
-use DBICTest::Schema;
-use Scalar::Util ();
BEGIN {
require DBIx::Class;
# Test for SQLT-related leaks
{
my $s = DBICTest::Schema->clone;
- my $sqlt_schema = create_schema ({ schema => $s });
+
+ my @schemas = (
+ create_schema ({ schema => $s }),
+ create_schema ({ args => { parser_args => { 'DBIx::Class::Schema' => $s } } }),
+ create_schema ({ args => { parser_args => { 'DBIx::Schema' => $s } } }),
+ create_schema ({ args => { parser_args => { package => $s } } }),
+ );
+
Scalar::Util::weaken ($s);
ok (!$s, 'Schema not leaked');
- isa_ok ($sqlt_schema, 'SQL::Translator::Schema', 'SQLT schema object produced');
+ isa_ok ($_, 'SQL::Translator::Schema', "SQLT schema object $_ produced")
+ for @schemas;
}
# make sure classname-style works
lives_ok { isa_ok (create_schema ({ schema => 'DBICTest::Schema' }), 'SQL::Translator::Schema', 'SQLT schema object produced') };
-my $schema = DBICTest->init_schema();
+my $schema = DBICTest->init_schema( no_deploy => 1 );
+
# Dummy was yanked out by the sqlt hook test
# CustomSql tests the horrific/deprecated ->name(\$sql) hack
# YearXXXXCDs are views
});
+{
+ package DBICTest::PartialSchema;
+
+ use base qw/DBIx::Class::Schema/;
+
+ __PACKAGE__->load_classes(
+ { 'DBICTest::Schema' => [qw/
+ CD
+ Track
+ Tag
+ Producer
+ CD_to_Producer
+ /]}
+ );
+}
+
+{
+ my $partial_schema = DBICTest::PartialSchema->connect(DBICTest->_database);
+
+ lives_ok (sub {
+ my $sqlt_schema = do {
+
+ local $SIG{__WARN__} = sub {
+ warn @_
+ unless $_[0] =~ /Ignoring relationship .+ related resultsource .+ is not registered with this schema/
+ };
+
+ create_schema({ schema => $partial_schema });
+ };
+
+ my @tables = $sqlt_schema->get_tables;
+
+ is_deeply (
+ [sort map { $_->name } @tables],
+ [qw/cd cd_to_producer producer tags track/],
+ 'partial dbic schema parsing ok',
+ );
+
+ # the primary key is currently unnamed in sqlt - adding below
+ my %constraints_for_table = (
+ producer => [qw/prod_name /],
+ tags => [qw/tagid_cd tagid_cd_tag tags_fk_cd tags_tagid_tag tags_tagid_tag_cd /],
+ track => [qw/track_cd_position track_cd_title track_fk_cd /],
+ cd => [qw/cd_artist_title cd_fk_single_track /],
+ cd_to_producer => [qw/cd_to_producer_fk_cd cd_to_producer_fk_producer /],
+ );
+
+ for my $table (@tables) {
+ my $tablename = $table->name;
+ my @constraints = $table->get_constraints;
+ is_deeply (
+ [ sort map { $_->name } @constraints ],
+
+ # the primary key (present on all loaded tables) is currently named '' in sqlt
+ # subject to future changes
+ [ '', @{$constraints_for_table{$tablename}} ],
+
+ "constraints of table '$tablename' ok",
+ );
+ }
+ }, 'partial schema tests successful');
+}
+
done_testing;
sub create_schema {
my $additional_sqltargs = $args->{args} || {};
my $sqltargs = {
- add_drop_table => 1,
+ add_drop_table => 1,
ignore_constraint_names => 1,
ignore_index_names => 1,
%{$additional_sqltargs}
use Test::More;
+use lib 't/lib';
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
use Test::Exception;
use Test::Warn;
+use Path::Class;
+
+use lib qw(t/lib);
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
}
-use lib qw(t/lib);
-use DBICTest;
-
-use Path::Class;
-
use_ok 'DBIx::Class::Admin';
+# lock early
+DBICTest->init_schema(no_deploy => 1, no_populate => 1);
-my $sql_dir = dir(qw/t var/);
-my @connect_info = DBICTest->_database(
- no_deploy=>1,
- no_populate=>1,
- sqlite_use_file => 1,
+my $db_fn = DBICTest->_sqlite_dbfilename;
+my @connect_info = (
+ "dbi:SQLite:$db_fn",
+ undef,
+ undef,
+ { on_connect_do => 'PRAGMA synchronous = OFF' },
);
+my $ddl_dir = dir(qw/t var/, "admin_ddl-$$");
+
{ # create the schema
# make sure we are clean
-clean_dir($sql_dir);
+clean_dir($ddl_dir);
my $admin = DBIx::Class::Admin->new(
schema_class=> "DBICTest::Schema",
- sql_dir=> $sql_dir,
- connect_info => \@connect_info,
+ sql_dir=> $ddl_dir,
+ connect_info => \@connect_info,
);
isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
lives_ok { $admin->create('MySQL'); } 'Can create MySQL sql';
lives_ok { $admin->create('SQLite'); } 'Can Create SQLite sql';
+lives_ok {
+ $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/s };
+ $admin->deploy()
+} 'Can Deploy schema';
}
{ # upgrade schema
-#my $schema = DBICTest->init_schema(
-# no_deploy => 1,
-# no_populat => 1,
-# sqlite_use_file => 1,
-#);
-
-clean_dir($sql_dir);
+clean_dir($ddl_dir);
require DBICVersion_v1;
my $admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
- sql_dir => $sql_dir,
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $ddl_dir,
connect_info => \@connect_info,
);
require DBICVersion_v2;
+DBICVersion::Schema->upgrade_directory (undef); # so that we can test use of $ddl_dir
$admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
- sql_dir => $sql_dir,
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $ddl_dir,
connect_info => \@connect_info
);
{
local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /DB version .+? is lower than the schema version/ };
lives_ok {$admin->upgrade();} 'upgrade the schema';
+ dies_ok {$admin->deploy} 'cannot deploy installed schema, should upgrade instead';
}
is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versions match');
{ # install
-clean_dir($sql_dir);
+clean_dir($ddl_dir);
my $admin = DBIx::Class::Admin->new(
- schema_class => 'DBICVersion::Schema',
- sql_dir => $sql_dir,
+ schema_class => 'DBICVersion::Schema',
+ sql_dir => $ddl_dir,
_confirm => 1,
connect_info => \@connect_info,
);
lives_ok { $admin->install("4.0") } 'can force install to allready existing version'
}, qr/Forcing install may not be a good idea/, 'Force warning emitted' );
is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0');
-#clean_dir($sql_dir);
}
sub clean_dir {
my ($dir) = @_;
- $dir = $dir->resolve;
- if ( ! -d $dir ) {
- $dir->mkpath();
- }
- foreach my $file ($dir->children) {
- # skip any hidden files
- next if ($file =~ /^\./);
- unlink $file;
- }
+ $dir->rmtree if -d $dir;
+ unlink $db_fn;
+}
+
+END {
+ clean_dir($ddl_dir);
}
done_testing;
use warnings;
use Test::More;
-
use Test::Exception;
+use lib 't/lib';
+use DBICTest;
+
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
}
-use lib 't/lib';
-use DBICTest;
-
use_ok 'DBIx::Class::Admin';
$admin->insert('Employee', {name =>'Aran'});
- my $expected_data = [
+ my $expected_data = [
[$employee->result_source->columns() ],
- [1,1,undef,undef,undef,'Trout'],
- [2,2,undef,undef,undef,'Aran']
+ [1,1,undef,undef,undef,'Trout',undef],
+ [2,2,undef,undef,undef,'Aran',undef]
];
my $data;
lives_ok { $data = $admin->select('Employee')} 'can retrive data from database';
use Test::More;
use Config;
use lib qw(t/lib);
-$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
use DBICTest;
-
BEGIN {
require DBIx::Class;
plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin_script')
unless DBIx::Class::Optional::Dependencies->req_ok_for('admin_script');
}
+$ENV{PATH} = '';
+$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+
my @json_backends = qw/XS JSON DWIW/;
-my $tests_per_run = 5;
-plan tests => $tests_per_run * @json_backends;
+# test the script is setting @INC properly
+test_exec (qw|-It/lib/testinclude --schema=DBICTestAdminInc --connect=[] --insert|);
+cmp_ok ( $? >> 8, '==', 70, 'Correct exit code from connecting a custom INC schema' );
+
+# test that config works properly
+{
+ no warnings 'qw';
+ test_exec(qw|-It/lib/testinclude --schema=DBICTestConfig --create --connect=["klaatu","barada","nikto"]|);
+ cmp_ok( $? >> 8, '==', 71, 'Correct schema loaded via config' ) || exit;
+}
+
+# test that config-file works properly
+test_exec(qw|-It/lib/testinclude --schema=DBICTestConfig --config=t/lib/admincfgtest.json --config-stanza=Model::Gort --deploy|);
+cmp_ok ($? >> 8, '==', 71, 'Correct schema loaded via testconfig');
for my $js (@json_backends) {
eval {JSON::Any->import ($js) };
SKIP: {
- skip ("Json backend $js is not available, skip testing", $tests_per_run) if $@;
+ skip ("JSON backend $js is not available, skip testing", 1) if $@;
$ENV{JSON_ANY_ORDER} = $js;
eval { test_dbicadmin () };
}
}
+done_testing();
+
sub test_dbicadmin {
my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); # reinit a fresh db for every run
my $employees = $schema->resultset('Employee');
- system( _prepare_system_args( qw|--op=insert --set={"name":"Matt"}| ) );
+ test_exec( default_args(), qw|--op=insert --set={"name":"Matt"}| );
ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: insert count" );
my $employee = $employees->find(1);
ok( ($employee->name() eq 'Matt'), "$ENV{JSON_ANY_ORDER}: insert valid" );
- system( _prepare_system_args( qw|--op=update --set={"name":"Trout"}| ) );
+ test_exec( default_args(), qw|--op=update --set={"name":"Trout"}| );
$employee = $employees->find(1);
ok( ($employee->name() eq 'Trout'), "$ENV{JSON_ANY_ORDER}: update" );
- system( _prepare_system_args( qw|--op=insert --set={"name":"Aran"}| ) );
+ test_exec( default_args(), qw|--op=insert --set={"name":"Aran"}| );
SKIP: {
skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
- open(my $fh, "-|", _prepare_system_args( qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+ my ($perl) = $^X =~ /(.*)/;
+
+ open(my $fh, "-|", ( $perl, 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
my $data = do { local $/; <$fh> };
close($fh);
if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) {
};
}
- system( _prepare_system_args( qw|--op=delete --where={"name":"Trout"}| ) );
+ test_exec( default_args(), qw|--op=delete --where={"name":"Trout"}| );
ok( ($employees->count()==1), "$ENV{JSON_ANY_ORDER}: delete" );
}
+sub default_args {
+ my $dbname = DBICTest->_sqlite_dbfilename;
+ return (
+ qw|--quiet --schema=DBICTest::Schema --class=Employee|,
+ qq|--connect=["dbi:SQLite:dbname=$dbname","","",{"AutoCommit":1}]|,
+ qw|--force -I testincludenoniterference|,
+ );
+}
+
# Why do we need this crap? Apparently MSWin32 can not pass through quotes properly
# (sometimes it will and sometimes not, depending on what compiler was used to build
# perl). So we go the extra mile to escape all the quotes. We can't also use ' instead
# of ", because JSON::XS (proudly) does not support "malformed JSON" as the author
# calls it. Bleh.
#
-sub _prepare_system_args {
- my $perl = $^X;
-
- my @args = (
- qw|script/dbicadmin --quiet --schema=DBICTest::Schema --class=Employee|,
- q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|,
- qw|--force|,
- @_,
- );
-
- if ( $^O eq 'MSWin32' ) {
- $perl = qq|"$perl"|; # execution will fail if $^X contains paths
- for (@args) {
- $_ =~ s/"/\\"/g;
- }
+sub test_exec {
+ my ($perl) = $^X =~ /(.*)/;
+
+ my @args = ('script/dbicadmin', @_);
+
+ if ( $^O eq 'MSWin32' ) {
+ $perl = qq|"$perl"|; # execution will fail if $^X contains paths
+ for (@args) {
+ $_ =~ s/"/\\"/g;
}
+ }
- return ($perl, @args);
+ system ($perl, @args);
}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
-my ($dsn, $dbuser, $dbpass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
- unless ($dsn && $dbuser);
-
-plan tests => 6;
-
-my $schema = DBICTest::Schema->connection($dsn, $dbuser, $dbpass, { AutoCommit => 1 });
-
-my $dbh = $schema->storage->dbh;
-
-{
- local $SIG{__WARN__} = sub {};
- $dbh->do('DROP TABLE IF EXISTS bindtype_test');
-
- # the blob/clob are for reference only, will be useful when we switch to SQLT and can test Oracle along the way
- $dbh->do(qq[
- CREATE TABLE bindtype_test
- (
- id serial NOT NULL PRIMARY KEY,
- bytea bytea NULL,
- blob bytea NULL,
- clob text NULL
- );
- ],{ RaiseError => 1, PrintError => 1 });
-}
-
-my $big_long_string = "\x00\x01\x02 abcd" x 125000;
-
-my $new;
-# test inserting a row
-{
- $new = $schema->resultset('BindType')->create({ bytea => $big_long_string });
-
- ok($new->id, "Created a bytea row");
- is($new->bytea, $big_long_string, "Set the blob correctly.");
-}
-
-# test retrieval of the bytea column
-{
- my $row = $schema->resultset('BindType')->find({ id => $new->id });
- is($row->get_column('bytea'), $big_long_string, "Created the blob correctly.");
-}
-
-{
- my $rs = $schema->resultset('BindType')->search({ bytea => $big_long_string });
-
- # search on the bytea column (select)
- {
- my $row = $rs->first;
- is($row ? $row->id : undef, $new->id, "Found the row searching on the bytea column.");
- }
-
- # search on the bytea column (update)
- {
- my $new_big_long_string = $big_long_string . "2";
- $schema->txn_do(sub {
- $rs->update({ bytea => $new_big_long_string });
- my $row = $schema->resultset('BindType')->find({ id => $new->id });
- is($row ? $row->get_column('bytea') : undef, $new_big_long_string,
- "Updated the row correctly (searching on the bytea column)."
- );
- $schema->txn_rollback;
- });
- }
-
- # search on the bytea column (delete)
- {
- $schema->txn_do(sub {
- $rs->delete;
- my $row = $schema->resultset('BindType')->find({ id => $new->id });
- is($row, undef, "Deleted the row correctly (searching on the bytea column).");
- $schema->txn_rollback;
- });
- }
-}
-
-$dbh->do("DROP TABLE bindtype_test");
use Test::More;
use lib 't/cdbi/testlib';
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@") : (tests=> 24);
-}
-
#-----------------------------------------------------------------------
# Make sure that we can set up columns properly
is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
+done_testing;
use strict;
use Test::More;
+use Scalar::Util 'refaddr';
+use namespace::clean;
$| = 1;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- plan tests => 98;
-}
-
INIT {
use lib 't/cdbi/testlib';
use Film;
eval { my $id = Film->title };
#like $@, qr/class method/, "Can't get title with no object";
ok $@, "Can't get title with no object";
-}
+}
eval { my $duh = Film->insert; };
like $@, qr/create needs a hashref/, "needs a hashref";
# Test that a disconnect doesnt harm anything.
{
- # SQLite is loud on disconnect/reconnect.
+ # SQLite is loud on disconnect/reconnect.
# This is solved in DBIC but not in ContextualFetch
local $SIG{__WARN__} = sub {
warn @_ unless $_[0] =~
# my bad taste is your bad taste
my $btaste = Film->retrieve('Bad Taste');
my $btaste2 = Film->retrieve('Bad Taste');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ is refaddr $btaste, refaddr $btaste2,
"Retrieving twice gives ref to same object";
my ($btaste5) = Film->search(title=>'Bad Taste');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste5),
+ is refaddr $btaste, refaddr $btaste5,
"Searching also gives ref to same object";
$btaste2->remove_from_object_index;
my $btaste3 = Film->retrieve('Bad Taste');
- isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste3),
+ isnt refaddr $btaste2, refaddr $btaste3,
"Removing from object_index and retrieving again gives new object";
$btaste3->clear_object_index;
my $btaste4 = Film->retrieve('Bad Taste');
- isnt Scalar::Util::refaddr($btaste2), Scalar::Util::refaddr($btaste4),
+ isnt refaddr $btaste2, refaddr $btaste4,
"Clearing cache and retrieving again gives new object";
-
+
$btaste=Film->insert({
Title => 'Bad Taste 2',
Director => 'Peter Jackson',
NumExplodingSheep => 2,
});
$btaste2 = Film->retrieve('Bad Taste 2');
- is Scalar::Util::refaddr($btaste), Scalar::Util::refaddr($btaste2),
+ is refaddr $btaste, refaddr $btaste2,
"Creating and retrieving gives ref to same object";
-
+
}
+
+done_testing;
# Make sure subclasses can be themselves subclassed
#----------------------------------------------------------------------
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
-}
-
use lib 't/cdbi/testlib';
use Film;
isa_ok $btaste => "Film::Threat";
isa_ok $btaste => "Film";
is $btaste->Title, 'Bad Taste', 'subclass get()';
+
+done_testing;
-#!/usr/bin/perl -w
-
use strict;
+use warnings;
use Test::More;
use Test::Warn;
# Test lazy loading
#----------------------------------------------------------------------
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@
- ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
- : (tests => 36)
- ;
-}
-
INIT {
use lib 't/cdbi/testlib';
use Lazy;
}, undef, 23, $l->this);
is $l->oop, 23;
-
+
$l->delete;
}
inflate => sub { Date::Simple->new($_[0] . '-01-01') },
deflate => 'format'
);
-
+
my $l = Lazy->create({
this => 89,
that => 2,
SET orp = ?
WHERE this = ?
}, undef, 1987, $l->this);
-
+
is $l->orp, '1987-01-01';
$l->orp(2007);
is $l->orp, '2007-01-01'; # make sure it's inflated
$l->update;
-
+
ok $l->db_Main->do(qq{
UPDATE @{[ $l->table ]}
SET orp = ?
}, undef, 1942, $l->this);
is $l->orp, '1942-01-01';
-
+
$l->delete;
}
oop => 3,
opop => 4,
});
-
+
# Delete the object without it knowing.
Lazy->db_Main->do(qq[
DELETE
FROM @{[ Lazy->table ]}
WHERE this = 99
]);
-
+
$l->eep;
-
+
# The problem was when an object had an inflated object
# loaded. _flesh() would set _column_data to undef and
# get_column() would think nothing was there.
# I'm too lazy to set up the proper inflation test.
ok !exists $l->{_column_data}{orp};
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 24);
-}
-
@YA::Film::ISA = 'Film';
#local $SIG{__WARN__} = sub { };
isa_ok($bar->fav, "Foo");
isa_ok($foo->fav, "Film");
-{
+{
my $foo;
Foo->add_trigger(after_create => sub { $foo = shift->fav });
my $gwh = Foo->create({ id => 93, fav => 'Good Will Hunting' });
isa_ok $foo, "Film", "Object in after_create trigger";
}
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
- : (tests=> 3);
-}
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite;
package A;
@A::ISA = qw(DBIx::Class::CDBICompat);
is join (' ', sort A->columns), 'id', "A columns";
is join (' ', sort A::B->columns), 'b1 id', "A::B columns";
is join (' ', sort A::C->columns), 'c1 c2 c3 id', "A::C columns";
+
+done_testing;
use strict;
use Test::More;
-
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 31);
-}
-
-
use lib 't/cdbi/testlib';
use Film;
use Actor;
is_deeply [sort map { $_->id } $other_thing->things], [1,2];
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 13);
-}
-
use lib 't/cdbi/testlib';
use Film;
ok $ver->delete, "Delete";
{
- Film->add_trigger(before_create => sub {
+ Film->add_trigger(before_create => sub {
my $self = shift;
ok !$self->_attribute_exists('title'), "PK doesn't auto-vivify";
});
Film->create({director => "Me"});
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 50);
-}
-
use lib 't/cdbi/testlib';
use Actor;
use Film;
# make sure nothing gets clobbered;
test_normal_iterator;
-SKIP: {
- #skip "dbic iterators don't support slice yet", 12;
-
-
{
my @acts = $film->actors->slice(1, 2);
is @acts, 2, "Slice gives 2 actor";
package Class::DBI::My::Iterator;
-use vars qw/@ISA/;
+our @ISA;
@ISA = ($it_class);
is $@, '', "Deleting again does no harm";
}
-} # end SKIP block
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 23);
-}
-
use lib 't/cdbi/testlib';
use Film;
is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector";
}
+done_testing;
+
__DATA__
use CGI::Untaint;
return 1;
});
}
-
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 22);
-}
-
use lib 't/cdbi/testlib';
use Film;
use Blurb;
$blurb = Blurb->retrieve('Bad Taste');
is $blurb, undef, "Blurb has gone";
}
-
+
}
{
ok $host->info->delete;
$host->discard_changes;
ok !$host->info, 'relationships rechecked after discard_changes';
-}
\ No newline at end of file
+}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 75);
-}
-
INIT {
#local $SIG{__WARN__} =
#sub { like $_[0], qr/clashes with built-in method/, $_[0] };
$_->discard_changes for ($naked, $sandl);
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
-}
-
use lib 't/cdbi/testlib';
-require Film;
-require Order;
+use Film;
+use Order;
Film->has_many(orders => 'Order');
Order->has_a(film => 'Film');
isa_ok $infilm, "Film";
is $infilm->id, $film->id, "Orders hasa Film";
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41);
-}
-
use lib 't/cdbi/testlib';
use Film;
use Director;
eval { Film->has_a(driector => "Director") };
like $@, qr/driector/, "Sensible error from has_a with incorrect column: $@";
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 20);
-}
-
use lib 't/cdbi/testlib';
use Film;
use Actor;
my @cols = Film->columns('Essential');
is_deeply \@cols, ['title'], "1 Column in essential";
is +Film->transform_sql('__ESSENTIAL__'), 'title', '__ESSENTIAL__ expansion';
-
+
# This provides a more interesting test
Film->columns(Essential => qw(title rating));
is +Film->transform_sql('__ESSENTIAL__'), 'title, rating',
SELECT __ESSENTIAL__
FROM __TABLE__
WHERE __TABLE__.rating = 'PG'
- ORDER BY title DESC
+ ORDER BY title DESC
}
);
SELECT __ESSENTIAL__
FROM __TABLE__
WHERE rating = ?
- ORDER BY title DESC
+ ORDER BY title DESC
}
);
WHERE __IDENTIFIER__
}
);
-
+
my $film = Film->retrieve_all->first;
my @found = Film->search_by_id($film->id);
is @found, 1;
Film->set_sql(
namerate => qq{
SELECT __ESSENTIAL(f)__
- FROM __TABLE(=f)__, __TABLE(Actor=a)__
- WHERE __JOIN(a f)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(a f)__
AND a.name LIKE ?
AND f.rating = ?
- ORDER BY title
+ ORDER BY title
}
);
Film->set_sql(
ratename => qq{
SELECT __ESSENTIAL(f)__
- FROM __TABLE(=f)__, __TABLE(Actor=a)__
- WHERE __JOIN(f a)__
+ FROM __TABLE(=f)__, __TABLE(Actor=a)__
+ WHERE __JOIN(f a)__
AND f.rating = ?
AND a.name LIKE ?
- ORDER BY title
+ ORDER BY title
}
);
is $apg[1]->title, "B", "and B";
}
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 37);
-}
-
use lib 't/cdbi/testlib';
use Film;
is $it, 0;
ok !$it, "iterator returns false when no results";
}
+
+done_testing;
use Test::More;
-eval "use DBIx::Class::CDBICompat;";
-if ($@) {
- plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
- next;
-}
-
-plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
- unless ($ENV{DBICTEST_MYSQL_DSN} && $ENV{DBICTEST_MYSQL_USER});
-
-eval { require Time::Piece::MySQL };
-plan skip_all => "Need Time::Piece::MySQL for this test" if $@;
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-plan tests => 3;
+eval { require Time::Piece::MySQL }
+ or plan skip_all => 'Time::Piece::MySQL required for this test';
-use lib 't/cdbi/testlib';
use_ok ('Log');
package main;
ok eval { $log->datetime_stamp }, "Have datetime after update";
diag $@ if $@;
+done_testing;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required') : (tests=> 2);
-}
-
use strict;
use lib 't/cdbi/testlib';
is( scalar @aliases, 1, 'proper number of aliases' );
is( $aliases[ 0 ]->name, 'Second', 'proper alias' );
-
+done_testing;
use Test::More;
use Data::Dumper;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 12);
-}
-
INIT {
use lib 't/cdbi/testlib';
use Film;
#{ # Fail on cascade
# local $TODO = 'cascade => "Fail" unimplemented';
-#
+#
# Director->has_many(nasties => Film => { cascade => 'Fail' });
#
# my $dir = Director->insert({ name => "Nasty Noddy" });
# ok eval { $dir->delete };
# is $@, '', "Can delete once films are gone";
#}
+
+done_testing;
use strict;
use Test::More;
+use Test::Warn;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
- if $@;
-
- plan skip_all => "Time::Piece required for this test"
- unless eval { require Time::Piece };
-
- plan tests => 12;
-}
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
-use Test::Warn;
+eval { require Time::Piece }
+ or plan skip_all => 'Time::Piece required for this test';
package Temp::DBI;
use base qw(DBIx::Class::CDBICompat);
Temp::DBI->columns(All => qw(id date));
-my $strptime_inflate = sub {
- Time::Piece->strptime(shift, "%Y-%m-%d")
+my $strptime_inflate = sub {
+ Time::Piece->strptime(shift, "%Y-%m-%d")
};
Temp::DBI->has_a(
date => 'Time::Piece',
is $date->accessor, 'date';
is $date->args->{inflate}, $strptime_inflate;
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
- if $@;
-}
-
-BEGIN {
- eval "use DBD::SQLite";
- plan $@
- ? (skip_all => 'needs DBD::SQLite for testing')
- : (tests => 6);
-}
-
use lib 't/cdbi/testlib';
require Film;
eval {
my $data = $data;
$data->{sheep} = 1;
- ok $bt = Film->insert($data), "Modified accessor - with
+ ok $bt = Film->insert($data), "Modified accessor - with
accessor";
isa_ok $bt, "Film";
};
};
is $@, '', "No errors";
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
-}
-
use lib 't/cdbi/testlib';
use Film;
is( $it->next, undef, "next past end of page ok" );
# second page
-( $pager, $it ) = Film->page(
+( $pager, $it ) = Film->page(
{},
{ rows => 3,
page => 2 }
is( $pager->entries_on_this_page, 2, "entries on second page ok" );
is( $it->next->title, "Film 4", "second page first title ok" );
+
+done_testing;
use warnings;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => "Class::Trigger and DBIx::ContextualFetch required"
- if $@;
-
- eval { require DateTime };
- plan skip_all => "Need DateTime for inflation tests" if $@;
+use lib qw(t/cdbi/testlib);
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
- eval { require Clone };
- plan skip_all => "Need Clone for CDBICompat inflation tests" if $@;
+BEGIN {
+ eval { require DateTime; DateTime->VERSION(0.55) }
+ or plan skip_all => 'DateTime 0.55 required for this test';
}
-plan tests => 6;
-
-use lib qw(t/lib);
-use DBICTest;
-
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
$cd->year( $now );
$cd->update;
-($cd) = $schema->resultset("CD")->search( year => $now->year );
+($cd) = $schema->resultset("CD")->search({ year => $now->year });
is( $cd->year->year, $now->year, 'deflate ok' );
# re-test using alternate deflate syntax
$cd->year( $now );
$cd->update;
-($cd) = $schema->resultset("CD")->search( year => $now->year );
+($cd) = $schema->resultset("CD")->search({ year => $now->year });
is( $cd->year->year, $now->year, 'deflate ok' );
+done_testing;
# Test database failures
#----------------------------------------------------------------------
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7);
-}
-
use lib 't/cdbi/testlib';
use Film;
}
}
+done_testing;
use strict;
use Test::More;
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
+
BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
- next;
- }
-
- plan skip_all => 'needs DBD::SQLite for testing'
- unless eval { require DBD::SQLite };
-
- plan skip_all => 'needs Class::DBI::Plugin::DeepAbstractSearch'
- unless eval { require Class::DBI::Plugin::DeepAbstractSearch };
-
- plan tests => 19;
+ eval { require Class::DBI::Plugin::DeepAbstractSearch }
+ or plan skip_all => 'Class::DBI::Plugin::DeepAbstractSearch required for this test';
}
-my $DB = "t/var/cdbi_testdb";
-unlink $DB if -e $DB;
+my $DB = DBICTest->_sqlite_dbname(sqlite_use_file => 1);;
+
+# not usre why this test needs an AutoCommit => 0 and a commit further
+# down - EDONOTCARE
+$ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} = 1;
my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 0 });
"CDs from Sony or Supraphon";
}
-END { unlink $DB if -e $DB }
-
+done_testing;
use strict;
use warnings;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@");
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
-}
-
INIT {
use lib 't/cdbi/testlib';
use Film;
is_deeply [sort map $_->Title, @supers],
[sort ("Super Fuzz", "Superman")], 'like';
}
-
+
my @all = Film->search_where({}, { order_by => "Title ASC" });
is_deeply ["Batman", "Super Fuzz", "Superman"],
[map $_->Title, @all],
"limit_dialect ignored";
+done_testing;
use Test::More;
use Test::Warn;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : ('no_plan');
-}
-
use lib 't/cdbi/testlib';
use Film;
my $rating = $waves->{rating};
$waves->Rating("PG");
is $rating, "R", 'evaluation of column value is not deferred';
- } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at \Q$0};
+ } qr{^Column 'rating' of 'Film/$waves' was fetched as a hash at\b};
warnings_like {
is $waves->{title}, $waves->Title, "columns can be accessed as hashes";
} '', 'DBIC_CDBICOMPAT_HASH_WARN controls warnings';
-{
+{
$waves->rating("R");
$waves->update;
-
+
no warnings 'redefine';
local *Film::rating = sub {
return "wibble";
};
-
+
is $waves->{rating}, "R";
}
return "movie" if lc $col eq "film";
return $col;
};
-
+
require Actor;
Actor->has_a( film => "Film" );
name => 'Emily Watson',
film => $waves,
});
-
+
ok !eval { $actor->film };
is $actor->{film}->id, $waves->id,
'hash access still works despite lack of accessor';
# Emulate that Class::DBI inflates immediately
SKIP: {
- skip "Need MySQL to run this test", 3 unless eval { require MyFoo };
-
+ unless (eval { require MyFoo }) {
+ my ($err) = $@ =~ /([^\n]+)/;
+ skip $err, 3
+ }
+
my $foo = MyFoo->insert({
name => 'Whatever',
tdate => '1949-02-01',
});
isa_ok $foo, 'MyFoo';
-
+
isa_ok $foo->{tdate}, 'Date::Simple';
is $foo->{tdate}->year, 1949;
-}
\ No newline at end of file
+}
+
+done_testing;
use Test::More;
use lib 't/cdbi/testlib';
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : (tests=> 5);
-}
-
{
package Thing;
is( $thing->yarrow, "hock", 'custom accessor not overwritten by column' );
is( $thing->foo, 42, 'custom routine not overwritten by temp column' );
is( $thing->bar, "that", 'temp column accessor generated' );
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : (tests=> 5);
-}
-
INIT {
use lib 't/cdbi/testlib';
use Film;
my $film = Foo->construct({
temp_thing => 23
});
-
+
::is $film->temp_thing, 23, "construct sets temp columns";
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : (tests=> 4);
-}
-
INIT {
use lib 't/cdbi/testlib';
}
{
- package # hide from PAUSE
+ package # hide from PAUSE
MyFilm;
use base 'DBIC::Test::SQLite';
$new_film = $film->copy(42);
is $new_film->id, 42, "copy() with new id";
+done_testing;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : ('no_plan');
-}
-
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
{
package Thing;
Thing->columns(Essential => qw(foo bar baz));
is_deeply [Stuff->columns("Essential")], [];
-1;
+done_testing;
use strict;
use Test::More;
-
-
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 3);
-}
+use Class::Inspector ();
use lib 't/cdbi/testlib';
Director => "Yu Wang",
});
-is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
\ No newline at end of file
+is_deeply [sort $shan_hua->films], [sort $inframan, $guillotine2];
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => 'Class::Trigger and DBIx::ContextualFetch required')
- : (tests=> 2);
-}
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
package Foo;
#::is $@, '';
::is(Foo->table, "foo");
::is_deeply [sort map lc, Foo->columns], [sort map lc, qw(foo bar)];
+
+::done_testing;
# Test database failures
#----------------------------------------------------------------------
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 2);
-}
-
use lib 't/cdbi/testlib';
use Film;
is( Film->maximum_value_of("numexplodingsheep"), 10 );
is( Film->minimum_value_of("numexplodingsheep"), 2 );
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => 'Class::Trigger and DBIx::ContextualFetch required' if $@;
-
- eval "use DBD::SQLite";
- plan skip_all => 'needs DBD::SQLite for testing' if $@;
-
- plan 'no_plan';
-}
-
INIT {
use lib 't/cdbi/testlib';
require Film;
$film->wibble_thing(23);
is $film->wibble_thing, 23;
}
+
+done_testing;
use Test::More;
use lib 't/cdbi/testlib';
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : (tests=> 3);
-}
-
{
package Thing;
is $thing->baz, 99;
$thing->discard_changes;
+
+done_testing;
use Test::More;
$| = 1;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- }
-
- eval "use DBD::SQLite";
- plan skip_all => 'needs DBD::SQLite for testing' if $@;
-}
INIT {
use lib 't/cdbi/testlib';
{
Film->nocache(1);
-
+
my $film1 = Film->retrieve( "This Is Spinal Tap" );
my $film2 = Film->retrieve( "This Is Spinal Tap" );
$film1->Director("Marty DiBergi");
is $film2->Director, "Rob Reiner",
'caching turned off';
-
+
$film1->discard_changes;
}
$film1->discard_changes;
}
+
+done_testing;
use strict;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan $@ ? (skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@")
- : (tests=> 3);
-}
-
INIT {
use lib 't/cdbi/testlib';
use Film;
is @films, 2, "retrieve_from_sql with LIMIT";
is( $_->director, "Peter Jackson" ) for @films;
}
+
+done_testing;
use strict;
use Test::More;
+
use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
- if $@;
- plan skip_all => "DateTime required" unless eval { require DateTime };
- plan tests => 2;
+ eval { require DateTime; DateTime->VERSION(0.55) }
+ or plan skip_all => 'DateTime 0.55 required for this test';
}
$thing->discard_changes;
is @warnings, 0, 'no warnings';
+
+done_testing;
use strict;
use Test::More;
use Test::Exception;
+
use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite (); # this will issue the necessary SKIPs on missing reqs
BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- plan skip_all => "Class::Trigger and DBIx::ContextualFetch required: $@"
- if $@;
- plan skip_all => "DateTime required" unless eval { require DateTime };
- plan tests => 1;
+ eval { require DateTime; DateTime->VERSION(0.55) }
+ or plan skip_all => 'DateTime 0.55 required for this test';
}
{
$thing->set( date => $date );
};
-
-
$thing->discard_changes;
+
+done_testing;
use Test::More;
-BEGIN {
- eval "use DBIx::Class::CDBICompat;";
- if ($@) {
- plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
- next;
- }
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
-}
-
-use lib 't/lib';
-
-use_ok('DBICTest');
+use lib 't/cdbi/testlib';
+use DBIC::Test::SQLite;
DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
{ order_by => 'title',
rows => 3,
page => 1 } );
-
+
cmp_ok( $pager->entries_on_this_page, '==', 3, "entries_on_this_page ok" );
cmp_ok( $pager->next_page, '==', 2, "next_page ok" );
# based on a failing criteria submitted by waswas
( $pager, $it ) = DBICTest::CD->page(
{ title => [
- -and =>
+ -and =>
{
-like => '%bees'
},
{ rows => 5 }
);
is( $it->count, 1, "complex abstract count ok" );
+
+# cleanup globals so we do not trigger the leaktest
+for ( map { DBICTest->schema->class($_) } DBICTest->schema->sources ) {
+ $_->class_resolver(undef);
+ $_->resultset_instance(undef);
+ $_->result_source_instance(undef);
+}
+{
+ no warnings qw/redefine once/;
+ *DBICTest::schema = sub {};
+}
+
+done_testing;
-package # hide from PAUSE
+package # hide from PAUSE
Actor;
use strict;
return qq{
id INTEGER PRIMARY KEY,
name CHAR(40),
- film VARCHAR(255),
+ film VARCHAR(255),
salary INT
}
}
-package # hide from PAUSE
+package # hide from PAUSE
ActorAlias;
use strict;
-package # hide from PAUSE
+package # hide from PAUSE
CDBase;
use strict;
salary INT
}
}
-
+
=head1 DESCRIPTION
This provides a simple base class for DBIx::Class::CDBICompat tests using
use strict;
use warnings;
+use Test::More;
+
+use lib 't/lib';
+use DBICTest;
+
+BEGIN {
+ eval { require DBIx::Class::CDBICompat }
+ or plan skip_all => 'Class::DBI required for this test';
+}
+
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/CDBICompat Core DB/);
-use File::Temp qw/tempfile/;
-my (undef, $DB) = tempfile();
-END { unlink $DB if -e $DB }
-
+my $DB = DBICTest->_sqlite_dbfilename;
my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1, RaiseError => 1 });
__PACKAGE__->connection(@DSN);
-package # hide from PAUSE
+package # hide from PAUSE
Director;
use strict;
-package # hide from PAUSE
+package # hide from PAUSE
Film;
use base 'DBIC::Test::SQLite';
}
}
-sub create_test_film {
+sub create_test_film {
return shift->create({
Title => 'Bad Taste',
Director => 'Peter Jackson',
-package # hide from PAUSE
+package # hide from PAUSE
Lazy;
use base 'DBIC::Test::SQLite';
-package # hide from PAUSE
+package # hide from PAUSE
Log;
use base 'MyBase';
MyBase;
use strict;
+use DBI;
+
+use lib 't/lib';
+use DBICTest;
+
use base qw(DBIx::Class::CDBICompat);
-use DBI;
+our $dbh;
+
+my $err;
+if (! $ENV{DBICTEST_MYSQL_DSN} ) {
+ $err = 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test';
+}
+elsif ( ! DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql') ) {
+ $err = 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
+}
-use vars qw/$dbh/;
+if ($err) {
+ my $t = eval { Test::Builder->new };
+ if ($t and ! $t->current_test) {
+ $t->skip_all ($err);
+ }
+ else {
+ die "$err\n";
+ }
+}
my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0});
+# this is only so we grab a lock on mysql
+{
+ my $x = DBICTest::Schema->connect(@connect);
+}
+
$dbh = DBI->connect(@connect) or die DBI->errstr;
my @table;
-package # hide from PAUSE
+package # hide from PAUSE
MyFilm;
use base 'MyBase';
-package # hide from PAUSE
+package # hide from PAUSE
MyFoo;
use base 'MyBase';
-package # hide from PAUSE
+package # hide from PAUSE
MyStar;
use base 'MyBase';
-package # hide from PAUSE
+package # hide from PAUSE
MyStarLink;
use base 'MyBase';
-package # hide from PAUSE
+package # hide from PAUSE
MyStarLinkMCPK;
use base 'MyBase';
-package # hide from PAUSE
+package # hide from PAUSE
Order;
use strict;
use DBICTest;
use DBIC::SqlMakerTest;
use DBIC::DebugObj;
+use DBIx::Class::SQLMaker::LimitDialects;
-plan tests => 10;
+my ($ROWS, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
my $schema = DBICTest->init_schema();
JOIN track tracks ON tracks.cd = me.cdid
JOIN cd disc ON disc.cdid = tracks.cd
WHERE ( ( position = ? OR position = ? ) )
- LIMIT 3 OFFSET 8
- ) count_subq
+ LIMIT ? OFFSET ?
+ ) tracks
)',
- [ [ position => 1 ], [ position => 2 ] ],
+ [
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'position' }
+ => 2 ],
+ [$ROWS => 3],
+ [$OFFSET => 8],
+ ],
'count_rs db-side limit applied',
);
}
JOIN artist artist ON artist.artistid = cds.artist
WHERE tracks.position = ? OR tracks.position = ?
GROUP BY cds.cdid
- ) count_subq
+ ) cds
',
[ qw/'1' '2'/ ],
'count softlimit applied',
JOIN artist artist ON artist.artistid = cds.artist
WHERE tracks.position = ? OR tracks.position = ?
GROUP BY cds.cdid
- LIMIT 3 OFFSET 4
- ) count_subq
+ LIMIT ? OFFSET ?
+ ) cds
)',
- [ [ 'tracks.position' => 1 ], [ 'tracks.position' => 2 ] ],
+ [
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 1 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' }
+ => 2 ],
+ [ $ROWS => 3],
+ [$OFFSET => 4],
+ ],
'count_rs db-side limit applied',
);
}
+
+# count with a having clause
+{
+ my $rs = $schema->resultset("Artist")->search(
+ {},
+ {
+ join => 'cds',
+ group_by => 'me.artistid',
+ '+select' => [ { max => 'cds.year', -as => 'newest_cd_year' } ],
+ '+as' => ['newest_cd_year'],
+ having => { 'newest_cd_year' => '2001' }
+ }
+ );
+
+ my $crs = $rs->count_rs;
+
+ is_same_sql_bind (
+ $crs->as_query,
+ '(SELECT COUNT( * )
+ FROM (
+ SELECT me.artistid, MAX( cds.year ) AS newest_cd_year
+ FROM artist me
+ LEFT JOIN cd cds ON cds.artist = me.artistid
+ GROUP BY me.artistid
+ HAVING newest_cd_year = ?
+ ) me
+ )',
+ [ [ { dbic_colname => 'newest_cd_year' }
+ => '2001' ] ],
+ 'count with having clause keeps sql as alias',
+ );
+
+ is ($crs->next, 2, 'Correct artist count (each with one 2001 cd)');
+}
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1 });
is($get_count->($rs), 7, 'Count with IN subquery with outside distinct');
- $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1, select => 'tag' }),
+ $rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->get_column('tag')->as_query } }, { distinct => 1, select => 'tag' }),
is($get_count->($rs), 2, 'Count with IN subquery with outside distinct on a single column');
$rs = $schema->resultset('Tag')->search({ tag => { -in => $in_rs->search({}, { group_by => 'tag' })->get_column('tag')->as_query } });
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
-plan ( tests => 1 );
-
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $squery } } );
is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count');
}
+
+done_testing;
JOIN artist artist ON artist.artistid = cds.artist
WHERE tracks.position = ? OR tracks.position = ?
GROUP BY cds.cdid
- ) count_subq
+ ) cds
)',
- [ map { [ 'tracks.position' => $_ ] } (1, 2) ],
+ [ map { [ { sqlt_datatype => 'int', dbic_colname => 'tracks.position' } => $_ ] } (1, 2) ],
);
}
WHERE ( genre.name = ? )
GROUP BY genre.genreid
)
- count_subq
+ genre
)',
- [ [ 'genre.name' => 'emo' ] ],
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'genre.name' }
+ => 'emo' ]
+ ],
);
}
LEFT JOIN lyrics lyrics ON lyrics.track_id = tracks.trackid
WHERE lyrics.lyric_id IS NULL AND (position = ? OR position = ?)
)',
- [ map { [ position => $_ ] } (1, 2) ],
+ [ map { [ { sqlt_datatype => 'int', dbic_colname => 'position' } => $_ ] } (1, 2) ],
);
}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+
+use lib 't/lib';
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+$schema->_unregister_source('CD');
+
+warnings_like {
+ my $s = $schema;
+ lives_ok {
+ $_->delete for $s->resultset('Artist')->all;
+ } 'delete on rows with dangling rels lives';
+} [
+ # 12 == 3 artists * failed cascades:
+ # cds
+ # cds_unordered
+ # cds_very_very_very_long_relationship_name
+ (qr/skipping cascad/i) x 9
+], 'got warnings about cascading deletes';
+
+done_testing;
+
my $init_count = $artist_rs->count;
ok ($init_count, 'Some artists is database');
-$artist_rs->populate ([
- {
- name => 'foo',
- },
- {
- name => 'bar',
- }
-]);
-
-is ($artist_rs->count, $init_count + 2, '2 Artists created');
-
-$artist_rs->search ({
- -and => [
- { 'me.artistid' => { '!=', undef } },
+foreach my $delete_arg (
[ { 'me.name' => 'foo' }, { 'me.name' => 'bar' } ],
- ],
-})->delete;
-
-is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+ [ 'me.name' => 'foo', 'me.name' => 'bar' ],
+) {
+ $artist_rs->populate ([
+ {
+ name => 'foo',
+ },
+ {
+ name => 'bar',
+ }
+ ]);
+
+ is ($artist_rs->count, $init_count + 2, '2 Artists created');
+
+ $artist_rs->search ({
+ -and => [
+ { 'me.artistid' => { '!=', undef } },
+ $delete_arg,
+ ],
+ })->delete;
+
+ is ($artist_rs->count, $init_count, 'Correct amount of artists deleted');
+}
done_testing;
-#!/usr/bin/perl -w
-
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 5;
-
my $cd = $schema->resultset("CD")->find(2);
ok $cd->liner_notes;
-ok keys %{$cd->{_relationship_data}}, "_relationship_data populated";
+
+ok scalar(keys %{$cd->{_relationship_data}}), "_relationship_data populated";
$cd->discard_changes;
ok $cd->liner_notes, 'relationships still valid after discarding changes';
ok $cd->liner_notes->delete;
$cd->discard_changes;
-ok !$cd->liner_notes, 'discard_changes resets relationship';
\ No newline at end of file
+ok !$cd->liner_notes, 'discard_changes resets relationship';
+
+done_testing;
-use Test::More;
use strict;
use warnings;
+use Test::More;
+
use lib qw(t/lib);
use DBICTest;
-plan tests => 4;
-
my $schema = DBICTest->init_schema();
my $ars = $schema->resultset('Artist');
TODO: {
local $TODO = 'delete_related is based on search_related which is based on search which does not understand object arguments';
+ local $SIG{__WARN__} = sub {}; # trap the non-numeric warning, remove when the TODO is removed
+
my $cd2pr_count = $cd2pr_rs->count;
$prod_cd->delete_related('cd_to_producer', { producer => $prod } );
is ($cd2pr_rs->count, $cd2pr_count -= 1, 'm2m link deleted succesfully');
+
+ # see 187ec69a for why this is neccessary
+ $prod->result_source(undef);
}
+
+done_testing;
-#!/usr/bin/perl -w
-
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 1;
-
{
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_; };
# Test that this doesn't cause infinite recursion.
local *DBICTest::Artist::DESTROY;
local *DBICTest::Artist::DESTROY = sub { $_[0]->discard_changes };
-
- my $artist = $schema->resultset("Artist")->create( {
+
+ my $artist = $schema->resultset("Artist")->create( {
artistid => 10,
name => "artist number 10",
});
-
+
$artist->name("Wibble");
-
+
print "# About to call DESTROY\n";
}
is_deeply \@warnings, [];
-}
\ No newline at end of file
+}
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan tests => 8;
-
-my $schema = DBICTest->init_schema();
-my $art_rs = $schema->resultset('Artist');
-my $cdrs = $schema->resultset('CD');
-
-{
- my $cdrs2 = $cdrs->search({
- artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
- });
-
- is_same_sql_bind(
- $cdrs2->as_query,
- "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ))",
- [],
- );
-}
-
-{
- my $rs = $art_rs->search(
- {},
- {
- 'select' => [
- $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me)",
- [],
- );
-}
-
-{
- my $rs = $art_rs->search(
- {},
- {
- '+select' => [
- $cdrs->search({}, { rows => 1 })->get_column('id')->as_query,
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me)",
- [],
- );
-}
-
-# simple from
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( id > ? )
- ) cd2)",
- [
- [ 'id', 20 ]
- ],
- );
-}
-
-# nested from
-{
- my $art_rs2 = $schema->resultset('Artist')->search({},
- {
- from => [ { 'me' => 'artist' },
- [ { 'cds' => $cdrs->search({},{ 'select' => [\'me.artist as cds_artist' ]})->as_query },
- { 'me.artistid' => 'cds_artist' } ] ]
- });
-
- is_same_sql_bind(
- $art_rs2->as_query,
- "(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me JOIN (SELECT me.artist as cds_artist FROM cd me) cds ON me.artistid = cds_artist)",
- []
- );
-
-
-}
-
-# nested subquery in from
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search(
- { id => { '>' => 20 } },
- {
- alias => 'cd3',
- from => [
- { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
- ],
- }, )->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track
- FROM
- (SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
- FROM
- (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me WHERE ( id < ? ) ) cd3
- WHERE ( id > ? ) ) cd2)",
- [
- [ 'id', 40 ],
- [ 'id', 20 ]
- ],
- );
-
-}
-
-{
- my $rs = $cdrs->search({
- year => {
- '=' => $cdrs->search(
- { artistid => { '=' => \'me.artistid' } },
- { alias => 'inner' }
- )->get_column('year')->max_rs->as_query,
- },
- });
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE year = (SELECT MAX(inner.year) FROM cd inner WHERE artistid = me.artistid))",
- [],
- );
-}
-
-{
- my $rs = $cdrs->search(
- {},
- {
- alias => 'cd2',
- from => [
- { cd2 => $cdrs->search({ title => 'Thriller' })->as_query },
- ],
- },
- );
-
- is_same_sql_bind(
- $rs->as_query,
- "(SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( title = ? )
- ) cd2)",
- [ [ 'title', 'Thriller' ] ],
- );
-}
my $schema = DBICTest->init_schema();
-eval { require DateTime };
-plan skip_all => "Need DateTime for inflation tests" if $@;
+plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
$schema->class('CD') ->inflate_column( 'year',
{ inflate => sub { DateTime->new( year => shift ) },
is( $cd->year->month, 1, 'inflated month ok' );
-eval { $cd->year(\'year +1'); };
-ok(!$@, 'updated year using a scalarref');
+lives_ok (
+ sub { $cd->year(\'year +1') },
+ 'updated year using a scalarref'
+);
$cd->update();
$cd->discard_changes();
is( $cd->year->year, 1998, 'updated year, bypassing inflation' );
-is( $cd->year->month, 1, 'month is still 1' );
+is( $cd->year->month, 1, 'month is still 1' );
# get_inflated_column test
is( $cd->year->year, $now->year, 'deflate ok' );
# set_inflated_column test
-eval { $cd->set_inflated_column('year', $now) };
-ok(!$@, 'set_inflated_column with DateTime object');
+lives_ok (
+ sub { $cd->set_inflated_column('year', $now) },
+ 'set_inflated_column with DateTime object'
+);
$cd->update;
$cd = $rs->find(3);
$cd = $rs->find(3);
my $before_year = $cd->year->year;
-eval { $cd->set_inflated_column('year', \'year + 1') };
-ok(!$@, 'set_inflated_column to "year + 1"');
+lives_ok (
+ sub { $cd->set_inflated_column('year', \'year + 1') },
+ 'set_inflated_column to "year + 1"',
+);
$cd->update;
$cd->store_inflated_column('year', \'year + 1');
# store_inflated_column test
$cd = $rs->find(3);
-eval { $cd->store_inflated_column('year', $now) };
-ok(!$@, 'store_inflated_column with DateTime object');
+lives_ok (
+ sub { $cd->store_inflated_column('year', $now) },
+ 'store_inflated_column with DateTime object'
+);
$cd->update;
is( $cd->year->year, $now->year, 'deflate ok' );
# update tests
$cd = $rs->find(3);
-eval { $cd->update({'year' => $now}) };
-ok(!$@, 'update using DateTime object ok');
+lives_ok (
+ sub { $cd->update({'year' => $now}) },
+ 'update using DateTime object ok'
+);
is($cd->year->year, $now->year, 'deflate ok');
$cd = $rs->find(3);
$before_year = $cd->year->year;
-eval { $cd->update({'year' => \'year + 1'}) };
-ok(!$@, 'update using scalarref ok');
+lives_ok (
+ sub { $cd->update({'year' => \'year + 1'}) },
+ 'update using scalarref ok'
+);
$cd = $rs->find(3);
is($cd->year->year, $before_year + 1, 'deflate ok');
use warnings;
use Test::More;
+use Test::Warn;
+use Try::Tiny;
use lib qw(t/lib);
use DBICTest;
+# so user's env doesn't screw us
+delete $ENV{DBIC_DT_SEARCH_OK};
+
my $schema = DBICTest->init_schema();
-eval { require DateTime::Format::SQLite };
-plan $@
- ? ( skip_all => "Need DateTime::Format::SQLite for DT inflation tests" )
- : ( tests => 18 )
-;
+plan skip_all => 'DT inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
# inflation test
my $event = $schema->resultset("Event")->find(1);
my $starts = $event->starts_at;
is("$starts", '2006-04-25T22:24:33', 'Correct date/time');
+my $dt_warn_re = qr/DateTime objects.+not supported properly/;
+
+my $row;
+
+{
+ local $ENV{DBIC_DT_SEARCH_OK} = 1;
+ local $SIG{__WARN__} = sub {
+ fail('Disabled warning still issued') if $_[0] =~ $dt_warn_re;
+ warn @_;
+ };
+ $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
+}
+
+warnings_exist {
+ $row = $schema->resultset('Event')->search({ starts_at => $starts })->single
+} [$dt_warn_re],
+ 'using a DateTime object in ->search generates a warning';
+
TODO: {
local $TODO = "We can't do this yet before 0.09" if DBIx::Class->VERSION < 0.09;
- ok(my $row =
- $schema->resultset('Event')->search({ starts_at => $starts })->single);
is(eval { $row->id }, 1, 'DT in search');
+ local $ENV{DBIC_DT_SEARCH_OK} = 1;
+
ok($row =
- $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })->single);
+ $schema->resultset('Event')->search({ starts_at => { '>=' => $starts } })
+ ->single);
+
is(eval { $row->id }, 1, 'DT in search with condition');
}
## skip inflation field
my $skip_inflation = $event->skip_inflation;
is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use DBICTest;
-eval { require DateTime::Format::SQLite };
-plan $@ ? ( skip_all => 'Requires DateTime::Format::SQLite' )
- : ( tests => 3 );
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_sqlite')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_sqlite');
my $schema = DBICTest->init_schema(
no_deploy => 1, # Deploying would cause an early rebless
is($parser, 'DateTime::Format::SQLite', 'Got expected storage-set datetime_parser');
isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::SQLite', 'storage');
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+use Scope::Guard ();
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_FIREBIRD_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_INTERBASE_${_}" } qw/DSN USER PASS/};
+my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Test needs ' .
+ (join ' and ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird_interbase'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_firebird_odbc')))
+ unless
+ DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird_interbase')
+ or
+ $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_firebird_odbc'))
+ or (not $dsn || $dsn2 || $dsn3);
+
+if (not ($dsn || $dsn2)) {
+ plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}
+and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN}
+_USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'event'";
+EOF
+}
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+ [ $dsn3, $user3, $pass3 ],
+);
+
+my $schema;
+
+foreach my $conn_idx (0..$#info) {
+ my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] };
+
+ next unless $dsn;
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ quote_char => '"',
+ name_sep => '.',
+ on_connect_call => [ 'datetime_setup' ],
+ });
+
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+
+ eval { $schema->storage->dbh->do('DROP TABLE "event"') };
+ $schema->storage->dbh->do(<<'SQL');
+ CREATE TABLE "event" (
+ "id" INT PRIMARY KEY,
+ "starts_at" DATE,
+ "created_on" TIMESTAMP
+ )
+SQL
+ my $rs = $schema->resultset('Event');
+
+ my $dt = DateTime->now;
+ $dt->set_nanosecond(555600000);
+
+ my $date_only = DateTime->new(
+ year => $dt->year, month => $dt->month, day => $dt->day
+ );
+
+ my $row;
+ ok( $row = $rs->create({
+ id => 1,
+ starts_at => $date_only,
+ created_on => $dt,
+ }));
+ ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] })
+ ->first
+ );
+ is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip';
+
+ cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond,
+ 'fractional part of a second survived';
+
+ is $row->starts_at, $date_only, 'DATE as DateTime roundtrip';
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+ my $schema = shift;
+ my $dbh;
+ eval {
+ $schema->storage->disconnect; # to avoid object FOO is in use errors
+ $dbh = $schema->storage->dbh;
+ };
+ return unless $dbh;
+
+ eval { $dbh->do(qq{DROP TABLE "$_"}) } for qw/event/;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+use Scope::Guard ();
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
+. ' and ' .
+DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_informix')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt')
+ && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_informix');
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_INFORMIX_${_}" } qw/DSN USER PASS/};
+
+if (not $dsn) {
+ plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_INFORMIX_DSN} _USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'event'";
+EOF
+}
+
+my $schema;
+
+{
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ on_connect_call => [ 'datetime_setup' ],
+ });
+
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+
+ eval { $schema->storage->dbh->do('DROP TABLE event') };
+ $schema->storage->dbh->do(<<'SQL');
+ CREATE TABLE event (
+ id INT PRIMARY KEY,
+ starts_at DATE,
+ created_on DATETIME YEAR TO FRACTION(5)
+ );
+SQL
+ my $rs = $schema->resultset('Event');
+
+ my $dt = DateTime->now;
+ $dt->set_nanosecond(555640000);
+
+ my $date_only = DateTime->new(
+ year => $dt->year, month => $dt->month, day => $dt->day
+ );
+
+ my $row;
+ ok( $row = $rs->create({
+ id => 1,
+ starts_at => $date_only,
+ created_on => $dt,
+ }));
+ ok( $row = $rs->search({ id => 1 }, { select => [qw/starts_at created_on/] })
+ ->first
+ );
+ is $row->created_on, $dt, 'TIMESTAMP as DateTime roundtrip';
+
+ cmp_ok $row->created_on->nanosecond, '==', $dt->nanosecond,
+ 'fractional part of a second survived';
+
+ is $row->starts_at, $date_only, 'DATE as DateTime roundtrip';
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+ my $schema = shift;
+ my $dbh;
+ eval {
+ $dbh = $schema->storage->dbh;
+ };
+ return unless $dbh;
+
+ eval { $dbh->do(qq{DROP TABLE $_}) } for qw/event/;
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $no_class = '_DBICTEST_NONEXISTENT_CLASS_';
+
+my $schema = DBICTest->init_schema();
+$schema->storage->datetime_parser_type($no_class);
+
+my $event = $schema->resultset('Event')->find(1);
+
+# test that datetime_undef_if_invalid does not eat the missing dep exception
+throws_ok {
+ my $dt = $event->starts_at;
+} qr{Can't locate ${no_class}\.pm};
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Scope::Guard ();
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Test needs ' .
+ (join ' and ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado')))
+ unless
+ DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado'))
+ or (not $dsn || $dsn2);
+
+plan skip_all => <<'EOF' unless $dsn || $dsn2;
+Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.
+Warning: this test drops and creates the table 'track'.
+EOF
+
+my @connect_info = (
+ [ $dsn, $user || '', $pass || '' ],
+ [ $dsn2, $user2 || '', $pass2 || '' ],
+);
+
+for my $connect_info (@connect_info) {
+ my ($dsn, $user, $pass) = @$connect_info;
+
+ next unless $dsn;
+
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ on_connect_call => 'datetime_setup',
+ quote_names => 1,
+ });
+
+ my $guard = Scope::Guard->new(sub { cleanup($schema) });
+
+ try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE track (
+ trackid AUTOINCREMENT PRIMARY KEY,
+ cd INT,
+ [position] INT,
+ last_updated_at DATETIME
+)
+SQL
+
+ ok(my $dt = DateTime->new({
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ second => 48,
+ }));
+
+ ok(my $row = $schema->resultset('Track')->create({
+ last_updated_at => $dt,
+ cd => 1
+ }));
+ ok($row = $schema->resultset('Track')
+ ->search({ trackid => $row->trackid }, { select => ['last_updated_at'] })
+ ->first
+ );
+ is($row->last_updated_at, $dt, "DATETIME roundtrip" );
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+ my $schema = shift;
+ # have to reconnect to drop a table that's in use
+ if (my $storage = eval { $schema->storage }) {
+ local $^W = 0;
+ $storage->disconnect;
+ $storage->dbh->do('DROP TABLE track');
+ }
+}
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSSQL_${_}" } qw/DSN USER PASS/};
+my ($dsn3, $user3, $pass3) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
-if (not ($dsn && $user)) {
- plan skip_all =>
- 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test' .
- "\nWarning: This test drops and creates a table called 'track'";
-} else {
- eval "use DateTime; use DateTime::Format::Strptime;";
- if ($@) {
- plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
- }
- else {
- plan tests => 4 * 2; # (tests * dt_types)
+plan skip_all => 'Test needs ' .
+ (join ' and ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_odbc'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_sybase'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_mssql_ado')))
+ unless
+ DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_odbc')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_sybase')
+ or
+ $dsn3 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mssql_ado'))
+ or (not $dsn || $dsn2 || $dsn3);
+
+# use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else
+BEGIN {
+ if (my $lib_dirs = $ENV{DBICTEST_MSSQL_PERL5LIB}) {
+ unshift @INC, $_ for split /:/, $lib_dirs;
}
}
-my $schema = DBICTest::Schema->clone;
-
-$schema->connection($dsn, $user, $pass);
-$schema->storage->ensure_connected;
-
-# coltype, column, datehash
-my @dt_types = (
- ['DATETIME',
- 'last_updated_at',
- {
- year => 2004,
- month => 8,
- day => 21,
- hour => 14,
- minute => 36,
- second => 48,
- nanosecond => 500000000,
- }],
- ['SMALLDATETIME', # minute precision
- 'small_dt',
- {
- year => 2004,
- month => 8,
- day => 21,
- hour => 14,
- minute => 36,
- }],
+if (not ($dsn || $dsn2 || $dsn3)) {
+ plan skip_all =>
+ 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN} and/or $ENV{DBICTEST_MSSQL_DSN} and/or '
+ .'$ENV{DBICTEST_MSSQL_ADO_DSN} _USER and _PASS to run this test' .
+ "\nWarning: This test drops and creates tables called 'event_small_dt' and"
+ ." 'track'.";
+}
+
+DBICTest::Schema->load_classes('EventSmallDT');
+
+my @connect_info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+ [ $dsn3, $user3, $pass3 ],
);
-for my $dt_type (@dt_types) {
- my ($type, $col, $sample_dt) = @$dt_type;
+my $schema;
+
+SKIP:
+for my $connect_info (@connect_info) {
+ my ($dsn, $user, $pass) = @$connect_info;
- eval { $schema->storage->dbh->do("DROP TABLE track") };
+ next unless $dsn;
+
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ on_connect_call => 'datetime_setup'
+ });
+
+ {
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ $schema->storage->ensure_connected;
+ if ($w =~ /Your DBD::Sybase is too old to support DBIx::Class::InflateColumn::DateTime/) {
+ skip "Skipping tests on old DBD::Sybase " . DBD::Sybase->VERSION, 1;
+ }
+ }
+
+ my $guard = Scope::Guard->new(sub{ cleanup($schema) });
+
+ # $^W because DBD::ADO is a piece of crap
+ try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE track") };
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE track (
trackid INT IDENTITY PRIMARY KEY,
cd INT,
position INT,
- $col $type,
+ last_updated_at DATETIME,
)
SQL
- ok(my $dt = DateTime->new($sample_dt));
-
- my $row;
- ok( $row = $schema->resultset('Track')->create({
- $col => $dt,
- cd => 1,
- }));
- ok( $row = $schema->resultset('Track')
- ->search({ trackid => $row->trackid }, { select => [$col] })
- ->first
+ try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event_small_dt") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE event_small_dt (
+ id INT IDENTITY PRIMARY KEY,
+ small_dt SMALLDATETIME,
+)
+SQL
+ try { local $^W = 0; $schema->storage->dbh->do("DROP TABLE event") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE event (
+ id int IDENTITY(1,1) NOT NULL,
+ starts_at smalldatetime NULL,
+ created_on datetime NULL,
+ varchar_date varchar(20) NULL,
+ varchar_datetime varchar(20) NULL,
+ skip_inflation datetime NULL,
+ ts_without_tz datetime NULL
+)
+SQL
+
+# coltype, column, source, pk, create_extra, datehash
+ my @dt_types = (
+ ['DATETIME',
+ 'last_updated_at',
+ 'Track',
+ 'trackid',
+ { cd => 1 },
+ {
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ second => 48,
+ nanosecond => 500000000,
+ }],
+ ['SMALLDATETIME', # minute precision
+ 'small_dt',
+ 'EventSmallDT',
+ 'id',
+ {},
+ {
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ }],
);
- is( $row->$col, $dt, 'DateTime roundtrip' );
+
+ for my $dt_type (@dt_types) {
+ my ($type, $col, $source, $pk, $create_extra, $sample_dt) = @$dt_type;
+
+ delete $sample_dt->{nanosecond} if $dsn =~ /:ADO:/;
+
+ ok(my $dt = DateTime->new($sample_dt));
+
+ my $row;
+ ok( $row = $schema->resultset($source)->create({
+ $col => $dt,
+ %$create_extra,
+ }));
+ ok( $row = $schema->resultset($source)
+ ->search({ $pk => $row->$pk }, { select => [$col] })
+ ->first
+ );
+ is( $row->$col, $dt, "$type roundtrip" );
+
+ cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond},
+ 'DateTime fractional portion roundtrip' )
+ if exists $sample_dt->{nanosecond};
+ }
+
+ # Check for bulk insert SQL_DATE funtimes when using DBD::ODBC and sqlncli
+ # dbi:ODBC:driver=SQL Server Native Client 10.0;server=10.6.0.9;database=odbctest;
+ lives_ok {
+ $schema->resultset('Event')->populate([{
+ id => 1,
+ starts_at => undef,
+ },{
+ id => 2,
+ starts_at => '2011-03-22',
+ }])
+ } 'populate with datetime does not throw';
+ ok ( my $row = $schema->resultset('Event')->find(2), 'SQL_DATE bulk insert check' );
}
+
+done_testing;
+
# clean up our mess
-END {
- if (my $dbh = eval { $schema->storage->_dbh }) {
+sub cleanup {
+ my $schema = shift;
+ if (my $dbh = eval { $schema->storage->dbh }) {
$dbh->do('DROP TABLE track');
+ $dbh->do('DROP TABLE event_small_dt');
+ $dbh->do('DROP TABLE event');
}
}
use Test::More;
use Test::Exception;
+use Test::Warn;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
use DBICTest::Schema;
+plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_mysql')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_mysql');
+
{
local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
DBICTest::Schema->load_classes('EventTZ');
DBICTest::Schema->load_classes('EventTZDeprecated');
}
-eval { require DateTime::Format::MySQL };
-plan $@
- ? ( skip_all => "Need DateTime::Format::MySQL for inflation tests")
- : ( tests => 33 )
-;
-
my $schema = DBICTest->init_schema();
# Test "timezone" parameter
# Test floating timezone warning
# We expect one warning
SKIP: {
- skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
- local $SIG{__WARN__} = sub {
- like(
- shift,
- qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
- 'Floating timezone warning'
- );
- };
- my $event_tz_floating = $schema->resultset($tbl)->create({
- starts_at => DateTime->new(year=>2007, month=>12, day=>31, ),
- created_on => DateTime->new(year=>2006, month=>1, day=>31,
- hour => 13, minute => 34, second => 56, ),
- });
- delete $SIG{__WARN__};
+ skip "ENV{DBIC_FLOATING_TZ_OK} was set, skipping", 1 if $ENV{DBIC_FLOATING_TZ_OK};
+ warnings_exist (
+ sub {
+ $schema->resultset($tbl)->create({
+ starts_at => DateTime->new(year=>2007, month=>12, day=>31 ),
+ created_on => DateTime->new(year=>2006, month=>1, day=>31, hour => 13, minute => 34, second => 56 ),
+ });
+ },
+ qr/You're using a floating timezone, please see the documentation of DBIx::Class::InflateColumn::DateTime for an explanation/,
+ 'Floating timezone warning'
+ );
};
# This should fail to set
qr/invalid date format/i,
"Invalid date format exception"
);
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_ORA_${_}" } qw/DSN USER PASS/};
if (not ($dsn && $user && $pass)) {
plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test. ' .
'Warning: This test drops and creates a table called \'track\'';
}
-else {
- eval "use DateTime; use DateTime::Format::Oracle;";
- if ($@) {
- plan skip_all => 'needs DateTime and DateTime::Format::Oracle for testing';
- }
- else {
- plan tests => 10;
- }
-}
# DateTime::Format::Oracle needs this set
$ENV{NLS_DATE_FORMAT} = 'DD-MON-YY';
$ENV{NLS_TIMESTAMP_FORMAT} = 'YYYY-MM-DD HH24:MI:SSXFF';
$ENV{NLS_LANG} = 'AMERICAN_AMERICA.WE8ISO8859P1';
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+# older oracles do not support a TIMESTAMP datatype
+my $timestamp_datatype = ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9
+ ? 'DATE'
+ : 'TIMESTAMP'
+;
+
# Need to redefine the last_updated_on column
my $col_metadata = $schema->class('Track')->column_info('last_updated_on');
$schema->class('Track')->add_column( 'last_updated_on' => {
data_type => 'date' });
$schema->class('Track')->add_column( 'last_updated_at' => {
- data_type => 'timestamp' });
+ data_type => $timestamp_datatype });
my $dbh = $schema->storage->dbh;
eval {
$dbh->do("DROP TABLE track");
};
-$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at TIMESTAMP, small_dt DATE)");
+$dbh->do("CREATE TABLE track (trackid NUMBER(12), cd NUMBER(12), position NUMBER(12), title VARCHAR(255), last_updated_on DATE, last_updated_at $timestamp_datatype)");
+
+TODO: {
+local $TODO = 'FIXME - something odd is going on with Oracle < 9 datetime support'
+ if ($schema->storage->_server_info->{normalized_dbms_version}||0) < 9;
+lives_ok {
# insert a row to play with
my $new = $schema->resultset('Track')->create({ trackid => 1, cd => 1, position => 1, title => 'Track1', last_updated_on => '06-MAY-07', last_updated_at => '2009-05-03 21:17:18.5' });
is( int $track->last_updated_at->nanosecond, int 500_000_000,
'TIMESTAMP nanoseconds survived' );
+} 'dateteime operations executed correctly' } # end of lives_ok/TODO block
+
+done_testing;
+
# clean up our mess
END {
- if($schema && ($dbh = $schema->storage->dbh)) {
- $dbh->do("DROP TABLE track");
- }
+ if($schema && (my $dbh = $schema->storage->dbh)) {
+ $dbh->do("DROP TABLE track");
+ }
+ undef $schema;
}
use warnings;
use Test::More;
+use Test::Warn;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg');
+
{
local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
DBICTest::Schema->load_classes('EventTZPg');
}
-eval { require DateTime::Format::Pg };
-plan $@
- ? ( skip_all => 'Need DateTime::Format::Pg for timestamp inflation tests')
- : ( tests => 6 )
-;
-
-
my $schema = DBICTest->init_schema();
-{
+warnings_are {
my $event = $schema->resultset("EventTZPg")->find(1);
$event->update({created_on => '2009-01-15 17:00:00+00'});
$event->discard_changes;
is($event->ts_without_tz, $dt, 'timestamp without time zone inflation');
is($event->ts_without_tz->microsecond, $dt->microsecond,
'timestamp without time zone microseconds survived');
-}
+} [], 'No warnings during DT manipulations';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Scope::Guard ();
+use DBIx::Class::Optional::Dependencies ();
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SQLANYWHERE_${_}" } qw/DSN USER PASS/};
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SQLANYWHERE_ODBC_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Test needs ' .
+ (join ' and ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_dt'),
+ (join ' or ', map { $_ ? $_ : () }
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere'),
+ DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_sqlanywhere_odbc')))
+ unless
+ DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt') && (
+ $dsn && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere')
+ or
+ $dsn2 && DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_sqlanywhere_odbc'))
+ or (not $dsn || $dsn2);
+
+if (not ($dsn || $dsn2)) {
+ plan skip_all => <<'EOF';
+Set $ENV{DBICTEST_SQLANYWHERE_DSN} and/or $ENV{DBICTEST_SQLANYWHERE_ODBC_DSN}
+_USER and _PASS to run this test'.
+Warning: This test drops and creates a table called 'event'";
+EOF
+}
+
+my @info = (
+ [ $dsn, $user, $pass ],
+ [ $dsn2, $user2, $pass2 ],
+);
+
+my $schema;
+
+foreach my $info (@info) {
+ my ($dsn, $user, $pass) = @$info;
+
+ next unless $dsn;
+
+ $schema = DBICTest::Schema->clone;
+
+ $schema->connection($dsn, $user, $pass, {
+ on_connect_call => 'datetime_setup',
+ });
+
+ my $sg = Scope::Guard->new(sub { cleanup($schema) } );
+
+ eval { $schema->storage->dbh->do('DROP TABLE event') };
+ $schema->storage->dbh->do(<<"SQL");
+ CREATE TABLE event (
+ id INT IDENTITY PRIMARY KEY,
+ created_on TIMESTAMP,
+ starts_at DATE
+ )
+SQL
+
+# coltype, col, date
+ my @dt_types = (
+ [
+ 'TIMESTAMP',
+ 'created_on',
+ '2004-08-21 14:36:48.080445',
+ ],
+# date only (but minute precision according to ASA docs)
+ [
+ 'DATE',
+ 'starts_at',
+ '2004-08-21 00:00:00.000000',
+ ],
+ );
+
+ for my $dt_type (@dt_types) {
+ my ($type, $col, $sample_dt) = @$dt_type;
+
+ ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt));
+
+ my $row;
+ ok( $row = $schema->resultset('Event')->create({ $col => $dt, }));
+ ok( $row = $schema->resultset('Event')
+ ->search({ id => $row->id }, { select => [$col] })
+ ->first
+ );
+ is( $row->$col, $dt, "$type roundtrip" );
+
+ is $row->$col->nanosecond, $dt->nanosecond,
+ 'nanoseconds survived' if 0+$dt->nanosecond;
+ }
+}
+
+done_testing;
+
+# clean up our mess
+sub cleanup {
+ my $schema = shift;
+ if (my $dbh = $schema->storage->dbh) {
+ eval { $dbh->do("DROP TABLE $_") } for qw/event/;
+ }
+}
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
+use Scope::Guard ();
+use Try::Tiny;
+use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
+. ' and ' .
+DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_ase')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt')
+ && DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_ase');
+
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_${_}" } qw/DSN USER PASS/};
if (not ($dsn && $user)) {
plan skip_all =>
'Set $ENV{DBICTEST_SYBASE_DSN}, _USER and _PASS to run this test' .
- "\nWarning: This test drops and creates a table called 'track'";
-} else {
- eval "use DateTime; use DateTime::Format::Sybase;";
- if ($@) {
- plan skip_all => 'needs DateTime and DateTime::Format::Sybase for testing';
- }
+ "\nWarning: This test drops and creates a table called 'track' and " .
+ "'event_small_dt'";
}
+DBICTest::Schema->load_classes('EventSmallDT');
+
my @storage_types = (
'DBI::Sybase::ASE',
'DBI::Sybase::ASE::NoBindVars',
$schema->storage_type("::$storage_type");
}
$schema->connection($dsn, $user, $pass, {
- AutoCommit => 1,
- on_connect_call => [ 'datetime_setup' ],
+ on_connect_call => 'datetime_setup',
});
+ my $guard = Scope::Guard->new(sub { cleanup($schema) } );
+
$schema->storage->ensure_connected;
isa_ok( $schema->storage, "DBIx::Class::Storage::$storage_type" );
-# coltype, col, date
+ eval { $schema->storage->dbh->do("DROP TABLE track") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE track (
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT NULL,
+ position INT NULL,
+ last_updated_at DATETIME NULL
+)
+SQL
+ eval { $schema->storage->dbh->do("DROP TABLE event_small_dt") };
+ $schema->storage->dbh->do(<<"SQL");
+CREATE TABLE event_small_dt (
+ id INT IDENTITY PRIMARY KEY,
+ small_dt SMALLDATETIME NULL,
+)
+SQL
+
+# coltype, column, source, pk, create_extra, datehash
my @dt_types = (
- ['DATETIME', 'last_updated_at', '2004-08-21T14:36:48.080Z'],
-# minute precision
- ['SMALLDATETIME', 'small_dt', '2004-08-21T14:36:00.000Z'],
+ ['DATETIME',
+ 'last_updated_at',
+ 'Track',
+ 'trackid',
+ { cd => 1 },
+ {
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ second => 48,
+ nanosecond => 500000000,
+ }],
+ ['SMALLDATETIME', # minute precision
+ 'small_dt',
+ 'EventSmallDT',
+ 'id',
+ {},
+ {
+ year => 2004,
+ month => 8,
+ day => 21,
+ hour => 14,
+ minute => 36,
+ }],
);
-
+
for my $dt_type (@dt_types) {
- my ($type, $col, $sample_dt) = @$dt_type;
+ my ($type, $col, $source, $pk, $create_extra, $sample_dt) = @$dt_type;
- eval { $schema->storage->dbh->do("DROP TABLE track") };
- $schema->storage->dbh->do(<<"SQL");
-CREATE TABLE track (
- trackid INT IDENTITY PRIMARY KEY,
- cd INT NULL,
- position INT NULL,
- $col $type NULL
-)
-SQL
- ok(my $dt = DateTime::Format::Sybase->parse_datetime($sample_dt));
+ ok(my $dt = DateTime->new($sample_dt));
my $row;
- ok( $row = $schema->resultset('Track')->create({
+ ok( $row = $schema->resultset($source)->create({
$col => $dt,
- cd => 1,
+ %$create_extra,
}));
- ok( $row = $schema->resultset('Track')
- ->search({ trackid => $row->trackid }, { select => [$col] })
+ ok( $row = $schema->resultset($source)
+ ->search({ $pk => $row->$pk }, { select => [$col] })
->first
);
- is( $row->$col, $dt, 'DateTime roundtrip' );
+ is( $row->$col, $dt, "$type roundtrip" );
+
+ cmp_ok( $row->$col->nanosecond, '==', $sample_dt->{nanosecond},
+ 'DateTime fractional portion roundtrip' )
+ if exists $sample_dt->{nanosecond};
}
# test a computed datetime column
eval { $schema->storage->dbh->do("DROP TABLE track") };
$schema->storage->dbh->do(<<"SQL");
CREATE TABLE track (
- trackid INT IDENTITY PRIMARY KEY,
- cd INT NULL,
- position INT NULL,
- title VARCHAR(100) NULL,
- last_updated_on DATETIME NULL,
- last_updated_at AS getdate(),
- small_dt SMALLDATETIME NULL
+ trackid INT IDENTITY PRIMARY KEY,
+ cd INT NULL,
+ position INT NULL,
+ title VARCHAR(100) NULL,
+ last_updated_on DATETIME NULL,
+ last_updated_at AS getdate(),
)
SQL
- my $now = DateTime->now;
+ my $now = DateTime->now;
sleep 1;
my $new_row = $schema->resultset('Track')->create({});
$new_row->discard_changes;
done_testing;
# clean up our mess
-END {
- if (my $dbh = eval { $schema->storage->_dbh }) {
+sub cleanup {
+ my $schema = shift;
+ if (my $dbh = eval { $schema->storage->dbh }) {
$dbh->do('DROP TABLE track');
+ $dbh->do('DROP TABLE event_small_dt');
}
}
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-use lib qw(t/lib);
-use DBICTest;
-
-my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
-my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_SYBASE_ASA_ODBC_${_}" } qw/DSN USER PASS/};
-
-if (not ($dsn || $dsn2)) {
- plan skip_all => <<'EOF';
-Set $ENV{DBICTEST_SYBASE_ASA_DSN} and/or $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN}
-_USER and _PASS to run this test'.
-Warning: This test drops and creates a table called 'track'";
-EOF
-} else {
- eval "use DateTime; use DateTime::Format::Strptime;";
- if ($@) {
- plan skip_all => 'needs DateTime and DateTime::Format::Strptime for testing';
- }
-}
-
-my @info = (
- [ $dsn, $user, $pass ],
- [ $dsn2, $user2, $pass2 ],
-);
-
-my @handles_to_clean;
-
-foreach my $info (@info) {
- my ($dsn, $user, $pass) = @$info;
-
- next unless $dsn;
-
- my $schema = DBICTest::Schema->clone;
-
- $schema->connection($dsn, $user, $pass, {
- on_connect_call => [ 'datetime_setup' ],
- });
-
- push @handles_to_clean, $schema->storage->dbh;
-
-# coltype, col, date
- my @dt_types = (
- ['TIMESTAMP', 'last_updated_at', '2004-08-21 14:36:48.080445'],
-# date only (but minute precision according to ASA docs)
- ['DATE', 'small_dt', '2004-08-21 00:00:00.000000'],
- );
-
- for my $dt_type (@dt_types) {
- my ($type, $col, $sample_dt) = @$dt_type;
-
- eval { $schema->storage->dbh->do("DROP TABLE track") };
- $schema->storage->dbh->do(<<"SQL");
- CREATE TABLE track (
- trackid INT IDENTITY PRIMARY KEY,
- cd INT,
- position INT,
- $col $type,
- )
-SQL
- ok(my $dt = $schema->storage->datetime_parser->parse_datetime($sample_dt));
-
- my $row;
- ok( $row = $schema->resultset('Track')->create({
- $col => $dt,
- cd => 1,
- }));
- ok( $row = $schema->resultset('Track')
- ->search({ trackid => $row->trackid }, { select => [$col] })
- ->first
- );
- is( $row->$col, $dt, 'DateTime roundtrip' );
-
- is $row->$col->nanosecond, $dt->nanosecond,
- 'nanoseconds survived' if 0+$dt->nanosecond;
- }
-}
-
-done_testing;
-
-# clean up our mess
-END {
- foreach my $dbh (@handles_to_clean) {
- eval { $dbh->do("DROP TABLE $_") } for qw/track/;
- }
-}
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
+
+
use DBICTest;
+use DBICTest::Schema;
use File::Compare;
use Path::Class qw/file/;
-my $schema = DBICTest->init_schema();
+{
+ local $ENV{DBIC_IC_FILE_NOWARN} = 1;
+
+ package DBICTest::Schema::FileColumn;
+
+ use strict;
+ use warnings;
+ use base qw/DBICTest::BaseResult/;
+
+ use File::Temp qw/tempdir/;
+
+ __PACKAGE__->load_components (qw/InflateColumn::File/);
+ __PACKAGE__->table('file_columns');
+
+ __PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ file => {
+ data_type => 'varchar',
+ is_file_column => 1,
+ file_column_path => tempdir(CLEANUP => 1),
+ size => 255
+ }
+ );
+
+ __PACKAGE__->set_primary_key('id');
+}
+DBICTest::Schema->load_classes('FileColumn');
+
+my $schema = DBICTest->init_schema;
plan tests => 10;
+if (not $ENV{DBICTEST_SQLT_DEPLOY}) {
+ $schema->storage->dbh->do(<<'EOF');
+ CREATE TABLE file_columns (
+ id INTEGER PRIMARY KEY,
+ file VARCHAR(255)
+ )
+EOF
+}
+
my $rs = $schema->resultset('FileColumn');
my $source_file = file(__FILE__);
my $fname = $source_file->basename;
is ( $fc->file->{filename}, $new_fname, 'new filname matches' );
ok ( compare($new_storage, $new_source_file) == 0, 'new content matches' );
+if ($^O eq 'MSWin32') {
+ close $fc->file->{handle}; # can't delete open files on Win32
+}
$fc->delete;
ok ( ! -e $storage, 'storage deleted' );
use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
# Under some versions of SQLite if the $rs is left hanging around it will lock
# So we create a scope here cos I'm lazy
{
- my $rs = $schema->resultset('CD')->search ({}, { order_by => 'cdid' });
-
- # get the defined columns
- my @dbic_cols = sort $rs->result_source->columns;
-
- # use the hashref inflator class as result class
- $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
-
- # fetch first record
- my $datahashref1 = $rs->first;
-
- my @hashref_cols = sort keys %$datahashref1;
-
- is_deeply( \@dbic_cols, \@hashref_cols, 'returned columns' );
-
- my $cd1 = $rs->find ({cdid => 1});
- is_deeply ( $cd1, $datahashref1, 'first/find return the same thing');
-
- my $cd2 = $rs->search({ cdid => 1 })->single;
- is_deeply ( $cd2, $datahashref1, 'first/search+single return the same thing');
+ my $rs = $schema->resultset('CD')->search ({}, {
+ order_by => 'cdid',
+ });
+
+ my $orig_resclass = $rs->result_class;
+ eval "package DBICTest::CDSubclass; use base '$orig_resclass'";
+
+# override on a specific $rs object, should not chain
+ $rs->result_class ('DBICTest::CDSubclass');
+
+ my $cd = $rs->find ({cdid => 1});
+ is (ref $cd, 'DBICTest::CDSubclass', 'result_class override propagates to find');
+
+ $cd = $rs->search({ cdid => 1 })->single;
+ is (ref $cd, $orig_resclass, 'result_class override does not propagate over seach+single');
+
+ $cd = $rs->search()->find ({ cdid => 1 });
+ is (ref $cd, $orig_resclass, 'result_class override does not propagate over seach+find');
+
+# set as attr - should propagate
+ my $hri_rs = $rs->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' });
+ is ($rs->result_class, 'DBICTest::CDSubclass', 'original class unchanged');
+ is ($hri_rs->result_class, 'DBIx::Class::ResultClass::HashRefInflator', 'result_class accessor pre-set via attribute');
+
+
+ my $datahashref1 = $hri_rs->next;
+ is_deeply(
+ [ sort keys %$datahashref1 ],
+ [ sort $rs->result_source->columns ],
+ 'returned correct columns',
+ );
+
+ $cd = $hri_rs->find ({cdid => 1});
+ is_deeply ( $cd, $datahashref1, 'first/find return the same thing (result_class attr propagates)');
+
+ $cd = $hri_rs->search({ cdid => 1 })->single;
+ is_deeply ( $cd, $datahashref1, 'first/search+single return the same thing (result_class attr propagates)');
+
+ $hri_rs->result_class ('DBIx::Class::Row'); # something bogus
+ is(
+ $hri_rs->search->result_class, 'DBIx::Class::ResultClass::HashRefInflator',
+ 'result_class set using accessor does not propagate over unused search'
+ );
+
+# test result class auto-loading
+ throws_ok (
+ sub { $rs->result_class ('nonexsitant_bogus_class') },
+ qr/Can't locate nonexsitant_bogus_class.pm/,
+ 'Attempt to load on accessor override',
+ );
+ is ($rs->result_class, 'DBICTest::CDSubclass', 'class unchanged');
+
+ throws_ok (
+ sub { $rs->search ({}, { result_class => 'nonexsitant_bogus_class' }) },
+ qr/Can't locate nonexsitant_bogus_class.pm/,
+ 'Attempt to load on accessor override',
+ );
+ is ($rs->result_class, 'DBICTest::CDSubclass', 'class unchanged');
}
sub check_cols_of {
}
# sometimes for ultra-mega-speed you want to fetch columns in esoteric ways
-# check the inflator over a non-fetching join
+# check the inflator over a non-fetching join
$rs_dbic = $schema->resultset ('Artist')->search ({ 'me.artistid' => 1}, {
prefetch => { cds => 'tracks' },
order_by => [qw/cds.cdid tracks.trackid/],
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
#======= testing hashref serialization
-my $object = $rs->create( {
+my $object = $rs->create( {
serialized => '',
} );
ok($object->update( { serialized => $struct_hash } ), 'hashref deflation');
ok($inflated = $object->serialized, 'hashref inflation');
is_deeply($inflated, $struct_hash, 'inflated hash matches original');
-$object = $rs->create( {
+$object = $rs->create( {
serialized => '',
} );
$object->set_inflated_column('serialized', $struct_hash);
sub query_end { }
-sub txn_start { }
+sub txn_begin { }
sub txn_commit { }
use Test::More;
use DBIC::SqlMakerTest;
-
+
my ($sql, @bind) = $schema->storage->sql_maker->select(%args);
is_same_sql_bind(
- $sql, \@bind,
+ $sql, \@bind,
$expected_sql, \@expected_bind,
'foo bar works'
);
=head2 is_same_bind
is_same_bind(
- \@given_bind,
+ \@given_bind,
\@expected_bind,
$test_msg
);
--- /dev/null
+package DBICNSTest::Result::D;
+use base qw/DBIx::Class::Core/;
+__PACKAGE__->table('d');
+__PACKAGE__->add_columns('d');
+1;
--- /dev/null
+package DBICNSTest::ResultSet::D;
+1;
use base qw/DBIx::Class::Core/;
__PACKAGE__->table('a');
__PACKAGE__->add_columns('a');
+
+# part of a test, do not remove
+$_ = 'something completely utterly bogus';
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest;
use strict;
use warnings;
-use DBICTest::AuthorCheck;
+use DBICTest::RunMode;
use DBICTest::Schema;
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/;
+use Carp;
+use Path::Class::File ();
+use File::Spec;
+use Fcntl qw/:flock/;
=head1 NAME
use lib qw(t/lib);
use DBICTest;
use Test::More;
-
+
my $schema = DBICTest->init_schema();
=head1 DESCRIPTION
-This module provides the basic utilities to write tests against
+This module provides the basic utilities to write tests against
DBIx::Class.
=head1 METHODS
},
);
-This method removes the test SQLite database in t/var/DBIxClass.db
+This method removes the test SQLite database in t/var/DBIxClass.db
and then creates a new, empty database.
-This method will call deploy_schema() by default, unless the
+This method will call deploy_schema() by default, unless the
no_deploy flag is set.
-Also, by default, this method will call populate_schema() by
+Also, by default, this method will call populate_schema() by
default, unless the no_deploy or no_populate flags are set.
=cut
-sub has_custom_dsn {
- return $ENV{"DBICTEST_DSN"} ? 1:0;
+# some tests are very time sensitive and need to run on their own, without
+# being disturbed by anything else grabbing CPU or disk IO. Hence why everything
+# using DBICTest grabs a shared lock, and the few tests that request a :GlobalLock
+# will ask for an exclusive one and block until they can get it
+our ($global_lock_fh, $global_exclusive_lock);
+sub import {
+ my $self = shift;
+
+ my $lockpath = File::Spec->tmpdir . '/.dbictest_global.lock';
+
+ {
+ my $u = local_umask(0); # so that the file opens as 666, and any user can lock
+ open ($global_lock_fh, '>', $lockpath)
+ or die "Unable to open $lockpath: $!";
+ }
+
+ for (@_) {
+ if ($_ eq ':GlobalLock') {
+ flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+ $global_exclusive_lock = 1;
+ }
+ else {
+ croak "Unknown export $_ requested from $self";
+ }
+ }
+
+ unless ($global_exclusive_lock) {
+ flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
+ }
}
-sub _sqlite_dbfilename {
- return "t/var/DBIxClass.db";
+END {
+ if ($global_lock_fh) {
+ # delay destruction even more
+ }
+}
+
+{
+ my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
+ $dir->mkpath unless -d "$dir";
+ $dir = "$dir";
+
+ sub _sqlite_dbfilename {
+ my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
+ $holder = $$ if $holder == -1;
+
+ # useful for missing cleanup debugging
+ #if ( $holder == $$) {
+ # my $x = $0;
+ # $x =~ s/\//#/g;
+ # $holder .= "-$x";
+ #}
+
+ return "$dir/DBIxClass-$holder.db";
+ }
+
+ END {
+ _cleanup_dbfile();
+ }
+}
+
+$SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
+
+sub _cleanup_dbfile {
+ # cleanup if this is us
+ if (
+ ! $ENV{DBICTEST_LOCK_HOLDER}
+ or
+ $ENV{DBICTEST_LOCK_HOLDER} == -1
+ or
+ $ENV{DBICTEST_LOCK_HOLDER} == $$
+ ) {
+ my $db_file = _sqlite_dbfilename();
+ unlink $_ for ($db_file, "${db_file}-journal");
+ }
+}
+
+sub has_custom_dsn {
+ return $ENV{"DBICTEST_DSN"} ? 1:0;
}
sub _sqlite_dbname {
my $self = shift;
my %args = @_;
- return $self->_sqlite_dbfilename if $args{sqlite_use_file} or $ENV{"DBICTEST_SQLITE_USE_FILE"};
+ return $self->_sqlite_dbfilename if (
+ defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
+ );
return ":memory:";
}
sub _database {
my $self = shift;
my %args = @_;
+
+ if ($ENV{DBICTEST_DSN}) {
+ return (
+ (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
+ { AutoCommit => 1, %args },
+ );
+ }
my $db_file = $self->_sqlite_dbname(%args);
- unlink($db_file) if -e $db_file;
- unlink($db_file . "-journal") if -e $db_file . "-journal";
- mkdir("t/var") unless -d "t/var";
+ for ($db_file, "${db_file}-journal") {
+ next unless -e $_;
+ unlink ($_) or carp (
+ "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
+ );
+ }
+
+ return ("dbi:SQLite:${db_file}", '', '', {
+ AutoCommit => 1,
+
+ # this is executed on every connect, and thus installs a disconnect/DESTROY
+ # guard for every new $dbh
+ on_connect_do => sub {
+ my $storage = shift;
+ my $dbh = $storage->_get_dbh;
+
+ # no fsync on commit
+ $dbh->do ('PRAGMA synchronous = OFF');
+
+ # set a *DBI* disconnect callback, to make sure the physical SQLite
+ # file is still there (i.e. the test does not attempt to delete
+ # an open database, which fails on Win32)
+ if (my $guard_cb = __mk_disconnect_guard($db_file)) {
+ $dbh->{Callbacks} = {
+ connect => sub { $guard_cb->('connect') },
+ disconnect => sub { $guard_cb->('disconnect') },
+ DESTROY => sub { $guard_cb->('DESTROY') },
+ };
+ }
+ },
+ %args,
+ });
+}
+
+sub __mk_disconnect_guard {
+ return if DBIx::Class::_ENV_::PEEPEENESS(); # leaks handles, delaying DESTROY, can't work right
+
+ my $db_file = shift;
+ return unless -f $db_file;
- my $dsn = $ENV{"DBICTEST_DSN"} || "dbi:SQLite:${db_file}";
- my $dbuser = $ENV{"DBICTEST_DBUSER"} || '';
- my $dbpass = $ENV{"DBICTEST_DBPASS"} || '';
+ my $orig_inode = (stat($db_file))[1]
+ or return;
- my @connect_info = ($dsn, $dbuser, $dbpass, { AutoCommit => 1, %args });
+ my $clan_connect_caller = '*UNKNOWN*';
+ my $i;
+ while ( my ($pack, $file, $line) = caller(++$i) ) {
+ next if $file eq __FILE__;
+ next if $pack =~ /^DBIx::Class|^Try::Tiny/;
+ $clan_connect_caller = "$file line $line";
+ }
- return @connect_info;
+ my $failed_once = 0;
+ my $connected = 1;
+
+ return sub {
+ return if $failed_once;
+
+ my $event = shift;
+ if ($event eq 'connect') {
+ # this is necessary in case we are disconnected and connected again, all within the same $dbh object
+ $connected = 1;
+ return;
+ }
+ elsif ($event eq 'disconnect') {
+ $connected = 0;
+ }
+ elsif ($event eq 'DESTROY' and ! $connected ) {
+ return;
+ }
+
+ my $fail_reason;
+ if (! -e $db_file) {
+ $fail_reason = 'is missing';
+ }
+ else {
+ my $cur_inode = (stat($db_file))[1];
+
+ if ($orig_inode != $cur_inode) {
+ # pack/unpack to match the unsigned longs returned by `stat`
+ $fail_reason = sprintf 'was recreated (initially inode %s, now %s)', (
+ map { unpack ('L', pack ('l', $_) ) } ($orig_inode, $cur_inode )
+ );
+ }
+ }
+
+ if ($fail_reason) {
+ $failed_once++;
+
+ require Test::Builder;
+ my $t = Test::Builder->new;
+ local $Test::Builder::Level = $Test::Builder::Level + 3;
+ $t->ok (0,
+ "$db_file originally created at $clan_connect_caller $fail_reason before $event "
+ . 'of DBI handle - a strong indicator that the database file was tampered with while '
+ . 'still being open. This action would fail massively if running under Win32, hence '
+ . 'we make sure it fails on any OS :)'
+ );
+ }
+
+ return; # this empty return is a DBI requirement
+ };
}
+my $weak_registry = {};
+
sub init_schema {
my $self = shift;
my %args = @_;
} else {
$schema = DBICTest::Schema->compose_namespace('DBICTest');
}
+
if( $args{storage_type}) {
$schema->storage_type($args{storage_type});
}
+
if ( !$args{no_connect} ) {
$schema = $schema->connect($self->_database(%args));
- $schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
- unless $self->has_custom_dsn;
}
+
if ( !$args{no_deploy} ) {
__PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
__PACKAGE__->populate_schema( $schema )
if( !$args{no_populate} );
}
+
+ populate_weakregistry ( $weak_registry, $schema->storage )
+ if $INC{'Test/Builder.pm'} and $schema->storage;
+
return $schema;
}
+END {
+ assert_empty_weakregistry($weak_registry, 'quiet');
+}
+
=head2 deploy_schema
DBICTest->deploy_schema( $schema );
-This method does one of two things to the schema. It can either call
-the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
-variable is set, otherwise the default is to read in the t/lib/sqlite.sql
-file and execute the SQL within. Either way you end up with a fresh set
+This method does one of two things to the schema. It can either call
+the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
+variable is set, otherwise the default is to read in the t/lib/sqlite.sql
+file and execute the SQL within. Either way you end up with a fresh set
of tables for testing.
=cut
my $schema = shift;
my $args = shift || {};
- if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
+ if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
$schema->deploy($args);
} else {
- open IN, "t/lib/sqlite.sql";
- my $sql;
- { local $/ = undef; $sql = <IN>; }
- close IN;
+ my $filename = Path::Class::File->new(__FILE__)->dir
+ ->file('sqlite.sql')->stringify;
+ my $sql = do { local (@ARGV, $/) = $filename ; <> };
for my $chunk ( split (/;\s*\n+/, $sql) ) {
if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment
$schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
DBICTest->populate_schema( $schema );
-After you deploy your schema you can use this method to populate
+After you deploy your schema you can use this method to populate
the tables with test data.
=cut
[ 1, 2 ],
[ 1, 3 ],
]);
-
+
$schema->populate('TreeLike', [
[ qw/id parent name/ ],
[ 1, undef, 'root' ],
[ 1, "Tools" ],
[ 2, "Body Parts" ],
]);
-
+
$schema->populate('TypedObject', [
[ qw/objectid type value/ ],
[ 1, "pointy", "Awl" ],
use strict;
use warnings;
+#use base qw/DBIx::Class::Relationship::Cascade::Rekey DBIx::Class::Core/;
use base qw/DBIx::Class::Core/;
use DBICTest::BaseResultSet;
__PACKAGE__->table ('bogus');
__PACKAGE__->resultset_class ('DBICTest::BaseResultSet');
+#sub add_relationship {
+# my $self = shift;
+# my $opts = $_[3] || {};
+# if (grep { $_ eq $_[0] } qw/
+# cds_90s cds_80s cds_84 artist_undirected_maps mapped_artists last_track
+# /) {
+# # nothing - join-dependent or non-cascadeable relationship
+# }
+# elsif ($opts->{is_foreign_key_constraint}) {
+# $opts->{on_update} ||= 'cascade';
+# }
+# else {
+# $opts->{cascade_rekey} = 1
+# unless ref $_[2] eq 'CODE';
+# }
+# $self->next::method(@_[0..2], $opts);
+#}
+
1;
--- /dev/null
+package DBICTest::Cursor;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI::Cursor/;
+
+1;
--- /dev/null
+# belongs to t/86sqlt.t
+package # hide from PAUSE
+ DBICTest::DeployComponent;
+use warnings;
+use strict;
+
+our $hook_cb;
+
+sub sqlt_deploy_hook {
+ my $class = shift;
+
+ $hook_cb->($class, @_) if $hook_cb;
+ $class->next::method(@_) if $class->next::can;
+}
+
+1;
# belongs to t/run/90ensure_class_loaded.tl
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::ErrorComponent;
use warnings;
use strict;
# belongs to t/run/90ensure_class_loaded.tl
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::FakeComponent;
use warnings;
use strict;
# belongs to t/05components.t
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::ForeignComponent;
use warnings;
use strict;
# belongs to t/run/90ensure_class_loaded.tl
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::OptionalComponent;
use warnings;
use strict;
+++ /dev/null
-package # hide from PAUSE
- DBICTest::Plain;
-
-use strict;
-use warnings;
-use base qw/DBIx::Class::Schema/;
-use DBI;
-
-my $db_file = "t/var/Plain.db";
-
-unlink($db_file) if -e $db_file;
-unlink($db_file . "-journal") if -e $db_file . "-journal";
-mkdir("t/var") unless -d "t/var";
-
-my $dsn = "dbi:SQLite:${db_file}";
-
-__PACKAGE__->load_classes("Test");
-my $schema = __PACKAGE__->compose_connection(
- __PACKAGE__,
- $dsn,
- undef,
- undef,
- { AutoCommit => 1 }
-);
-
-my $dbh = DBI->connect($dsn);
-
-my $sql = <<EOSQL;
-CREATE TABLE test (
- id INTEGER NOT NULL,
- name VARCHAR(32) NOT NULL
-);
-
-INSERT INTO test (id, name) VALUES (1, 'DBIC::Plain is broken!');
-
-EOSQL
-
-$dbh->do($_) for split(/\n\n/, $sql);
-
-1;
+++ /dev/null
-package # hide from PAUSE
- DBICTest::Plain::Test;
-
-use base 'DBIx::Class::Core';
-
-__PACKAGE__->table('test');
-__PACKAGE__->add_columns(
- 'id' => {
- data_type => 'integer',
- is_auto_increment => 1
- },
- 'name' => {
- data_type => 'varchar',
- },
-);
-__PACKAGE__->set_primary_key('id');
-
-1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::ResultSetManager;
use base 'DBIx::Class::Schema';
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::ResultSetManager::Foo;
use base 'DBIx::Class::Core';
-package # hide from PAUSE
- DBICTest::AuthorCheck;
+package # hide from PAUSE
+ DBICTest::RunMode;
use strict;
use warnings;
+BEGIN {
+ if ($INC{'DBIx/Class.pm'}) {
+ my ($fr, @frame) = 1;
+ while (@frame = caller($fr++)) {
+ last if $frame[1] !~ m|^t/lib/DBICTest|;
+ }
+
+ die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n";
+ }
+}
+
use Path::Class qw/file dir/;
_check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION};
# not using file->stat as it invokes File::stat which in turn breaks stat(_)
my ($mf_pl_mtime, $mf_mtime, $optdeps_mtime) = ( map
- { (stat ($root->file ($_)) )[9] }
+ { (stat ($root->file ($_)) )[9] || undef } # stat returns () on nonexistent files
(qw|Makefile.PL Makefile|, $optdeps)
);
push @fail_reasons, "Missing ./inc directory";
}
- if (not $mf_mtime) {
+ if(not $mf_mtime) {
push @fail_reasons, "Missing ./Makefile";
}
- elsif($mf_mtime < $mf_pl_mtime) {
- push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
- }
-
- if ($mf_mtime < $optdeps_mtime) {
- push @fail_reasons, "./$optdeps is newer than ./Makefile";
+ else {
+ if($mf_mtime < $mf_pl_mtime) {
+ push @fail_reasons, "./Makefile.PL is newer than ./Makefile";
+ }
+ if($mf_mtime < $optdeps_mtime) {
+ push @fail_reasons, "./$optdeps is newer than ./Makefile";
+ }
}
if (@fail_reasons) {
We have a number of reasons to believe that this is a development
checkout and that you, the user, did not run `perl Makefile.PL`
before using this code. You absolutely _must_ perform this step,
-and ensure you have all required dependencies present. Not doing
+to ensure you have all required dependencies present. Not doing
so often results in a lot of wasted time for other contributors
trying to assit you with spurious "its broken!" problems.
+By default DBICs Makefile.PL turns all optional dependenciess into
+*HARD REQUIREMENTS*, in order to make sure that the entire test
+suite is executed, and no tests are skipped due to missing modules.
+If you for some reason need to disable this behavior - supply the
+--skip_author_deps option when running perl Makefile.PL
+
If you are seeing this message unexpectedly (i.e. you are in fact
attempting a regular installation be it through CPAN or manually),
please report the situation to either the mailing list or to the
return (
( not -d $root->subdir ('inc') )
or
- ( -e $root->subdir ('inc')->file ($^O eq 'VMS' ? '_author' : '.author') )
+ ( -e $root->subdir ('inc')->subdir ($^O eq 'VMS' ? '_author' : '.author') )
);
}
+sub is_smoker {
+ return ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} )
+}
+
+sub is_plain {
+ return (! __PACKAGE__->is_smoker && ! __PACKAGE__->is_author && ! $ENV{RELEASE_TESTING} )
+}
+
# Try to determine the root of a checkout/untar if possible
# or return undef
sub _find_co_root {
package # hide from PAUSE
DBICTest::Schema;
-use base qw/DBIx::Class::Schema/;
+use strict;
+use warnings;
+no warnings 'qw';
-no warnings qw/qw/;
+use base 'DBIx::Class::Schema';
+
+use Fcntl qw/:DEFAULT :seek :flock/;
+use Time::HiRes 'sleep';
+use Path::Class::File;
+use File::Spec;
+use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/;
+use namespace::clean;
+
+__PACKAGE__->mk_group_accessors(simple => 'custom_attr');
__PACKAGE__->load_classes(qw/
Artist
BindType
Employee
CD
- FileColumn
Genre
- Link
Bookmark
+ Link
#dummy
Track
Tag
Year1999CDs
CustomSql
Money
+ TimestampPrimaryKey
/,
{ 'DBICTest::Schema' => [qw/
LinerNotes
$sqlt_schema->drop_table('dummy');
}
+
+our $locker;
+END {
+ # we need the $locker to be referenced here for delayed destruction
+ if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
+ #warn "$$ $0 $locktype LOCK RELEASED";
+ }
+}
+
+my $weak_registry = {};
+
+sub connection {
+ my $self = shift->next::method(@_);
+
+# MASSIVE FIXME
+# we can't really lock based on DSN, as we do not yet have a way to tell that e.g.
+# DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst
+# and
+# DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0
+# are the same server
+# hence we lock everything based on sqlt_type or just globally if not available
+# just pretend we are python you know? :)
+
+
+ # when we get a proper DSN resolution sanitize to produce a portable lockfile name
+ # this may look weird and unnecessary, but consider running tests from
+ # windows over a samba share >.>
+ #utf8::encode($dsn);
+ #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge;
+ #$dsn =~ s/^dbi/dbi/i;
+
+ # provide locking for physical (non-memory) DSNs, so that tests can
+ # safely run in parallel. While the harness (make -jN test) does set
+ # an envvar, we can not detect when a user invokes prove -jN. Hence
+ # perform the locking at all times, it shouldn't hurt.
+ # the lock fh *should* inherit across forks/subprocesses
+ #
+ # File locking is hard. Really hard. By far the best lock implementation
+ # I've seen is part of the guts of File::Temp. However it is sadly not
+ # reusable. Since I am not aware of folks doing NFS parallel testing,
+ # nor are we known to work on VMS, I am just going to punt this and
+ # use the portable-ish flock() provided by perl itself. If this does
+ # not work for you - patches more than welcome.
+ if (
+ ! $DBICTest::global_exclusive_lock
+ and
+ ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ )
+ and
+ ref($_[0]) ne 'CODE'
+ and
+ ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
+ ) {
+
+ my $locktype = do {
+ # guard against infinite recursion
+ local $ENV{DBICTEST_LOCK_HOLDER} = -1;
+
+ # we need to connect a forced fresh clone so that we do not upset any state
+ # of the main $schema (some tests examine it quite closely)
+ local $@;
+ my $storage = eval {
+ my $st = ref($self)->connect(@{$self->storage->connect_info})->storage;
+ $st->ensure_connected; # do connect here, to catch a possible throw
+ $st;
+ };
+ $storage
+ ? do {
+ my $t = $storage->sqlt_type || 'generic';
+ eval { $storage->disconnect };
+ $t;
+ }
+ : undef
+ ;
+ };
+
+
+ # Never hold more than one lock. This solves the "lock in order" issues
+ # unrelated tests may have
+ # Also if there is no connection - there is no lock to be had
+ if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
+
+ warn "$$ $0 $locktype" if $locktype eq 'generic' or $locktype eq 'SQLite';
+
+ my $lockpath = File::Spec->tmpdir . "/.dbictest_$locktype.lock";
+
+ my $lock_fh;
+ {
+ my $u = local_umask(0); # so that the file opens as 666, and any user can lock
+ sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
+ }
+ flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
+ #warn "$$ $0 $locktype LOCK GRABBED";
+
+ # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
+ # if we do not do this we may end up trampling over some long-running END or somesuch
+ seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
+ my $old_pid;
+ if (
+ read ($lock_fh, $old_pid, 100)
+ and
+ ($old_pid) = $old_pid =~ /^(\d+)$/
+ ) {
+ for (1..50) {
+ kill (0, $old_pid) or last;
+ sleep 0.1;
+ }
+ }
+ #warn "$$ $0 $locktype POST GRAB WAIT";
+
+ truncate $lock_fh, 0;
+ seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
+ $lock_fh->autoflush(1);
+ print $lock_fh $$;
+
+ $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
+
+ $locker = {
+ type => $locktype,
+ fh => $lock_fh,
+ lock_name => "$lockpath",
+ };
+ }
+ }
+
+ if ($INC{'Test/Builder.pm'}) {
+ populate_weakregistry ( $weak_registry, $self->storage );
+
+ my $cur_connect_call = $self->storage->on_connect_call;
+
+ $self->storage->on_connect_call([
+ (ref $cur_connect_call eq 'ARRAY'
+ ? @$cur_connect_call
+ : ($cur_connect_call || ())
+ ),
+ [sub {
+ populate_weakregistry( $weak_registry, shift->_dbh )
+ }],
+ ]);
+ }
+
+ return $self;
+}
+
+sub clone {
+ my $self = shift->next::method(@_);
+ populate_weakregistry ( $weak_registry, $self )
+ if $INC{'Test/Builder.pm'};
+ $self;
+}
+
+END {
+ assert_empty_weakregistry($weak_registry, 'quiet');
+}
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Artist;
use base qw/DBICTest::BaseResult/;
+use Carp qw/confess/;
__PACKAGE__->table('artist');
__PACKAGE__->source_info({
},
);
__PACKAGE__->set_primary_key('artistid');
+__PACKAGE__->add_unique_constraint(['name']);
__PACKAGE__->add_unique_constraint(artist => ['artistid']); # do not remove, part of a test
+__PACKAGE__->add_unique_constraint(u_nullable => [qw/charfield rank/]);
+
__PACKAGE__->mk_classdata('field_name_for', {
artistid => 'primary key',
__PACKAGE__->has_many(
cds => 'DBICTest::Schema::CD', undef,
- { order_by => 'year' },
+ { order_by => { -asc => 'year'} },
+);
+
+
+__PACKAGE__->has_many(
+ cds_80s => 'DBICTest::Schema::CD',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artist" => { '=' => { -ident => "$args->{self_alias}.artistid"} },
+ "$args->{foreign_alias}.year" => { '>' => 1979, '<' => 1990 },
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid,
+ "$args->{foreign_alias}.year" => { '>' => 1979, '<' => 1990 },
+ }
+ );
+ },
+);
+
+
+__PACKAGE__->has_many(
+ cds_84 => 'DBICTest::Schema::CD',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
+ "$args->{foreign_alias}.year" => 1984,
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.artist" => $args->{self_rowobj}->artistid,
+ "$args->{foreign_alias}.year" => 1984,
+ }
+ );
+ }
+);
+
+
+__PACKAGE__->has_many(
+ cds_90s => 'DBICTest::Schema::CD',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artist" => { -ident => "$args->{self_alias}.artistid" },
+ "$args->{foreign_alias}.year" => { '>' => 1989, '<' => 2000 },
+ }
+ );
+ }
);
+
+
__PACKAGE__->has_many(
cds_unordered => 'DBICTest::Schema::CD'
);
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::ArtistGUID;
use base qw/DBICTest::BaseResult/;
# test MSSQL uniqueidentifier type
-__PACKAGE__->table('artist');
+__PACKAGE__->table('artist_guid');
__PACKAGE__->add_columns(
'artistid' => {
data_type => 'uniqueidentifier' # auto_nextval not necessary for PK
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::ArtistUndirectedMap;
use base qw/DBICTest::BaseResult/;
__PACKAGE__->has_many(
'mapped_artists', 'DBICTest::Schema::Artist',
[ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ],
+ { cascade_delete => 0 },
);
1;
DBICTest::Schema::Artwork;
use base qw/DBICTest::BaseResult/;
+use Carp qw/confess/;
__PACKAGE__->table('cd_artwork');
__PACKAGE__->add_columns(
__PACKAGE__->has_many('artwork_to_artist', 'DBICTest::Schema::Artwork_to_Artist', 'artwork_cd_id');
__PACKAGE__->many_to_many('artists', 'artwork_to_artist', 'artist');
+# both to test manytomany with custom rel
+__PACKAGE__->many_to_many('artists_test_m2m', 'artwork_to_artist', 'artist_test_m2m');
+__PACKAGE__->many_to_many('artists_test_m2m_noopt', 'artwork_to_artist', 'artist_test_m2m_noopt');
+
+# other test to manytomany
+__PACKAGE__->has_many('artwork_to_artist_test_m2m', 'DBICTest::Schema::Artwork_to_Artist',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artwork_cd_id" => { -ident => "$args->{self_alias}.cd_id" },
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.artwork_cd_id" => $args->{self_rowobj}->cd_id,
+ }
+ );
+ }
+);
+__PACKAGE__->many_to_many('artists_test_m2m2', 'artwork_to_artist_test_m2m', 'artist');
+
1;
DBICTest::Schema::Artwork_to_Artist;
use base qw/DBICTest::BaseResult/;
+use Carp qw/confess/;
__PACKAGE__->table('artwork_to_artist');
__PACKAGE__->add_columns(
__PACKAGE__->belongs_to('artwork', 'DBICTest::Schema::Artwork', 'artwork_cd_id');
__PACKAGE__->belongs_to('artist', 'DBICTest::Schema::Artist', 'artist_id');
+__PACKAGE__->belongs_to('artist_test_m2m', 'DBICTest::Schema::Artist',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" },
+ "$args->{foreign_alias}.rank" => { '<' => 10 },
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.artistid" => $args->{self_rowobj}->artist_id,
+ "$args->{foreign_alias}.rank" => { '<' => 10 },
+ }
+ );
+ }
+);
+
+__PACKAGE__->belongs_to('artist_test_m2m_noopt', 'DBICTest::Schema::Artist',
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.artistid" => { -ident => "$args->{self_alias}.artist_id" },
+ "$args->{foreign_alias}.rank" => { '<' => 10 },
+ }
+ );
+ }
+);
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::BindType;
use base qw/DBICTest::BaseResult/;
data_type => 'clob',
is_nullable => 1,
},
+ 'a_memo' => {
+ data_type => 'memo',
+ is_nullable => 1,
+ },
);
__PACKAGE__->set_primary_key('id');
package # hide from PAUSE
DBICTest::Schema::Bookmark;
- use base qw/DBICTest::BaseResult/;
-
+use base qw/DBICTest::BaseResult/;
use strict;
use warnings;
);
__PACKAGE__->set_primary_key('id');
-__PACKAGE__->belongs_to(link => 'DBICTest::Schema::Link', 'link', { on_delete => 'SET NULL' } );
+
+require DBICTest::Schema::Link; # so we can get a columnlist
+__PACKAGE__->belongs_to(
+ link => 'DBICTest::Schema::Link', 'link', {
+ on_delete => 'SET NULL',
+ join_type => 'LEFT',
+ proxy => { map { join('_', 'link', $_) => $_ } DBICTest::Schema::Link->columns },
+});
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::BooksInLibrary;
use base qw/DBICTest::BaseResult/;
);
__PACKAGE__->set_primary_key('id');
+__PACKAGE__->add_unique_constraint (['title']);
+
__PACKAGE__->resultset_attributes({where => { source => "Library" } });
__PACKAGE__->belongs_to ( owner => 'DBICTest::Schema::Owners', 'owner' );
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::CD;
use base qw/DBICTest::BaseResult/;
data_type => 'varchar',
size => 100,
},
- 'genreid' => {
+ 'genreid' => {
data_type => 'integer',
is_nullable => 1,
accessor => undef,
__PACKAGE__->set_primary_key('cdid');
__PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, {
- is_deferrable => 1,
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, {
+ is_deferrable => 1,
+ proxy => { artist_name => 'name' },
+});
+__PACKAGE__->belongs_to( very_long_artist_relationship => 'DBICTest::Schema::Artist', 'artist', {
+ is_deferrable => 1,
});
# in case this is a single-cd it promotes a track from another cd
-__PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track', 'single_track',
- { join_type => 'left'}
+__PACKAGE__->belongs_to( single_track => 'DBICTest::Schema::Track', 'single_track',
+ { join_type => 'left'}
);
# add a non-left single relationship for the complex prefetch tests
},
);
+
+# This is insane. Don't ever do anything like that
+# This is for testing purposes only!
+
+# mst: mo: DBIC is an "object relational mapper"
+# mst: mo: not an "object relational hider-because-mo-doesn't-understand-databases
+# ribasushi: mo: try it with a subselect nevertheless, I'd love to be proven wrong
+# ribasushi: mo: does sqlite actually take this?
+# ribasushi: an order in a correlated subquery is insane - how long does it take you on real data?
+
+__PACKAGE__->might_have(
+ 'last_track',
+ 'DBICTest::Schema::Track',
+ sub {
+ my $args = shift;
+ return (
+ {
+ "$args->{foreign_alias}.trackid" => { '=' =>
+ $args->{self_resultsource}->schema->resultset('Track')->search(
+ { 'correlated_tracks.cd' => { -ident => "$args->{self_alias}.cdid" } },
+ {
+ order_by => { -desc => 'position' },
+ rows => 1,
+ alias => 'correlated_tracks',
+ columns => ['trackid']
+ },
+ )->as_query
+ }
+ }
+ );
+ },
+);
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::CD_to_Producer;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Collection;
use base qw/DBICTest::BaseResult/;
{ where => { "object.type" => "pointy" } }
);
__PACKAGE__->many_to_many( round_objects => collection_object => "object",
- { where => { "object.type" => "round" } }
+ { where => { "object.type" => "round" } }
);
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::CollectionObject;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::ComputedColumn;
# for sybase and mssql computed column tests
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::CustomSql;
use base qw/DBICTest::Schema::Artist/;
__PACKAGE__->table('dummy');
__PACKAGE__->result_source_instance->name(\<<SQL);
- ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
+ ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
FROM artist a
JOIN cd ON cd.artist = a.artistid
WHERE cd.year = ?)
);
__PACKAGE__->set_primary_key('id');
+# part of a test, do not remove
+__PACKAGE__->sequence('bogus');
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Employee;
use base qw/DBICTest::BaseResult/;
size => 100,
is_nullable => 1,
},
+ encoded => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
);
__PACKAGE__->set_primary_key('employee_id');
__PACKAGE__->position_column('position');
-#__PACKAGE__->add_unique_constraint(position_group => [ qw/position group_id/ ]);
+# Do not add unique constraints here - different groups are used throughout
+# the ordered tests
-__PACKAGE__->mk_classdata('field_name_for', {
- employee_id => 'primary key',
- position => 'list position',
- group_id => 'collection column',
- name => 'employee name',
+__PACKAGE__->belongs_to (secretkey => 'DBICTest::Schema::Encoded', 'encoded', {
+ join_type => 'left'
});
1;
__PACKAGE__->set_primary_key('id');
+__PACKAGE__->has_many (keyholders => 'DBICTest::Schema::Employee', 'encoded');
+
sub set_column {
my ($self, $col, $value) = @_;
if( $col eq 'encoded' ){
__PACKAGE__->add_columns(
id => { data_type => 'integer', is_auto_increment => 1 },
- starts_at => { data_type => 'datetime' },
+
+# this MUST be 'date' for the Firebird and SQLAnywhere tests
+ starts_at => { data_type => 'date', datetime_undef_if_invalid => 1 },
+
created_on => { data_type => 'timestamp' },
- varchar_date => { data_type => 'varchar', inflate_date => 1, size => 20, is_nullable => 1 },
- varchar_datetime => { data_type => 'varchar', inflate_datetime => 1, size => 20, is_nullable => 1 },
+ varchar_date => { data_type => 'varchar', size => 20, is_nullable => 1 },
+ varchar_datetime => { data_type => 'varchar', size => 20, is_nullable => 1 },
skip_inflation => { data_type => 'datetime', inflate_datetime => 0, is_nullable => 1 },
ts_without_tz => { data_type => 'datetime', is_nullable => 1 }, # used in EventTZPg
);
__PACKAGE__->set_primary_key('id');
+# Test add_columns '+colname' to augment a column definition.
+__PACKAGE__->add_columns(
+ '+varchar_date' => {
+ inflate_date => 1,
+ },
+ '+varchar_datetime' => {
+ inflate_datetime => 1,
+ },
+);
+
1;
--- /dev/null
+package DBICTest::Schema::EventSmallDT;
+
+use strict;
+use warnings;
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->load_components(qw/InflateColumn::DateTime/);
+
+__PACKAGE__->table('event_small_dt');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ small_dt => { data_type => 'smalldatetime', is_nullable => 1 },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
DateTime::Format::Pg->new();
}
+# this is for a reentrancy test, the duplication from above is intentional
+__PACKAGE__->add_columns(
+ ts_without_tz => { data_type => 'timestamp without time zone', inflate_datetime => 1 },
+);
+
1;
+++ /dev/null
-package
-DBICTest::Schema::FileColumn;
-
-use strict;
-use warnings;
-use base qw/DBICTest::BaseResult/;
-use File::Temp qw/tempdir/;
-
-__PACKAGE__->load_components(qw/InflateColumn::File/);
-
-__PACKAGE__->table('file_columns');
-
-__PACKAGE__->add_columns(
- id => { data_type => 'integer', is_auto_increment => 1 },
- file => {
- data_type => 'varchar',
- is_file_column => 1,
- file_column_path => tempdir(CLEANUP => 1),
- size => 255
- }
-);
-
-__PACKAGE__->set_primary_key('id');
-
-1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::FourKeys;
use base qw/DBICTest::BaseResult/;
'hello' => { data_type => 'integer' },
'goodbye' => { data_type => 'integer' },
'sensors' => { data_type => 'character', size => 10 },
- 'read_count' => { data_type => 'integer', is_nullable => 1 },
+ 'read_count' => { data_type => 'int', is_nullable => 1 },
);
__PACKAGE__->set_primary_key(qw/foo bar hello goodbye/);
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::FourKeys_to_TwoKeys;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Image;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::LinerNotes;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Lyrics;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Money;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::NoPrimaryKey;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::OneKey;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Owners;
use base qw/DBICTest::BaseResult/;
);
__PACKAGE__->set_primary_key('id');
+__PACKAGE__->add_unique_constraint(['name']);
+
__PACKAGE__->has_many(books => "DBICTest::Schema::BooksInLibrary", "owner");
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Producer;
use base qw/DBICTest::BaseResult/;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::PunctuatedColumnName;
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('punctuated_column_name');
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ q{foo ' bar} => {
+ data_type => 'integer',
+ is_nullable => 1,
+ accessor => 'foo_bar',
+ },
+ q{bar/baz} => {
+ data_type => 'integer',
+ is_nullable => 1,
+ accessor => 'bar_baz',
+ },
+ q{baz;quux} => {
+ data_type => 'integer',
+ is_nullable => 1,
+ accessor => 'bar_quux',
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::SelfRef;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::SelfRefAlias;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::SequenceTest;
use base qw/DBICTest::BaseResult/;
'pkid1' => {
data_type => 'integer',
auto_nextval => 1,
- sequence => 'pkid1_seq',
+ sequence => \'"pkid1_seq"',
},
'pkid2' => {
data_type => 'integer',
auto_nextval => 1,
- sequence => 'pkid2_seq',
+ sequence => \'pkid2_seq',
},
'nonpkid' => {
data_type => 'integer',
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Serialized;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Tag;
use base qw/DBICTest::BaseResult/;
);
__PACKAGE__->set_primary_key('tagid');
-__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
+__PACKAGE__->add_unique_constraints( # do not remove, part of a test
+ tagid_cd => [qw/ tagid cd /],
+ tagid_cd_tag => [qw/ tagid cd tag /],
+);
+__PACKAGE__->add_unique_constraints( # do not remove, part of a test
+ [qw/ tagid tag /],
+ [qw/ tagid tag cd /],
+);
+
+__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', 'cd', {
+ proxy => [ 'year', { cd_title => 'title' } ],
+});
1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::TimestampPrimaryKey;
+
+use base qw/DBICTest::BaseResult/;
+
+__PACKAGE__->table('timestamp_primary_key_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'timestamp',
+ default_value => \'current_timestamp',
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Track;
use base qw/DBICTest::BaseResult/;
-__PACKAGE__->load_components(qw/InflateColumn::DateTime Ordered/);
+use Carp qw/confess/;
+
+__PACKAGE__->load_components(qw{
+ +DBICTest::DeployComponent
+ InflateColumn::DateTime
+ Ordered
+});
__PACKAGE__->table('track');
__PACKAGE__->add_columns(
data_type => 'datetime',
is_nullable => 1
},
- small_dt => { # for mssql and sybase DT tests
- data_type => 'smalldatetime',
- is_nullable => 1
- },
);
__PACKAGE__->set_primary_key('trackid');
__PACKAGE__->grouping_column ('cd');
-__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD' );
-__PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd');
+__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, {
+ proxy => { cd_title => 'title' },
+});
+__PACKAGE__->belongs_to( disc => 'DBICTest::Schema::CD' => 'cd', {
+ proxy => 'year'
+});
__PACKAGE__->might_have( cd_single => 'DBICTest::Schema::CD', 'single_track' );
__PACKAGE__->might_have( lyrics => 'DBICTest::Schema::Lyrics', 'track_id' );
{ join_type => 'left' },
);
+__PACKAGE__->has_many (
+ next_tracks => __PACKAGE__,
+ sub {
+ my $args = shift;
+
+ # This is for test purposes only. A regular user does not
+ # need to sanity check the passed-in arguments, this is what
+ # the tests are for :)
+ my @missing_args = grep { ! defined $args->{$_} }
+ qw/self_alias foreign_alias self_resultsource foreign_relname/;
+ confess "Required arguments not supplied to custom rel coderef: @missing_args\n"
+ if @missing_args;
+
+ return (
+ { "$args->{foreign_alias}.cd" => { -ident => "$args->{self_alias}.cd" },
+ "$args->{foreign_alias}.position" => { '>' => { -ident => "$args->{self_alias}.position" } },
+ },
+ $args->{self_rowobj} && {
+ "$args->{foreign_alias}.cd" => $args->{self_rowobj}->get_column('cd'),
+ "$args->{foreign_alias}.position" => { '>' => $args->{self_rowobj}->pos },
+ }
+ )
+ }
+);
+
+our $hook_cb;
+
+sub sqlt_deploy_hook {
+ my $class = shift;
+
+ $hook_cb->($class, @_) if $hook_cb;
+ $class->next::method(@_) if $class->next::can;
+}
+
1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::TreeLike;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::TwoKeyTreeLike;
use base qw/DBICTest::BaseResult/;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::TypedObject;
use base qw/DBICTest::BaseResult/;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::VaryingMAX;
+
+use base qw/DBICTest::BaseResult/;
+
+# Test VARCHAR(MAX) type for MSSQL (used in ADO tests)
+
+__PACKAGE__->table('varying_max_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'varchar_max' => {
+ data_type => 'varchar',
+ size => 'max',
+ is_nullable => 1,
+ },
+ 'nvarchar_max' => {
+ data_type => 'nvarchar',
+ size => 'max',
+ is_nullable => 1,
+ },
+ 'varbinary_max' => {
+ data_type => 'varbinary(max)', # alternately
+ size => undef,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Schema::Year1999CDs;
## Used in 104view.t
# belongs to t/run/90ensure_class_loaded.tl
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::SyntaxErrorComponent1;
use warnings;
use strict;
# belongs to t/run/90ensure_class_loaded.tl
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::SyntaxErrorComponent2;
use warnings;
use strict;
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Taint::Classes::Auto;
use base 'DBIx::Class::Core';
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Taint::Classes::Manual;
use base 'DBIx::Class::Core';
-package # hide from PAUSE
+package # hide from PAUSE
DBICTest::Taint::Namespaces::Result::Test;
use base 'DBIx::Class::Core';
--- /dev/null
+package DBICTest::Util;
+
+use warnings;
+use strict;
+
+use Carp;
+use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use Config;
+
+use base 'Exporter';
+our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
+
+sub local_umask {
+ return unless defined $Config{d_umask};
+
+ die 'Calling local_umask() in void context makes no sense'
+ if ! defined wantarray;
+
+ my $old_umask = umask(shift());
+ die "Setting umask failed: $!" unless defined $old_umask;
+
+ return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
+}
+{
+ package DBICTest::Util::UmaskGuard;
+ sub DESTROY {
+ local ($@, $!);
+ eval { defined (umask ${$_[0]}) or die };
+ warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
+ if ($@ || $!);
+ }
+}
+
+
+sub stacktrace {
+ my $frame = shift;
+ $frame++;
+ my (@stack, @frame);
+
+ while (@frame = caller($frame++)) {
+ push @stack, [@frame[3,1,2]];
+ }
+
+ return undef unless @stack;
+
+ $stack[0][0] = '';
+ return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
+}
+
+my $refs_traced = 0;
+sub populate_weakregistry {
+ my ($reg, $target, $slot) = @_;
+
+ croak 'Target is not a reference' unless defined ref $target;
+
+ $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
+ (defined blessed $target) ? blessed($target) . '=' : '',
+ reftype $target,
+ refaddr $target,
+ );
+
+ if (defined $reg->{$slot}{weakref}) {
+ if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) {
+ print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n";
+ exit 255;
+ }
+ }
+ else {
+ $refs_traced++;
+ weaken( $reg->{$slot}{weakref} = $target );
+ $reg->{$slot}{stacktrace} = stacktrace(1);
+ }
+
+ $target;
+}
+
+my $leaks_found;
+sub assert_empty_weakregistry {
+ my ($weak_registry, $quiet) = @_;
+
+ croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
+
+ return unless keys %$weak_registry;
+
+ my $tb = eval { Test::Builder->new }
+ or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
+
+ for my $slot (sort keys %$weak_registry) {
+ next if ! defined $weak_registry->{$slot}{weakref};
+ $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
+ unless isweak( $weak_registry->{$slot}{weakref} );
+ }
+
+
+ for my $slot (sort keys %$weak_registry) {
+ ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+
+ $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
+ $leaks_found = 1;
+
+ my $diag = '';
+
+ $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+ if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
+
+ if (my $stack = $weak_registry->{$slot}{stacktrace}) {
+ $diag .= " Reference first seen$stack";
+ }
+
+ $tb->diag($diag) if $diag;
+ };
+ }
+}
+
+END {
+ if ($INC{'Test/Builder.pm'}) {
+ my $tb = Test::Builder->new;
+
+ # we check for test passage - a leak may be a part of a TODO
+ if ($leaks_found and !$tb->is_passing) {
+
+ $tb->diag(sprintf
+ "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
+ . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
+ . "\n\n%s\n%s\n\n", ('#' x 16) x 4
+ ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
+
+ }
+ else {
+ $tb->note("Auto checked $refs_traced references for leaks - none detected");
+ }
+ }
+}
+
+1;
--- /dev/null
+package DBICTest::Util::OverrideRequire;
+
+# no use/require of any kind - work bare
+
+BEGIN {
+ # Neat STDERR require call tracer
+ #
+ # 0 - no trace
+ # 1 - just requires and return values
+ # 2 - neat stacktrace (assumes that the supplied $override_cref does *not* (ab)use goto)
+ # 3 - full stacktrace
+ *TRACE = sub () { 0 };
+}
+
+# Takes a single coderef and replaces CORE::GLOBAL::require with it.
+#
+# On subsequent require() calls, the coderef will be invoked with
+# two arguments - ($next_require, $module_name_copy)
+#
+# $next_require is a coderef closing over the module name. It needs
+# to be invoked at some point without arguments for the actual
+# require to take place (this way your coderef in essence becomes an
+# around modifier)
+#
+# $module_name_copy is a string-copy of what $next_require is closing
+# over. The reason for the copy is that you may trigger a side effect
+# on magical values, and subsequently abort the require (e.g.
+# require v.5.8.8 magic)
+#
+# All of this almost verbatim copied from Lexical::SealRequireHints
+# Zefram++
+sub override_global_require (&) {
+ my $override_cref = shift;
+
+ our $next_require = defined(&CORE::GLOBAL::require)
+ ? \&CORE::GLOBAL::require
+ : sub {
+
+ my ($arg) = @_;
+
+ # The shenanigans with $CORE::GLOBAL::{require}
+ # are required because if there's a
+ # &CORE::GLOBAL::require when the eval is
+ # executed then the CORE::require in there is
+ # interpreted as plain require on some Perl
+ # versions, leading to recursion.
+ my $grequire = delete $CORE::GLOBAL::{require};
+
+ my $res = eval sprintf '
+ local $SIG{__DIE__};
+ $CORE::GLOBAL::{require} = $grequire;
+ package %s;
+ CORE::require($arg);
+ ', scalar caller(0); # the caller already had its package replaced
+
+ my $err = $@ if $@ ne '';
+
+ if( TRACE ) {
+ if (TRACE == 1) {
+ printf STDERR "Require of '%s' (returned: '%s')\n",
+ (my $m_copy = $arg),
+ (my $r_copy = $res),
+ ;
+ }
+ else {
+ my ($fr_num, @fr, @tr, $excise);
+ while (@fr = caller($fr_num++)) {
+
+ # Package::Stash::XS is a cock and gets mightily confused if one
+ # uses a regex in the require hook. Even though it happens only
+ # on < 5.8.7 it's still rather embarassing (also wtf does P::S::XS
+ # even need to regex its own module name?!). So we do not use re :)
+ if (TRACE == 3 or (index($fr[1], '(eval ') != 0 and index($fr[1], __FILE__) != 0) ) {
+ push @tr, [@fr]
+ }
+
+ # the caller before this would be the override site - kill it away
+ # if the cref writer uses goto - well tough, tracer won't work
+ if ($fr[3] eq 'DBICTest::Util::OverrideRequire::__ANON__') {
+ $excise ||= $tr[-2]
+ if TRACE == 2;
+ }
+ }
+
+ my @stack =
+ map { "$_->[1], line $_->[2]" }
+ grep { ! $excise or $_->[1] ne $excise->[1] or $_->[2] ne $excise->[2] }
+ @tr
+ ;
+
+ printf STDERR "Require of '%s' (returned: '%s')\n%s\n\n",
+ (my $m_copy = $arg),
+ (my $r_copy = $res||''),
+ join "\n", (map { " $_" } @stack)
+ ;
+ }
+ }
+
+ die $err if defined $err;
+
+ return $res;
+ }
+ ;
+
+ # Need to suppress the redefinition warning, without
+ # invoking warnings.pm.
+ BEGIN { ${^WARNING_BITS} = ""; }
+
+ *CORE::GLOBAL::require = sub {
+ die "wrong number of arguments to require\n"
+ unless @_ == 1;
+
+ # the copy is to prevent accidental overload firing (e.g. require v5.8.8)
+ my ($arg_copy) = our ($arg) = @_;
+
+ return $override_cref->(sub {
+ die "The require delegate takes no arguments\n"
+ if @_;
+
+ my $res = eval sprintf '
+ local $SIG{__DIE__};
+ package %s;
+ $next_require->($arg);
+ ', scalar caller(2); # 2 for the indirection of the $override_cref around
+
+ die $@ if $@ ne '';
+
+ return $res;
+
+ }, $arg_copy);
+ }
+}
+
+1;
__PACKAGE__->register_class('Table', 'DBICVersion::Table');
__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned');
-
-sub upgrade_directory
-{
- return 't/var/';
-}
+__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$");
sub ordered_schema_versions {
return('1.0','2.0','3.0');
__PACKAGE__->register_class('Table', 'DBICVersion::Table');
__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned');
-__PACKAGE__->upgrade_directory('t/var/');
-__PACKAGE__->backup_directory('t/var/backup/');
-
-#sub upgrade_directory
-#{
-# return 't/var/';
-#}
+__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$");
+__PACKAGE__->backup_directory("t/var/versioning_backup-$$");
1;
__PACKAGE__->register_class('Table', 'DBICVersion::Table');
__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned');
-__PACKAGE__->upgrade_directory('t/var/');
-__PACKAGE__->backup_directory('t/var/backup/');
+__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$");
+__PACKAGE__->backup_directory("t/var/versioning_backup-$$");
1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps;
+## Used in 105view_deps.t
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema';
+
+__PACKAGE__->load_namespaces;
+
+sub sqlt_deploy_hook {
+ my $self = shift;
+ $self->{sqlt} = shift;
+}
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::ANameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('a_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM artist WHERE name like 'a%'"
+);
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::AbNameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('ab_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM a_name_artists WHERE name like 'ab%'"
+);
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDeps::Result::ANameArtists"]
+);
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::AbaNameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('aba_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM ab_name_artists WHERE name like 'aba%'" );
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDeps::Result::AbNameArtists"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::AbaNameArtistsAnd2010CDsWithManyTracks;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('aba_name_artists_and_2010_cds_with_many_tracks');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT aba.id,aba.name,cd.title,cd.year,cd.number_tracks FROM aba_name_artists aba JOIN year_2010_cds_with_many_tracks cd on (aba.id = cd.artist)"
+);
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDeps::Result::AbNameArtists","ViewDeps::Result::Year2010CDsWithManyTracks"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+ title => { data_type => 'text' },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::Artist;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('artist');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::Artwork;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('artwork');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ cd => { data_type => 'integer' },
+ file => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::CD;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('cd');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::Track;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('track');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ cd => { data_type => 'integer' },
+ track_number => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::TrackNumberFives;
+
+use strict;
+use warnings;
+use base 'ViewDeps::Result::Track';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('track_number_fives');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,title,cd,track_number FROM track WHERE track_number = '5'");
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ cd => { data_type => 'integer' },
+ track_number => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDeps::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::Year2010CDs;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('year_2010_cds');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,title,artist,year,number_tracks FROM cd WHERE year = '2010'");
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDeps::Result::Year2010CDsWithManyTracks;
+
+use strict;
+use warnings;
+use base 'ViewDeps::Result::Year2010CDs';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('year_2010_cds_with_many_tracks');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cd.id,cd.title,cd.artist,cd.year,cd.number_tracks,art.file FROM year_2010_cds cd JOIN artwork art on art.cd = cd.id WHERE cd.number_tracks > 10"
+);
+
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDeps::Result::Year2010CDs"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+ file => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDeps::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDeps::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad;
+## Used in 105view_deps.t
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema';
+
+__PACKAGE__->load_namespaces;
+
+sub sqlt_deploy_hook {
+ my $self = shift;
+ $self->{sqlt} = shift;
+}
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::ANameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('a_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM artist WHERE name like 'a%'"
+);
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDeps::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::AbNameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('ab_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM a_name_artists WHERE name like 'ab%'"
+);
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDepsBad::Result::ANameArtists"]
+);
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::AbaNameArtists;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('aba_name_artists');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,name FROM ab_name_artists WHERE name like 'aba%'" );
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDepsBad::Result::AbNameArtists", "ViewDepsBad::Result::AbaNameArtistsAnd2010CDsWithManyTracks"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::AbaNameArtistsAnd2010CDsWithManyTracks;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('aba_name_artists_and_2010_cds_with_many_tracks');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT aba.id,aba.name,cd.title,cd.year,cd.number_tracks FROM aba_name_artists aba JOIN year_2010_cds_with_many_tracks cd on (aba.id = cd.artist)"
+);
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDepsBad::Result::AbNameArtists","ViewDepsBad::Result::Year2010CDsWithManyTracks"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+ title => { data_type => 'text' },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::Artist;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('artist');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ name => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->has_many( 'cds', 'ViewDepsBad::Result::CD',
+ { "foreign.artist" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::Artwork;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('artwork');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ cd => { data_type => 'integer' },
+ file => { data_type => 'text' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::CD;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('cd');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::Track;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table('track');
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ cd => { data_type => 'integer' },
+ track_number => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::TrackNumberFives;
+
+use strict;
+use warnings;
+use base 'ViewDepsBad::Result::Track';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('track_number_fives');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,title,cd,track_number FROM track WHERE track_number = '5'");
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ cd => { data_type => 'integer' },
+ track_number => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'cd', 'ViewDepsBad::Result::CD',
+ { "foreign.id" => "self.cd" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::Year2010CDs;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Core';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('year_2010_cds');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT id,title,artist,year,number_tracks FROM cd WHERE year = '2010'");
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+package # hide from PAUSE
+ ViewDepsBad::Result::Year2010CDsWithManyTracks;
+
+use strict;
+use warnings;
+use base 'ViewDepsBad::Result::Year2010CDs';
+
+__PACKAGE__->table_class('DBIx::Class::ResultSource::View');
+__PACKAGE__->table('year_2010_cds_with_many_tracks');
+__PACKAGE__->result_source_instance->view_definition(
+ "SELECT cd.id,cd.title,cd.artist,cd.year,cd.number_tracks,art.file FROM year_2010_cds cd JOIN artwork art on art.cd = cd.id WHERE cd.number_tracks > 10"
+);
+
+__PACKAGE__->result_source_instance->deploy_depends_on(
+ ["ViewDepsBad::Result::Year2010CDs"] );
+
+__PACKAGE__->add_columns(
+ id => { data_type => 'integer', is_auto_increment => 1 },
+ title => { data_type => 'text' },
+ artist => { data_type => 'integer', is_nullable => 0 },
+ year => { data_type => 'integer' },
+ number_tracks => { data_type => 'integer' },
+ file => { data_type => 'integer' },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+__PACKAGE__->belongs_to( 'artist', 'ViewDepsBad::Result::Artist',
+ { "foreign.id" => "self.artist" },
+);
+
+__PACKAGE__->has_many( 'tracks', 'ViewDepsBad::Result::Track',
+ { "foreign.cd" => "self.id" },
+);
+
+1;
--- /dev/null
+{
+ "Model" : {
+ "Gort" : {
+ "connect_info" : [
+ "klaatu",
+ "barada",
+ "nikto"
+ ]
+ }
+ }
+}
--- /dev/null
+{"indent_string":"frioux"}
+
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sat Jan 30 19:18:55 2010
+-- Created on Fri Mar 2 18:22:33 2012
--
-;
--
-- Table: artist
CREATE TABLE artist (
artistid INTEGER PRIMARY KEY NOT NULL,
name varchar(100),
- rank integer NOT NULL DEFAULT '13',
+ rank integer NOT NULL DEFAULT 13,
charfield char(10)
);
CREATE INDEX artist_name_hookidx ON artist (name);
+CREATE UNIQUE INDEX artist_name ON artist (name);
+
+CREATE UNIQUE INDEX u_nullable ON artist (charfield, rank);
+
--
-- Table: bindtype_test
--
id INTEGER PRIMARY KEY NOT NULL,
bytea blob,
blob blob,
- clob clob
+ clob clob,
+ a_memo memo
);
--
);
--
--- Table: employee
---
-CREATE TABLE employee (
- employee_id INTEGER PRIMARY KEY NOT NULL,
- position integer NOT NULL,
- group_id integer,
- group_id_2 integer,
- group_id_3 integer,
- name varchar(100)
-);
-
---
-- Table: encoded
--
CREATE TABLE encoded (
--
CREATE TABLE event (
id INTEGER PRIMARY KEY NOT NULL,
- starts_at datetime NOT NULL,
+ starts_at date NOT NULL,
created_on timestamp NOT NULL,
varchar_date varchar(20),
varchar_datetime varchar(20),
);
--
--- Table: file_columns
---
-CREATE TABLE file_columns (
- id INTEGER PRIMARY KEY NOT NULL,
- file varchar(255) NOT NULL
-);
-
---
-- Table: fourkeys
--
CREATE TABLE fourkeys (
hello integer NOT NULL,
goodbye integer NOT NULL,
sensors character(10) NOT NULL,
- read_count integer,
+ read_count int,
PRIMARY KEY (foo, bar, hello, goodbye)
);
name varchar(100) NOT NULL
);
+CREATE UNIQUE INDEX owners_name ON owners (name);
+
--
-- Table: producer
--
);
--
+-- Table: timestamp_primary_key_test
+--
+CREATE TABLE timestamp_primary_key_test (
+ id timestamp NOT NULL DEFAULT current_timestamp,
+ PRIMARY KEY (id)
+);
+
+--
-- Table: treelike
--
CREATE TABLE treelike (
CREATE INDEX books_idx_owner ON books (owner);
+CREATE UNIQUE INDEX books_title ON books (title);
+
+--
+-- Table: employee
+--
+CREATE TABLE employee (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ position integer NOT NULL,
+ group_id integer,
+ group_id_2 integer,
+ group_id_3 integer,
+ name varchar(100),
+ encoded integer
+);
+
+CREATE INDEX employee_idx_encoded ON employee (encoded);
+
--
-- Table: forceforeign
--
position int NOT NULL,
title varchar(100) NOT NULL,
last_updated_on datetime,
- last_updated_at datetime,
- small_dt smalldatetime
+ last_updated_at datetime
);
CREATE INDEX track_idx_cd ON track (cd);
CREATE INDEX tags_idx_cd ON tags (cd);
+CREATE UNIQUE INDEX tagid_cd ON tags (tagid, cd);
+
+CREATE UNIQUE INDEX tagid_cd_tag ON tags (tagid, cd, tag);
+
+CREATE UNIQUE INDEX tags_tagid_tag ON tags (tagid, tag);
+
+CREATE UNIQUE INDEX tags_tagid_tag_cd ON tags (tagid, tag, cd);
+
--
-- Table: cd_to_producer
--
-- View: year2000cds
--
CREATE VIEW year2000cds AS
- SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000"
\ No newline at end of file
+ SELECT cdid, artist, title, year, genreid, single_track FROM cd WHERE year = "2000";
--- /dev/null
+--
+-- This table line should not be skipped
+--
+CREATE TABLE artist (
+ artistid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100),
+ rank integer NOT NULL DEFAULT 13,
+ charfield char(10)
+);
+
+CREATE INDEX artist_name_hookidx ON artist (name); -- This line should error if artist was not parsed correctly
--- /dev/null
+package DBICTestAdminInc;
+use base 'DBIx::Class::Schema';
+
+sub connect { exit 70 } # this is what the test will expect to see
+
+1;
--- /dev/null
+package DBICTestConfig;
+use base 'DBIx::Class::Schema';
+
+sub connect {
+ my($self, @opt) = @_;
+ @opt == 4
+ and $opt[0] eq 'klaatu'
+ and $opt[1] eq 'barada'
+ and $opt[2] eq 'nikto'
+ and $opt[3]->{ignore_version}
+ and exit 71; # this is what the test will expect to see
+ exit 1;
+}
+
+1;
use strict;
use warnings;
-use Test::More qw(no_plan);
-use Test::Exception;
+use Test::More;
use lib qw(t/lib);
use DBICTest;
ok($single->cdid, 'Got cdid');
};
+
+done_testing;
# even if the preceeding relationship already exists.
#
# To get this to work a minor rewrite of find() is necessary, and
-# more importantly some sort of recursive_insert() call needs to
+# more importantly some sort of recursive_insert() call needs to
# be available. The way things will work then is:
# *) while traversing the hierarchy code calls find_or_create()
# *) this in turn calls find(%\nested_dataset)
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use lib qw(t/lib);
use DBICTest;
-plan tests => 12;
-
my $schema = DBICTest->init_schema();
-# Test various new() invocations - this is all about backcompat, making
+# Test various new() invocations - this is all about backcompat, making
# sure that insert() still works as expected by legacy code.
#
# What we essentially do is multi-instantiate objects, making sure nothing
{
my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave in Silence', 'year' => 1982});
- eval {
+ lives_ok {
$new_artist->insert;
$new_related_cd->insert;
- };
- is ($@, '', 'Staged insertion successful');
+ } 'Staged insertion successful';
ok($new_artist->in_storage, 'artist inserted');
ok($new_related_cd->in_storage, 'new_related_cd inserted');
}
{
- my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode' });
+ my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Mode Depeche' });
my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Slightly Noisily', 'year' => 1982});
- eval {
+ lives_ok {
$new_related_cd->insert;
- };
- is ($@, '', 'CD insertion survives by finding artist');
+ } 'CD insertion survives by finding artist';
ok($new_artist->in_storage, 'artist inserted');
ok($new_related_cd->in_storage, 'new_related_cd inserted');
}
{
- my $new_artist = $schema->resultset("Artist")->new_result({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
- my $new_related_cd = $new_artist->new_related('cds', { 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
- eval {
- $new_related_cd->insert;
- };
- is ($@, '', 'CD insertion survives by inserting artist');
+ my $new_cd = $schema->resultset('CD')->new ({ 'title' => 'Leave Loudly While Singing Off Key', 'year' => 1982});
+ my $new_artist = $schema->resultset("Artist")->new ({ 'name' => 'Depeche Mode 2: Insertion Boogaloo' });
+ $new_cd->artist ($new_artist);
+
+ lives_ok {
+ $new_cd->insert;
+ } 'CD insertion survives by inserting artist';
+ ok($new_cd->in_storage, 'new_related_cd inserted');
ok($new_artist->in_storage, 'artist inserted');
- ok($new_related_cd->in_storage, 'new_related_cd inserted');
+
+ my $retrieved_cd = $schema->resultset('CD')->find ({ 'title' => 'Leave Loudly While Singing Off Key'});
+ ok ($retrieved_cd, 'CD found in db');
+ is ($retrieved_cd->artist->name, 'Depeche Mode 2: Insertion Boogaloo', 'Correct artist attached to cd');
+}
+
+{
+ my $new_cd = $schema->resultset('CD')->new ({ 'title' => 'Leave screaming Off Key in the nude', 'year' => 1982});
+ my $new_related_artist = $new_cd->new_related( artist => { 'name' => 'Depeche Mode 3: Insertion Boogaloo' });
+ lives_ok {
+ $new_related_artist->insert;
+ $new_cd->insert;
+ } 'CD insertion survives after inserting artist';
+ ok($new_cd->in_storage, 'cd inserted');
+ ok($new_related_artist->in_storage, 'artist inserted');
+
+ my $retrieved_cd = $schema->resultset('CD')->find ({ 'title' => 'Leave screaming Off Key in the nude'});
+ ok ($retrieved_cd, 'CD found in db');
+ is ($retrieved_cd->artist->name, 'Depeche Mode 3: Insertion Boogaloo', 'Correct artist attached to cd');
+}
+
+# test both sides of a 1:(1|0)
+{
+ for my $reldir ('might_have', 'belongs_to') {
+ my $artist = $schema->resultset('Artist')->next;
+
+ my $new_track = $schema->resultset('Track')->new ({
+ title => "$reldir: First track of latest cd",
+ cd => {
+ title => "$reldir: Latest cd",
+ year => 2666,
+ artist => $artist,
+ },
+ });
+
+ my $new_single = $schema->resultset('CD')->new ({
+ artist => $artist,
+ title => "$reldir: Awesome first single",
+ year => 2666,
+ });
+
+ if ($reldir eq 'might_have') {
+ $new_track->cd_single ($new_single);
+ $new_track->insert;
+ }
+ else {
+ $new_single->single_track ($new_track);
+ $new_single->insert;
+ }
+
+ ok ($new_single->in_storage, "$reldir single inserted");
+ ok ($new_track->in_storage, "$reldir track inserted");
+
+ my $new_cds = $artist->search_related ('cds',
+ { year => '2666' },
+ { prefetch => 'tracks', order_by => 'cdid' }
+ );
+
+ is_deeply (
+ [$new_cds->search ({}, { result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->all ],
+ [
+ {
+ artist => 1,
+ cdid => 10,
+ genreid => undef,
+ single_track => undef,
+ title => "$reldir: Latest cd",
+ tracks => [
+ {
+ cd => 10,
+ last_updated_at => undef,
+ last_updated_on => undef,
+ position => 1,
+ title => "$reldir: First track of latest cd",
+ trackid => 19
+ }
+ ],
+ year => 2666
+ },
+ {
+ artist => 1,
+ cdid => 11,
+ genreid => undef,
+ single_track => 19,
+ title => "$reldir: Awesome first single",
+ tracks => [],
+ year => 2666
+ },
+ ],
+ 'Expected rows created in database',
+ );
+
+ $new_cds->delete_all;
+ }
}
{
ok($new_related_artist->in_storage, 'related artist inserted');
ok($new_cd->in_storage, 'cd inserted');
}
+
+done_testing;
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use lib qw(t/lib);
use DBICTest;
-plan 'no_plan';
-
my $schema = DBICTest->init_schema();
my $query_stats;
}
-1;
+done_testing;
lives_ok ( sub {
my $cd = $schema->resultset('CD')->create({
- artist => {
- name => 'Fred Bloggs'
+ artist => {
+ name => 'Fred Bloggs'
},
title => 'Some CD',
year => 1996
}, 'Test might_have again but with just a PK and FK (neither specified) in the mid-table');
lives_ok ( sub {
- my $newartist2 = $schema->resultset('Artist')->find_or_create({
+ my $newartist2 = $schema->resultset('Artist')->find_or_create({
name => 'Fred 3',
cds => [
- {
+ {
title => 'Noah Act',
year => 2007,
},
lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
-
+
my $cd_result = $artist->create_related('cds', {
-
+
title => 'TestOneCD1',
year => 2007,
tracks => [
],
});
-
+
isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
ok( $cd_result->title eq "TestOneCD1", "Got Expected Title");
-
+
my $tracks = $cd_result->tracks;
-
+
isa_ok( $tracks, 'DBIx::Class::ResultSet', 'Got Expected Tracks ResultSet');
-
+
foreach my $track ($tracks->all)
{
isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
lives_ok ( sub {
my $artist = $schema->resultset('Artist')->first;
-
+
my $cd_result = $artist->create_related('cds', {
-
+
title => 'TestOneCD2',
year => 2007,
tracks => [
liner_notes => { notes => 'I can haz liner notes?' },
});
-
+
isa_ok( $cd_result, 'DBICTest::CD', "Got Good CD Class");
ok( $cd_result->title eq "TestOneCD2", "Got Expected Title");
ok( $cd_result->notes eq 'I can haz liner notes?', 'Liner notes');
-
+
my $tracks = $cd_result->tracks;
-
+
isa_ok( $tracks, 'DBIx::Class::ResultSet', "Got Expected Tracks ResultSet");
-
+
foreach my $track ($tracks->all)
{
isa_ok( $track, 'DBICTest::Track', 'Got Expected Track Class');
$schema->resultset('Artist')->populate([ $kurt_cobain ]); # %)
- $a = $schema->resultset('Artist')->find({name => 'Kurt Cobain'});
+ my $artist = $schema->resultset('Artist')->find({name => 'Kurt Cobain'});
- is($a->name, 'Kurt Cobain', 'Artist insertion ok');
- is($a->cds && $a->cds->first && $a->cds->first->title,
+ is($artist->name, 'Kurt Cobain', 'Artist insertion ok');
+ is($artist->cds && $artist->cds->first && $artist->cds->first->title,
'In Utero', 'CD insertion ok');
}, 'populate');
## Create foreign key col obj including PK
## See test 20 in 66relationships.t
lives_ok ( sub {
- my $new_cd_hashref = {
- cdid => 27,
- title => 'Boogie Woogie',
- year => '2007',
+ my $new_cd_hashref = {
+ cdid => 27,
+ title => 'Boogie Woogie',
+ year => '2007',
artist => { artistid => 17, name => 'king luke' }
};
}, 'Create foreign key col obj including PK');
lives_ok ( sub {
- $schema->resultset("CD")->create({
- cdid => 28,
- title => 'Boogie Wiggle',
- year => '2007',
+ $schema->resultset("CD")->create({
+ cdid => 28,
+ title => 'Boogie Wiggle',
+ year => '2007',
artist => { artistid => 18, name => 'larry' }
});
}, 'new cd created without clash on related artist');
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
plan tests => 23;
-# an insane multicreate
+# an insane multicreate
# (should work, despite the fact that no one will probably use it this way)
my $schema = DBICTest->init_schema();
name => 'bob',
producer_to_cd => [
{
- cd => {
+ cd => {
artist => {
name => 'lars',
cds => [
},
},
{
- cd => {
+ cd => {
artist => {
name => 'lars', # should already exist
# even though the artist 'name' is not uniquely constrained
- # find_or_create will arguably DWIM
+ # find_or_create will arguably DWIM
},
title => 'Greatest hits 7',
year => 2013,
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
-use warnings;
+use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+my $orig_debug = $schema->storage->debug;
+
+my $cdrs = $schema->resultset('CD')->search({ 'me.artist' => { '!=', 2 }});
+
+my $cd_data = { map {
+ $_->cdid => {
+ siblings => $cdrs->search ({ artist => $_->get_column('artist') })->count - 1,
+ track_titles => [ map { $_->title } ($_->tracks->all) ],
+ },
+} ( $cdrs->all ) };
+
+my $c_rs = $cdrs->search ({}, {
+ prefetch => 'tracks',
+ '+columns' => { sibling_count => $cdrs->search(
+ {
+ 'siblings.artist' => { -ident => 'me.artist' },
+ 'siblings.cdid' => { '!=' => ['-and', { -ident => 'me.cdid' }, 23414] },
+ }, { alias => 'siblings' },
+ )->count_rs->as_query,
+ },
+});
+
+is_same_sql_bind(
+ $c_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
+ (SELECT COUNT( * )
+ FROM cd siblings
+ WHERE siblings.artist = me.artist
+ AND siblings.cdid != me.cdid
+ AND siblings.cdid != ?
+ AND me.artist != ?
+ ),
+ tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at
+ FROM cd me
+ LEFT JOIN track tracks
+ ON tracks.cd = me.cdid
+ WHERE me.artist != ?
+ ORDER BY tracks.cd
+ )',
+ [
+
+ # subselect
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
+
+ # outher WHERE
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
+ ],
+ 'Expected SQL on correlated realiased subquery'
+);
+
+my $queries = 0;
+$schema->storage->debugcb(sub { $queries++; });
+$schema->storage->debug(1);
+
+is_deeply (
+ { map
+ { $_->cdid => {
+ track_titles => [ map { $_->title } ($_->tracks->all) ],
+ siblings => $_->get_column ('sibling_count'),
+ } }
+ $c_rs->all
+ },
+ $cd_data,
+ 'Proper information retrieved from correlated subquery'
+);
+
+is ($queries, 1, 'Only 1 query fired to retrieve everything');
+
+$schema->storage->debug($orig_debug);
+$schema->storage->debugcb(undef);
+
+# now add an unbalanced select/as pair
+$c_rs = $c_rs->search ({}, {
+ '+select' => $cdrs->search(
+ { 'siblings.artist' => { -ident => 'me.artist' } },
+ { alias => 'siblings', columns => [
+ { first_year => { min => 'year' }},
+ { last_year => { max => 'year' }},
+ ]},
+ )->as_query,
+ '+as' => [qw/active_from active_to/],
+});
+
+is_same_sql_bind(
+ $c_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
+ (SELECT COUNT( * )
+ FROM cd siblings
+ WHERE siblings.artist = me.artist
+ AND siblings.cdid != me.cdid
+ AND siblings.cdid != ?
+ AND me.artist != ?
+ ),
+ (SELECT MIN( year ), MAX( year )
+ FROM cd siblings
+ WHERE siblings.artist = me.artist
+ AND me.artist != ?
+ ),
+ tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at
+ FROM cd me
+ LEFT JOIN track tracks
+ ON tracks.cd = me.cdid
+ WHERE me.artist != ?
+ ORDER BY tracks.cd
+ )',
+ [
+
+ # first subselect
+ [ { sqlt_datatype => 'integer', dbic_colname => 'siblings.cdid' }
+ => 23414 ],
+
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
+
+ # second subselect
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
+
+ # outher WHERE
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 2 ],
+ ],
+ 'Expected SQL on correlated realiased subquery'
+);
+
+done_testing;
JOIN track tracks ON tracks.cd = cds.cdid
WHERE ( me.artistid = ? )
)',
- [ [ 'me.artistid' => 4 ] ],
+ [ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artistid' }
+ => 4 ] ],
);
# The current artwork belongs to a cd by artist1
# but the artwork itself is painted by artist2
#
-# What we try is all possible permutations of join/prefetch
+# What we try is all possible permutations of join/prefetch
# combinations in both directions, while always expecting to
# arrive at the specific artist at the end of each path.
my $cd_paths = {
'no cd' => [],
+ 'no cd empty' => [ '' ],
+ 'no cd undef' => [ undef ],
+ 'no cd href' => [ {} ],
+ 'no cd aoh' => [ [{}] ],
+ 'no cd complex' => [ [ [ undef ] ] ],
'cd' => ['cd'],
'cd->artist1' => [{'cd' => 'artist'}]
};
my $a2a_paths = {
'no a2a' => [],
+ 'no a2a empty ' => [ '' ],
+ 'no a2a undef' => [ undef ],
+ 'no a2a href' => [ {} ],
+ 'no a2a aoh' => [ [{}] ],
+ 'no a2a complex' => [ [ '' ] ],
'a2a' => ['artwork_to_artist'],
'a2a->artist2' => [{'artwork_to_artist' => 'artist'}]
};
-use warnings;
+use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
use DBICTest;
'(
SELECT
cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track,
- single_track.trackid, single_track.cd, single_track.position, single_track.title, single_track.last_updated_on, single_track.last_updated_at, single_track.small_dt,
- single_track_2.trackid, single_track_2.cd, single_track_2.position, single_track_2.title, single_track_2.last_updated_on, single_track_2.last_updated_at, single_track_2.small_dt,
+ single_track.trackid, single_track.cd, single_track.position, single_track.title, single_track.last_updated_on, single_track.last_updated_at,
+ single_track_2.trackid, single_track_2.cd, single_track_2.position, single_track_2.title, single_track_2.last_updated_on, single_track_2.last_updated_at,
cd.cdid, cd.artist, cd.title, cd.year, cd.genreid, cd.single_track
FROM artist me
JOIN cd cds ON cds.artist = me.artistid
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
my $schema = DBICTest->init_schema();
my $sdebug = $schema->storage->debug;
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
GROUP BY me.cd
)
- count_subq
+ me
)',
- [ map { [ 'me.cd' => $_] } ($cd_rs->get_column ('cdid')->all) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
'count() query generated expected SQL',
);
JOIN cd cd ON cd.cdid = me.cd
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
)',
- [ map { [ 'me.cd' => $_] } ( ($cd_rs->get_column ('cdid')->all) x 2 ) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ( ($cd_rs->get_column ('cdid')->all) x 2 ) ],
'next() query generated expected SQL',
);
FROM cd me
WHERE ( me.cdid IS NOT NULL )
GROUP BY me.cdid
- LIMIT 2
- ) count_subq
+ LIMIT ?
+ ) me
)',
- [],
+ [[$ROWS => 2]],
'count() query generated expected SQL',
);
$most_tracks_rs->as_query,
'(
SELECT me.cdid, me.track_count, me.maxtr,
- tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at, tracks.small_dt,
+ tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at,
liner_notes.liner_id, liner_notes.notes
FROM (
SELECT me.cdid, COUNT( tracks.trackid ) AS track_count, MAX( tracks.trackid ) AS maxtr
WHERE ( me.cdid IS NOT NULL )
GROUP BY me.cdid
ORDER BY track_count DESC, maxtr ASC
- LIMIT 2
+ LIMIT ?
) me
LEFT JOIN track tracks ON tracks.cd = me.cdid
LEFT JOIN liner_notes liner_notes ON liner_notes.liner_id = me.cdid
WHERE ( me.cdid IS NOT NULL )
ORDER BY track_count DESC, maxtr ASC, tracks.cd
)',
- [],
+ [[$ROWS => 2]],
'next() query generated expected SQL',
);
FROM (
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
- GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, cdid
+ GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
ORDER BY cdid
) me
LEFT JOIN tags tags ON tags.cd = me.cdid
WHERE ( me.cd IN ( ?, ?, ?, ?, ? ) )
GROUP BY SUBSTR(me.cd, 1, 1)
)
- count_subq
+ me
)',
- [ map { [ 'me.cd' => $_] } ($cd_rs->get_column ('cdid')->all) ],
+ [ map { [ { sqlt_datatype => 'integer', dbic_colname => 'me.cd' }
+ => $_ ] } ($cd_rs->get_column ('cdid')->all) ],
'count() query generated expected SQL',
);
}
GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
artist.artistid, artist.name, artist.rank, artist.charfield
)',
- [ map { [ 'tracks.title' => 'ugabuganoexist' ] } (1 .. 2) ],
+ [ map { [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' }
+ => 'ugabuganoexist' ] } (1,2)
+ ],
);
}
FROM (SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, COUNT( tags.tag ) AS test_count
FROM cd me LEFT JOIN tags tags ON tags.cd = me.cdid
GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track, tags.tag
- ORDER BY tags.tag ASC LIMIT 1)
+ ORDER BY tags.tag ASC LIMIT ?)
me
LEFT JOIN tags tags ON tags.cd = me.cdid
ORDER BY tags.tag ASC, tags.cd, tags.tag
)
- }, []);
+ }, [[$ROWS => 1]]);
}
done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-plan tests => 9;
-
my $schema = DBICTest->init_schema();
lives_ok(sub {
is ($cd->artist->name, 'Random Boy Band', 'Artist object has correct name');
}, 'implicit keyless prefetch works');
+
+# sane error
+throws_ok(
+ sub {
+ $schema->resultset('Track')->search({}, { join => { cd => 'artist' }, '+columns' => 'artist.name' } )->next;
+ },
+ qr|\QCan't inflate manual prefetch into non-existent relationship 'artist' from 'Track', check the inflation specification (columns/as) ending in 'artist.name'|,
+ 'Sensible error message on mis-specified "as"',
+);
+
+done_testing;
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
use DBICTest;
JOIN artist artist ON artist.artistid = me.artist
LEFT JOIN cd cds ON cds.artist = artist.artistid
LEFT JOIN artist artist_2 ON artist_2.artistid = cds.artist
- ORDER BY cds.artist, cds.year
+ ORDER BY cds.artist, cds.year ASC
)',
[],
);
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($ROWS, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+my $schema = DBICTest->init_schema();
+
+my $artist_rs = $schema->resultset('Artist');
+my $ar = $artist_rs->current_source_alias;
+
+my $filtered_cd_rs = $artist_rs->search_related('cds_unordered',
+ { "$ar.rank" => 13 },
+ {
+ prefetch => [ 'tracks' ],
+ order_by => [ { -asc => "$ar.name" }, "$ar.artistid DESC" ],
+ offset => 3,
+ rows => 3,
+ },
+);
+
+is_same_sql_bind(
+ $filtered_cd_rs->as_query,
+ q{(
+ SELECT cds_unordered.cdid, cds_unordered.artist, cds_unordered.title, cds_unordered.year, cds_unordered.genreid, cds_unordered.single_track,
+ tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at
+ FROM artist me
+ JOIN (
+ SELECT cds_unordered.cdid, cds_unordered.artist, cds_unordered.title, cds_unordered.year, cds_unordered.genreid, cds_unordered.single_track
+ FROM artist me
+ JOIN cd cds_unordered
+ ON cds_unordered.artist = me.artistid
+ WHERE ( me.rank = ? )
+ ORDER BY me.name ASC, me.artistid DESC
+ LIMIT ?
+ OFFSET ?
+ ) cds_unordered
+ ON cds_unordered.artist = me.artistid
+ LEFT JOIN track tracks
+ ON tracks.cd = cds_unordered.cdid
+ WHERE ( me.rank = ? )
+ ORDER BY me.name ASC, me.artistid DESC, tracks.cd
+ )},
+ [
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ],
+ [ $ROWS => 3 ],
+ [ $OFFSET => 3 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.rank' } => 13 ],
+ ],
+ 'correct SQL on limited prefetch over search_related ordered by root',
+);
+
+# note: we only requested "get all cds of all artists with rank 13 then order
+# by the artist name and give me the fourth, fifth and sixth", consequently the
+# cds that belong to the same artist are unordered; fortunately we know that
+# the first artist have 3 cds and the second and third artist both have only
+# one, so the first 3 cds belong to the first artist and the fourth and fifth
+# cds belong to the second and third artist, respectively, and there's no sixth
+# row
+is_deeply (
+ [ $filtered_cd_rs->hri_dump ],
+ [
+ {
+ 'artist' => '2',
+ 'cdid' => '4',
+ 'genreid' => undef,
+ 'single_track' => undef,
+ 'title' => 'Generic Manufactured Singles',
+ 'tracks' => [
+ {
+ 'cd' => '4',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '1',
+ 'title' => 'Boring Name',
+ 'trackid' => '10'
+ },
+ {
+ 'cd' => '4',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '2',
+ 'title' => 'Boring Song',
+ 'trackid' => '11'
+ },
+ {
+ 'cd' => '4',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '3',
+ 'title' => 'No More Ideas',
+ 'trackid' => '12'
+ }
+ ],
+ 'year' => '2001'
+ },
+ {
+ 'artist' => '3',
+ 'cdid' => '5',
+ 'genreid' => undef,
+ 'single_track' => undef,
+ 'title' => 'Come Be Depressed With Us',
+ 'tracks' => [
+ {
+ 'cd' => '5',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '1',
+ 'title' => 'Sad',
+ 'trackid' => '13'
+ },
+ {
+ 'cd' => '5',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '3',
+ 'title' => 'Suicidal',
+ 'trackid' => '15'
+ },
+ {
+ 'cd' => '5',
+ 'last_updated_at' => undef,
+ 'last_updated_on' => undef,
+ 'position' => '2',
+ 'title' => 'Under The Weather',
+ 'trackid' => '14'
+ }
+ ],
+ 'year' => '1998'
+ }
+ ],
+ 'Correctly ordered result',
+);
+
+done_testing;
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBICTest;
# test for partial prefetch via columns attr
my $cd = $schema->resultset('CD')->find(1,
{
- columns => [qw/title artist artist.name/],
+ columns => [qw/title artist artist.name/],
join => { 'artist' => {} }
}
);
cmp_ok( $rs->count, '==', 3, "count() ok after group_by on related column" );
-$rs = $schema->resultset("Artist")->search(
- {},
- { join => [qw/ cds /], group_by => [qw/ me.name /], having =>{ 'MAX(cds.cdid)'=> \'< 5' } }
-);
+$rs = $schema->resultset("Artist")->search({}, {
+ join => [qw/ cds /],
+ group_by => [qw/ me.name /],
+ having => \[ 'MAX(cds.cdid) < ?', [ \'int' => 5 ] ],
+});
cmp_ok( $rs->all, '==', 2, "results ok after group_by on related column with a having" );
'Tree search_related with prefetch ok');
$tree_like = eval { $schema->resultset('TreeLike')->search(
- { 'children.id' => 3, 'children_2.id' => 6 },
+ { 'children.id' => 3, 'children_2.id' => 6 },
{ join => [qw/children children children/] }
)->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' }
)->first->children->first; };
my $schema = DBICTest->init_schema();
+my $queries;
+my $debugcb = sub { $queries++; };
+my $orig_debug = $schema->storage->debug;
+
lives_ok ( sub {
my $no_prefetch = $schema->resultset('Track')->search_related(cd =>
{
}, 'search_related prefetch with order_by works');
-TODO: { local $TODO = 'Unqualified columns in where clauses can not be fixed without an SQLA rewrite' if SQL::Abstract->VERSION < 2;
lives_ok ( sub {
my $no_prefetch = $schema->resultset('Track')->search_related(cd =>
{
is($use_prefetch->count, $no_prefetch->count, 'counts with and without prefetch match');
}, 'search_related prefetch with condition referencing unqualified column of a joined table works');
-}
-
lives_ok (sub {
my $rs = $schema->resultset("Artwork")->search(undef, {distinct => 1})
TODO: {
local $TODO = "This makes another 2 trips to the database, it can't be right";
+
+ $queries = 0;
+ $schema->storage->debugcb ($debugcb);
+ $schema->storage->debug (1);
+
# artist -> 2 cds -> 2 genres -> 2 cds for each genre + distinct = 2
is($rs->search_related('cds')->all, 2, 'prefetched distinct with prefetch (objects)');
is($rs->search_related('cds')->count, 2, 'prefetched distinct with prefetch (count)');
+
+ is ($queries, 0, 'No extra queries fired (prefetch survives search_related)');
+
+ $schema->storage->debugcb (undef);
+ $schema->storage->debug ($orig_debug);
}
}, 'distinct generally works with prefetch on deep search_related chains');
use Test::Exception;
use lib qw(t/lib);
use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
my $schema = DBICTest->init_schema();
}
);
+# add an extra +select to make sure it does not throw things off
+# we also expect it to appear in both selectors, as we can not know
+# for sure which part of the query it applies to (may be order_by,
+# maybe something else)
+#
+# we use a reference to the same array in bind vals, because
+# is_deeply picks up this difference too (not sure if bug or
+# feature)
+$use_prefetch = $use_prefetch->search({}, {
+ '+columns' => { monkeywrench => \[ 'me.artistid + ?', [ \ 'inTEger' => 1 ] ] },
+});
+
+my $bind_int_resolved = sub { [ { sqlt_datatype => 'inTEger' } => 1 ] };
+my $bind_vc_resolved = sub { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'tracks.title' }
+ => 'blah-blah-1234568'
+] };
+is_same_sql_bind (
+ $use_prefetch->as_query,
+ '(
+ SELECT me.artistid + ?,
+ me.artistid, me.name,
+ cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track
+ FROM (
+ SELECT me.artistid + ?,
+ me.artistid, me.name
+ FROM artist me
+ LEFT JOIN cd cds
+ ON cds.artist = me.artistid
+ LEFT JOIN cd_artwork artwork
+ ON artwork.cd_id = cds.cdid
+ LEFT JOIN track tracks
+ ON tracks.cd = cds.cdid
+ WHERE artwork.cd_id IS NULL
+ OR tracks.title != ?
+ GROUP BY me.artistid + ?, me.artistid, me.name
+ ORDER BY name DESC LIMIT ?
+ ) me
+ LEFT JOIN cd cds
+ ON cds.artist = me.artistid
+ LEFT JOIN cd_artwork artwork
+ ON artwork.cd_id = cds.cdid
+ LEFT JOIN track tracks
+ ON tracks.cd = cds.cdid
+ WHERE artwork.cd_id IS NULL
+ OR tracks.title != ?
+ GROUP BY me.artistid + ?, me.artistid, me.name, cds.cdid, cds.artist, cds.title, cds.year, cds.genreid, cds.single_track
+ ORDER BY name DESC, cds.artist, cds.year ASC
+ )',
+ [
+ $bind_int_resolved->(), # outer select
+ $bind_int_resolved->(), # inner select
+ $bind_vc_resolved->(), # inner where
+ $bind_int_resolved->(), # inner group_by
+ [ $ROWS => 3 ],
+ $bind_vc_resolved->(), # outer where
+ $bind_int_resolved->(), # outer group_by
+ ],
+ 'Expected SQL on complex limited prefetch'
+);
+
is($no_prefetch->count, $use_prefetch->count, '$no_prefetch->count == $use_prefetch->count');
is(
scalar ($no_prefetch->all),
'single() with multiprefetch is illegal',
);
+throws_ok (
+ sub {
+ $use_prefetch->search(
+ {'tracks.title' => { '!=' => 'foo' }},
+ { order_by => \ 'some oddball literal sql', join => { cds => 'tracks' } }
+ )->next
+ }, qr/A required group_by clause could not be constructed automatically/,
+);
+
my $artist = $use_prefetch->search({'cds.title' => $artist_many_cds->cds->first->title })->next;
is($artist->cds->count, 1, "count on search limiting prefetched has_many");
my $artist2 = $use_prefetch->search({'cds.title' => { '!=' => $artist_many_cds->cds->first->title } })->slice (0,0)->next;
is($artist2->cds->count, 2, "count on search limiting prefetched has_many");
+# make sure 1:1 joins do not force a subquery (no point to exercise the optimizer, if at all available)
+# get cd's that have any tracks and their artists
+my $single_prefetch_rs = $schema->resultset ('CD')->search (
+ { 'me.year' => 2010, 'artist.name' => 'foo' },
+ { prefetch => ['tracks', 'artist'], rows => 15 },
+);
+is_same_sql_bind (
+ $single_prefetch_rs->as_query,
+ '(
+ SELECT
+ me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
+ tracks.trackid, tracks.cd, tracks.position, tracks.title, tracks.last_updated_on, tracks.last_updated_at,
+ artist.artistid, artist.name, artist.rank, artist.charfield
+ FROM (
+ SELECT
+ me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ JOIN artist artist ON artist.artistid = me.artist
+ WHERE ( ( artist.name = ? AND me.year = ? ) )
+ LIMIT ?
+ ) me
+ LEFT JOIN track tracks
+ ON tracks.cd = me.cdid
+ JOIN artist artist
+ ON artist.artistid = me.artist
+ WHERE ( ( artist.name = ? AND me.year = ? ) )
+ ORDER BY tracks.cd
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'artist.name' } => 'foo' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2010 ],
+ [ $ROWS => 15 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'artist.name' } => 'foo' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' } => 2010 ],
+ ],
+ 'No grouping of non-multiplying resultsets',
+);
+
done_testing;
} );
$track->set_from_related( cd => $cd );
+# has_relationship
+ok(! $track->has_relationship( 'foo' ), 'Track has no relationship "foo"');
+ok($track->has_relationship( 'disc' ), 'Track has relationship "disk"' );
+
is($track->disc->cdid, 4, 'set_from_related ok, including alternative accessor' );
$track->set_from_related( cd => undef );
ok( !defined($track->cd), 'set_from_related with undef ok');
-TODO: {
- local $TODO = 'accessing $object->rel and set_from_related';
- my $track = $schema->resultset("Track")->new( {} );
- $track->cd;
- $track->set_from_related( cd => $cd );
- ok ($track->cd, 'set_from_related ok after using the accessor' );
-};
+$track = $schema->resultset("Track")->new( {} );
+$track->cd;
+$track->set_from_related( cd => $cd );
+ok ($track->cd, 'set_from_related ok after using the accessor' );
# update_from_related, the same as set_from_related, but it calls update afterwards
$track = $schema->resultset("Track")->create( {
} );
$track->update_from_related( cd => $cd );
-my $t_cd = ($schema->resultset("Track")->search( cd => 4, title => 'Hidden Track 2' ))[0]->cd;
+my $t_cd = ($schema->resultset("Track")->search({ cd => 4, title => 'Hidden Track 2' }))[0]->cd;
is( $t_cd->cdid, 4, 'update_from_related ok' );
is( ($artist->search_related('cds'))[4]->title, 'Greatest Hits', 'find_or_create_related new record search ok' );
$artist->delete_related( cds => { title => 'Greatest Hits' });
-cmp_ok( $schema->resultset("CD")->search( title => 'Greatest Hits' ), '==', 0, 'delete_related ok' );
+cmp_ok( $schema->resultset("CD")->search({ title => 'Greatest Hits' }), '==', 0, 'delete_related ok' );
# find_or_new_related with an existing record
$cd = $artist->find_or_new_related( 'cds', { title => 'Big Flop' } );
is($newartist->name, 'Random Boy Band Two', 'find_or_new_related new artist record with id');
is($newartist->id, 200, 'find_or_new_related new artist id set');
-lives_ok(
- sub {
+lives_ok(
+ sub {
my $new_bookmark = $schema->resultset("Bookmark")->new_result( {} );
my $new_related_link = $new_bookmark->new_related( 'link', {} );
},
TODO: {
local $TODO = "relationship checking needs fixing";
# try to add a bogus relationship using the wrong cols
- eval {
+ throws_ok {
DBICTest::Schema::Artist->add_relationship(
tracks => 'DBICTest::Schema::Track',
{ 'foreign.cd' => 'self.cdid' }
);
- };
- like($@, qr/Unknown column/, 'failed when creating a rel with invalid key, ok');
+ } qr/Unknown column/, 'failed when creating a rel with invalid key, ok';
}
-
+
# another bogus relationship using no join condition
-eval {
+throws_ok {
DBICTest::Schema::Artist->add_relationship( tracks => 'DBICTest::Track' );
-};
-like($@, qr/join condition/, 'failed when creating a rel without join condition, ok');
+} qr/join condition/, 'failed when creating a rel without join condition, ok';
# many_to_many helper tests
$cd = $schema->resultset("CD")->find(1);
is( $producers[0]->name, 'Matt S Trout', 'many_to_many ok' );
is( $cd->producers_sorted->next->name, 'Bob The Builder',
'sorted many_to_many ok' );
-is( $cd->producers_sorted(producerid => 3)->next->name, 'Fred The Phenotype',
+is( $cd->producers_sorted({producerid => 3})->next->name, 'Fred The Phenotype',
'sorted many_to_many with search condition ok' );
$cd = $schema->resultset('CD')->find(2);
$cd->add_to_producers({ name => 'Jack Black' });
is( $prod_rs->count(), 2, 'many_to_many add_to_$rel($hash) count ok' );
$cd->set_producers($schema->resultset('Producer')->all);
-is( $cd->producers->count(), $prod_before_count+2,
+is( $cd->producers->count(), $prod_before_count+2,
'many_to_many set_$rel(@objs) count ok' );
$cd->set_producers($schema->resultset('Producer')->find(1));
is( $cd->producers->count(), 1, 'many_to_many set_$rel($obj) count ok' );
$cd->set_producers([$schema->resultset('Producer')->all]);
-is( $cd->producers->count(), $prod_before_count+2,
+is( $cd->producers->count(), $prod_before_count+2,
'many_to_many set_$rel(\@objs) count ok' );
$cd->set_producers([$schema->resultset('Producer')->find(1)]);
is( $cd->producers->count(), 1, 'many_to_many set_$rel([$obj]) count ok' );
-eval { $cd->remove_from_producers({ fake => 'hash' }); };
-like( $@, qr/needs an object/, 'remove_from_$rel($hash) dies correctly' );
+throws_ok {
+ $cd->remove_from_producers({ fake => 'hash' })
+} qr/needs an object/, 'remove_from_$rel($hash) dies correctly';
-eval { $cd->add_to_producers(); };
-like( $@, qr/needs an object or hashref/,
- 'add_to_$rel(undef) dies correctly' );
+throws_ok {
+ $cd->add_to_producers()
+} qr/needs an object or hashref/, 'add_to_$rel(undef) dies correctly';
# many_to_many stresstest
my $twokey = $schema->resultset('TwoKeys')->find(1,1);
my $undef_artist_cd = $schema->resultset("CD")->new_result({ 'title' => 'badgers', 'year' => 2007 });
is($undef_artist_cd->has_column_loaded('artist'), '', 'FK not loaded');
is($undef_artist_cd->search_related('artist')->count, 0, '0=1 search when FK does not exist and object not yet in db');
-eval{
+lives_ok {
$undef_artist_cd->related_resultset('artist')->new({name => 'foo'});
-};
-is( $@, '', "Object created on a resultset related to not yet inserted object");
+} 'Object created on a resultset related to not yet inserted object';
lives_ok{
$schema->resultset('Artwork')->new_result({})->cd;
} 'undef_on_null_fk does not choke on empty conds';
ON artist_undirected_maps.id1 = me.artistid OR artist_undirected_maps.id2 = me.artistid
WHERE ( artistid = ? )
)',
- [[artistid => 1]],
+ [[ { sqlt_datatype => 'integer', dbic_colname => 'artistid' }
+ => 1 ]],
'expected join sql produced',
);
my $relinfo_with_attr = $rs_overridden->relationship_info ('cd_3');
cmp_ok($relinfo_with_attr->{attrs}{is_foreign_key_constraint}, '==', 0, "is_foreign_key_constraint defined for belongs_to relationships with attr.");
-# check that relationships below left join relationships are forced to left joins
+# check that relationships below left join relationships are forced to left joins
# when traversing multiple belongs_to
my $cds = $schema->resultset("CD")->search({ 'me.cdid' => 5 }, { join => { single_track => 'cd' } });
is($cds->count, 1, "subjoins under left joins force_left (string)");
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+$schema->resultset('Artist')->delete;
+$schema->resultset('CD')->delete;
+
+my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 });
+my $artist2 = $schema->resultset("Artist")->create({ artistid => 22, name => 'Chico Buarque', rank => 1 }) ;
+my $artist3 = $schema->resultset("Artist")->create({ artistid => 23, name => 'Ziraldo', rank => 1 });
+my $artist4 = $schema->resultset("Artist")->create({ artistid => 24, name => 'Paulo Caruso', rank => 20 });
+
+my @artworks;
+
+foreach my $year (1975..1985) {
+ my $cd = $artist->create_related('cds', { year => $year, title => 'Compilation from ' . $year });
+ push @artworks, $cd->create_related('artwork', {});
+}
+
+foreach my $year (1975..1995) {
+ my $cd = $artist2->create_related('cds', { year => $year, title => 'Compilation from ' . $year });
+ push @artworks, $cd->create_related('artwork', {});
+}
+
+foreach my $artwork (@artworks) {
+ $artwork->create_related('artwork_to_artist', { artist => $_ }) for ($artist3, $artist4);
+}
+
+
+my $cds_80s_rs = $artist->cds_80s;
+is_same_sql_bind(
+ $cds_80s_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM cd me
+ WHERE ( ( me.artist = ? AND ( me.year < ? AND me.year > ? ) ) )
+ )',
+ [
+ [
+ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' }
+ => 21
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1990
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1979
+ ],
+ ],
+);
+my @cds_80s = $cds_80s_rs->all;
+is(@cds_80s, 6, '6 80s cds found (1980 - 1985)');
+map { ok($_->year < 1990 && $_->year > 1979) } @cds_80s;
+
+
+my $cds_90s_rs = $artist2->cds_90s;
+is_same_sql_bind(
+ $cds_90s_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM artist artist__row
+ JOIN cd me
+ ON ( me.artist = artist__row.artistid AND ( me.year < ? AND me.year > ? ) )
+ WHERE ( artist__row.artistid = ? )
+ )',
+ [
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 2000
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1989
+ ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist__row.artistid' }
+ => 22
+ ],
+ ]
+);
+
+# re-test with ::-containing moniker name
+# (we don't have any currently, so fudge it with lots of local() )
+{
+ local $schema->source('Artist')->{source_name} = 'Ar::Tist';
+ local $artist2->{related_resultsets};
+
+ is_same_sql_bind(
+ $artist2->cds_90s->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ FROM artist ar_tist__row
+ JOIN cd me
+ ON ( me.artist = ar_tist__row.artistid AND ( me.year < ? AND me.year > ? ) )
+ WHERE ( ar_tist__row.artistid = ? )
+ )',
+ [
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 2000
+ ],
+ [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.year' }
+ => 1989
+ ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'ar_tist__row.artistid' }
+ => 22
+ ],
+ ]
+ );
+}
+
+
+my @cds_90s = $cds_90s_rs->all;
+is(@cds_90s, 6, '6 90s cds found (1990 - 1995) even with non-optimized search');
+map { ok($_->year < 2000 && $_->year > 1989) } @cds_90s;
+
+lives_ok {
+ my @cds_90s_95 = $artist2->cds_90s->search({ 'me.year' => 1995 });
+ is(@cds_90s_95, 1, '1 90s (95) cds found even with non-optimized search');
+ map { ok($_->year == 1995) } @cds_90s_95;
+} 'should preserve chain-head "me" alias (API-consistency)';
+
+# search for all artists prefetching published cds in the 80s...
+my @all_artists_with_80_cds = $schema->resultset("Artist")->search
+ ({ 'cds_80s.cdid' => { '!=' => undef } }, { join => 'cds_80s', distinct => 1 });
+
+is_deeply(
+ [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds ) ],
+ [ sort (1980..1989, 1980..1985) ],
+ '16 correct cds found'
+);
+
+TODO: {
+local $TODO = 'Prefetch on custom rels can not work until the collapse rewrite is finished '
+ . '(currently collapser requires a right-side (which is indeterministic) order-by)';
+lives_ok {
+
+my @all_artists_with_80_cds_pref = $schema->resultset("Artist")->search
+ ({ 'cds_80s.cdid' => { '!=' => undef } }, { prefetch => 'cds_80s' });
+
+is_deeply(
+ [ sort ( map { $_->year } map { $_->cds_80s->all } @all_artists_with_80_cds_pref ) ],
+ [ sort (1980..1989, 1980..1985) ],
+ '16 correct cds found'
+);
+
+} 'prefetchy-fetchy-fetch';
+} # end of TODO
+
+
+# try to create_related a 80s cd
+throws_ok {
+ $artist->create_related('cds_80s', { title => 'related creation 1' });
+} qr/\QCustom relationship 'cds_80s' not definitive - returns conditions instead of values for column(s): 'year'/,
+'Create failed - complex cond';
+
+# now supply an explicit arg overwriting the ambiguous cond
+my $id_2020 = $artist->create_related('cds_80s', { title => 'related creation 2', year => '2020' })->id;
+is(
+ $schema->resultset('CD')->find($id_2020)->title,
+ 'related creation 2',
+ '2020 CD created correctly'
+);
+
+# try a default year from a specific rel
+my $id_1984 = $artist->create_related('cds_84', { title => 'related creation 3' })->id;
+is(
+ $schema->resultset('CD')->find($id_1984)->title,
+ 'related creation 3',
+ '1984 CD created correctly'
+);
+
+# try a specific everything via a non-simplified rel
+throws_ok {
+ $artist->create_related('cds_90s', { title => 'related_creation 4', year => '2038' });
+} qr/\QCustom relationship 'cds_90s' does not resolve to a join-free condition fragment/,
+'Create failed - non-simplified rel';
+
+# Do a self-join last-entry search
+my @last_tracks;
+for my $cd ($schema->resultset('CD')->search ({}, { order_by => 'cdid'})->all) {
+ push @last_tracks, $cd->tracks
+ ->search ({}, { order_by => { -desc => 'position'} })
+ ->next || ();
+}
+
+my $last_tracks_rs = $schema->resultset('Track')->search (
+ {'next_tracks.trackid' => undef},
+ { join => 'next_tracks', order_by => 'me.cd' },
+);
+
+is_deeply (
+ [$last_tracks_rs->get_column ('trackid')->all],
+ [ map { $_->trackid } @last_tracks ],
+ 'last group-entry via self-join works',
+);
+
+is_deeply (
+ [map { $_->last_track->id } grep { $_->last_track } $schema->resultset('CD')->search ({}, { order_by => 'cdid', prefetch => 'last_track'})->all],
+ [ map { $_->trackid } @last_tracks ],
+ 'last_track via insane subquery condition works',
+);
+
+is_deeply (
+ [map { $_->last_track->id } grep { $_->last_track } $schema->resultset('CD')->search ({}, { order_by => 'cdid'})->all],
+ [ map { $_->trackid } @last_tracks ],
+ 'last_track via insane subquery condition works, even without prefetch',
+);
+
+my $artwork = $schema->resultset('Artwork')->search({},{ order_by => 'cd_id' })->first;
+my @artists = $artwork->artists->all;
+is(scalar @artists, 2, 'the two artists are associated');
+
+my @artwork_artists = $artwork->artwork_to_artist->all;
+foreach (@artwork_artists) {
+ lives_ok {
+ my $artista = $_->artist;
+ my $artistb = $_->artist_test_m2m;
+ ok($artista->rank < 10 ? $artistb : 1, 'belongs_to with custom rel works.');
+ my $artistc = $_->artist_test_m2m_noopt;
+ ok($artista->rank < 10 ? $artistc : 1, 'belongs_to with custom rel works even in non-simplified.');
+ } 'belongs_to works with custom rels';
+}
+
+@artists = ();
+lives_ok {
+ @artists = $artwork->artists_test_m2m2->all;
+} 'manytomany with extended rels in the has many works';
+is(scalar @artists, 2, 'two artists');
+
+@artists = ();
+lives_ok {
+ @artists = $artwork->artists_test_m2m->all;
+} 'can fetch many to many with optimized version';
+is(scalar @artists, 1, 'only one artist is associated');
+
+@artists = ();
+lives_ok {
+ @artists = $artwork->artists_test_m2m_noopt->all;
+} 'can fetch many to many with non-optimized version';
+is(scalar @artists, 1, 'only one artist is associated');
+
+
+# Make a single for each last_track
+my @singles = map {
+ $_->create_related('cd_single', {
+ title => $_->title . ' (the single)',
+ artist => $artist,
+ year => 1999,
+ }) } @last_tracks
+;
+
+# See if chaining works
+is_deeply (
+ [ map { $_->title } $last_tracks_rs->search_related('cd_single')->all ],
+ [ map { $_->title } @singles ],
+ 'Retrieved singles in proper order'
+);
+
+# See if prefetch works
+is_deeply (
+ [ map { $_->cd_single->title } $last_tracks_rs->search({}, { prefetch => 'cd_single' })->all ],
+ [ map { $_->title } @singles ],
+ 'Prefetched singles in proper order'
+);
+
+done_testing;
ok $link->id;
$link->delete;
-is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+is $schema->resultset("Link")->search({id => $link_id})->count, 0,
"link $link_id was deleted";
# Get a fresh object with nothing cached
# This would create a new link row if none existed
$bookmark->link;
-is $schema->resultset("Link")->search(id => $link_id)->count, 0,
+is $schema->resultset("Link")->search({id => $link_id})->count, 0,
'accessor did not create a link object where there was none';
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+#
+# The test must be performed on non-registered result classes
+#
+{
+ package DBICTest::Thing;
+ use warnings;
+ use strict;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table('thing');
+ __PACKAGE__->add_columns(qw/id ancestor_id/);
+ __PACKAGE__->set_primary_key('id');
+ __PACKAGE__->has_many(children => __PACKAGE__, 'id');
+ __PACKAGE__->belongs_to(parent => __PACKAGE__, 'id', { join_type => 'left' } );
+
+ __PACKAGE__->has_many(subthings => 'DBICTest::SubThing', 'thing_id');
+}
+
+{
+ package DBICTest::SubThing;
+ use warnings;
+ use strict;
+ use base qw/DBIx::Class::Core/;
+ __PACKAGE__->table('subthing');
+ __PACKAGE__->add_columns(qw/thing_id/);
+ __PACKAGE__->belongs_to(thing => 'DBICTest::Thing', 'thing_id');
+ __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } );
+}
+
+my $schema = DBICTest->init_schema;
+
+for my $without_schema (1,0) {
+
+ my ($t, $s) = $without_schema
+ ? (qw/DBICTest::Thing DBICTest::SubThing/)
+ : do {
+ $schema->register_class(relinfo_thing => 'DBICTest::Thing');
+ $schema->register_class(relinfo_subthing => 'DBICTest::SubThing');
+
+ map { $schema->source ($_) } qw/relinfo_thing relinfo_subthing/;
+ }
+ ;
+
+ is_deeply(
+ [ sort $t->relationships ],
+ [qw/ children parent subthings/],
+ "Correct relationships on $t",
+ );
+
+ is_deeply(
+ [ sort $s->relationships ],
+ [qw/ thing thing2 /],
+ "Correct relationships on $s",
+ );
+
+ is_deeply(
+ _instance($s)->reverse_relationship_info('thing'),
+ { subthings => $t->relationship_info('subthings') },
+ 'reverse_rel_info works cross-class belongs_to direction',
+ );
+ is_deeply(
+ _instance($s)->reverse_relationship_info('thing2'),
+ { subthings => $t->relationship_info('subthings') },
+ 'reverse_rel_info works cross-class belongs_to direction 2',
+ );
+
+ is_deeply(
+ _instance($t)->reverse_relationship_info('subthings'),
+ { map { $_ => $s->relationship_info($_) } qw/thing thing2/ },
+ 'reverse_rel_info works cross-class has_many direction',
+ );
+
+ is_deeply(
+ _instance($t)->reverse_relationship_info('parent'),
+ { children => $t->relationship_info('children') },
+ 'reverse_rel_info works in-class belongs_to direction',
+ );
+ is_deeply(
+ _instance($t)->reverse_relationship_info('children'),
+ { parent => $t->relationship_info('parent') },
+ 'reverse_rel_info works in-class has_many direction',
+ );
+}
+
+sub _instance {
+ $_[0]->isa('DBIx::Class::ResultSource')
+ ? $_[0]
+ : $_[0]->result_source_instance
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd = $schema->resultset('CD')->find(2);
+is($cd->notes, $cd->liner_notes->notes, 'notes proxy ok');
+is($cd->artist_name, $cd->artist->name, 'artist_name proxy ok');
+
+my $track = $cd->tracks->first;
+is($track->cd_title, $track->cd->title, 'cd_title proxy ok');
+is($track->cd_title, $cd->title, 'cd_title proxy II ok');
+is($track->year, $cd->year, 'year proxy ok');
+
+my $tag = $schema->resultset('Tag')->first;
+is($tag->year, $tag->cd->year, 'year proxy II ok');
+is($tag->cd_title, $tag->cd->title, 'cd_title proxy III ok');
+
+my $bookmark = $schema->resultset('Bookmark')->create ({
+ link => { url => 'http://cpan.org', title => 'CPAN' },
+});
+my $link = $bookmark->link;
+ok($bookmark->link_id == $link->id, 'link_id proxy ok');
+is($bookmark->link_url, $link->url, 'link_url proxy ok');
+is($bookmark->link_title, $link->title, 'link_title proxy ok');
+
+my $cd_source_class = $schema->class('CD');
+throws_ok {
+ $cd_source_class->add_relationship('artist_regex',
+ 'DBICTest::Schema::Artist', {
+ 'foreign.artistid' => 'self.artist'
+ }, { proxy => qr/\w+/ }
+ ) } qr/unable \s to \s process \s the \s \'proxy\' \s argument/ix,
+ 'proxy attr with a regex ok';
+throws_ok {
+ $cd_source_class->add_relationship('artist_sub',
+ 'DBICTest::Schema::Artist', {
+ 'foreign.artistid' => 'self.artist'
+ }, { proxy => sub {} }
+ ) } qr/unable \s to \s process \s the \s \'proxy\' \s argument/ix,
+ 'proxy attr with a sub ok';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+
+# test with relname == colname
+my $bookmark = $schema->resultset("Bookmark")->find(1);
+ok( $bookmark->has_column ('link'), 'Right column name' );
+ok( $bookmark->has_relationship ('link'), 'Right rel name' );
+
+my $link = $bookmark->link;
+
+my $new_link = $schema->resultset("Link")->create({
+ url => "http://bugsarereal.com",
+ title => "bugsarereal.com",
+ id => 9,
+});
+
+is( $bookmark->link->id, 1, 'Initial relation id' );
+
+$bookmark->set_column( 'link', 9 );
+is( $bookmark->link->id, 9, 'Correct object re-selected after belongs_to set' );
+
+$bookmark->discard_changes;
+is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' );
+
+
+$bookmark->link($new_link);
+is( $bookmark->get_column('link'), 9, 'Correct column set from related' );
+
+$bookmark->discard_changes;
+is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' );
+
+
+$bookmark->link(9);
+is( $bookmark->link->id, 9, 'Correct object selected on deflated accessor set');
+
+$bookmark->discard_changes;
+is( $bookmark->link->id, 1, 'Pulled the correct old object after belongs_to reset' );
+
+
+$bookmark->update({ link => 9 });
+is( $bookmark->link->id, 9, 'Correct relationship after update' );
+is( $bookmark->get_from_storage->link->id, 9, 'Correct relationship after re-select' );
+
+
+# test with relname != colname
+my $lyric = $schema->resultset('Lyrics')->create({ track_id => 5 });
+is( $lyric->track->id, 5, 'Initial relation id');
+
+$lyric->track_id(6);
+my $track6 = $lyric->track;
+is( $track6->trackid, 6, 'Correct object re-selected after belongs_to set');
+
+$lyric->discard_changes;
+is( $lyric->track->trackid, 5, 'Pulled the correct old rel object after belongs_to reset');
+
+$lyric->track($track6);
+is( $lyric->track_id, 6, 'Correct column set from related');
+
+$lyric->discard_changes;
+is( $lyric->track->trackid, 5, 'Pulled the correct old rel object after belongs_to reset');
+
+$lyric->update({ track => $track6 });
+is( $lyric->track->trackid, 6, 'Correct relationship obj after update' );
+is( $lyric->get_from_storage->track->trackid, 6, 'Correct relationship after re-select' );
+
+done_testing;
use Test::More;
use Test::Exception;
+use Test::Warn;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
my $schema = DBICTest->init_schema();
my $sdebug = $schema->storage->debug;
-plan tests => 6;
-
my $artist = $schema->resultset ('Artist')->first;
my $genre = $schema->resultset ('Genre')
->create ({ name => 'par excellence' });
+my $genre_cds = $genre->cds;
-is ($genre->search_related( 'cds' )->count, 0, 'No cds yet');
+is ($genre_cds->count, 0, 'No cds yet');
# expect a create
$genre->update_or_create_related ('cds', {
});
# verify cd was inserted ok
-is ($genre->search_related( 'cds' )->count, 1, 'One cd');
-my $cd = $genre->find_related ('cds', {});
+is ($genre_cds->count, 1, 'One cd');
+my $cd = $genre_cds->first;
is_deeply (
{ map { $_, $cd->get_column ($_) } qw/artist year title/ },
{
);
# expect a year update on the only related row
-# (non-qunique column + unique column as disambiguator)
+# (non-qunique column + unique column set as disambiguator)
$genre->update_or_create_related ('cds', {
year => 2010,
title => 'the best thing since sliced bread',
+ artist => 1,
});
# re-fetch the cd, verify update
is ($genre->search_related( 'cds' )->count, 1, 'Still one cd');
-$cd = $genre->find_related ('cds', {});
+$cd = $genre_cds->first;
is_deeply (
{ map { $_, $cd->get_column ($_) } qw/artist year title/ },
{
'CD year column updated correctly',
);
+# expect a failing create:
+# the unique constraint is not complete, and there is nothing
+# in the database with such a year yet - insertion will fail due
+# to missing artist fk
+throws_ok {
+ $genre->update_or_create_related ('cds', {
+ year => 2020,
+ title => 'the best thing since sliced bread',
+ })
+} qr/\Qcd.artist may not be NULL/, 'ambiguous find + create failed';
# expect a create, after a failed search using *only* the
# *current* relationship and the unique column constraints
is_same_sql (
$search_sql,
'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me
+ FROM cd me
WHERE ( me.artist = ? AND me.title = ? AND me.genreid = ? )
',
'expected select issued',
# a has_many search without a unique constraint makes no sense
# but I am not sure what to test for - leaving open
+
+done_testing;
use Test::More;
-plan ( tests => 5 );
-
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
$art_rs = $art_rs->search({ name => 'Billy Joel' });
+my $name_resolved_bind = [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'name' }
+ => 'Billy Joel'
+];
+
{
is_same_sql_bind(
$art_rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( name = ? ))",
- [ [ name => 'Billy Joel' ] ],
+ [ $name_resolved_bind ],
);
}
$art_rs = $art_rs->search({ rank => 2 });
+my $rank_resolved_bind = [
+ { sqlt_datatype => 'integer', dbic_colname => 'rank' }
+ => 2
+];
+
{
is_same_sql_bind(
$art_rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ [ $rank_resolved_bind, $name_resolved_bind ],
);
}
is_same_sql_bind(
$rscol->as_query,
"(SELECT me.charfield FROM artist me WHERE ( ( ( rank = ? ) AND ( name = ? ) ) ) )",
- [ [ rank => 2 ], [ name => 'Billy Joel' ] ],
+ [ $rank_resolved_bind, $name_resolved_bind ],
);
}
my $subsel_rs = $schema->resultset("CD")->search( { cdid => { IN => $rs->get_column('cdid')->as_query } } );
is($subsel_rs->count, $rs->count, 'Subselect on PK got the same row count');
}
+
+
+is_same_sql_bind($schema->resultset('Artist')->search({
+ rank => 1,
+}, {
+ from => $schema->resultset('Artist')->search({ 'name' => 'frew'})->as_query,
+})->as_query,
+ '(SELECT me.artistid, me.name, me.rank, me.charfield FROM (
+ SELECT me.artistid, me.name, me.rank, me.charfield FROM
+ artist me
+ WHERE (
+ ( name = ? )
+ )
+ ) WHERE (
+ ( rank = ? )
+ )
+ )',
+ [
+ [{ dbic_colname => 'name', sqlt_datatype => 'varchar', sqlt_size => 100 }, 'frew'],
+ [{ dbic_colname => 'rank' }, 1],
+ ],
+ 'from => ...->as_query works'
+);
+
+done_testing;
'... and chaining off the virtual view works';
dies_ok { $new_rs->as_subselect_rs->search({'artwork_to_artist.artwork_cd_id'=> 1})->count }
q{... but chaining off of a virtual view using join doesn't work};
+
+my $book_rs = $schema->resultset ('BooksInLibrary')->search ({}, { join => 'owner' });
+
+is_same_sql_bind (
+ $book_rs->as_subselect_rs->as_query,
+ '(SELECT me.id, me.source, me.owner, me.title, me.price
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ) me
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ 'Resultset-class attributes do not seep outside of the subselect',
+);
+
done_testing;
$new_source->source_name('Complex');
$new_source->name(\<<'');
- ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
+ ( SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year
FROM artist a
JOIN cd ON cd.artist = a.artistid
WHERE cd.year = ?)
->search({ 'artistid' => 1 });
is ( $rs->count, 1, '...cookbook (bind first) + chained search' );
- $rs = $schema->resultset('Complex')->search({}, { bind => [ 1999 ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
+ $rs = $schema->resultset('Complex')->search({}, { bind => [ [{ sqlt_datatype => 'datetime'} => 1999 ] ] })->search({}, { where => \"title LIKE ?", bind => [ 'Spoon%' ] });
is_same_sql_bind(
$rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
- [ '!!dummy' => '1999' ],
- [ '!!dummy' => 'Spoon%' ]
+ [ { sqlt_datatype => 'datetime' } => '1999' ],
+ [ {} => 'Spoon%' ]
],
'got correct SQL'
);
$rs->as_query,
"(SELECT me.artistid, me.name, me.rank, me.charfield FROM (SELECT a.*, cd.cdid AS cdid, cd.title AS title, cd.year AS year FROM artist a JOIN cd ON cd.artist = a.artistid WHERE cd.year = ?) me WHERE title LIKE ?)",
[
- [ '!!dummy' => '1999' ],
- [ '!!dummy' => 'Spoon%' ]
+ [ {} => '1999' ],
+ [ {} => 'Spoon%' ]
],
'got correct SQL (cookbook arbitrary SQL, in separate file)'
);
use lib qw(t/lib);
use Test::More;
-use Test::Exception;
use DBICTest;
my $schema = DBICTest->init_schema();
# More complicated ordering
{
- my $ordered = $rs->search(undef, {
+ my $ordered = $rs->search(undef, {
order_by => [
- { -asc => 'artistid' },
+ { -asc => 'artistid' },
{ -desc => 'name' },
- ]
+ ]
});
ok $ordered->is_ordered, 'more complicated resultset ordering is_ordered';
}
use lib qw(t/lib);
use Test::More;
-use Test::Exception;
use DBICTest;
my $schema = DBICTest->init_schema();
use lib qw(t/lib);
use Test::More;
-use Test::Exception;
use DBICTest;
my $schema = DBICTest->init_schema();
);
SKIP: {
- eval { require DateTime };
- skip "Need DateTime for +select/get_inflated_columns tests", 1 if $@;
+ skip (
+ "+select/get_inflated_columns tests need " . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt'),
+ 1
+ ) unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
$schema->class('CD')->inflate_column( 'year',
{ inflate => sub { DateTime->new( year => shift ) },
use Test::More;
use Test::Exception;
use DBICTest;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
-#plan tests => 5;
-plan 'no_plan';
+my $schema = DBICTest->init_schema;
-my $schema = DBICTest->init_schema();
+my ($sql, @bind);
+my $debugobj = DBIC::DebugObj->new (\$sql, \@bind);
+my $orig_debugobj = $schema->storage->debugobj;
+my $orig_debug = $schema->storage->debug;
my $tkfks = $schema->resultset('FourKeys_to_TwoKeys');
->search ({ map { $_ => [1, 2] } qw/foo bar hello goodbye/}, { join => 'fourkeys_to_twokeys' });
is ($fks->count, 4, 'Joined FourKey count correct (2x2)');
-$fks->update ({ read_count => \ 'read_count + 1' });
-$_->discard_changes for ($fa, $fb);
-is ($fa->read_count, 11, 'Update ran only once on joined resultset');
-is ($fb->read_count, 21, 'Update ran only once on joined resultset');
+$schema->storage->debugobj ($debugobj);
+$schema->storage->debug (1);
+$fks->update ({ read_count => \ 'read_count + 1' });
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'UPDATE fourkeys
+ SET read_count = read_count + 1
+ WHERE ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? ) OR ( bar = ? AND foo = ? AND goodbye = ? AND hello = ? )',
+ [ map { "'$_'" } ( (1) x 4, (2) x 4 ) ],
+ 'Correct update-SQL without multicolumn in support',
+);
+is ($fa->discard_changes->read_count, 11, 'Update ran only once on joined resultset');
+is ($fb->discard_changes->read_count, 21, 'Update ran only once on joined resultset');
+
+# try the same sql with forced multicolumn in
+$schema->storage->_use_multicolumn_in (1);
+$schema->storage->debugobj ($debugobj);
+$schema->storage->debug (1);
+eval { $fks->update ({ read_count => \ 'read_count + 1' }) }; # this can't actually execute, we just need the "as_query"
+$schema->storage->_use_multicolumn_in (undef);
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'UPDATE fourkeys
+ SET read_count = read_count + 1
+ WHERE (
+ (foo, bar, hello, goodbye) IN (
+ SELECT me.foo, me.bar, me.hello, me.goodbye
+ FROM fourkeys me
+ WHERE ( bar = ? OR bar = ? ) AND ( foo = ? OR foo = ? ) AND ( goodbye = ? OR goodbye = ? ) AND ( hello = ? OR hello = ? )
+ )
+ )
+ ',
+ [ map { "'$_'" } ( (1, 2) x 4 ) ],
+ 'Correct update-SQL with multicolumn in support',
+);
#
-# Make sure multicolumn in or the equivalen functions correctly
+# Make sure multicolumn in or the equivalent functions correctly
#
my $sub_rs = $tkfks->search (
$sub_rs->search (
{},
{
- group_by => [ reverse $sub_rs->result_source->primary_columns ], # reverse to make sure the PK-list comaprison works
+ group_by => [ reverse $sub_rs->result_source->primary_columns ], # reverse to make sure the PK-list comparison works
},
)->update ({ pilot_sequence => \ 'pilot_sequence + 1' });
is_deeply (
[ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
- ->get_column ('pilot_sequence')->all
+ ->get_column ('pilot_sequence')->all
],
[qw/11 21 30 40/],
'Only two rows incremented',
is_deeply (
[ $tkfks->search ({ autopilot => [qw/a b x y/]}, { order_by => 'autopilot' })
- ->get_column ('pilot_sequence')->all
+ ->get_column ('pilot_sequence')->all
],
[qw/12 22 30 40/],
'Only two rows incremented (where => scalarref works)',
);
-$sub_rs->delete;
+{
+ my $rs = $schema->resultset('FourKeys_to_TwoKeys')->search (
+ {
+ -or => [
+ { 'me.pilot_sequence' => 12 },
+ { 'me.autopilot' => 'b' },
+ ],
+ }
+ );
+ lives_ok { $rs->update({ autopilot => 'z' }) }
+ 'Update with table name qualifier in -or conditions lives';
+ is_deeply (
+ [ $tkfks->search ({ pilot_sequence => [12, 22]})
+ ->get_column ('autopilot')->all
+ ],
+ [qw/z z/],
+ '... and yields the right data',
+ );
+}
+
+$sub_rs->delete;
is ($tkfks->count, $tkfk_cnt -= 2, 'Only two rows deleted');
+
+# make sure limit-only deletion works
+cmp_ok ($tkfk_cnt, '>', 1, 'More than 1 row left');
+$tkfks->search ({}, { rows => 1 })->delete;
+is ($tkfks->count, $tkfk_cnt -= 1, 'Only one row deleted');
+
+
+# Make sure prefetch is properly stripped too
+# check with sql-equality, as sqlite will accept bad sql just fine
+$schema->storage->debugobj ($debugobj);
+$schema->storage->debug (1);
+$schema->resultset('CD')->search(
+ { year => { '!=' => 2010 } },
+ { prefetch => 'liner_notes' },
+)->delete;
+
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me WHERE ( year != ? ) ) )',
+ ["'2010'"],
+ 'Update on prefetching resultset strips prefetch correctly'
+);
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
unshift(@INC, './t/lib');
use lib 't/lib';
-plan tests => 5;
use DBICTest;
is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICTest::BaseResultSet', 'default resultset class');
ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded');
+
DBICTest::Schema->source('Artist')->resultset_class('DBICNSTest::ResultSet::A');
-ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded automatically');
+
+ok(!Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class not loaded on SET');
is(DBICTest::Schema->source('Artist')->resultset_class, 'DBICNSTest::ResultSet::A', 'custom resultset class set');
+ok(Class::Inspector->loaded('DBICNSTest::ResultSet::A'), 'custom resultset class loaded on GET');
my $schema = DBICTest->init_schema;
my $resultset = $schema->resultset('Artist')->search;
isa_ok($resultset, 'DBICNSTest::ResultSet::A', 'resultset is custom class');
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
my $schema = DBICTest->init_schema();
-plan tests => 6;
-
{
my $rs = $schema->resultset("CD")->search({});
{
my $rs = $schema->resultset("CD")->search({ title => "Does not exist" });
-
+
ok !$rs->count;
is $rs, $rs->count, "resultset as number without results";
ok $rs, "resultset as boolean always true";
-}
\ No newline at end of file
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $from_storage_ran = 0;
+my $to_storage_ran = 0;
+my $schema = DBICTest->init_schema();
+DBICTest::Schema::Artist->load_components(qw(FilterColumn InflateColumn));
+DBICTest::Schema::Artist->filter_column(rank => {
+ filter_from_storage => sub { $from_storage_ran++; $_[1] * 2 },
+ filter_to_storage => sub { $to_storage_ran++; $_[1] / 2 },
+});
+Class::C3->reinitialize();
+
+my $artist = $schema->resultset('Artist')->create( { rank => 20 } );
+
+# this should be using the cursor directly, no inflation/processing of any sort
+my ($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+
+is ($raw_db_rank, 10, 'INSERT: correctly unfiltered on insertion');
+
+for my $reloaded (0, 1) {
+ my $test = $reloaded ? 'reloaded' : 'stored';
+ $artist->discard_changes if $reloaded;
+
+ is( $artist->rank , 20, "got $test filtered rank" );
+}
+
+$artist->update;
+$artist->discard_changes;
+is( $artist->rank , 20, "got filtered rank" );
+
+$artist->update ({ rank => 40 });
+($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+is ($raw_db_rank, 20, 'UPDATE: correctly unflitered on update');
+
+$artist->discard_changes;
+$artist->rank(40);
+ok( !$artist->is_column_changed('rank'), 'column is not dirty after setting the same value' );
+
+MC: {
+ my $cd = $schema->resultset('CD')->create({
+ artist => { rank => 20 },
+ title => 'fun time city!',
+ year => 'forevertime',
+ });
+ ($raw_db_rank) = $schema->resultset('Artist')
+ ->search ($cd->artist->ident_condition)
+ ->get_column('rank')
+ ->_resultset
+ ->cursor
+ ->next;
+
+ is $raw_db_rank, 10, 'artist rank gets correctly unfiltered w/ MC';
+ is $cd->artist->rank, 20, 'artist rank gets correctly filtered w/ MC';
+}
+
+CACHE_TEST: {
+ my $expected_from = $from_storage_ran;
+ my $expected_to = $to_storage_ran;
+
+ # ensure we are creating a fresh obj
+ $artist = $schema->resultset('Artist')->single($artist->ident_condition);
+
+ is $from_storage_ran, $expected_from, 'from has not run yet';
+ is $to_storage_ran, $expected_to, 'to has not run yet';
+
+ $artist->rank;
+ cmp_ok (
+ $artist->get_filtered_column('rank'),
+ '!=',
+ $artist->get_column('rank'),
+ 'filter/unfilter differ'
+ );
+ is $from_storage_ran, ++$expected_from, 'from ran once, therefor caches';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->rank(6);
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, ++$expected_to, 'to ran once';
+
+ ok ($artist->is_column_changed ('rank'), 'Column marked as dirty');
+
+ $artist->rank;
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->update;
+
+ $artist->set_column(rank => 3);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same set_column value');
+ is ($artist->rank, '6', 'Column set properly (cache blown)');
+ is $from_storage_ran, ++$expected_from, 'from ran once (set_column blew cache)';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->rank(6);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on same accessor-set value');
+ is ($artist->rank, '6', 'Column set properly');
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->store_column(rank => 4);
+ ok (! $artist->is_column_changed ('rank'), 'Column not marked as dirty on differing store_column value');
+ is ($artist->rank, '8', 'Cache properly blown');
+ is $from_storage_ran, ++$expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+}
+
+IC_DIE: {
+ dies_ok {
+ DBICTest::Schema::Artist->inflate_column(rank =>
+ { inflate => sub {}, deflate => sub {} }
+ );
+ } q(Can't inflate column after filter column);
+
+ DBICTest::Schema::Artist->inflate_column(name =>
+ { inflate => sub {}, deflate => sub {} }
+ );
+
+ dies_ok {
+ DBICTest::Schema::Artist->filter_column(name => {
+ filter_to_storage => sub {},
+ filter_from_storage => sub {}
+ });
+ } q(Can't filter column after inflate column);
+}
+
+# test when we do not set both filter_from_storage/filter_to_storage
+DBICTest::Schema::Artist->filter_column(rank => {
+ filter_to_storage => sub { $to_storage_ran++; $_[1] },
+});
+Class::C3->reinitialize();
+
+ASYMMETRIC_TO_TEST: {
+ # initialise value
+ $artist->rank(20);
+ $artist->update;
+
+ my $expected_from = $from_storage_ran;
+ my $expected_to = $to_storage_ran;
+
+ $artist->rank(10);
+ ok ($artist->is_column_changed ('rank'), 'Column marked as dirty on accessor-set value');
+ is ($artist->rank, '10', 'Column set properly');
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, ++$expected_to, 'to did run';
+
+ $artist->discard_changes;
+
+ is ($artist->rank, '20', 'Column set properly');
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+}
+
+DBICTest::Schema::Artist->filter_column(rank => {
+ filter_from_storage => sub { $from_storage_ran++; $_[1] },
+});
+Class::C3->reinitialize();
+
+ASYMMETRIC_FROM_TEST: {
+ # initialise value
+ $artist->rank(23);
+ $artist->update;
+
+ my $expected_from = $from_storage_ran;
+ my $expected_to = $to_storage_ran;
+
+ $artist->rank(13);
+ ok ($artist->is_column_changed ('rank'), 'Column marked as dirty on accessor-set value');
+ is ($artist->rank, '13', 'Column set properly');
+ is $from_storage_ran, $expected_from, 'from did not run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+
+ $artist->discard_changes;
+
+ is ($artist->rank, '23', 'Column set properly');
+ is $from_storage_ran, ++$expected_from, 'from did run';
+ is $to_storage_ran, $expected_to, 'to did not run';
+}
+
+throws_ok { DBICTest::Schema::Artist->filter_column( rank => {} ) }
+ qr/\QAn invocation of filter_column() must specify either a filter_from_storage or filter_to_storage/,
+ 'Correctly throws exception for empty attributes'
+;
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+$schema->resultset('Artist')->delete;
+$schema->resultset('CD')->delete;
+
+my $artist = $schema->resultset("Artist")->create({ artistid => 21, name => 'Michael Jackson', rank => 20 });
+my $cd = $artist->create_related('cds', { year => 1975, title => 'Compilation from 1975' });
+
+my ($sql, @bind);
+local $schema->storage->{debug} = 1;
+local $schema->storage->{debugobj} = DBIC::DebugObj->new(\$sql, \@bind);
+
+my $find_cd = $artist->find_related('cds',{title => 'Compilation from 1975'});
+
+s/^'//, s/'\z// for @bind; # why does DBIC::DebugObj not do this?
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE ( ( me.artist = ? AND me.title = ? ) ) ORDER BY year ASC',
+ [21, 'Compilation from 1975'],
+ 'find_related only uses foreign key condition once',
+);
+
+done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
+package My::Schema::Result::User;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Core/;
+
+### Define what our admin class is, for ensure_class_loaded()
+my $admin_class = __PACKAGE__ . '::Admin';
+
+__PACKAGE__->table('users');
+
+__PACKAGE__->add_columns(
+ qw/user_id email password
+ firstname lastname active
+ admin/
+);
+
+__PACKAGE__->set_primary_key('user_id');
+
+sub inflate_result {
+ my $self = shift;
+ my $ret = $self->next::method(@_);
+ if ( $ret->admin ) { ### If this is an admin, rebless for extra functions
+ $self->ensure_class_loaded($admin_class);
+ bless $ret, $admin_class;
+ }
+ return $ret;
+}
+
+sub hello {
+ return "I am a regular user.";
+}
+
+package My::Schema::Result::User::Admin;
+
+use strict;
+use warnings;
+use base qw/My::Schema::Result::User/;
+
+# This line is important
+__PACKAGE__->table('users');
+
+sub hello {
+ return "I am an admin.";
+}
+
+sub do_admin_stuff {
+ return "I am doing admin stuff";
+}
+
+package My::Schema;
+
+use base qw/DBIx::Class::Schema/;
+
+My::Schema->register_class( Admin => 'My::Schema::Result::User::Admin' );
+My::Schema->register_class( User => 'My::Schema::Result::User' );
+
+1;
+
+package main;
+my $user_data = {
+ email => 'someguy@place.com',
+ password => 'pass1',
+ admin => 0
+};
+
+my $admin_data = {
+ email => 'someadmin@adminplace.com',
+ password => 'pass2',
+ admin => 1
+};
+
+ok( my $schema = My::Schema->connect(DBICTest->_database) );
+
+ok(
+ $schema->storage->dbh->do(
+"create table users (user_id, email, password, firstname, lastname, active, admin)"
+ )
+);
+
+TODO: {
+ local $TODO = 'New objects should also be inflated';
+ my $user = $schema->resultset('User')->create($user_data);
+ my $admin = $schema->resultset('User')->create($admin_data);
+
+ is( ref $user, 'My::Schema::Result::User' );
+ is( ref $admin, 'My::Schema::Result::User::Admin' );
+}
+
+my $user = $schema->resultset('User')->single($user_data);
+my $admin = $schema->resultset('User')->single($admin_data);
+
+is( ref $user, 'My::Schema::Result::User' );
+is( ref $admin, 'My::Schema::Result::User::Admin' );
+
+is( $user->password, 'pass1' );
+is( $admin->password, 'pass2' );
+is( $user->hello, 'I am a regular user.' );
+is( $admin->hello, 'I am an admin.' );
+
+ok( !$user->can('do_admin_stuff') );
+ok( $admin->can('do_admin_stuff') );
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('NoPrimaryKey');
+
+my $row = $rs->create ({ foo => 1, bar => 1, baz => 1 });
+
+lives_ok (sub {
+ $row->foo (2);
+}, 'Set on pkless object works');
+
+is ($row->foo, 2, 'Column updated in-object');
+
+dies_ok (sub {
+ $row->update ({baz => 3});
+}, 'update() fails on pk-less object');
+
+is ($row->foo, 2, 'Column not updated by failed update()');
+
+dies_ok (sub {
+ $row->delete;
+}, 'delete() fails on pk-less object');
+
+done_testing;
my $schema = DBICTest->init_schema();
-my $clone = $schema->clone;
-cmp_ok ($clone->storage, 'eq', $schema->storage, 'Storage copied into new schema (not a new instance)');
+{
+ my $clone = $schema->clone;
+ cmp_ok ($clone->storage, 'eq', $schema->storage, 'Storage copied into new schema (not a new instance)');
+}
+
+{
+ is $schema->custom_attr, undef;
+ my $clone = $schema->clone(custom_attr => 'moo');
+ is $clone->custom_attr, 'moo', 'cloning can change existing attrs';
+}
+
+{
+ my $clone = $schema->clone({ custom_attr => 'moo' });
+ is $clone->custom_attr, 'moo', 'cloning can change existing attrs';
+}
+
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+# make sure order + distinct do not double-inject group criteria
+my $year_rs = $schema->resultset ('CD')->search ({}, {
+ distinct => 1,
+ columns => [qw/year/],
+ order_by => 'year',
+});
+
+is_same_sql_bind (
+ $year_rs->as_query,
+ '(
+ SELECT me.year
+ FROM cd me
+ GROUP BY me.year
+ ORDER BY year
+ )',
+ [],
+ 'Correct GROUP BY',
+);
+
+done_testing;
use Test::Exception;
use lib qw(t/lib);
+use DBICTest;
use DBIC::SqlMakerTest;
use DBIC::DebugObj;
-use DBICTest;
-# use Data::Dumper comparisons to avoid mesing with coderefs
-use Data::Dumper;
-$Data::Dumper::Sortkeys = 1;
+use Storable qw/dclone/;
my $schema = DBICTest->init_schema();
-plan tests => 22;
-
# A search() with prefetch seems to pollute an already joined resultset
# in a way that offsets future joins (adapted from a test case by Debolaz)
{
# test a real-life case - rs is obtained by an implicit m2m join
$cd_rs = $schema->resultset ('Producer')->first->cds;
- $attrs = Dumper $cd_rs->{attrs};
+ $attrs = dclone( $cd_rs->{attrs} );
$cd_rs->search ({})->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
}, 'first prefetching search ok');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
}, 'second prefetching search ok');
# test a regular rs with an empty seen_join injected - it should still work!
$cd_rs = $schema->resultset ('CD');
$cd_rs->{attrs}{seen_join} = {};
- $attrs = Dumper $cd_rs->{attrs};
+ $attrs = dclone( $cd_rs->{attrs} );
$cd_rs->search ({})->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
}, 'first prefetching search ok');
lives_ok (sub {
$cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
- is (Dumper ($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+ is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
}, 'second prefetching search ok');
}
is_same_sql_bind ($rs->as_query, $q{$s}{query}, "$s resultset unmodified (as_query matches)" );
}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $cd_rs = $schema->resultset('CD')->search ({ artist => { '!=', undef }});
+
+# create some CDs without tracks
+$cd_rs->create({ artist => 1, title => 'trackless_foo', year => 2010 });
+$cd_rs->create({ artist => 1, title => 'trackless_bar', year => 2010 });
+
+my $tr_count = $schema->resultset('Track')->count;
+
+my $tr_rs = $cd_rs->search_related('tracks');
+
+
+my @tracks;
+while ($tr_rs->next) {
+ push @tracks, $_;
+}
+
+is (scalar @tracks, $tr_count, 'Iteration is correct');
+is ($tr_rs->count, $tr_count, 'Count is correct');
+is (scalar ($tr_rs->all), $tr_count, 'All is correct');
+
+done_testing;
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
use DBICTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
my $schema = DBICTest->init_schema();
my $rs = $schema->resultset('CD')->search (
- { 'tracks.id' => { '!=', 666 }},
+ { 'tracks.trackid' => { '!=', 666 }},
{ join => 'artist', prefetch => 'tracks', rows => 2 }
);
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
FROM cd me
JOIN artist artist ON artist.artistid = me.artist
- LEFT JOIN track tracks ON tracks.cd = me.cdid
- WHERE ( tracks.id != ? )
- LIMIT 2
+ LEFT JOIN track tracks ON tracks.cd = me.cdid
+ WHERE ( tracks.trackid != ? )
+ LIMIT ?
) me
JOIN artist artist ON artist.artistid = me.artist
JOIN tags tags ON tags.cd = me.cdid
GROUP BY tags.tagid, tags.cd, tags.tag
)',
- [ [ 'tracks.id' => 666 ] ],
+ [
+ [ { sqlt_datatype => 'integer', dbic_colname => 'tracks.trackid' } => 666 ],
+ [ $ROWS => 2 ]
+ ],
'Prefetch spec successfully stripped on search_related'
);
use warnings;
use Test::More;
-use Test::Exception;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
my @chain = (
{
columns => [ 'cdid' ],
- '+columns' => [ { title_lc => { lower => 'title' } } ],
+ '+columns' => [ { title_lc => { lower => 'title', -as => 'lctitle' } } ],
'+select' => [ 'genreid' ],
'+as' => [ 'genreid' ],
- } => 'SELECT me.cdid, LOWER( title ), me.genreid FROM cd me',
+ } => 'SELECT me.cdid, LOWER( title ) AS lctitle, me.genreid FROM cd me',
{
- '+columns' => [ { max_year => { max => 'me.year' }}, ],
+ '+columns' => [ { max_year => { max => 'me.year', -as => 'last_y' }}, ],
'+select' => [ { count => 'me.cdid' }, ],
'+as' => [ 'cnt' ],
- } => 'SELECT me.cdid, LOWER( title ), MAX( me.year ), me.genreid, COUNT( me.cdid ) FROM cd me',
+ } => 'SELECT me.cdid, LOWER( title ) AS lctitle, MAX( me.year ) AS last_y, me.genreid, COUNT( me.cdid ) FROM cd me',
{
select => [ { min => 'me.cdid' }, ],
} => 'SELECT MIN( me.cdid ) FROM cd me',
{
- '+columns' => [ { cnt => { count => 'cdid' } } ],
- } => 'SELECT MIN( me.cdid ), COUNT ( cdid ) FROM cd me',
+ '+columns' => [ { cnt => { count => 'cdid', -as => 'cnt' } } ],
+ } => 'SELECT COUNT ( cdid ) AS cnt, MIN( me.cdid ) FROM cd me',
{
- columns => [ 'year' ],
- } => 'SELECT me.year FROM cd me',
+ columns => [ { foo => { coalesce => [qw/a b c/], -as => 'firstfound' } } ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound FROM cd me',
+
+ {
+ '+columns' => [ 'me.year' ],
+ '+select' => [ { max => 'me.year', -as => 'last_y' } ],
+ '+as' => [ 'ly' ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y FROM cd me',
+
+ {
+ '+select' => [ { count => 'me.cdid', -as => 'cnt' } ],
+ '+as' => [ 'cnt' ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt FROM cd me',
+
+ # adding existing stuff should not alter selector
+ {
+ '+select' => [ 'me.year' ],
+ '+as' => [ 'year' ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me',
+
+ {
+ '+columns' => [ 'me.year' ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me',
+
+ {
+ '+columns' => 'me.year',
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year FROM cd me',
+
+ # naked selector at the end should just work
+ {
+ '+select' => 'me.moar_stuff',
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year, me.moar_stuff FROM cd me',
+
+ {
+ '+select' => [ { MOAR => 'f', -as => 'func' } ],
+ } => 'SELECT COALESCE( a, b, c ) AS firstfound, me.year, MAX( me.year ) AS last_y, COUNT( me.cdid ) AS cnt, me.year, me.moar_stuff, MOAR(f) AS func FROM cd me',
+
);
my $rs = $schema->resultset('CD');
$testno++;
}
+# Make sure we don't lose bits even with weird selector specs
+# also check that the default selector list is lazy
+# and make sure that unaliased +select does not go crazy
+$rs = $schema->resultset('CD');
+for my $attr (
+ { '+columns' => [ 'me.title' ] }, # this one should be de-duplicated but not the select's
+
+ { '+select' => \'me.year AS foo' }, # duplication of identical select expected (FIXME ?)
+ { '+select' => \['me.year AS foo'] },
+
+ { '+select' => [ \'me.artistid AS bar' ] },
+ { '+select' => { count => 'artistid', -as => 'baz' } },
+) {
+ for (qw/columns select as/) {
+ ok (! exists $rs->{attrs}{$_}, "No eager '$_' attr on fresh resultset" );
+ }
+
+ $rs = $rs->search({}, $attr);
+}
+
+is_same_sql_bind (
+ $rs->as_query,
+ '( SELECT
+ me.cdid,
+ me.artist,
+ me.title,
+ me.year,
+ me.genreid,
+ me.single_track,
+ me.year AS foo,
+ me.year AS foo,
+ me.artistid AS bar,
+ COUNT( artistid ) AS baz
+ FROM cd me
+ )',
+ [],
+ 'Correct chaining before attr resolution'
+);
+
+# Test the order of columns
+$rs = $schema->resultset('CD')->search ({}, {
+ 'select' => [ 'me.cdid', 'me.title' ],
+});
+
+is_same_sql_bind (
+ $rs->as_query,
+ '( SELECT
+ me.cdid,
+ me.title
+ FROM cd me
+ )',
+ [],
+ 'Correct order of selected columns'
+);
+
+# Test bare +select with as from root of resultset
+$rs = $schema->resultset('CD')->search ({}, {
+ '+select' => [
+ \ 'foo',
+ { MOAR => 'f', -as => 'func' },
+ ],
+});
+
+is_same_sql_bind (
+ $rs->as_query,
+ '( SELECT
+ me.cdid,
+ me.artist,
+ me.title,
+ me.year,
+ me.genreid,
+ me.single_track,
+ foo,
+ MOAR( f ) AS func
+ FROM cd me
+ )',
+ [],
+ 'Correct order of selected columns'
+);
+
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+use DBICTest;
+
+
+my $schema = DBICTest->init_schema();
+
+my $multicol_rs = $schema->resultset('Artist')->search({ artistid => \'1' }, { columns => [qw/name rank/] });
+
+my @chain = (
+ {
+ select => 'cdid',
+ as => 'cd_id',
+ columns => [ 'title' ],
+ } => 'SELECT
+ me.title,
+ me.cdid
+ FROM cd me'
+ => [qw/title cd_id/],
+
+ {
+ '+select' => \ 'DISTINCT(foo, bar)',
+ '+as' => [qw/foo bar/],
+ } => 'SELECT
+ me.title,
+ me.cdid,
+ DISTINCT(foo, bar)
+ FROM cd me'
+ => [qw/title cd_id foo bar/],
+
+ {
+ '+select' => [ 'genreid', $multicol_rs->as_query ],
+ '+as' => [qw/genreid name rank/],
+ } => 'SELECT
+ me.title,
+ me.cdid,
+ DISTINCT(foo, bar),
+ me.genreid,
+ (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 ))
+ FROM cd me'
+ => [qw/title cd_id foo bar genreid name rank/],
+
+ {
+ '+select' => { count => 'me.cdid', -as => 'cnt' }, # lack of 'as' infers from '-as'
+ '+columns' => { len => { length => 'me.title' } },
+ } => 'SELECT
+ me.title,
+ LENGTH( me.title ),
+ me.cdid,
+ DISTINCT(foo, bar),
+ me.genreid,
+ (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )),
+ COUNT( me.cdid ) AS cnt
+ FROM cd me'
+ => [qw/title len cd_id foo bar genreid name rank cnt/],
+ {
+ '+select' => \'unaliased randomness',
+ } => 'SELECT
+ me.title,
+ LENGTH( me.title ),
+ me.cdid,
+ DISTINCT(foo, bar),
+ me.genreid,
+ (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )),
+ COUNT( me.cdid ) AS cnt,
+ unaliased randomness
+ FROM cd me'
+ => [qw/title len cd_id foo bar genreid name rank cnt/],
+ {
+ '+select' => \'MOAR unaliased randomness',
+ } => 'SELECT
+ me.title,
+ LENGTH( me.title ),
+ me.cdid,
+ DISTINCT(foo, bar),
+ me.genreid,
+ (SELECT me.name, me.rank FROM artist me WHERE ( artistid 1 )),
+ COUNT( me.cdid ) AS cnt,
+ unaliased randomness,
+ MOAR unaliased randomness
+ FROM cd me'
+ => [qw/title len cd_id foo bar genreid name rank cnt/],
+);
+
+my $rs = $schema->resultset('CD');
+
+my $testno = 1;
+while (@chain) {
+ my $attrs = shift @chain;
+ my $sql = shift @chain;
+ my $as = shift @chain;
+
+ $rs = $rs->search ({}, $attrs);
+
+ is_same_sql_bind (
+ $rs->as_query,
+ "($sql)",
+ [],
+ "Test $testno of SELECT assembly ok",
+ );
+
+ is_deeply(
+ $rs->_resolved_attrs->{as},
+ $as,
+ "Correct dbic-side aliasing for test $testno",
+ );
+
+ $testno++;
+}
+
+# make sure proper exceptions are thrown on unbalanced use
+{
+ my $rs = $schema->resultset('CD')->search({}, { select => \'count(me.cdid)'});
+
+ lives_ok(sub {
+ $rs->search({}, { '+select' => 'me.cdid' })->next
+ }, 'Two dark selectors are ok');
+
+ throws_ok(sub {
+ $rs->search({}, { '+select' => 'me.cdid', '+as' => 'cdid' })->next
+ }, qr/resultset contains an unnamed selector/, 'Unnamed followed by named is not');
+
+ throws_ok(sub {
+ $rs->search_rs({}, { prefetch => 'tracks' })->next
+ }, qr/resultset contains an unnamed selector/, 'Throw on unaliased selector followed by prefetch');
+
+ throws_ok(sub {
+ $rs->search_rs({}, { '+select' => 'me.title', '+as' => 'title' })->next
+ }, qr/resultset contains an unnamed selector/, 'Throw on unaliased selector followed by +select/+as');
+}
+
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my $ROWS = DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype;
my $schema = DBICTest->init_schema();
my $art_rs = $schema->resultset('Artist');
my @tests = (
{
rs => $cdrs,
- search => \[ "title = ? AND year LIKE ?", 'buahaha', '20%' ],
+ search => \[ "title = ? AND year LIKE ?", [ title => 'buahaha' ], [ year => '20%' ] ],
attrs => { rows => 5 },
sqlbind => \[
- "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT 5)",
- 'buahaha',
- '20%',
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE (title = ? AND year LIKE ?) LIMIT ?)",
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' } => 'buahaha' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'year' } => '20%' ],
+ [ $ROWS => 5 ],
],
},
{
rs => $cdrs,
search => {
- artist_id => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'id' )->as_query },
+ artistid => { 'in' => $art_rs->search({}, { rows => 1 })->get_column( 'artistid' )->as_query },
},
sqlbind => \[
- "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist_id IN ( SELECT id FROM artist me LIMIT 1 ) )",
+ "( SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artistid IN ( SELECT me.artistid FROM artist me LIMIT ? ) )",
+ [ $ROWS => 1 ],
],
},
],
},
sqlbind => \[
- "( SELECT (SELECT id FROM cd me LIMIT 1) FROM artist me )",
+ "( SELECT (SELECT me.id FROM cd me LIMIT ?) FROM artist me )",
+ [ $ROWS => 1 ],
],
},
],
},
sqlbind => \[
- "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT id FROM cd me LIMIT 1) FROM artist me )",
+ "( SELECT me.artistid, me.name, me.rank, me.charfield, (SELECT me.id FROM cd me LIMIT ?) FROM artist me )",
+ [ $ROWS => 1 ],
],
},
attrs => {
alias => 'cd2',
from => [
- { cd2 => $cdrs->search({ id => { '>' => 20 } })->as_query },
+ { cd2 => $cdrs->search({ artist => { '>' => 20 } })->as_query },
],
},
sqlbind => \[
"( SELECT cd2.cdid, cd2.artist, cd2.title, cd2.year, cd2.genreid, cd2.single_track FROM (
- SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE id > ?
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE artist > ?
) cd2
)",
- [ 'id', 20 ]
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 20 ]
],
},
{ 'me' => 'artist' },
[
{ 'cds' => $cdrs->search({}, { 'select' => [\'me.artist as cds_artist' ]})->as_query },
- { 'me.artistid' => 'cds_artist' }
+ { 'me.artistid' => 'cds_artist' }
]
]
},
alias => 'cd2',
from => [
{ cd2 => $cdrs->search(
- { id => { '>' => 20 } },
- {
+ { artist => { '>' => 20 } },
+ {
alias => 'cd3',
- from => [
- { cd3 => $cdrs->search( { id => { '<' => 40 } } )->as_query }
+ from => [
+ { cd3 => $cdrs->search( { artist => { '<' => 40 } } )->as_query }
],
}, )->as_query },
],
(SELECT cd3.cdid, cd3.artist, cd3.title, cd3.year, cd3.genreid, cd3.single_track
FROM
(SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
- FROM cd me WHERE id < ?) cd3
- WHERE id > ?) cd2
+ FROM cd me WHERE artist < ?) cd3
+ WHERE artist > ?) cd2
)",
- [ 'id', 40 ],
- [ 'id', 20 ]
+ [ { sqlt_datatype => 'integer', dbic_colname => 'artist' } => 40 ],
+ [ { dbic_colname => 'artist' } => 20 ], # no rsrc in outer manual from - hence no resolution
],
},
SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me WHERE title = ?
) cd2
)",
- [ 'title',
- 'Thriller'
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'title' }
+ => 'Thriller'
]
],
},
);
-plan tests => @tests * 2;
-
for my $i (0 .. $#tests) {
my $t = $tests[$i];
for my $p (1, 2) { # repeat everything twice, make sure we do not clobber search arguments
);
}
}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema(no_deploy => 1);
+
+throws_ok {
+ $schema->resultset('Artist')->search
+} qr/\Qsearch is *not* a mutator/, 'Proper exception on search in void ctx';
+
+done_testing;
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-my $schema = DBICTest->init_schema;
-
-# Trick the sqlite DB to use Top limit emulation
-# We could test all of this via $sq->$op directly,
-# but some conditions need a $rsrc
-delete $schema->storage->_sql_maker->{_cached_syntax};
-$schema->storage->_sql_maker->limit_dialect ('Top');
-
-my $rs = $schema->resultset ('BooksInLibrary')->search ({}, { prefetch => 'owner', rows => 1, offset => 3 });
-
-sub default_test_order {
- my $order_by = shift;
- is_same_sql_bind(
- $rs->search ({}, {order_by => $order_by})->as_query,
- "(SELECT
- TOP 1 me__id, source, owner, title, price, owner__id, name FROM
- (SELECT
- TOP 4 me.id AS me__id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name
- FROM books me
- JOIN owners owner ON
- owner.id = me.owner
- WHERE ( source = ? )
- ORDER BY me__id ASC
- ) me ORDER BY me__id DESC
- )",
- [ [ source => 'Library' ] ],
- );
-}
-
-sub test_order {
- my $args = shift;
-
- my $req_order = $args->{order_req}
- ? "ORDER BY $args->{order_req}"
- : ''
- ;
-
- is_same_sql_bind(
- $rs->search ({}, {order_by => $args->{order_by}})->as_query,
- "(SELECT
- me__id, source, owner, title, price, owner__id, name FROM
- (SELECT
- TOP 1 me__id, source, owner, title, price, owner__id, name FROM
- (SELECT
- TOP 4 me.id AS me__id, me.source, me.owner, me.title, me.price, owner.id AS owner__id, owner.name FROM
- books me
- JOIN owners owner ON owner.id = me.owner
- WHERE ( source = ? )
- ORDER BY $args->{order_inner}
- ) me ORDER BY $args->{order_outer}
- ) me $req_order
- )",
- [ [ source => 'Library' ] ],
- );
-}
-
-my @tests = (
- {
- order_by => \'foo DESC',
- order_req => 'foo DESC',
- order_inner => 'foo DESC',
- order_outer => 'foo ASC'
- },
- {
- order_by => { -asc => 'foo' },
- order_req => 'foo ASC',
- order_inner => 'foo ASC',
- order_outer => 'foo DESC',
- },
- {
- order_by => 'foo',
- order_req => 'foo',
- order_inner => 'foo ASC',
- order_outer => 'foo DESC',
- },
- {
- order_by => [ qw{ foo bar} ],
- order_req => 'foo, bar',
- order_inner => 'foo ASC, bar ASC',
- order_outer => 'foo DESC, bar DESC',
- },
- {
- order_by => { -desc => 'foo' },
- order_req => 'foo DESC',
- order_inner => 'foo DESC',
- order_outer => 'foo ASC',
- },
- {
- order_by => ['foo', { -desc => 'bar' } ],
- order_req => 'foo, bar DESC',
- order_inner => 'foo ASC, bar DESC',
- order_outer => 'foo DESC, bar ASC',
- },
- {
- order_by => { -asc => [qw{ foo bar }] },
- order_req => 'foo ASC, bar ASC',
- order_inner => 'foo ASC, bar ASC',
- order_outer => 'foo DESC, bar DESC',
- },
- {
- order_by => [
- { -asc => 'foo' },
- { -desc => [qw{bar}] },
- { -asc => [qw{hello sensors}]},
- ],
- order_req => 'foo ASC, bar DESC, hello ASC, sensors ASC',
- order_inner => 'foo ASC, bar DESC, hello ASC, sensors ASC',
- order_outer => 'foo DESC, bar ASC, hello DESC, sensors DESC',
- },
-);
-
-my @default_tests = ( undef, '', {}, [] );
-
-plan (tests => scalar @tests + scalar @default_tests + 1);
-
-test_order ($_) for @tests;
-default_test_order ($_) for @default_tests;
-
-
-is_same_sql_bind (
- $rs->search ({}, { group_by => 'title', order_by => 'title' })->as_query,
-'(SELECT
-me.id, me.source, me.owner, me.title, me.price, owner.id, owner.name FROM
- ( SELECT
- id, source, owner, title, price FROM
- ( SELECT
- TOP 1 id, source, owner, title, price FROM
- ( SELECT
- TOP 4 me.id, me.source, me.owner, me.title, me.price FROM
- books me JOIN
- owners owner ON owner.id = me.owner
- WHERE ( source = ? )
- GROUP BY title
- ORDER BY title ASC
- ) me
- ORDER BY title DESC
- ) me
- ORDER BY title
- ) me JOIN
- owners owner ON owner.id = me.owner WHERE
- ( source = ? )
- ORDER BY title)' ,
- [ [ source => 'Library' ], [ source => 'Library' ] ],
-);
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($ROWS, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('CD')->search({ -and => [
+ 'me.artist' => { '!=', '666' },
+ 'me.artist' => { '!=', \[ '?', [ _ne => 'bar' ] ] },
+]});
+
+# bogus sql query to make sure bind composition happens properly
+my $complex_rs = $rs->search({}, {
+ '+columns' => { cnt => $rs->count_rs->as_query },
+ '+select' => \[ 'me.artist + ?', [ _add => 1 ] ], # free select
+ group_by => ['me.cdid', \[ 'me.artist - ?', [ _sub => 2 ] ] ],
+ having => \[ 'me.artist < ?', [ _lt => 3 ] ],
+ order_by => \[ 'me.artist * ? ', [ _mu => 4 ] ],
+ rows => 1,
+ page => 3,
+});
+
+for (1,2) {
+ is_same_sql_bind (
+ $complex_rs->as_query,
+ '(
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track,
+ (SELECT COUNT( * ) FROM cd me WHERE me.artist != ? AND me.artist != ?),
+ me.artist + ?
+ FROM cd me
+ WHERE me.artist != ? AND me.artist != ?
+ GROUP BY me.cdid, me.artist - ?
+ HAVING me.artist < ?
+ ORDER BY me.artist * ?
+ LIMIT ? OFFSET ?
+ )',
+ [
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 666 ],
+ [ { dbic_colname => '_ne' } => 'bar' ],
+ [ { dbic_colname => '_add' } => 1 ],
+ [ { sqlt_datatype => 'integer', dbic_colname => 'me.artist' } => 666 ],
+ [ { dbic_colname => '_ne' } => 'bar' ],
+ [ { dbic_colname => '_sub' } => 2 ],
+ [ { dbic_colname => '_lt' } => 3 ],
+ [ { dbic_colname => '_mu' } => 4 ],
+ [ $ROWS => 1 ],
+ [ $OFFSET => 2 ],
+ ],
+ 'Correct crazy sql',
+ );
+}
+
+# see if we get anything back at all
+isa_ok ($complex_rs->next, 'DBIx::Class::Row');
+
+done_testing;
);
}
-# Make sure the carp/croak override in SQLA works (via SQLAHacks)
+# Make sure the carp/croak override in SQLA works (via SQLMaker)
my $file = quotemeta (__FILE__);
throws_ok (sub {
$schema->resultset ('Artist')->search ({}, { order_by => { -asc => 'stuff', -desc => 'staff' } } )->as_query;
[
'me.cdid',
{ count => 'tracks.cd' },
- { min => 'me.year', -as => 'me.minyear' },
+ { min => 'me.year', -as => 'minyear' },
],
{
'artist.name' => 'Caterwauler McCrae',
'me.year' => 2001
},
- [],
+ {},
undef,
undef
);
is_same_sql_bind(
$sql, \@bind,
q/
- SELECT `me`.`cdid`, COUNT( `tracks`.`cd` ), MIN( `me`.`year` ) AS `me`.`minyear`
+ SELECT `me`.`cdid`, COUNT( `tracks`.`cd` ), MIN( `me`.`year` ) AS `minyear`
FROM `cd` `me`
JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` )
LEFT JOIN `tracks` `tracks` ON ( `tracks`.`cd` = `me`.`cdid` )
'me.year'
],
undef,
- 'year DESC',
+ { order_by => 'year DESC' },
undef,
undef
);
'me.year'
],
undef,
- [
+ { order_by => [
'year DESC',
'title ASC'
- ],
+ ]},
undef,
undef
);
'me.year'
],
undef,
- { -desc => 'year' },
+ { order_by => { -desc => 'year' } },
undef,
undef
);
'me.year'
],
undef,
- [
+ { order_by => [
{ -desc => 'year' },
- { -asc => 'title' }
- ],
+ { -asc => 'title' },
+ ]},
undef,
undef
);
'me.year'
],
undef,
- \'year DESC',
+ { order_by => \'year DESC' },
undef,
undef
);
'me.year'
],
undef,
- [
+ { order_by => [
\'year DESC',
\'title ASC'
- ],
+ ]},
undef,
undef
);
'me.*'
],
undef,
- [],
undef,
- undef
+ undef,
+ undef,
);
is_same_sql_bind(
'artist.name' => 'Caterwauler McCrae',
'me.year' => 2001
},
- [],
undef,
- undef
+ undef,
+ undef,
);
is_same_sql_bind(
use strict;
-use warnings;
+use warnings;
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
);
is( $cds[0]->title, "Spoonful of bees", "software offset ok" );
+throws_ok {
+ $schema->resultset("CD")->search({}, {
+ rows => 2,
+ software_limit => 1,
+ })->as_query;
+} qr/Unable to generate limited query representation with 'software_limit' enabled/;
@cds = $schema->resultset("CD")->search( {},
{
);
is( $cds[0]->title, "Spoonful of bees", "offset with no limit" );
-
-# based on a failing criteria submitted by waswas
-# requires SQL::Abstract >= 1.20
$it = $schema->resultset("CD")->search(
{ title => [
- -and =>
+ -and =>
{
-like => '%bees'
},
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::Schema;
+use DBIC::SqlMakerTest;
+
+# This is legacy stuff from SQL::Absract::Limit
+# Keep it around just in case someone is using it
+
+{
+ package DBICTest::SQLMaker::CustomDialect;
+ use base qw/DBIx::Class::SQLMaker/;
+ sub emulate_limit {
+ my ($self, $sql, $rs_attrs, $limit, $offset) = @_;
+ return sprintf ('shiny sproc ((%s), %d, %d)',
+ $sql,
+ $limit || 0,
+ $offset || 0,
+ );
+ }
+}
+my $s = DBICTest::Schema->connect (DBICTest->_database);
+$s->storage->sql_maker_class ('DBICTest::SQLMaker::CustomDialect');
+
+my $rs = $s->resultset ('CD');
+is_same_sql_bind (
+ $rs->search ({}, { rows => 1, offset => 3,columns => [
+ { id => 'foo.id' },
+ { 'bar.id' => 'bar.id' },
+ { bleh => \ 'TO_CHAR (foo.womble, "blah")' },
+ ]})->as_query,
+ '(
+ shiny sproc (
+ (
+ SELECT foo.id, bar.id, TO_CHAR (foo.womble, "blah")
+ FROM cd me
+ ),
+ 1,
+ 3
+ )
+ )',
+ [],
+ 'Rownum subsel aliasing works correctly'
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+# based on toplimit.t
+delete $schema->storage->_sql_maker->{_cached_syntax};
+$schema->storage->_sql_maker->limit_dialect ('FetchFirst');
+
+my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, {
+ prefetch => 'owner', rows => 2, offset => 3,
+ columns => [ grep { $_ ne 'title' } $schema->source('BooksInLibrary')->columns ],
+});
+
+for my $null_order (
+ undef,
+ '',
+ {},
+ [],
+ [{}],
+) {
+ my $rs = $books_45_and_owners->search ({}, {order_by => $null_order });
+ is_same_sql_bind(
+ $rs->as_query,
+ '(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.id
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY me.id DESC
+ FETCH FIRST 2 ROWS ONLY
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+
+for my $ord_set (
+ {
+ order_by => \'title DESC',
+ order_inner => 'title DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => { -asc => 'title' },
+ order_inner => 'title ASC',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1 ASC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => { -desc => 'title' },
+ order_inner => 'title DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => 'title',
+ order_inner => 'title',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => [ qw{ title me.owner} ],
+ order_inner => 'title, me.owner',
+ order_outer => 'ORDER__BY__1 DESC, me.owner DESC',
+ order_req => 'ORDER__BY__1, me.owner',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => ['title', { -desc => 'bar' } ],
+ order_inner => 'title, bar DESC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => { -asc => [qw{ title bar }] },
+ order_inner => 'title ASC, bar ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC',
+ order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => [
+ 'title',
+ { -desc => [qw{bar}] },
+ { -asc => [qw{me.owner sensors}]},
+ ],
+ order_inner => 'title, bar DESC, me.owner ASC, sensors ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3',
+ },
+) {
+ my $o_sel = $ord_set->{exselect_outer}
+ ? ', ' . $ord_set->{exselect_outer}
+ : ''
+ ;
+ my $i_sel = $ord_set->{exselect_inner}
+ ? ', ' . $ord_set->{exselect_inner}
+ : ''
+ ;
+
+ is_same_sql_bind(
+ $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query,
+ "(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY $ord_set->{order_inner}
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY $ord_set->{order_outer}
+ FETCH FIRST 2 ROWS ONLY
+ ) me
+ ORDER BY $ord_set->{order_req}
+ )",
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+# with groupby
+is_same_sql_bind (
+ $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query,
+ '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1 AS title
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, title AS ORDER__BY__1
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ GROUP BY title
+ ORDER BY title
+ FETCH FIRST 5 ROWS ONLY
+ ) me
+ ORDER BY ORDER__BY__1 DESC
+ FETCH FIRST 2 ROWS ONLY
+ ) me
+ ORDER BY ORDER__BY__1
+ ) me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY title
+ )',
+ [ map { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ]
+ } (1,2) ],
+);
+
+# test deprecated column mixing over join boundaries
+my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1
+});
+
+is_same_sql_bind( $rs_selectas_top->search({})->as_query,
+ '(SELECT
+ me.id, me.source, me.owner, me.title, me.price, owner.name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ FETCH FIRST 1 ROWS ONLY
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'artistid',
+ offset => 1,
+ order_by => 'artistid',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($LIMIT, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+my $schema = DBICTest->init_schema;
+
+$schema->storage->_sql_maker->limit_dialect ('FirstSkip');
+
+my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner.name'],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_col->as_query,
+ '(
+ SELECT FIRST ? SKIP ? me.id, me.source, me.owner, me.title, me.price, owner.name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ )',
+ [
+ [ $LIMIT => 1 ],
+ [ $OFFSET => 2 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+);
+
+$schema->storage->_sql_maker->quote_char ([qw/ [ ] /]);
+$schema->storage->_sql_maker->name_sep ('.');
+
+my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT FIRST ? SKIP ? [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[name]
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ )',
+ [
+ [ $LIMIT => 1 ],
+ [ $OFFSET => 2 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+);
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+ 'count.name' => 'fail', # no one would do this in real life, the rows makes even less sense
+}, { alias => 'owner', rows => 1 })->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT FIRST ? SKIP ?
+ [owner].[name],
+ ( SELECT COUNT(*) FROM
+ ( SELECT FIRST ? [owner].[id] FROM [owners] [owner]
+ WHERE [count].[id] = [owner].[id] and [count].[name] = ?
+ ) [owner]
+ )
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ )',
+ [
+ [ $LIMIT => 1 ], # outer
+ [ $OFFSET => 2 ], # outer
+ [ {%$LIMIT} => 1 ], # inner
+ [ { dbic_colname => 'count.name' } => 'fail' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+)
+};
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'name',
+ offset => 1,
+ order_by => 'name',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'books.owner' => { -ident => 'owner.id' },
+}, { alias => 'owner', select => ['id'], offset => 3, rows => 4 });
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1, offset => 2 } );
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT FIRST ? SKIP ? [me].[id], [me].[owner]
+ FROM [books] [me]
+ WHERE ( ( (EXISTS (
+ SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] )
+ )) AND [source] = ? ) )
+ )',
+ [
+ [ $LIMIT => 1 ], #outer
+ [ $OFFSET => 2 ], #outer
+ [ {%$LIMIT} => 4 ], #inner
+ [ {%$OFFSET} => 3 ], #inner
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+ 'Pagination with sub-query in WHERE works'
+);
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+my ($ROWS, $TOTAL, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__total_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+
+my $schema = DBICTest->init_schema;
+
+$schema->storage->_sql_maker->limit_dialect ('GenericSubQ');
+
+my $rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+columns' => [{ owner_name => 'owner.name' }],
+ join => 'owner',
+ rows => 2,
+ order_by => 'me.title',
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner_name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner.name AS owner_name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ) me
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM books rownum__emulation
+ WHERE rownum__emulation.title < me.title
+ ) < ?
+ ORDER BY me.title
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $ROWS => 2 ],
+ ],
+);
+
+is_deeply (
+ [ $rs->get_column ('title')->all ],
+ ['Best Recipe Cookbook', 'Dynamical Systems'],
+ 'Correct columns selected with rows',
+);
+
+$schema->storage->_sql_maker->quote_char ('"');
+$schema->storage->_sql_maker->name_sep ('.');
+
+$rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ order_by => { -desc => 'title' },
+ '+select' => ['owner.name'],
+ '+as' => ['owner.name'],
+ join => 'owner',
+ rows => 3,
+ offset => 1,
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT "me"."id", "me"."source", "me"."owner", "me"."title", "me"."price",
+ "owner__name"
+ FROM (
+ SELECT "me"."id", "me"."source", "me"."owner", "me"."title", "me"."price",
+ "owner"."name" AS "owner__name"
+ FROM "books" "me"
+ JOIN "owners" "owner" ON "owner"."id" = "me"."owner"
+ WHERE ( "source" = ? )
+ ) "me"
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM "books" "rownum__emulation"
+ WHERE "rownum__emulation"."title" > "me"."title"
+ ) BETWEEN ? AND ?
+ ORDER BY "title" DESC
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 3 ],
+ ],
+);
+
+is_deeply (
+ [ $rs->get_column ('title')->all ],
+ [ 'Dynamical Systems', 'Best Recipe Cookbook' ],
+ 'Correct columns selected with rows',
+);
+
+$rs = $schema->resultset ('BooksInLibrary')->search ({}, {
+ order_by => 'title',
+ 'select' => ['owner.name'],
+ 'as' => ['owner_name'],
+ join => 'owner',
+ offset => 1,
+});
+
+is_same_sql_bind(
+ $rs->as_query,
+ '(
+ SELECT "owner_name"
+ FROM (
+ SELECT "owner"."name" AS "owner_name", "title"
+ FROM "books" "me"
+ JOIN "owners" "owner" ON "owner"."id" = "me"."owner"
+ WHERE ( "source" = ? )
+ ) "me"
+ WHERE
+ (
+ SELECT COUNT(*)
+ FROM "books" "rownum__emulation"
+ WHERE "rownum__emulation"."title" < "me"."title"
+ ) BETWEEN ? AND ?
+ ORDER BY "title"
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 2147483647 ],
+ ],
+);
+
+is_deeply (
+ [ $rs->get_column ('owner_name')->all ],
+ [ ('Newton') x 2 ],
+ 'Correct columns selected with rows',
+);
+
+{
+ $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'artistid',
+ offset => 1,
+ order_by => 'artistid',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+# this is a nonsensical order_by, we are just making sure the bind-transport is correct
+# (not that it'll be useful anywhere in the near future)
+my $attr = {};
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search(undef, {
+ columns => 'me.id',
+ offset => 3,
+ rows => 4,
+ '+columns' => { bar => \['? * ?', [ $attr => 11 ], [ $attr => 12 ]], baz => \[ '?', [ $attr => 13 ]] },
+ order_by => [ 'id', \['? / ?', [ $attr => 1 ], [ $attr => 2 ]], \[ '?', [ $attr => 3 ]] ],
+ having => \[ '?', [ $attr => 21 ] ],
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT "me"."id", "bar", "baz"
+ FROM (
+ SELECT "me"."id", ? * ? AS "bar", ? AS "baz"
+ FROM "books" "me"
+ WHERE ( "source" = ? )
+ HAVING ?
+ ) "me"
+ WHERE ( SELECT COUNT(*) FROM "books" "rownum__emulation" WHERE "rownum__emulation"."id" < "me"."id" ) BETWEEN ? AND ?
+ ORDER BY "id", ? / ?, ?
+ )',
+ [
+ [ $attr => 11 ], [ $attr => 12 ], [ $attr => 13 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $attr => 21 ],
+ [ {%$OFFSET} => 3 ],
+ [ {%$TOTAL} => 6 ],
+ [ $attr => 1 ], [ $attr => 2 ], [ $attr => 3 ],
+ ],
+ 'Pagination with sub-query in ORDER BY works'
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($TOTAL, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__total_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+my $schema = DBICTest->init_schema;
+
+$schema->storage->_sql_maker->limit_dialect ('RowNumberOver');
+
+my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner.name'],
+ join => 'owner',
+ rows => 1,
+});
+
+is_same_sql_bind(
+ $rs_selectas_col->as_query,
+ '(
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner__name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner__name,
+ ROW_NUMBER() OVER( ) AS rno__row__index
+ FROM (
+ SELECT me.id, me.source, me.owner, me.title, me.price,
+ owner.name AS owner__name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ) me
+ ) me
+ WHERE rno__row__index >= ? AND rno__row__index <= ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 1 ],
+ ],
+);
+
+$schema->storage->_sql_maker->quote_char ([qw/ [ ] /]);
+$schema->storage->_sql_maker->name_sep ('.');
+
+my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price],
+ [owner_name]
+ FROM (
+ SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price],
+ [owner_name],
+ ROW_NUMBER() OVER( ) AS [rno__row__index]
+ FROM (
+ SELECT [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price],
+ [owner].[name] AS [owner_name]
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ ) [me]
+ ) [me]
+ WHERE [rno__row__index] >= ? AND [rno__row__index] <= ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 1 ],
+ ],
+);
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+ 'count.name' => 'fail', # no one would do this in real life
+}, { alias => 'owner' })->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 1,
+ order_by => 'me.id',
+});
+
+# SELECT [owner_name], [owner_books] FROM (
+# SELECT [owner_name], [owner_books], [ORDER__BY__1], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__1] ) AS [rno__row__index] FROM (
+# SELECT [owner].[name] AS [owner_name], (SELECT COUNT( * ) FROM [owners] [owner] WHERE ( ( [count].[id] = [owner].[id] AND [count].[name] = ? ) )) AS [owner_books], [me].[id] AS [ORDER__BY__1] FROM [books] [me] JOIN [owners] [owner] ON [owner].[id] = [me].[owner] WHERE ( [source] = ? )
+# ) [me]
+# ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ?
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT [owner_name], [owner_books]
+ FROM (
+ SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ORDER BY [ORDER__BY__1] ) AS [rno__row__index]
+ FROM (
+ SELECT [owner].[name] AS [owner_name],
+ ( SELECT COUNT( * ) FROM [owners] [owner]
+ WHERE [count].[id] = [owner].[id] and [count].[name] = ? ) AS [owner_books],
+ [me].[id] AS [ORDER__BY__1]
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ ) [me]
+ ) [me]
+ WHERE [rno__row__index] >= ? AND [rno__row__index] <= ?
+ )',
+ [
+ [ { dbic_colname => 'count.name' } => 'fail' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 1 ],
+ ],
+);
+
+}{
+my $subq = $schema->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+}, { alias => 'owner' })->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 1,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT [owner_name], [owner_books]
+ FROM (
+ SELECT [owner_name], [owner_books], ROW_NUMBER() OVER( ) AS [rno__row__index]
+ FROM (
+ SELECT [owner].[name] AS [owner_name],
+ ( SELECT COUNT( * ) FROM [owners] [owner] WHERE [count].[id] = [owner].[id] ) AS [owner_books]
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ ) [me]
+ ) [me]
+ WHERE [rno__row__index] >= ? AND [rno__row__index] <= ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 1 ],
+ ],
+);
+
+}
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'name',
+ offset => 1,
+ order_by => 'name',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'books.owner' => { -ident => 'owner.id' },
+}, { alias => 'owner', select => ['id'] } )->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } );
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT [me].[id], [me].[owner] FROM (
+ SELECT [me].[id], [me].[owner], ROW_NUMBER() OVER( ) AS [rno__row__index] FROM (
+ SELECT [me].[id], [me].[owner]
+ FROM [books] [me]
+ WHERE ( ( (EXISTS (
+ SELECT COUNT( * ) FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] )
+ )) AND [source] = ? ) )
+ ) [me]
+ ) [me] WHERE [rno__row__index] >= ? AND [rno__row__index] <= ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $OFFSET => 1 ],
+ [ $TOTAL => 1 ],
+ ],
+ 'Pagination with sub-query in WHERE works'
+);
+
+}
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($TOTAL, $OFFSET, $ROWS) = (
+ DBIx::Class::SQLMaker::LimitDialects->__total_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+);
+
+my $s = DBICTest->init_schema (no_deploy => 1, );
+$s->storage->sql_maker->limit_dialect ('RowNum');
+
+my $rs = $s->resultset ('CD')->search({ id => 1 });
+
+my $where_bind = [ { dbic_colname => 'id' }, 1 ];
+
+for my $test_set (
+ {
+ name => 'Rownum subsel aliasing works correctly',
+ rs => $rs->search_rs(undef, {
+ rows => 1,
+ offset => 3,
+ columns => [
+ { id => 'foo.id' },
+ { 'bar.id' => 'bar.id' },
+ { bleh => \'TO_CHAR (foo.womble, "blah")' },
+ ]
+ }),
+ sql => '(
+ SELECT id, bar__id, bleh
+ FROM (
+ SELECT id, bar__id, bleh, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, bar.id AS bar__id, TO_CHAR (foo.womble, "blah") AS bleh
+ FROM cd me
+ WHERE id = ?
+ ) me
+ ) me WHERE rownum__index BETWEEN ? AND ?
+ )',
+ binds => [
+ $where_bind,
+ [ $OFFSET => 4 ],
+ [ $TOTAL => 4 ],
+ ],
+ }, {
+ name => 'Rownum subsel aliasing works correctly with unique order_by',
+ rs => $rs->search_rs(undef, {
+ rows => 1,
+ offset => 3,
+ columns => [
+ { id => 'foo.id' },
+ { 'bar.id' => 'bar.id' },
+ { bleh => \'TO_CHAR (foo.womble, "blah")' },
+ ],
+ order_by => [qw( artist title )],
+ }),
+ sql => '(
+ SELECT id, bar__id, bleh
+ FROM (
+ SELECT id, bar__id, bleh, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, bar.id AS bar__id, TO_CHAR(foo.womble, "blah") AS bleh
+ FROM cd me
+ WHERE id = ?
+ ORDER BY artist, title
+ ) me
+ WHERE ROWNUM <= ?
+ ) me
+ WHERE rownum__index >= ?
+ )',
+ binds => [
+ $where_bind,
+ [ $TOTAL => 4 ],
+ [ $OFFSET => 4 ],
+ ],
+ },
+ {
+ name => 'Rownum subsel aliasing works correctly with non-unique order_by',
+ rs => $rs->search_rs(undef, {
+ rows => 1,
+ offset => 3,
+ columns => [
+ { id => 'foo.id' },
+ { 'bar.id' => 'bar.id' },
+ { bleh => \'TO_CHAR (foo.womble, "blah")' },
+ ],
+ order_by => 'artist',
+ }),
+ sql => '(
+ SELECT id, bar__id, bleh
+ FROM (
+ SELECT id, bar__id, bleh, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, bar.id AS bar__id, TO_CHAR(foo.womble, "blah") AS bleh
+ FROM cd me
+ WHERE id = ?
+ ORDER BY artist
+ ) me
+ ) me
+ WHERE rownum__index BETWEEN ? and ?
+ )',
+ binds => [
+ $where_bind,
+ [ $OFFSET => 4 ],
+ [ $TOTAL => 4 ],
+ ],
+ }, {
+ name => 'Rownum subsel aliasing #2 works correctly',
+ rs => $rs->search_rs(undef, {
+ rows => 2,
+ offset => 3,
+ columns => [
+ { id => 'foo.id' },
+ { 'ends_with_me.id' => 'ends_with_me.id' },
+ ]
+ }),
+ sql => '(
+ SELECT id, ends_with_me__id
+ FROM (
+ SELECT id, ends_with_me__id, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id
+ FROM cd me
+ WHERE id = ?
+ ) me
+ ) me WHERE rownum__index BETWEEN ? AND ?
+ )',
+ binds => [
+ $where_bind,
+ [ $OFFSET => 4 ],
+ [ $TOTAL => 5 ],
+ ],
+ }, {
+ name => 'Rownum subsel aliasing #2 works correctly with unique order_by',
+ rs => $rs->search_rs(undef, {
+ rows => 2,
+ offset => 3,
+ columns => [
+ { id => 'foo.id' },
+ { 'ends_with_me.id' => 'ends_with_me.id' },
+ ],
+ order_by => [qw( artist title )],
+ }),
+ sql => '(
+ SELECT id, ends_with_me__id
+ FROM (
+ SELECT id, ends_with_me__id, ROWNUM rownum__index
+ FROM (
+ SELECT foo.id AS id, ends_with_me.id AS ends_with_me__id
+ FROM cd me
+ WHERE id = ?
+ ORDER BY artist, title
+ ) me
+ WHERE ROWNUM <= ?
+ ) me
+ WHERE rownum__index >= ?
+ )',
+ binds => [
+ $where_bind,
+ [ $TOTAL => 5 ],
+ [ $OFFSET => 4 ],
+ ],
+ }
+) {
+ is_same_sql_bind(
+ $test_set->{rs}->as_query,
+ $test_set->{sql},
+ $test_set->{binds},
+ $test_set->{name});
+}
+
+{
+my $subq = $s->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+}, { alias => 'owner' })->count_rs;
+
+my $rs_selectas_rel = $s->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 2,
+ offset => 3,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT owner_name, owner_books
+ FROM (
+ SELECT owner_name, owner_books, ROWNUM rownum__index
+ FROM (
+ SELECT owner.name AS owner_name,
+ ( SELECT COUNT( * ) FROM owners owner WHERE (count.id = owner.id)) AS owner_books
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ) me
+ ) me
+ WHERE rownum__index BETWEEN ? AND ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ],
+ [ $OFFSET => 4 ],
+ [ $TOTAL => 5 ],
+ ],
+
+ 'pagination with subquery works'
+);
+
+}
+
+{
+ $rs = $s->resultset('Artist')->search({}, {
+ columns => 'name',
+ offset => 1,
+ order_by => 'name',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+{
+my $subq = $s->resultset('Owners')->search({
+ 'books.owner' => { -ident => 'owner.id' },
+}, { alias => 'owner', select => ['id'] } )->count_rs;
+
+my $rs_selectas_rel = $s->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } );
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT me.id, me.owner FROM (
+ SELECT me.id, me.owner FROM books me WHERE ( ( (EXISTS (SELECT COUNT( * ) FROM owners owner WHERE ( books.owner = owner.id ))) AND source = ? ) )
+ ) me
+ WHERE ROWNUM <= ?
+ )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ [ $ROWS => 1 ],
+ ],
+ 'Pagination with sub-query in WHERE works'
+);
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::LimitDialects;
+
+my ($LIMIT, $OFFSET) = (
+ DBIx::Class::SQLMaker::LimitDialects->__rows_bindtype,
+ DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype,
+);
+
+my $schema = DBICTest->init_schema;
+
+$schema->storage->_sql_maker->limit_dialect ('SkipFirst');
+
+my $rs_selectas_col = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner.name'],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_col->as_query,
+ '(
+ SELECT SKIP ? FIRST ? me.id, me.source, me.owner, me.title, me.price, owner.name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ )',
+ [
+ [ $OFFSET => 2 ],
+ [ $LIMIT => 1 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+);
+
+$schema->storage->_sql_maker->quote_char ([qw/ [ ] /]);
+$schema->storage->_sql_maker->name_sep ('.');
+
+my $rs_selectas_rel = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT SKIP ? FIRST ? [me].[id], [me].[source], [me].[owner], [me].[title], [me].[price], [owner].[name]
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ )',
+ [
+ [ $OFFSET => 2 ],
+ [ $LIMIT => 1 ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+);
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+ 'count.name' => 'fail', # no one would do this in real life, the rows makes even less sense
+}, { alias => 'owner', rows => 1 })->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 1,
+ offset => 2,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT SKIP ? FIRST ?
+ [owner].[name],
+ ( SELECT COUNT(*) FROM
+ ( SELECT FIRST ? [owner].[id] FROM [owners] [owner]
+ WHERE [count].[id] = [owner].[id] and [count].[name] = ?
+ ) [owner]
+ )
+ FROM [books] [me]
+ JOIN [owners] [owner] ON [owner].[id] = [me].[owner]
+ WHERE ( [source] = ? )
+ )',
+ [
+ [ $OFFSET => 2 ], # outer
+ [ $LIMIT => 1 ], # outer
+ [ {%$LIMIT} => 1 ], # inner
+ [ { dbic_colname => 'count.name' } => 'fail' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+)
+};
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'name',
+ offset => 1,
+ order_by => 'name',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'books.owner' => { -ident => 'owner.id' },
+}, { alias => 'owner', select => ['id'], offset => 3, rows => 4 });
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1, offset => 2 } );
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT SKIP ? FIRST ? [me].[id], [me].[owner]
+ FROM [books] [me]
+ WHERE ( ( (EXISTS (
+ SELECT SKIP ? FIRST ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] )
+ )) AND [source] = ? ) )
+ )',
+ [
+ [ $OFFSET => 2 ], #outer
+ [ $LIMIT => 1 ], #outer
+ [ {%$OFFSET} => 3 ], #inner
+ [ {%$LIMIT} => 4 ], #inner
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+ 'Pagination with sub-query in WHERE works'
+);
+
+}
+
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+# Trick the sqlite DB to use Top limit emulation
+# We could test all of this via $sq->$op directly,
+# but some conditions need a $rsrc
+delete $schema->storage->_sql_maker->{_cached_syntax};
+$schema->storage->_sql_maker->limit_dialect ('Top');
+
+my $books_45_and_owners = $schema->resultset ('BooksInLibrary')->search ({}, {
+ prefetch => 'owner', rows => 2, offset => 3,
+ columns => [ grep { $_ ne 'title' } $schema->source('BooksInLibrary')->columns ],
+});
+
+for my $null_order (
+ undef,
+ '',
+ {},
+ [],
+ [{}],
+) {
+ my $rs = $books_45_and_owners->search ({}, {order_by => $null_order });
+ is_same_sql_bind(
+ $rs->as_query,
+ '(SELECT TOP 2
+ me.id, me.source, me.owner, me.price, owner__id, owner__name
+ FROM (
+ SELECT TOP 5
+ me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.id
+ ) me
+ ORDER BY me.id DESC
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'count.id' => { -ident => 'owner.id' },
+}, { alias => 'owner' })->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search ({}, {
+ columns => [
+ { owner_name => 'owner.name' },
+ { owner_books => $subq->as_query },
+ ],
+ join => 'owner',
+ rows => 2,
+ offset => 3,
+});
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(
+ SELECT TOP 2 owner_name, owner_books
+ FROM (
+ SELECT TOP 5 owner.name AS owner_name,
+ ( SELECT COUNT( * )
+ FROM owners owner
+ WHERE ( count.id = owner.id )
+ ) AS owner_books
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY me.id
+ ) me
+ ORDER BY me.id DESC
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ 'pagination with subqueries works'
+);
+
+}
+
+for my $ord_set (
+ {
+ order_by => \'title DESC',
+ order_inner => 'title DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => { -asc => 'title' },
+ order_inner => 'title ASC',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1 ASC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => { -desc => 'title' },
+ order_inner => 'title DESC',
+ order_outer => 'ORDER__BY__1 ASC',
+ order_req => 'ORDER__BY__1 DESC',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => 'title',
+ order_inner => 'title',
+ order_outer => 'ORDER__BY__1 DESC',
+ order_req => 'ORDER__BY__1',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => [ qw{ title me.owner} ],
+ order_inner => 'title, me.owner',
+ order_outer => 'ORDER__BY__1 DESC, me.owner DESC',
+ order_req => 'ORDER__BY__1, me.owner',
+ exselect_outer => 'ORDER__BY__1',
+ exselect_inner => 'title AS ORDER__BY__1',
+ },
+ {
+ order_by => ['title', { -desc => 'bar' } ],
+ order_inner => 'title, bar DESC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => { -asc => [qw{ title bar }] },
+ order_inner => 'title ASC, bar ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 DESC',
+ order_req => 'ORDER__BY__1 ASC, ORDER__BY__2 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2',
+ },
+ {
+ order_by => [
+ 'title',
+ { -desc => [qw{bar}] },
+ { -asc => [qw{me.owner sensors}]},
+ ],
+ order_inner => 'title, bar DESC, me.owner ASC, sensors ASC',
+ order_outer => 'ORDER__BY__1 DESC, ORDER__BY__2 ASC, me.owner DESC, ORDER__BY__3 DESC',
+ order_req => 'ORDER__BY__1, ORDER__BY__2 DESC, me.owner ASC, ORDER__BY__3 ASC',
+ exselect_outer => 'ORDER__BY__1, ORDER__BY__2, ORDER__BY__3',
+ exselect_inner => 'title AS ORDER__BY__1, bar AS ORDER__BY__2, sensors AS ORDER__BY__3',
+ },
+) {
+ my $o_sel = $ord_set->{exselect_outer}
+ ? ', ' . $ord_set->{exselect_outer}
+ : ''
+ ;
+ my $i_sel = $ord_set->{exselect_inner}
+ ? ', ' . $ord_set->{exselect_inner}
+ : ''
+ ;
+
+ is_same_sql_bind(
+ $books_45_and_owners->search ({}, {order_by => $ord_set->{order_by}})->as_query,
+ "(SELECT me.id, me.source, me.owner, me.price, owner__id, owner__name
+ FROM (
+ SELECT TOP 2
+ me.id, me.source, me.owner, me.price, owner__id, owner__name$o_sel
+ FROM (
+ SELECT TOP 5
+ me.id, me.source, me.owner, me.price, owner.id AS owner__id, owner.name AS owner__name$i_sel
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY $ord_set->{order_inner}
+ ) me
+ ORDER BY $ord_set->{order_outer}
+ ) me
+ ORDER BY $ord_set->{order_req}
+ )",
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+}
+
+# with groupby
+is_same_sql_bind (
+ $books_45_and_owners->search ({}, { group_by => 'title', order_by => 'title' })->as_query,
+ '(SELECT me.id, me.source, me.owner, me.price, owner.id, owner.name
+ FROM (
+ SELECT me.id, me.source, me.owner, me.price, ORDER__BY__1 AS title
+ FROM (
+ SELECT TOP 2
+ me.id, me.source, me.owner, me.price, ORDER__BY__1
+ FROM (
+ SELECT TOP 5
+ me.id, me.source, me.owner, me.price, title AS ORDER__BY__1
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ GROUP BY title
+ ORDER BY title
+ ) me
+ ORDER BY ORDER__BY__1 DESC
+ ) me
+ ORDER BY ORDER__BY__1
+ ) me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ ORDER BY title
+ )',
+ [ map { [
+ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ]
+ } (1,2) ],
+);
+
+# test deprecated column mixing over join boundaries
+my $rs_selectas_top = $schema->resultset ('BooksInLibrary')->search ({}, {
+ '+select' => ['owner.name'],
+ '+as' => ['owner_name'],
+ join => 'owner',
+ rows => 1
+});
+
+is_same_sql_bind( $rs_selectas_top->search({})->as_query,
+ '(SELECT
+ TOP 1 me.id, me.source, me.owner, me.title, me.price,
+ owner.name
+ FROM books me
+ JOIN owners owner ON owner.id = me.owner
+ WHERE ( source = ? )
+ )',
+ [ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
+ => 'Library' ] ],
+ );
+
+{
+ my $rs = $schema->resultset('Artist')->search({}, {
+ columns => 'artistid',
+ offset => 1,
+ order_by => 'artistid',
+ });
+ local $rs->result_source->{name} = "weird \n newline/multi \t \t space containing \n table";
+
+ like (
+ ${$rs->as_query}->[0],
+ qr| weird \s \n \s newline/multi \s \t \s \t \s space \s containing \s \n \s table|x,
+ 'Newlines/spaces preserved in final sql',
+ );
+}
+
+{
+my $subq = $schema->resultset('Owners')->search({
+ 'books.owner' => { -ident => 'owner.id' },
+}, { alias => 'owner', select => ['id'] } )->count_rs;
+
+my $rs_selectas_rel = $schema->resultset('BooksInLibrary')->search( { -exists => $subq->as_query }, { select => ['id','owner'], rows => 1 } );
+
+is_same_sql_bind(
+ $rs_selectas_rel->as_query,
+ '(SELECT TOP 1 me.id, me.owner FROM books me WHERE ( ( (EXISTS (SELECT COUNT( * ) FROM owners owner WHERE ( books.owner = owner.id ))) AND source = ? ) ) )',
+ [
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+ ],
+ 'Pagination with sub-query in WHERE works'
+);
+
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+my $attr = {};
+my @where_bind = (
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Study' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.title' } => 'kama sutra' ],
+ [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' } => 'Library' ],
+);
+my @select_bind = (
+ [ $attr => 11 ], [ $attr => 12 ], [ $attr => 13 ],
+);
+my @group_bind = (
+ [ $attr => 21 ],
+);
+my @having_bind = (
+ [ $attr => 31 ],
+);
+my @order_bind = (
+ [ $attr => 1 ], [ $attr => 2 ], [ $attr => 3 ],
+);
+
+my $tests = {
+
+ LimitOffset => {
+ ordered_limit_offset => [
+ '(
+ SELECT me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ LIMIT ?
+ OFFSET ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ ],
+ ],
+ },
+
+ LimitXY => {
+ ordered_limit_offset => [
+ '(
+ SELECT me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ LIMIT ?, ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ },
+
+ SkipFirst => {
+ ordered_limit_offset => [
+ '(
+ SELECT SKIP ? FIRST ? me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ )',
+ [
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ ],
+ ],
+ },
+
+ FirstSkip => {
+ ordered_limit_offset => [
+ '(
+ SELECT FIRST ? SKIP ? me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ )',
+ [
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ ],
+ ],
+ },
+
+ RowNumberOver => do {
+ my $unordered_sql = '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER() AS rno__row__index
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ) me
+ ) me
+ WHERE rno__row__index >= ? AND rno__row__index <= ?
+ )';
+
+ my $ordered_sql = '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner__id, owner__name, bar, baz, ROW_NUMBER() OVER( ORDER BY ORDER__BY__1, ORDER__BY__2 ) AS rno__row__index
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz,
+ ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ) me
+ ) me
+ WHERE rno__row__index >= ? AND rno__row__index <= ?
+ )';
+
+ {
+ limit => [$unordered_sql,
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 1 ],
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ limit_offset => [$unordered_sql,
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ [ { sqlt_datatype => 'integer' } => 7 ],
+ ],
+ ],
+ ordered_limit => [$ordered_sql,
+ [
+ @select_bind,
+ @order_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 1 ],
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ ordered_limit_offset => [$ordered_sql,
+ [
+ @select_bind,
+ @order_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ [ { sqlt_datatype => 'integer' } => 7 ],
+ ],
+ ],
+ };
+ },
+
+ RowNum => do {
+ my $limit_sql = sub {
+ sprintf '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ %s
+ ) me
+ WHERE ROWNUM <= ?
+ )', $_[0] || '';
+ };
+
+ {
+ limit => [ $limit_sql->(),
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ) me
+ ) me
+ WHERE rownum__index BETWEEN ? AND ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ [ { sqlt_datatype => 'integer' } => 7 ],
+ ],
+ ],
+ ordered_limit => [ $limit_sql->('ORDER BY ? / ?, ?'),
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ ordered_limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner__id, owner__name, bar, baz, ROWNUM rownum__index
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ ) me
+ WHERE ROWNUM <= ?
+ ) me
+ WHERE rownum__index >= ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ [ { sqlt_datatype => 'integer' } => 7 ],
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ };
+ },
+
+ FetchFirst => {
+ limit => [
+ '(
+ SELECT me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ FETCH FIRST 4 ROWS ONLY
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ ],
+ ],
+ limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY me.id
+ FETCH FIRST 7 ROWS ONLY
+ ) me
+ ORDER BY me.id DESC
+ FETCH FIRST 4 ROWS ONLY
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ ],
+ ],
+ ordered_limit => [
+ '(
+ SELECT me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ FETCH FIRST 4 ROWS ONLY
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ ],
+ ],
+ ordered_limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner__id, owner__name, bar, baz, ORDER__BY__1, ORDER__BY__2
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ FETCH FIRST 7 ROWS ONLY
+ ) me
+ ORDER BY ORDER__BY__1 DESC, ORDER__BY__2 DESC
+ FETCH FIRST 4 ROWS ONLY
+ ) me
+ ORDER BY ORDER__BY__1, ORDER__BY__2
+ )',
+ [
+ @select_bind,
+ @order_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ (map { [ @$_ ] } @order_bind), # without this is_deeply throws a fit
+ ],
+ ],
+ },
+
+ Top => {
+ limit => [
+ '(
+ SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ ],
+ ],
+ limit_offset => [
+ '(
+ SELECT TOP 4 me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY me.id
+ ) me
+ ORDER BY me.id DESC
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ ],
+ ],
+ ordered_limit => [
+ '(
+ SELECT TOP 4 me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ @order_bind,
+ ],
+ ],
+ ordered_limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT TOP 4 me.id, owner__id, owner__name, bar, baz, ORDER__BY__1, ORDER__BY__2
+ FROM (
+ SELECT TOP 7 me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz, ? / ? AS ORDER__BY__1, ? AS ORDER__BY__2
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY ? / ?, ?
+ ) me
+ ORDER BY ORDER__BY__1 DESC, ORDER__BY__2 DESC
+ ) me
+ ORDER BY ORDER__BY__1, ORDER__BY__2
+ )',
+ [
+ @select_bind,
+ @order_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ (map { [ @$_ ] } @order_bind), # without this is_deeply throws a fit
+ ],
+ ],
+ },
+
+ RowCountOrGenericSubQ => {
+ limit => [
+ '(
+ SET ROWCOUNT 4
+ SELECT me.id, owner.id, owner.name, ? * ?, ?
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg(me.id / ?)
+ HAVING ?
+ ORDER BY me.id
+ SET ROWCOUNT 0
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ ],
+ ],
+ limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg( me.id / ? )
+ HAVING ?
+ ) me
+ WHERE (
+ SELECT COUNT( * )
+ FROM books rownum__emulation
+ WHERE rownum__emulation.id < me.id
+ ) BETWEEN ? AND ?
+ ORDER BY me.id
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ [ { sqlt_datatype => 'integer' } => 6 ],
+ ],
+ ],
+ },
+
+ GenericSubQ => {
+ limit => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg( me.id / ? )
+ HAVING ?
+ ) me
+ WHERE (
+ SELECT COUNT( * )
+ FROM books rownum__emulation
+ WHERE rownum__emulation.id < me.id
+ ) < ?
+ ORDER BY me.id
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 4 ],
+ ],
+ ],
+ limit_offset => [
+ '(
+ SELECT me.id, owner__id, owner__name, bar, baz
+ FROM (
+ SELECT me.id, owner.id AS owner__id, owner.name AS owner__name, ? * ? AS bar, ? AS baz
+ FROM books me
+ JOIN owners owner
+ ON owner.id = me.owner
+ WHERE source != ? AND me.title = ? AND source = ?
+ GROUP BY avg( me.id / ? )
+ HAVING ?
+ ) me
+ WHERE (
+ SELECT COUNT( * )
+ FROM books rownum__emulation
+ WHERE rownum__emulation.id < me.id
+ ) BETWEEN ? AND ?
+ ORDER BY me.id
+ )',
+ [
+ @select_bind,
+ @where_bind,
+ @group_bind,
+ @having_bind,
+ [ { sqlt_datatype => 'integer' } => 3 ],
+ [ { sqlt_datatype => 'integer' } => 6 ],
+ ],
+ ],
+ }
+};
+
+for my $limtype (sort keys %$tests) {
+
+ Test::Builder->new->is_passing or exit;
+
+ delete $schema->storage->_sql_maker->{_cached_syntax};
+ $schema->storage->_sql_maker->limit_dialect ($limtype);
+
+ # chained search is necessary to exercise the recursive {where} parser
+ my $rs = $schema->resultset('BooksInLibrary')->search({ 'me.title' => { '=' => 'kama sutra' } })->search({ source => { '!=', 'Study' } }, {
+ columns => [ { identifier => 'me.id' }, 'owner.id', 'owner.name' ], # people actually do that. BLEH!!! :)
+ join => 'owner', # single-rel manual prefetch
+ rows => 4,
+ '+columns' => { bar => \['? * ?', [ $attr => 11 ], [ $attr => 12 ]], baz => \[ '?', [ $attr => 13 ]] },
+ group_by => \[ 'avg(me.id / ?)', [ $attr => 21 ] ],
+ having => \[ '?', [ $attr => 31 ] ],
+ ($limtype =~ /GenericSubQ/ ? ( order_by => 'me.id' ) : () ), # needs a simple-column stable order to be happy
+ });
+
+ #
+ # not all tests run on all dialects (somewhere impossible, somewhere makes no sense)
+ #
+
+ # only limit, no offset, no order
+ is_same_sql_bind(
+ $rs->as_query,
+ @{$tests->{$limtype}{limit}},
+ "$limtype: Unordered limit with select/group/having",
+ ) if $tests->{$limtype}{limit};
+
+ # limit + offset, no order
+ is_same_sql_bind(
+ $rs->search({}, { offset => 3 })->as_query,
+ @{$tests->{$limtype}{limit_offset}},
+ "$limtype: Unordered limit+offset with select/group/having",
+ ) if $tests->{$limtype}{limit_offset};
+
+ # order + limit, no offset
+ $rs = $rs->search(undef, {
+ order_by => [ \['? / ?', [ $attr => 1 ], [ $attr => 2 ]], \[ '?', [ $attr => 3 ]] ],
+ });
+
+ is_same_sql_bind(
+ $rs->as_query,
+ @{$tests->{$limtype}{ordered_limit}},
+ "$limtype: Ordered limit with select/group/having",
+ ) if $tests->{$limtype}{ordered_limit};
+
+ # order + limit + offset
+ is_same_sql_bind(
+ $rs->search({}, { offset => 3 })->as_query,
+ @{$tests->{$limtype}{ordered_limit_offset}},
+ "$limtype: Ordered limit+offset with select/group/having",
+ ) if $tests->{$limtype}{ordered_limit_offset};
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema(no_populate => 1);
+my $ars = $schema->resultset('Artist');
+
+my $rank = \13;
+my $ref1 = \['?', [name => 'foo']];
+my $ref2 = \['?', [name => 'bar']];
+my $ref3 = \['?', [name => 'baz']];
+
+# do it twice, make sure the args are untouched
+for (1,2) {
+ $ars->delete;
+
+ lives_ok {
+ $ars->create({ artistid => 666, name => $ref1, rank => $rank });
+ } 'inserted row using literal sql';
+
+ ok (($ars->search({ name => 'foo' })->first),
+ 'row was inserted');
+
+ lives_ok {
+ $ars->search({ name => { '=' => $ref1} })->update({ name => $ref2, rank => $rank });
+ } 'search/updated row using literal sql';
+
+ ok (($ars->search({ name => 'bar' })->first),
+ 'row was updated');
+
+ lives_ok {
+ $ars->populate([{ artistid => 777, name => $ref3, rank => $rank }]);
+ } 'populated row using literal sql';
+
+ ok (($ars->search({ name => 'baz' })->first),
+ 'row was populated');
+}
+
+is_deeply(
+ $ref1,
+ \['?', [name => 'foo']],
+ 'ref1 unchanged',
+);
+is_deeply(
+ $ref2,
+ \['?', [name => 'bar']],
+ 'ref2 unchanged',
+);
+is_deeply(
+ $ref3,
+ \['?', [name => 'baz']],
+ 'ref3 unchanged',
+);
+
+done_testing;
+
+# vim:sts=2 sw=2:
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+use DBIx::Class::SQLMaker::ACCESS ();
+
+my $sa = DBIx::Class::SQLMaker::ACCESS->new;
+
+# my ($self, $table, $fields, $where, $order, @rest) = @_;
+my ($sql, @bind) = $sa->select(
+ [
+ { me => "cd" },
+ [
+ { "-join_type" => "LEFT", artist => "artist" },
+ { "artist.artistid" => "me.artist" },
+ ],
+ ],
+ [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ undef,
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM (cd me LEFT JOIN artist artist ON artist.artistid = me.artist)', [],
+ 'one-step join parenthesized'
+);
+
+($sql, @bind) = $sa->select(
+ [
+ { me => "cd" },
+ [
+ { "-join_type" => "LEFT", track => "track" },
+ { "track.cd" => "me.cdid" },
+ ],
+ [
+ { artist => "artist" },
+ { "artist.artistid" => "me.artist" },
+ ],
+ ],
+ [ 'track.title', 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ],
+ undef,
+ undef
+);
+is_same_sql_bind(
+ $sql, \@bind,
+ 'SELECT track.title, cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM ((cd me LEFT JOIN track track ON track.cd = me.cdid) INNER JOIN artist artist ON artist.artistid = me.artist)', [],
+ 'two-step join parenthesized and inner join prepended with INNER'
+);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
+use_ok('DBICTest');
+
+my $schema = DBICTest->init_schema();
+
+my $sql_maker = $schema->storage->sql_maker;
+
+# a loop so that the callsite line does not change
+for my $expect_warn (1, 0) {
+ warnings_like (
+ sub {
+ my ($sql, @bind) = $sql_maker->select ('foo', undef, { -nest => \ 'bar' } );
+ is_same_sql_bind (
+ $sql, \@bind,
+ 'SELECT * FROM foo WHERE ( bar )', [],
+ '-nest still works'
+ );
+ },
+ ($expect_warn ? qr/\Q-nest in search conditions is deprecated/ : []),
+ 'Only one deprecation warning'
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
+use_ok('DBICTest');
+
+my $schema = DBICTest->init_schema();
+
+my $sql_maker = $schema->storage->sql_maker;
+
+for my $q ('', '"') {
+
+ $sql_maker->quote_char($q);
+
+ is_same_sql_bind (
+ \[ $sql_maker->select ('artist', '*', { 'artist.name' => { -ident => 'artist.pseudonym' } } ) ],
+ "SELECT *
+ FROM ${q}artist${q}
+ WHERE ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q}
+ ",
+ [],
+ );
+
+ is_same_sql_bind (
+ \[ $sql_maker->update ('artist',
+ { 'artist.name' => { -ident => 'artist.pseudonym' } },
+ { 'artist.name' => { '!=' => { -ident => 'artist.pseudonym' } } },
+ ) ],
+ "UPDATE ${q}artist${q}
+ SET ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q}
+ WHERE ${q}artist${q}.${q}name${q} != ${q}artist${q}.${q}pseudonym${q}
+ ",
+ [],
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBIC::SqlMakerTest;
+
+use_ok('DBICTest');
+
+my $schema = DBICTest->init_schema();
+
+my $sql_maker = $schema->storage->sql_maker;
+
+for my $q ('', '"') {
+
+ $sql_maker->quote_char($q);
+
+ is_same_sql_bind (
+ \[ $sql_maker->select ('artist', '*', { arr1 => { -value => [1,2] }, arr2 => { '>', { -value => [3,4] } }, field => [5,6] } ) ],
+ "SELECT *
+ FROM ${q}artist${q}
+ WHERE ${q}arr1${q} = ? AND
+ ${q}arr2${q} > ? AND
+ ( ${q}field${q} = ? OR ${q}field${q} = ? )
+ ",
+ [
+ [ arr1 => [1,2] ],
+ [ arr2 => [3,4] ],
+ [ field => 5 ],
+ [ field => 6 ],
+ ],
+ );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ require DBIx::Class::Optional::Dependencies;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
+}
+
+use Test::Exception;
+use Data::Dumper::Concise;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+use DBIx::Class::SQLMaker::Oracle;
+
+#
+# Offline test for connect_by
+# ( without active database connection)
+#
+my @handle_tests = (
+ {
+ connect_by => { 'parentid' => { '-prior' => \'artistid' } },
+ stmt => '"parentid" = PRIOR artistid',
+ bind => [],
+ msg => 'Simple: "parentid" = PRIOR artistid',
+ },
+ {
+ connect_by => { 'parentid' => { '!=' => { '-prior' => { -ident => 'artistid' } } } },
+ stmt => '"parentid" != ( PRIOR "artistid" )',
+ bind => [],
+ msg => 'Simple: "parentid" != ( PRIOR "artistid" )',
+ },
+ # Examples from http://download.oracle.com/docs/cd/B19306_01/server.102/b14200/queries003.htm
+
+ # CONNECT BY last_name != 'King' AND PRIOR employee_id = manager_id ...
+ {
+ connect_by => [
+ last_name => { '!=' => 'King' },
+ manager_id => { '-prior' => { -ident => 'employee_id' } },
+ ],
+ stmt => '( "last_name" != ? OR "manager_id" = PRIOR "employee_id" )',
+ bind => ['King'],
+ msg => 'oracle.com example #1',
+ },
+ # CONNECT BY PRIOR employee_id = manager_id and
+ # PRIOR account_mgr_id = customer_id ...
+ {
+ connect_by => {
+ manager_id => { '-prior' => { -ident => 'employee_id' } },
+ customer_id => { '>', { '-prior' => \'account_mgr_id' } },
+ },
+ stmt => '( "customer_id" > ( PRIOR account_mgr_id ) AND "manager_id" = PRIOR "employee_id" )',
+ bind => [],
+ msg => 'oracle.com example #2',
+ },
+ # CONNECT BY NOCYCLE PRIOR employee_id = manager_id AND LEVEL <= 4;
+ # TODO: NOCYCLE parameter doesn't work
+);
+
+my $sqla_oracle = DBIx::Class::SQLMaker::Oracle->new( quote_char => '"', name_sep => '.' );
+isa_ok($sqla_oracle, 'DBIx::Class::SQLMaker::Oracle');
+
+
+for my $case (@handle_tests) {
+ my ( $stmt, @bind );
+ my $msg = sprintf("Offline: %s",
+ $case->{msg} || substr($case->{stmt},0,25),
+ );
+ lives_ok(
+ sub {
+ ( $stmt, @bind ) = $sqla_oracle->_recurse_where( $case->{connect_by} );
+ is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind},$msg )
+ || diag "Search term:\n" . Dumper $case->{connect_by};
+ }
+ ,sprintf("lives is ok from '%s'",$msg));
+}
+
+is (
+ $sqla_oracle->_shorten_identifier('short_id'),
+ 'short_id',
+ '_shorten_identifier for short id without keywords ok'
+);
+
+is (
+ $sqla_oracle->_shorten_identifier('short_id', [qw/ foo /]),
+ 'short_id',
+ '_shorten_identifier for short id with one keyword ok'
+);
+
+is (
+ $sqla_oracle->_shorten_identifier('short_id', [qw/ foo bar baz /]),
+ 'short_id',
+ '_shorten_identifier for short id with keywords ok'
+);
+
+is (
+ $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit'),
+ 'VryLngIdntfrWhchExc_72M8CIDTM7',
+ '_shorten_identifier without keywords ok',
+);
+
+is (
+ $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit',[qw/ foo /]),
+ 'Foo_72M8CIDTM7KBAUPXG48B22P4E',
+ '_shorten_identifier with one keyword ok',
+);
+is (
+ $sqla_oracle->_shorten_identifier('very_long_identifier_which_exceeds_the_30char_limit',[qw/ foo bar baz /]),
+ 'FooBarBaz_72M8CIDTM7KBAUPXG48B',
+ '_shorten_identifier with keywords ok',
+);
+
+# test SQL generation for INSERT ... RETURNING
+
+sub UREF { \do { my $x } };
+
+$sqla_oracle->{bindtype} = 'columns';
+
+for my $q ('', '"') {
+ local $sqla_oracle->{quote_char} = $q;
+
+ my ($sql, @bind) = $sqla_oracle->insert(
+ 'artist',
+ {
+ 'name' => 'Testartist',
+ },
+ {
+ 'returning' => 'artistid',
+ 'returning_container' => [],
+ },
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ "INSERT INTO ${q}artist${q} (${q}name${q}) VALUES (?) RETURNING ${q}artistid${q} INTO ?",
+ [ [ name => 'Testartist' ], [ artistid => UREF ] ],
+ 'sql_maker generates insert returning for one column'
+ );
+
+ ($sql, @bind) = $sqla_oracle->insert(
+ 'artist',
+ {
+ 'name' => 'Testartist',
+ },
+ {
+ 'returning' => \'artistid',
+ 'returning_container' => [],
+ },
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ "INSERT INTO ${q}artist${q} (${q}name${q}) VALUES (?) RETURNING artistid INTO ?",
+ [ [ name => 'Testartist' ], [ artistid => UREF ] ],
+ 'sql_maker generates insert returning for one column'
+ );
+
+
+ ($sql, @bind) = $sqla_oracle->insert(
+ 'computed_column_test',
+ {
+ 'a_timestamp' => '2010-05-26 18:22:00',
+ },
+ {
+ 'returning' => [ 'id', 'a_computed_column', 'charfield' ],
+ 'returning_container' => [],
+ },
+ );
+
+ is_same_sql_bind(
+ $sql, \@bind,
+ "INSERT INTO ${q}computed_column_test${q} (${q}a_timestamp${q}) VALUES (?) RETURNING ${q}id${q}, ${q}a_computed_column${q}, ${q}charfield${q} INTO ?, ?, ?",
+ [ [ a_timestamp => '2010-05-26 18:22:00' ], [ id => UREF ], [ a_computed_column => UREF ], [ charfield => UREF ] ],
+ 'sql_maker generates insert returning for multiple columns'
+ );
+}
+
+done_testing;
use warnings;
use Test::More;
-use DBIx::Class::SQLAHacks::OracleJoins;
+
+BEGIN {
+ require DBIx::Class::Optional::Dependencies;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('id_shortener')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('id_shortener');
+}
use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
+use DBICTest;
+use DBIx::Class::SQLMaker::OracleJoins;
use DBIC::SqlMakerTest;
-plan tests => 4;
-
-my $sa = new DBIx::Class::SQLAHacks::OracleJoins;
-
-$sa->limit_dialect('RowNum');
-
-is($sa->select('rubbish',
- [ 'foo.id', 'bar.id', \'TO_CHAR(foo.womble, "blah")' ],
- undef, undef, 1, 3),
- 'SELECT * FROM
-(
- SELECT A.*, ROWNUM r FROM
- (
- SELECT foo.id AS col1, bar.id AS col2, TO_CHAR(foo.womble, "blah") AS col3 FROM rubbish
- ) A
- WHERE ROWNUM < 5
-) B
-WHERE r >= 4
-', 'Munged stuff to make Oracle not explode');
-
-# test WhereJoins
-# search with undefined or empty $cond
+my $sa = DBIx::Class::SQLMaker::OracleJoins->new;
# my ($self, $table, $fields, $where, $order, @rest) = @_;
my ($sql, @bind) = $sa->select(
'WhereJoins search with or in where clause'
);
+done_testing;
use Test::More;
use Test::Exception;
+use Data::Dumper::Concise;
use lib qw(t/lib);
use DBICTest;
use DBIC::SqlMakerTest;
-my $schema = DBICTest->init_schema;
-
-my $rs = $schema->resultset('FourKeys');
-
sub test_order {
TODO: {
+ my $rs = shift;
my $args = shift;
local $TODO = "Not implemented" if $args->{todo};
{
order_by => $args->{order_by},
having =>
- [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', 8 ] ]
+ [ { read_count => { '>' => 5 } }, \[ 'read_count < ?', [ read_count => 8 ] ] ]
}
)->as_query,
"(
- SELECT me.foo, me.bar, me.hello, me.goodbye, me.sensors, me.read_count
- FROM fourkeys me
- WHERE ( foo = ? )
+ SELECT me.foo, me.bar, me.hello, me.goodbye, me.sensors, me.read_count
+ FROM fourkeys me
+ WHERE ( foo = ? )
HAVING read_count > ? OR read_count < ?
ORDER BY $args->{order_req}
)",
[
- [qw(foo bar)],
- [qw(read_count 5)],
- 8,
+ [ { sqlt_datatype => 'integer', dbic_colname => 'foo' }
+ => 'bar' ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'read_count' }
+ => 5 ],
+ [ { sqlt_datatype => 'int', dbic_colname => 'read_count' }
+ => 8 ],
$args->{bind}
- ? @{ $args->{bind} }
+ ? map { [ { dbic_colname => $_->[0] } => $_->[1] ] } @{ $args->{bind} }
: ()
],
- );
+ ) || diag Dumper $args->{order_by};
};
- fail('Fail the unfinished is_same_sql_bind') if $@;
}
}
bind => [],
},
{
- order_by => { -desc => \[ 'colA LIKE ?', 'test' ] },
+ order_by => { -desc => \[ 'colA LIKE ?', [ colA => 'test' ] ] },
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
+ bind => [ [ colA => 'test' ] ],
},
{
- order_by => \[ 'colA LIKE ? DESC', 'test' ],
+ order_by => \[ 'colA LIKE ? DESC', [ colA => 'test' ] ],
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
+ bind => [ [ colA => 'test' ] ],
},
{
order_by => [
{ -asc => \['colA'] },
- { -desc => \[ 'colB LIKE ?', 'test' ] },
- { -asc => \[ 'colC LIKE ?', 'tost' ] }
+ { -desc => \[ 'colB LIKE ?', [ colB => 'test' ] ] },
+ { -asc => \[ 'colC LIKE ?', [ colC => 'tost' ] ] },
],
order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
- bind => [qw(test tost)],
+ bind => [ [ colB => 'test' ], [ colC => 'tost' ] ],
},
-
- # (mo) this would be really really nice!
- # (ribasushi) I don't think so, not writing it - patches welcome
{
+ todo => 1,
order_by => [
{ -asc => 'colA' },
{ -desc => { colB => { 'LIKE' => 'test' } } },
{ -asc => { colC => { 'LIKE' => 'tost' } } }
],
order_req => 'colA ASC, colB LIKE ? DESC, colC LIKE ? ASC',
- bind => [ [ colB => 'test' ], [ colC => 'tost' ] ], # ???
- todo => 1,
+ bind => [ [ colB => 'test' ], [ colC => 'tost' ] ],
},
{
+ todo => 1,
order_by => { -desc => { colA => { LIKE => 'test' } } },
order_req => 'colA LIKE ? DESC',
- bind => [qw(test)],
- todo => 1,
+ bind => [ [ colA => 'test' ] ],
},
);
-plan( tests => scalar @tests * 2 );
-
-test_order($_) for @tests;
+my $rs = DBICTest->init_schema->resultset('FourKeys');
+test_order($rs, $_) for @tests;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema();
+
+my $rs = $schema->resultset('CD')->search({}, {
+ 'join' => 'tracks',
+ order_by => {
+ -desc => {
+ count => 'tracks.track_id',
+ },
+ },
+ distinct => 1,
+ rows => 2,
+ page => 1,
+});
+my $match = q{
+ SELECT me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track FROM cd me
+ GROUP BY me.cdid, me.artist, me.title, me.year, me.genreid, me.single_track
+ ORDER BY COUNT(tracks.trackid) DESC
+};
+
+TODO: {
+ todo_skip 'order_by using function', 2;
+ is_same_sql($rs->as_query, $match, 'order by with func query');
+
+ ok($rs->count == 2, 'amount of rows return in order by func query');
+}
+
+done_testing;
use_ok('DBIC::DebugObj');
my $schema = DBICTest->init_schema();
-#diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
-
$schema->storage->sql_maker->quote_char('`');
$schema->storage->sql_maker->name_sep('.');
my $schema = DBICTest->init_schema();
-#diag('Testing against ' . join(' ', map { $schema->storage->dbh->get_info($_) } qw/17 18/));
-
my $dsn = $schema->storage->_dbi_connect_info->[0];
$schema->connection(
$dsn,
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+my $schema = DBICTest->init_schema;
+
+is_same_sql_bind(
+ $schema->resultset('Artist')->search ({}, {for => 'update'})->as_query,
+ '(SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me)', [],
+);
+
+done_testing;
use Test::More;
use Test::Warn;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use Data::Dumper;
my $storage = $schema->storage;
$storage->ensure_connected;
-eval {
+throws_ok {
$schema->storage->throw_exception('test_exception_42');
-};
-like($@, qr/\btest_exception_42\b/, 'basic exception');
+} qr/\btest_exception_42\b/, 'basic exception';
-eval {
+throws_ok {
$schema->resultset('CD')->search_literal('broken +%$#$1')->all;
-};
-like($@, qr/prepare_cached failed/, 'exception via DBI->HandleError, etc');
+} qr/prepare_cached failed/, 'exception via DBI->HandleError, etc';
bless $storage, "DBICTest::ExplodingStorage";
$schema->storage($storage);
-eval {
+lives_ok {
$schema->resultset('Artist')->create({ name => "Exploding Sheep" });
-};
-
-is($@, "", "Exploding \$sth->execute was caught");
+} 'Exploding $sth->execute was caught';
is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count,
"And the STH was retired");
AutoCommit => 0,
},
],
+ warn => qr/\QYou provided explicit AutoCommit => 0 in your connection_info/,
},
'connect_info ([ \%attr_with_coderef ])' => {
args => [ {
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema(cursor_class => 'DBICTest::Cursor');
+
+lives_ok {
+ is($schema->resultset("Artist")->search(), 3, "Three artists returned");
+} 'Custom cursor autoloaded';
+
+SKIP: {
+ eval { require Class::Unload }
+ or skip 'component_class reentrancy test requires Class::Unload', 1;
+
+ Class::Unload->unload('DBICTest::Cursor');
+
+ lives_ok {
+ is($schema->resultset("Artist")->search(), 3, "Three artists still returned");
+ } 'Custom cursor auto re-loaded';
+}
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
-use warnings;
+use warnings;
-use Test::More tests => 8;
+use Test::More;
use lib qw(t/lib);
use DBICTest;
my $schema = DBICTest->init_schema();
my $storage = $schema->storage;
-my $test_func = sub {
- is $_[0], $storage;
- is $_[1], $storage->dbh;
- is $_[2], "foo";
- is $_[3], "bar";
-};
+my @args;
+my $test_func = sub { @args = @_ };
-$storage->dbh_do(
- $test_func,
- "foo", "bar"
+$storage->dbh_do($test_func, "foo", "bar");
+is_deeply (
+ \@args,
+ [ $storage, $storage->dbh, "foo", "bar" ],
);
+
my $storage_class = ref $storage;
{
- no strict 'refs';
- *{$storage_class .'::__test_method'} = $test_func;
+ no strict 'refs';
+ local *{$storage_class .'::__test_method'} = $test_func;
+ $storage->dbh_do("__test_method", "baz", "buz");
}
-$storage->dbh_do("__test_method", "foo", "bar");
-
\ No newline at end of file
+is_deeply (
+ \@args,
+ [ $storage, $storage->dbh, "baz", "buz" ],
+);
+
+# test aliasing
+my $res = 'original';
+$storage->dbh_do (sub { $_[2] = 'changed' }, $res);
+
+is ($res, 'changed', "Arguments properly aliased for dbh_do");
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
plan tests => 1;
-# Set up the "usual" sqlite for DBICTest
+# Set up the "usual" sqlite for DBICTest and disconnect
my $normal_schema = DBICTest->init_schema( sqlite_use_file => 1 );
+$normal_schema->storage->disconnect;
# Steal the dsn, which should be like 'dbi:SQLite:t/var/DBIxClass.db'
-my $normal_dsn = $normal_schema->storage->_dbi_connect_info->[0];
-
-# Make sure we have no active connection
-$normal_schema->storage->disconnect;
+my @dsn = ($normal_schema->storage->_dbi_connect_info->[0], undef, undef, {
+ RaiseError => 1
+});
# Make a new clone with a new connection, using a code reference
-my $code_ref_schema = $normal_schema->connect(sub { DBI->connect($normal_dsn); });
+my $code_ref_schema = $normal_schema->connect(sub { DBI->connect(@dsn); });
# Stolen from 60core.t - this just verifies things seem to work at all
my @art = $code_ref_schema->resultset("Artist")->search({ }, { order_by => 'name DESC'});
--- /dev/null
+use strict;
+use warnings;
+use lib qw(t/lib);
+use DBICTest;
+use Test::More;
+use Test::Exception;
+
+BEGIN { delete @ENV{qw(DBI_DSN DBI_DRIVER)} }
+
+$ENV{DBICTEST_LOCK_HOLDER} = -1;
+
+# pre-populate
+my $schema = DBICTest->init_schema(sqlite_use_file => 1);
+
+my $dbname = DBICTest->_sqlite_dbname(sqlite_use_file => 1);
+
+sub count_sheep {
+ my $schema = shift;
+ scalar $schema->resultset('Artist')->search( { name => "Exploding Sheep" } )
+ ->all;
+}
+
+$schema = DBICTest::Schema->connect("dbi::$dbname");
+throws_ok { count_sheep($schema) } qr{I can't work out what driver to use},
+ 'Driver in DSN empty';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+$schema = DBICTest::Schema->connect("dbi:Test_NonExistant_DBD:$dbname");
+throws_ok { count_sheep($schema) }
+ qr{Can't locate DBD/Test_NonExistant_DBD\.pm in \@INC},
+ "Driver class doesn't exist";
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+$ENV{DBI_DSN} = "dbi::$dbname";
+$schema = DBICTest::Schema->connect;
+throws_ok { count_sheep($schema) } qr{I can't work out what driver to use},
+ "Driver class not defined in DBI_DSN either.";
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+$ENV{DBI_DSN} = "dbi:Test_NonExistant_DBD2:$dbname";
+$schema = DBICTest::Schema->connect;
+throws_ok { count_sheep($schema) }
+ qr{Can't locate DBD/Test_NonExistant_DBD2\.pm in \@INC},
+ "Driver class defined in DBI_DSN doesn't exist";
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+$ENV{DBI_DSN} = "dbi::$dbname";
+$ENV{DBI_DRIVER} = 'Test_NonExistant_DBD3';
+$schema = DBICTest::Schema->connect;
+throws_ok { count_sheep($schema) }
+ qr{Can't locate DBD/Test_NonExistant_DBD3\.pm in \@INC},
+ "Driver class defined in DBI_DRIVER doesn't exist";
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+$ENV{DBI_DSN} = "dbi:Test_NonExistant_DBD4:$dbname";
+$schema = DBICTest::Schema->connect;
+throws_ok { count_sheep($schema) }
+qr{Can't locate DBD/Test_NonExistant_DBD4\.pm in \@INC},
+ "Driver class defined in DBI_DSN doesn't exist";
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI';
+
+delete @ENV{qw(DBI_DSN DBI_DRIVER)};
+
+$schema = DBICTest::Schema->connect("dbi:SQLite:$dbname");
+lives_ok { count_sheep($schema) } 'SQLite passed to connect_info';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite';
+
+$ENV{DBI_DRIVER} = 'SQLite';
+$schema = DBICTest::Schema->connect("dbi::$dbname");
+lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite';
+
+delete $ENV{DBI_DRIVER};
+$ENV{DBI_DSN} = "dbi:SQLite:$dbname";
+$schema = DBICTest::Schema->connect;
+lives_ok { count_sheep($schema) } 'SQLite in DBI_DSN';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite';
+
+$ENV{DBI_DRIVER} = 'SQLite';
+$schema = DBICTest::Schema->connect;
+lives_ok { count_sheep($schema) } 'SQLite in DBI_DSN (and DBI_DRIVER)';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite';
+
+$ENV{DBI_DSN} = "dbi::$dbname";
+$ENV{DBI_DRIVER} = 'SQLite';
+$schema = DBICTest::Schema->connect;
+lives_ok { count_sheep($schema) } 'SQLite in DBI_DRIVER (not DBI_DSN)';
+isa_ok $schema->storage, 'DBIx::Class::Storage::DBI::SQLite';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use lib qw(t/lib);
+use DBICTest;
+use Test::More;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_prettydebug')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_prettydebug');
+}
+
+BEGIN { delete @ENV{qw(DBIC_TRACE_PROFILE)} }
+
+{
+ my $schema = DBICTest->init_schema;
+
+ isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Statistics');
+}
+
+{
+ local $ENV{DBIC_TRACE_PROFILE} = 'console';
+
+ my $schema = DBICTest->init_schema;
+
+ isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Debug::PrettyPrint');;
+ is($schema->storage->debugobj->_sqlat->indent_string, ' ', 'indent string set correctly from console profile');
+}
+
+{
+ local $ENV{DBIC_TRACE_PROFILE} = './t/lib/awesome.json';
+
+ my $schema = DBICTest->init_schema;
+
+ isa_ok($schema->storage->debugobj, 'DBIx::Class::Storage::Debug::PrettyPrint');;
+ is($schema->storage->debugobj->_sqlat->indent_string, 'frioux', 'indent string set correctly from file-based profile');
+}
+
+done_testing;
use strict;
-use warnings;
+use warnings;
+no warnings 'once';
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
use DBIC::DebugObj;
use DBIC::SqlMakerTest;
use Path::Class qw/file/;
+BEGIN { delete @ENV{qw(DBIC_TRACE DBIC_TRACE_PROFILE DBICTEST_SQLITE_USE_FILE)} }
+
my $schema = DBICTest->init_schema();
+my $lfn = file("t/var/sql-$$.log");
+unlink $lfn or die $!
+ if -e $lfn;
-ok ( $schema->storage->debug(1), 'debug' );
-$schema->storage->debugfh(file('t/var/sql.log')->openw);
+# make sure we are testing the vanilla debugger and not ::PrettyPrint
+$schema->storage->debugobj(DBIx::Class::Storage::Statistics->new);
+ok ( $schema->storage->debug(1), 'debug' );
+$schema->storage->debugfh($lfn->openw);
$schema->storage->debugfh->autoflush(1);
-my $rs = $schema->resultset('CD')->search({});
-$rs->count();
+$schema->resultset('CD')->count;
-my $log = file('t/var/sql.log')->openr;
-my $line = <$log>;
-$log->close();
-ok($line =~ /^SELECT COUNT/, 'Log success');
+my @loglines = $lfn->slurp;
+is (@loglines, 1, 'one line of log');
+like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success');
$schema->storage->debugfh(undef);
-$ENV{'DBIC_TRACE'} = '=t/var/foo.log';
-$rs = $schema->resultset('CD')->search({});
-$rs->count();
-$log = file('t/var/foo.log')->openr;
-$line = <$log>;
-$log->close();
-ok($line =~ /^SELECT COUNT/, 'Log success');
-$schema->storage->debugobj->debugfh(undef);
-delete($ENV{'DBIC_TRACE'});
+
+{
+ local $ENV{DBIC_TRACE} = "=$lfn";
+ unlink $lfn;
+
+ $schema->resultset('CD')->count;
+
+ my $schema2 = DBICTest->init_schema(no_deploy => 1);
+ $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms
+
+ my @loglines = $lfn->slurp;
+ is(@loglines, 2, '2 lines of log');
+ like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success');
+ like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success');
+
+ $schema->storage->debugobj->debugfh(undef)
+}
+
+END {
+ unlink $lfn;
+}
+
open(STDERRCOPY, '>&STDERR');
-stat(STDERRCOPY); # nop to get warnings quiet
close(STDERR);
-eval {
- $rs = $schema->resultset('CD')->search({});
- $rs->count();
-};
-ok($@, 'Died on closed FH');
+dies_ok {
+ $schema->resultset('CD')->search({})->count;
+} 'Died on closed FH';
+
open(STDERR, '>&STDERRCOPY');
# test trace output correctness for bind params
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use lib qw(t/lib);
+use DBICTest;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all =>
+ 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
+}
+
+use File::Spec;
+use Path::Class qw/dir/;
+
+lives_ok( sub {
+ my $parse_schema = DBICTest->init_schema(no_deploy => 1);
+ $parse_schema->deploy({},'t/lib/test_deploy');
+ $parse_schema->resultset("Artist")->all();
+}, 'artist table deployed correctly' );
+
+my $schema = DBICTest->init_schema();
+
+my $var = dir ("t/var/ddl_dir-$$");
+$var->mkpath unless -d $var;
+
+my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' );
+$test_dir_1->rmtree if -d $test_dir_1;
+$schema->create_ddl_dir( undef, undef, $test_dir_1 );
+
+ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' );
+ok( scalar( glob $test_dir_1.'/*.sql' ), 'there are sql files in there' );
+
+TODO: {
+ local $TODO = 'we should probably add some tests here for actual deployability of the DDL?';
+ ok( 0 );
+}
+
+END {
+ $var->rmtree;
+}
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
# Set up the "usual" sqlite for DBICTest
my $schema = DBICTest->init_schema;
-my $sth_one = $schema->storage->sth('SELECT 42');
-my $sth_two = $schema->storage->sth('SELECT 42');
+my $sth_one = $schema->storage->_sth('SELECT 42');
+my $sth_two = $schema->storage->_sth('SELECT 42');
$schema->storage->disable_sth_caching(1);
-my $sth_three = $schema->storage->sth('SELECT 42');
+my $sth_three = $schema->storage->_sth('SELECT 42');
ok($sth_one == $sth_two, "statement caching works");
ok($sth_two != $sth_three, "disabling statement caching works");
my $schema = DBICTest->init_schema;
warnings_are ( sub {
- throws_ok (sub {
- $schema->resultset('CD')->create({ title => 'vacation in antarctica' });
- }, qr/NULL/); # as opposed to some other error
+ throws_ok (
+ sub {
+ $schema->resultset('CD')->create({ title => 'vacation in antarctica' })
+ },
+ qr/DBI Exception.+cd\.artist.+NULL/s
+ ); # as opposed to some other error
}, [], 'No warnings besides exception' );
+my $dbh = $schema->storage->dbh;
+
+throws_ok (
+ sub {
+ $dbh->do ('INSERT INTO nonexistent_table VALUES (1)')
+ },
+ qr/DBI Exception.+no such table.+nonexistent_table/s,
+ 'DBI exceptions properly handled by dbic-installed callback'
+);
+
+# This usage is a bit unusual but it was actually seen in the wild
+# destruction of everything except the $dbh should use the proper
+# exception fallback:
+
+SKIP: {
+ if (DBIx::Class::_ENV_::PEEPEENESS()) {
+ skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1;
+ }
+
+ undef ($schema);
+ throws_ok (
+ sub {
+ $dbh->do ('INSERT INTO nonexistent_table VALUES (1)')
+ },
+ qr/DBI Exception.+unhandled by DBIC.+no such table.+nonexistent_table/s,
+ 'callback works after $schema is gone'
+ );
+}
+
done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
sub _populate_dbh {
my $self = shift;
+
my $death = $self->_dbi_connect_info->[3]{die};
die "storage test died: $death" if $death eq 'before_populate';
}
for (qw/before_populate after_populate/) {
- dies_ok (sub {
+ throws_ok (sub {
my $schema = DBICTest::Schema->clone;
$schema->storage_type ('Dying::Storage');
$schema->connection (DBICTest->_database, { die => $_ });
$schema->storage->ensure_connected;
- }, "$_ exception found");
+ }, qr/$_/, "$_ exception found");
}
done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+use DBIx::Class::Optional::Dependencies ();
+
+use lib qw(t/lib);
+use DBICTest;
+
+plan skip_all => 'Test segfaults on Win32' if $^O eq 'MSWin32';
+
+for my $type (qw/PG MYSQL/) {
+
+ SKIP: {
+ skip "Skipping $type tests without DBICTEST_${type}_DSN", 1
+ unless $ENV{"DBICTEST_${type}_DSN"};
+
+ if ($type eq 'PG') {
+ skip "skipping Pg tests without dependencies installed", 1
+ unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_pg');
+ }
+ elsif ($type eq 'MYSQL') {
+ skip "skipping MySQL tests without dependencies installed", 1
+ unless DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_mysql');
+ }
+
+ my $schema = DBICTest::Schema->connect (@ENV{map { "DBICTEST_${type}_${_}" } qw/DSN USER PASS/});
+
+ # emulate a singleton-factory, just cache the object *somewhere in a different package*
+ # to induce out-of-order destruction
+ $DBICTest::FakeSchemaFactory::schema = $schema;
+
+ # so we can see the retry exceptions (if any)
+ $ENV{DBIC_DBIRETRY_DEBUG} = 1;
+
+ ok (!$schema->storage->connected, "$type: start disconnected");
+
+ lives_ok (sub {
+ $schema->txn_do (sub {
+
+ ok ($schema->storage->connected, "$type: transaction starts connected");
+
+ my $pid = fork();
+ SKIP: {
+ skip "Fork failed: $!", 1 if (! defined $pid);
+
+ if ($pid) {
+ note "Parent $$ sleeping...";
+ wait();
+ note "Parent $$ woken up after child $pid exit";
+ }
+ else {
+ note "Child $$ terminating";
+ undef $DBICTest::FakeSchemaFactory::schema;
+ exit 0;
+ }
+
+ ok ($schema->storage->connected, "$type: parent still connected (in txn_do)");
+ }
+ });
+ });
+
+ ok ($schema->storage->connected, "$type: parent still connected (outside of txn_do)");
+
+ undef $DBICTest::FakeSchemaFactory::schema;
+ }
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::DebugObj;
+use DBIC::SqlMakerTest;
+use DBI::Const::GetInfoType;
+
+{ # Fake storage driver for SQLite + no bind variables
+ package DBICTest::SQLite::NoBindVars;
+ use Class::C3;
+ use base qw/
+ DBIx::Class::Storage::DBI::NoBindVars
+ DBIx::Class::Storage::DBI::SQLite
+ /;
+}
+
+my $schema = DBICTest->init_schema (storage_type => 'DBICTest::SQLite::NoBindVars', no_populate => 1);
+
+# test primary key handling
+my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+ok($new->artistid, "Auto-PK worked");
+
+# test LIMIT support
+for (1..6) {
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+}
+my $it = $schema->resultset('Artist')->search( {},
+ { rows => 3,
+ offset => 2,
+ order_by => 'artistid' }
+);
+
+is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 7 artists
+
+my ($sql, @bind);
+my $orig_debugobj = $schema->storage->debugobj;
+my $orig_debug = $schema->storage->debug;
+$schema->storage->debugobj (DBIC::DebugObj->new (\$sql, \@bind) );
+$schema->storage->debug (1);
+
+is( $it->next->name, "Artist 2", "iterator->next ok" );
+$it->next;
+$it->next;
+is( $it->next, undef, "next past end of resultset ok" );
+
+$schema->storage->debugobj ($orig_debugobj);
+$schema->storage->debug ($orig_debug);
+
+is_same_sql_bind (
+ $sql,
+ \@bind,
+ 'SELECT me.artistid, me.name, me.rank, me.charfield FROM artist me ORDER BY artistid LIMIT 3 OFFSET 2',
+ [],
+ 'Correctly interpolated SQL'
+);
+
+done_testing;
# !!! do not replace this with done_testing - tests reside in the callbacks
# !!! number of calls is important
-use Test::More tests => 16;
+use Test::More tests => 17;
# !!!
+use Test::Warn;
my $schema = DBICTest::Schema->clone;
{
ok $schema->connection(
- sub { DBI->connect(DBICTest->_database) },
+ sub { DBI->connect(DBICTest->_database, undef, undef, { AutoCommit => 0 } ) },
{
# method list form
on_connect_call => [ sub { ok 1, "on_connect_call after DT parser" }, ],
ok (! $schema->storage->connected, 'start disconnected');
- $schema->storage->_determine_driver; # this should connect due to the coderef
+ # this should connect due to the coderef, and also warn due to the false autocommit above
+ warnings_exist {
+ $schema->storage->_determine_driver
+ } qr/The 'RaiseError' of the externally supplied DBI handle is set to false/, 'Warning on clobbered AutoCommit => 0 fired';
ok ($schema->storage->connected, 'determine driver connects');
$schema->storage->disconnect;
use strict;
use warnings;
-use Test::More tests => 12;
+# !!! do not replace this with done_testing - tests reside in the callbacks
+# !!! number of calls is important
+use Test::More tests => 13;
+# !!!
+use Test::Warn;
+use Test::Exception;
use lib qw(t/lib);
-use base 'DBICTest';
+use DBICTest;
require DBI;
$schema->storage->disconnect;
ok $schema->connection(
- sub { DBI->connect(DBICTest->_database) },
+ sub { DBI->connect(DBICTest->_database, undef, undef, { AutoCommit => 0 }) },
{
on_connect_do => [
'CREATE TABLE TEST_empty (id INTEGER)',
},
), 'connection()';
+warnings_exist {
+ $schema->storage->ensure_connected
+} qr/The 'RaiseError' of the externally supplied DBI handle is set to false/,
+'Warning on clobbered AutoCommit => 0 fired';
+
is_deeply (
$schema->storage->dbh->selectall_arrayref('SELECT * FROM TEST_empty'),
[ [ 2 ], [ 3 ], [ 7 ] ],
'on_connect_do() worked'
);
-eval { $schema->storage->dbh->do('SELECT 1 FROM TEST_nonexistent'); };
-ok $@, 'Searching for nonexistent table dies';
+dies_ok {
+ $schema->storage->dbh->do('SELECT 1 FROM TEST_nonexistent');
+} 'Searching for nonexistent table dies';
$schema->storage->disconnect();
ok $disconnected, 'on_disconnect_do() called after disconnect()';
isa_ok($cb_args[0], 'DBIx::Class::Storage', 'first arg to on_connect_do hook');
+@cb_args = ();
sub check_exists {
my $storage = shift;
sub check_dropped {
my $storage = shift;
- eval { $storage->dbh->do('SELECT 1 FROM TEST_empty'); };
- ok $@, 'Reading from dropped table fails';
+
+ dies_ok {
+ $storage->dbh->do('SELECT 1 FROM TEST_empty');
+ } 'Reading from dropped table fails';
return;
}
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use Data::Dumper::Concise;
+use Try::Tiny;
+use lib qw(t/lib);
+use DBICTest;
+
+my %expected = (
+ 'DBIx::Class::Storage::DBI' =>
+ # no default quote_char
+ { name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::MSSQL' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::DB2' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Informix' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::InterBase' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::mysql' =>
+ { quote_char => '`', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Pg' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::ODBC::ACCESS' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+
+# Not testing this one, it's a pain.
+# 'DBIx::Class::Storage::DBI::ODBC::DB2_400_SQL' =>
+# { quote_char => '"', name_sep => qr/must be connected/ },
+
+ 'DBIx::Class::Storage::DBI::Oracle::Generic' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::SQLAnywhere' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::SQLite' =>
+ { quote_char => '"', name_sep => '.' },
+
+ 'DBIx::Class::Storage::DBI::Sybase::ASE' =>
+ { quote_char => [ '[', ']' ], name_sep => '.' },
+);
+
+for my $class (keys %expected) { SKIP: {
+ eval "require ${class}"
+ or skip "Skipping test of quotes for $class due to missing dependencies", 1;
+
+ my $mapping = $expected{$class};
+ my ($quote_char, $name_sep) = @$mapping{qw/quote_char name_sep/};
+ my $instance = $class->new;
+
+ my $quote_char_text = dumper($quote_char);
+
+ if (exists $mapping->{quote_char}) {
+ is_deeply $instance->sql_quote_char, $quote_char,
+ "sql_quote_char for $class is $quote_char_text";
+ }
+
+ is $instance->sql_name_sep, $name_sep,
+ "sql_name_sep for $class is '$name_sep'";
+}}
+
+# Try quote_names with available DBs.
+
+# Env var to base class mapping, these are the DBs I actually have.
+# the SQLITE is a fake memory dsn
+local $ENV{DBICTEST_SQLITE_DSN} = 'dbi:SQLite::memory:';
+my %dbs = (
+ SQLITE => 'DBIx::Class::Storage::DBI::SQLite',
+ ORA => 'DBIx::Class::Storage::DBI::Oracle::Generic',
+ PG => 'DBIx::Class::Storage::DBI::Pg',
+ MYSQL => 'DBIx::Class::Storage::DBI::mysql',
+ DB2 => 'DBIx::Class::Storage::DBI::DB2',
+ SYBASE => 'DBIx::Class::Storage::DBI::Sybase::ASE',
+ SQLANYWHERE => 'DBIx::Class::Storage::DBI::SQLAnywhere',
+ SQLANYWHERE_ODBC => 'DBIx::Class::Storage::DBI::SQLAnywhere',
+ FIREBIRD => 'DBIx::Class::Storage::DBI::InterBase',
+ FIREBIRD_ODBC => 'DBIx::Class::Storage::DBI::InterBase',
+ INFORMIX => 'DBIx::Class::Storage::DBI::Informix',
+ MSSQL_ODBC => 'DBIx::Class::Storage::DBI::MSSQL',
+);
+
+# lie that we already locked stuff - the tests below do not touch anything
+$ENV{DBICTEST_LOCK_HOLDER} = -1;
+
+# Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
+# clashes with libssl, and will segfault everything coming after them
+for my $db (sort {
+ $a eq 'ORA' ? 1
+ : $b eq 'ORA' ? -1
+ : $a cmp $b
+} keys %dbs) {
+ my ($dsn, $user, $pass) = map $ENV{"DBICTEST_${db}_$_"}, qw/DSN USER PASS/;
+
+ next unless $dsn;
+
+ my $schema;
+
+ try {
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ quote_names => 1
+ });
+ $schema->storage->ensure_connected;
+ 1;
+ } || next;
+
+ my ($exp_quote_char, $exp_name_sep) =
+ @{$expected{$dbs{$db}}}{qw/quote_char name_sep/};
+
+ my ($quote_char_text, $name_sep_text) = map { dumper($_) }
+ ($exp_quote_char, $exp_name_sep);
+
+ is_deeply $schema->storage->sql_maker->quote_char,
+ $exp_quote_char,
+ "$db quote_char with quote_names => 1 is $quote_char_text";
+
+
+ is $schema->storage->sql_maker->name_sep,
+ $exp_name_sep,
+ "$db name_sep with quote_names => 1 is $name_sep_text";
+}
+
+done_testing;
+
+sub dumper {
+ my $val = shift;
+
+ my $dd = DumperObject;
+ $dd->Indent(0);
+ return $dd->Values([ $val ])->Dump;
+}
+
+1;
use strict;
-use warnings;
+use warnings;
use FindBin;
-use File::Copy;
+use File::Copy 'move';
use Test::More;
+use Test::Exception;
use lib qw(t/lib);
use DBICTest;
-plan tests => 6;
-
-my $db_orig = "$FindBin::Bin/../var/DBIxClass.db";
+my $db_orig = DBICTest->_sqlite_dbfilename;
my $db_tmp = "$db_orig.tmp";
# Set up the "usual" sqlite for DBICTest
### Now, disconnect the dbh, and move the db file;
# create a new one and chmod 000 to prevent SQLite from connecting.
$schema->storage->_dbh->disconnect;
-move( $db_orig, $db_tmp );
+move( $db_orig, $db_tmp )
+ or die "failed to move $db_orig to $db_tmp: $!";
open DBFILE, '>', $db_orig;
print DBFILE 'THIS IS NOT A REAL DATABASE';
close DBFILE;
{
# Catch the DBI connection error
local $SIG{__WARN__} = sub {};
- eval {
+ dies_ok {
my @art_three = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
- };
- ok( $@, 'The operation failed' );
+ } 'The operation failed';
}
+# otherwise can't unlink the fake db file
+$schema->storage->_dbh->disconnect if $^O eq 'MSWin32';
+
### Now, move the db file back to the correct name
-unlink($db_orig);
-move( $db_tmp, $db_orig );
-
-SKIP: {
- skip "Cannot reconnect if original connection didn't fail", 2
- if ( $@ =~ /encrypted or is not a database/ );
-
- ### Try the operation again... this time, it should succeed
- my @art_four;
- eval {
- @art_four = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
- };
- ok( !$@, 'The operation succeeded' );
- cmp_ok( @art_four, '==', 3, "Three artists returned" );
-}
+unlink($db_orig) or die "could not delete $db_orig: $!";
+move( $db_tmp, $db_orig )
+ or die "could not move $db_tmp to $db_orig: $!";
+
+### Try the operation again... this time, it should succeed
+my @art_four;
+lives_ok {
+ @art_four = $schema->resultset("Artist")->search( {}, { order_by => 'name DESC' } );
+} 'The operation succeeded';
+cmp_ok( @art_four, '==', 3, "Three artists returned" );
+
+# check that reconnection contexts are preserved in txn_do / dbh_do
+
+my $args = [1, 2, 3];
+
+my $ctx_map = {
+ VOID => {
+ invoke => sub { shift->(); 1 },
+ wa => undef,
+ },
+ SCALAR => {
+ invoke => sub { my $foo = shift->() },
+ wa => '',
+ },
+ LIST => {
+ invoke => sub { my @foo = shift->() },
+ wa => 1,
+ },
+};
+
+for my $ctx (keys %$ctx_map) {
+
+ # start disconnected and then connected
+ $schema->storage->disconnect;
+ for (1, 2) {
+ my $disarmed;
+
+ $ctx_map->{$ctx}{invoke}->(sub { $schema->txn_do(sub {
+ is_deeply (\@_, $args, 'Args propagated correctly' );
+
+ is (wantarray(), $ctx_map->{$ctx}{wa}, "Correct $ctx context");
+
+ # this will cause a retry
+ $schema->storage->_dbh->disconnect unless $disarmed++;
+
+ isa_ok ($schema->resultset('Artist')->next, 'DBICTest::Artist');
+ }, @$args) });
+ }
+};
+
+done_testing;
use strict;
use warnings;
-use lib qw(t/lib);
+
use Test::More;
-use Test::Exception;
+
+use lib qw(t/lib);
use DBICTest;
+
+BEGIN {
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated');
+}
+
+
+if (DBICTest::RunMode->is_smoker) {
+ my $mver = Moose->VERSION;
+ plan skip_all => "A trial version $mver of Moose detected known to break replication - skipping test known to fail"
+ if ($mver >= 1.99 and $mver <= 1.9902);
+}
+
+use Test::Moose;
+use Test::Exception;
use List::Util 'first';
use Scalar::Util 'reftype';
use File::Spec;
use IO::Handle;
+use Moose();
+use MooseX::Types();
+note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
-BEGIN {
- eval { require Test::Moose; Test::Moose->import() };
- plan skip_all => "Need Test::Moose to run this test" if $@;
- require DBIx::Class;
-
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('replicated')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
-}
+my $var_dir = quotemeta ( File::Spec->catdir(qw/t var/) );
use_ok 'DBIx::Class::Storage::DBI::Replicated::Pool';
use_ok 'DBIx::Class::Storage::DBI::Replicated::Balancer';
use_ok 'DBIx::Class::Storage::DBI::Replicated::Replicant';
use_ok 'DBIx::Class::Storage::DBI::Replicated';
-use Moose();
-use MooseX::Types();
-diag "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
=head1 HOW TO USE
balancer_type=>'::Random',
balancer_args=>{
auto_validate_every=>100,
- master_read_weight => 1
+ master_read_weight => 1
},
}
},
storage_type=> '::DBI::Replicated',
balancer_type=>'::Random',
balancer_args=> {
- auto_validate_every=>100,
- master_read_weight => 1
+ auto_validate_every=>100,
+ master_read_weight => 1
+ },
+ pool_args=>{
+ maximum_lag=>1,
},
deploy_args=>{
add_drop_table => 1,
## Silence warning about not supporting the is_replicating method if using the
## sqlite dbs.
$replicated->schema->storage->debugobj->silence(1)
- if first { m{^t/} } @replicant_names;
+ if first { $_ =~ /$var_dir/ } @replicant_names;
isa_ok $replicated->schema->storage->balancer->current_replicant
=> 'DBIx::Class::Storage::DBI';
## Silence warning about not supporting the is_replicating method if using the
## sqlite dbs.
$replicated->schema->storage->debugobj->silence(1)
- if first { m{^t/} } @replicant_names;
+ if first { $_ =~ /$var_dir/ } @replicant_names;
$replicated->schema->storage->pool->validate_replicants;
"got last query from a master: $debug{dsn}";
like $fallback_warning, qr/falling back to master/
- => 'emits falling back to master warning';
+ => 'emits falling back to master debug';
$replicated->schema->storage->debugfh($oldfh);
}
## Silence warning about not supporting the is_replicating method if using the
## sqlite dbs.
$replicated->schema->storage->debugobj->silence(1)
- if first { m{^t/} } @replicant_names;
+ if first { $_ =~ /$var_dir/ } @replicant_names;
$replicated->schema->storage->pool->validate_replicants;
$replicated->schema->storage->debugobj->silence(0);
-ok $replicated->schema->resultset('Artist')->find(2)
- => 'Returned to replicates';
+{
+ ## catch the fallback to master warning
+ open my $debugfh, '>', \my $return_warning;
+ my $oldfh = $replicated->schema->storage->debugfh;
+ $replicated->schema->storage->debugfh($debugfh);
+
+ ok $replicated->schema->resultset('Artist')->find(2)
+ => 'Return to replicants';
+
+ is $debug{storage_type}, 'REPLICANT',
+ "got last query from a replicant: $debug{dsn}";
+
+ like $return_warning, qr/Moved back to slave/
+ => 'emits returning to slave debug';
-is $debug{storage_type}, 'REPLICANT',
- "got last query from a replicant: $debug{dsn}";
+ $replicated->schema->storage->debugfh($oldfh);
+}
## Getting slave status tests
->schema
->populate('Artist', [
[ qw/artistid name/ ],
- [ $id, "Children of the Grave"],
+ [ $id, "Children of the Grave $id"],
]);
ok my $result = $replicated->schema->resultset('Artist')->find($id)
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+{
+ package DBICTest::Legacy::Storage;
+ use base 'DBIx::Class::Storage::DBI::SQLite';
+
+ use Data::Dumper::Concise;
+
+ sub source_bind_attributes { return {} }
+}
+
+
+my $schema = DBICTest::Schema->clone;
+$schema->storage_type('DBICTest::Legacy::Storage');
+$schema->connection('dbi:SQLite::memory:');
+
+$schema->storage->dbh_do( sub { $_[1]->do(<<'EOS') } );
+CREATE TABLE artist (
+ artistid INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100),
+ rank integer NOT NULL DEFAULT 13,
+ charfield char(10)
+)
+EOS
+
+my $legacy = sub { $schema->resultset('Artist')->search({ name => 'foo'})->next };
+if (DBIx::Class->VERSION >= 0.09) {
+ &throws_ok(
+ $legacy,
+ qr/XXXXXXXXX not sure what error to put here yet XXXXXXXXXXXXXXX/,
+ 'deprecated use of source_bind_attributes throws',
+ );
+}
+else {
+ &warnings_exist (
+ $legacy,
+ qr/\QThe source_bind_attributes() override in DBICTest::Legacy::Storage relies on a deprecated codepath/,
+ 'Warning issued during invocation of legacy storage codepath',
+ );
+}
+
+done_testing;
-#!/usr/bin/perl
-
use strict;
use warnings;
use Test::More;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my $code = sub {
+ my ($artist, @cd_titles) = @_;
+
+ $artist->create_related('cds', {
+ title => $_,
+ year => 2006,
+ }) foreach (@cd_titles);
+
+ return $artist->cds->all;
+};
+
+# Test checking of parameters
+{
+ my $schema = DBICTest->init_schema;
+
+ throws_ok (sub {
+ (ref $schema)->txn_do(sub{});
+ }, qr/storage/, "can't call txn_do without storage");
+
+ throws_ok ( sub {
+ $schema->txn_do('');
+ }, qr/must be a CODE reference/, '$coderef parameter check ok');
+}
+
+# Test successful txn_do() - scalar/list context
+for my $want (0,1) {
+ my $schema = DBICTest->init_schema;
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+
+ my @titles = map {'txn_do test CD ' . $_} (1..5);
+ my $artist = $schema->resultset('Artist')->find(1);
+ my $count_before = $artist->cds->count;
+
+ my @res;
+ if ($want) {
+ @res = $schema->txn_do($code, $artist, @titles);
+ is(scalar @res, $count_before+5, 'successful txn added 5 cds');
+ }
+ else {
+ $res[0] = $schema->txn_do($code, $artist, @titles);
+ is($res[0], $count_before+5, 'successful txn added 5 cds');
+ }
+
+ is($artist->cds({
+ title => "txn_do test CD $_",
+ })->first->year, 2006, "new CD $_ year correct") for (1..5);
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
+}
+
+# Test txn_do() @_ aliasing support
+{
+ my $schema = DBICTest->init_schema;
+
+ my $res = 'original';
+ $schema->storage->txn_do (sub { $_[0] = 'changed' }, $res);
+ is ($res, 'changed', "Arguments properly aliased for txn_do");
+}
+
+# Test nested successful txn_do()
+{
+ my $schema = DBICTest->init_schema;
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+
+ my $nested_code = sub {
+ my ($schema, $artist, $code) = @_;
+
+ my @titles1 = map {'nested txn_do test CD ' . $_} (1..5);
+ my @titles2 = map {'nested txn_do test CD ' . $_} (6..10);
+
+ $schema->txn_do($code, $artist, @titles1);
+ $schema->txn_do($code, $artist, @titles2);
+ };
+
+ my $artist = $schema->resultset('Artist')->find(2);
+ my $count_before = $artist->cds->count;
+
+ lives_ok (sub {
+ $schema->txn_do($nested_code, $schema, $artist, $code);
+ }, 'nested txn_do succeeded');
+
+ is($artist->cds({
+ title => 'nested txn_do test CD '.$_,
+ })->first->year, 2006, qq{nested txn_do CD$_ year ok}) for (1..10);
+ is($artist->cds->count, $count_before+10, 'nested txn_do added all CDs');
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth has been reset');
+}
+
+# test nested txn_begin on fresh connection
+{
+ my $schema = DBICTest->init_schema(sqlite_use_file => 1, no_deploy => 1);
+ $schema->storage->ensure_connected;
+
+ is ($schema->storage->transaction_depth, 0, 'Start outside txn');
+
+ my @pids;
+ for my $action (
+ sub {
+ my $s = shift;
+ die "$$ starts in txn!" if $s->storage->transaction_depth != 0;
+ $s->txn_do ( sub {
+ die "$$ not in txn!" if $s->storage->transaction_depth == 0;
+ $s->storage->dbh->do('SELECT 1') }
+ );
+ die "$$ did not finish txn!" if $s->storage->transaction_depth != 0;
+ },
+ sub {
+ $_[0]->txn_begin;
+ $_[0]->storage->dbh->do('SELECT 1');
+ $_[0]->txn_commit
+ },
+ sub {
+ my $guard = $_[0]->txn_scope_guard;
+ $_[0]->storage->dbh->do('SELECT 1');
+ $guard->commit
+ },
+ ) {
+ my $pid = fork();
+ die "Unable to fork: $!\n"
+ if ! defined $pid;
+
+ if ($pid) {
+ push @pids, $pid;
+ next;
+ }
+
+ $action->($schema);
+ exit 0;
+ }
+
+ is ($schema->storage->transaction_depth, 0, 'Parent still outside txn');
+
+ for my $pid (@pids) {
+ waitpid ($pid, 0);
+ ok (! $?, "Child $pid exit ok");
+ }
+}
+
+# Test txn_do/scope_guard with forking: outer txn_do
+{
+ my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
+
+ for my $pass (1..2) {
+
+ # do something trying to destabilize the depth count
+ for (1..2) {
+ eval {
+ my $guard = $schema->txn_scope_guard;
+ $schema->txn_do( sub { die } );
+ };
+ is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
+ $schema->txn_do( sub {
+ ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
+ });
+ }
+
+ $schema->txn_do ( sub { _test_forking_action ($schema, $pass) } );
+ }
+}
+
+# same test with outer guard
+{
+ my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
+
+ for my $pass (1..2) {
+
+ # do something trying to destabilize the depth count
+ for (1..2) {
+ eval {
+ my $guard = $schema->txn_scope_guard;
+ $schema->txn_do( sub { die } );
+ };
+ is( $schema->storage->transaction_depth, 0, 'Transaction successfully aborted' );
+ $schema->txn_do( sub {
+ ok ($schema->storage->_dbh->do ('SELECT 1'), "Query after exceptions ok ($_)");
+ });
+ }
+
+ my $guard = $schema->txn_scope_guard;
+ my @pids = _test_forking_action ($schema, $pass);
+ $guard->commit;
+ }
+}
+
+sub _test_forking_action {
+ my ($schema, $pass) = @_;
+
+ my @pids;
+
+ SKIP: for my $count (1 .. 5) {
+
+ skip 'Weird DBI General Protection Faults, skip forking tests (RT#63104)', 5
+ if $^O eq 'MSWin32';
+
+ my $pid = fork();
+ die "Unable to fork: $!\n"
+ if ! defined $pid;
+
+ if ($pid) {
+ push @pids, $pid;
+ next;
+ }
+
+ if ($count % 2) {
+ $schema->txn_do (sub {
+ my $depth = $schema->storage->transaction_depth;
+ die "$$(txn_do)unexpected txn depth $depth!" if $depth != 1;
+ $schema->resultset ('Artist')->create ({ name => "forking action $$"});
+ });
+ }
+ else {
+ my $guard = $schema->txn_scope_guard;
+ my $depth = $schema->storage->transaction_depth;
+ die "$$(scope_guard) unexpected txn depth $depth!" if $depth != 1;
+ $schema->resultset ('Artist')->create ({ name => "forking action $$"});
+ $guard->commit;
+ }
+
+ exit 0;
+ }
+
+ for my $pid (@pids) {
+ waitpid ($pid, 0);
+ ok (! $?, "Child $pid exit ok (pass $pass)");
+ }
+
+ # it is important to reap all children before checking the final db-state
+ # otherwise a deadlock may occur between the transactions running in the
+ # children and the query of the parent
+ for my $pid (@pids) {
+ isa_ok ($schema->resultset ('Artist')->find ({ name => "forking action $pid" }), 'DBIx::Class::Row');
+ }
+}
+
+my $fail_code = sub {
+ my ($artist) = @_;
+ $artist->create_related('cds', {
+ title => 'this should not exist',
+ year => 2005,
+ });
+ die "the sky is falling";
+};
+
+{
+ my $schema = DBICTest->init_schema;
+
+ # Test failed txn_do()
+ for my $pass (1,2) {
+
+ is( $schema->storage->{transaction_depth}, 0, "txn depth starts at 0 (pass $pass)");
+
+ my $artist = $schema->resultset('Artist')->find(3);
+
+ throws_ok (sub {
+ $schema->txn_do($fail_code, $artist);
+ }, qr/the sky is falling/, "failed txn_do threw an exception (pass $pass)");
+
+ my $cd = $artist->cds({
+ title => 'this should not exist',
+ year => 2005,
+ })->first;
+ ok(!defined($cd), qq{failed txn_do didn't change the cds table (pass $pass)});
+
+ is( $schema->storage->{transaction_depth}, 0, "txn depth has been reset (pass $pass)");
+ }
+
+
+ # Test failed txn_do() with failed rollback
+ {
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+
+ my $artist = $schema->resultset('Artist')->find(3);
+
+ # Force txn_rollback() to throw an exception
+ no warnings qw/once redefine/;
+
+ # this should logically work just fine - but it does not,
+ # only direct override of the existing method dtrt
+ #local *DBIx::Class::Storage::DBI::SQLite::txn_rollback = sub { die 'FAILED' };
+
+ local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'FAILED' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
+ throws_ok (
+ sub {
+ $schema->txn_do($fail_code, $artist);
+ },
+ qr/the sky is falling.+Rollback failed/s,
+ 'txn_rollback threw a rollback exception (and included the original exception'
+ );
+
+ my $cd = $artist->cds({
+ title => 'this should not exist',
+ year => 2005,
+ })->first;
+ isa_ok($cd, 'DBICTest::CD', q{failed txn_do with a failed txn_rollback }.
+ q{changed the cds table});
+ $cd->delete; # Rollback failed
+ $cd = $artist->cds({
+ title => 'this should not exist',
+ year => 2005,
+ })->first;
+ ok(!defined($cd), q{deleted the failed txn's cd});
+ $schema->storage->_dbh->rollback;
+ }
+}
+
+# Test nested failed txn_do()
+{
+ my $schema = DBICTest->init_schema();
+
+ is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
+
+ my $nested_fail_code = sub {
+ my ($schema, $artist, $code1, $code2) = @_;
+
+ my @titles = map {'nested txn_do test CD ' . $_} (1..5);
+
+ $schema->txn_do($code1, $artist, @titles); # successful txn
+ $schema->txn_do($code2, $artist); # failed txn
+ };
+
+ my $artist = $schema->resultset('Artist')->find(3);
+
+ throws_ok ( sub {
+ $schema->txn_do($nested_fail_code, $schema, $artist, $code, $fail_code);
+ }, qr/the sky is falling/, 'nested failed txn_do threw exception');
+
+ ok(!defined($artist->cds({
+ title => 'nested txn_do test CD '.$_,
+ year => 2006,
+ })->first), qq{failed txn_do didn't add first txn's cd $_}) for (1..5);
+ my $cd = $artist->cds({
+ title => 'this should not exist',
+ year => 2005,
+ })->first;
+ ok(!defined($cd), q{failed txn_do didn't add failed txn's cd});
+}
+
+
+# Grab a new schema to test txn before connect
+# also test nested txn exception
+{
+ my $schema = DBICTest->init_schema(no_deploy => 1);
+ lives_ok (sub {
+ $schema->txn_begin();
+ $schema->txn_begin();
+ }, 'Pre-connection nested transactions.');
+
+ throws_ok( sub { $schema->txn_rollback }, 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION', 'got proper nested rollback exception' );
+}
+
+# make sure AutoCommit => 0 on external handles behaves correctly with scope_guard
+warnings_are {
+ my $factory = DBICTest->init_schema;
+ cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
+ my $dbh = $factory->storage->dbh;
+ $dbh->{AutoCommit} = 0;
+
+ ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
+ my $schema = DBICTest::Schema->connect (sub { $dbh });
+
+ lives_ok ( sub {
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('CD')->delete;
+ $guard->commit;
+ }, 'No attempt to start a transaction with scope guard');
+
+ is ($schema->resultset('CD')->count, 0, 'Deletion successful in txn');
+
+ # this will commit the implicitly started txn
+ $dbh->commit;
+
+} [], 'No warnings on AutoCommit => 0 with txn_guard';
+
+# make sure AutoCommit => 0 on external handles behaves correctly with txn_do
+warnings_are {
+ my $factory = DBICTest->init_schema;
+ cmp_ok ($factory->resultset('CD')->count, '>', 0, 'Something to delete');
+ my $dbh = $factory->storage->dbh;
+ $dbh->{AutoCommit} = 0;
+
+ ok (!$dbh->{AutoCommit}, 'AutoCommit is off on $dbh');
+ my $schema = DBICTest::Schema->connect (sub { $dbh });
+
+ lives_ok ( sub {
+ $schema->txn_do (sub { $schema->resultset ('CD')->delete });
+ }, 'No attempt to start a atransaction with txn_do');
+
+ is ($schema->resultset('CD')->count, 0, 'Deletion successful');
+
+ # this will commit the implicitly started txn
+ $dbh->commit;
+
+} [], 'No warnings on AutoCommit => 0 with txn_do';
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Warn;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+# Test txn_scope_guard
+{
+ my $schema = DBICTest->init_schema();
+
+ is($schema->storage->transaction_depth, 0, "Correct transaction depth");
+ my $artist_rs = $schema->resultset('Artist');
+
+ my $fn = __FILE__;
+ throws_ok {
+ my $guard = $schema->txn_scope_guard;
+
+ $artist_rs->create({
+ name => 'Death Cab for Cutie',
+ made_up_column => 1,
+ });
+
+ $guard->commit;
+ } qr/No such column made_up_column .*? at .*?\Q$fn\E line \d+/s, "Error propogated okay";
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ my $inner_exception = ''; # set in inner() below
+ throws_ok (sub {
+ outer($schema, 1);
+ }, qr/$inner_exception/, "Nested exceptions propogated");
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ lives_ok (sub {
+
+ # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s
+ my $s = $schema;
+
+ warnings_exist ( sub {
+ # The 0 arg says don't die, just let the scope guard go out of scope
+ # forcing a txn_rollback to happen
+ outer($s, 0);
+ }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');
+
+ ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
+ }, 'rollback successful withot exception');
+
+ sub outer {
+ my ($schema, $fatal) = @_;
+
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset('Artist')->create({
+ name => 'Death Cab for Cutie',
+ });
+ inner($schema, $fatal);
+ }
+
+ sub inner {
+ my ($schema, $fatal) = @_;
+
+ my $inner_guard = $schema->txn_scope_guard;
+ is($schema->storage->transaction_depth, 2, "Correct transaction depth");
+
+ my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' });
+
+ eval {
+ $artist->cds->create({
+ title => 'Plans',
+ year => 2005,
+ $fatal ? ( foo => 'bar' ) : ()
+ });
+ };
+ if ($@) {
+ # Record what got thrown so we can test it propgates out properly.
+ $inner_exception = $@;
+ die $@;
+ }
+
+ # inner guard should commit without consequences
+ $inner_guard->commit;
+ }
+}
+
+# make sure the guard does not eat exceptions
+{
+ my $schema = DBICTest->init_schema;
+
+ no strict 'refs';
+ no warnings 'redefine';
+
+ local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
+ throws_ok (sub {
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
+
+ # this should freak out the guard rollback
+ # but it won't work because DBD::SQLite is buggy
+ # instead just install a toxic rollback above
+ #$schema->storage->_dbh( $schema->storage->_dbh->clone );
+
+ die 'Deliberate exception';
+ }, ($] >= 5.013008 )
+ ? qr/Deliberate exception/s # temporary until we get the generic exception wrapper rolling
+ : qr/Deliberate exception.+Rollback failed/s
+ );
+
+ # just to mask off warning since we could not disconnect above
+ $schema->storage->_dbh->disconnect;
+}
+
+# make sure it warns *big* on failed rollbacks
+# test with and without a poisoned $@
+for my $poison (0,1) {
+
+ my $schema = DBICTest->init_schema();
+
+ no strict 'refs';
+ no warnings 'redefine';
+ local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
+#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
+=begin
+ warnings_exist (
+ sub {
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
+
+ # this should freak out the guard rollback
+ # but it won't work because DBD::SQLite is buggy
+ # instead just install a toxic rollback above
+ #$schema->storage->_dbh( $schema->storage->_dbh->clone );
+ },
+ [
+ qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
+ qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
+ ],
+ 'proper warnings generated on out-of-scope+rollback failure'
+ );
+=cut
+
+# delete this once the above works properly (same test)
+ my @want = (
+ qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
+ qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
+ );
+
+ my @w;
+ local $SIG{__WARN__} = sub {
+ if (grep {$_[0] =~ $_} (@want)) {
+ push @w, $_[0];
+ }
+ else {
+ warn $_[0];
+ }
+ };
+ {
+ eval { die 'GIFT!' if $poison };
+ my $guard = $schema->txn_scope_guard;
+ $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
+ }
+
+ is (@w, 2, 'Both expected warnings found' . ($poison ? ' (after $@ poisoning)' : '') );
+
+ # just to mask off warning since we could not disconnect above
+ $schema->storage->_dbh->disconnect;
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $new_artist = $schema->resultset('Artist')->create({ name => 'new kid behind the block' });
+
+# see how many cds do we have, and relink them all to the new guy
+my $cds = $schema->resultset('CD');
+my $cds_count = $cds->count;
+cmp_ok($cds_count, '>', 0, 'have some cds');
+
+$cds->update_all({ artist => $new_artist });
+
+is( $new_artist->cds->count, $cds_count, 'All cds properly relinked');
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+my $schema = DBICTest->init_schema();
+
+my $artist = $schema->resultset('Artist')->next;
+
+is_deeply(
+ [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ],
+ [ 1, { artistid => 1 }, { artistid => 1 } ],
+ 'Correct identity state of freshly retrieved object',
+);
+
+$artist->artistid(888);
+
+is_deeply(
+ [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ],
+ [ 888, { artistid => 888 }, { artistid => 1 } ],
+ 'Correct identity state of object with modified PK',
+);
+
+$artist->update;
+
+is_deeply(
+ [ $artist->id, $artist->ident_condition, $artist->_storage_ident_condition ],
+ [ 888, { artistid => 888 }, { artistid => 888 } ],
+ 'Correct identity state after storage update',
+);
+
+done_testing;
use strict;
-use warnings;
+use warnings;
use Test::More;
use lib qw(t/lib);
use Test::More;
use Benchmark;
use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
+use DBICTest ':GlobalLock';
# This is a rather unusual test.
# It does not test any aspect of DBIx::Class, but instead tests the
'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set'
if ( $ENV{DBIC_NO_WARN_BAD_PERL} );
-plan skip_all => 'Skipping as AUTOMATED_TESTING is set'
- if ( $ENV{AUTOMATED_TESTING} );
+plan skip_all => 'Skipping as system appears to be a smoker'
+ if DBICTest::RunMode->is_smoker;
plan tests => 3;
use warnings;
use Test::More;
-use Test::Exception;
+
use lib 't/lib';
+use DBICTest::RunMode;
-use File::Temp ();
+if ( DBICTest::RunMode->is_plain ) {
+ plan( skip_all => "Skipping test on plain module install" );
+}
+
+use Test::Exception;
use DBICTest;
-use DBICTest::Schema;
+use File::Temp ();
plan tests => 2;
-my $wait_for = 30; # how many seconds to wait
+my $wait_for = 120; # how many seconds to wait
+
+# don't lock anything - this is a tempfile anyway
+$ENV{DBICTEST_LOCK_HOLDER} = -1;
for my $close (0,1) {
my $tmp = File::Temp->new(
UNLINK => 1,
- TMPDIR => 1,
- SUFFIX => '.sqlite',
+ DIR => 't/var',
+ SUFFIX => '.db',
+ TEMPLATE => 'DBIxClass-XXXXXX',
EXLOCK => 0, # important for BSD and derivatives
);
lives_ok (sub {
my $schema = DBICTest::Schema->connect ("DBI:SQLite:$tmp_fn");
+ $schema->storage->dbh_do(sub { $_[1]->do('PRAGMA synchronous = OFF') });
DBICTest->deploy_schema ($schema);
- #DBICTest->populate_schema ($schema);
+ DBICTest->populate_schema ($schema);
});
alarm 0;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+# Once upon a time there was a problem with a leaking $sth
+# which in turn delayed the $dbh destruction, which in turn
+# made the inode comaprison fire at the wrong time
+# This simulates the problem without doing much else
+for (1..2) {
+ my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
+ $schema->storage->ensure_connected;
+ isa_ok ($schema, 'DBICTest::Schema');
+}
+
+done_testing;
+
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+require DBIx::Class;
+unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_eol') ) {
+ my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_eol');
+ $ENV{RELEASE_TESTING}
+ ? die ("Failed to load release-testing module requirements: $missing")
+ : plan skip_all => "Test needs: $missing"
+}
+
+Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 },
+ qw/t xt lib script examples/,
+ DBICTest::RunMode->is_author ? ('maint') : (),
+);
+
+# Changes is not a "perl file", hence checked separately
+Test::EOL::eol_unix_ok('Changes', { trailing_whitespace => 1 });
+
+# FIXME - Test::EOL declares 'no_plan' which conflicts with done_testing
+# https://github.com/schwern/test-more/issues/14
+#done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib 't/lib';
+use DBICTest;
+
+require DBIx::Class;
+unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_notabs') ) {
+ my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_notabs');
+ $ENV{RELEASE_TESTING}
+ ? die ("Failed to load release-testing module requirements: $missing")
+ : plan skip_all => "Test needs: $missing"
+}
+
+Test::NoTabs::all_perl_files_ok(
+ qw/t xt lib script examples/,
+ DBICTest::RunMode->is_author ? ('maint') : (),
+);
+
+# Changes is not a "perl file", hence checked separately
+Test::NoTabs::notabs_ok('Changes');
+
+# FIXME - Test::NoTabs declares 'no_plan' which conflicts with done_testing
+# https://github.com/schwern/test-more/issues/14
+#done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+
+my @defined = grep { $ENV{$_} } qw/
+ DATA_DUMPER_TEST
+ DBICTEST_STORAGE_STRESS
+ DBICTEST_FORK_STRESS
+ DBICTEST_THREAD_STRESS
+/;
+
+$SIG{ALRM} = sub { die "\n\nENVCHECK prompt timeout\n\n\n" };
+if (@defined) {
+ diag join "\n",
+ 'The following ENV variables used to control the test suite, '
+ .'but no longer do so, please remove them from your environment',
+ @defined,
+ '',
+ '(press Enter to continue)',
+ ;
+ alarm(10);
+ <>;
+ alarm(0);
+}
+ok(1);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+no warnings qw/once/;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use Scalar::Util; # load before we break require()
+use Carp (); # Carp is not used in the test, but we want to have it loaded for proper %INC comparison
+
+# a dummy test which lazy-loads more modules (so we can compare INC below)
+ok (1);
+
+# record contents of %INC - makes sure there are no extra deps slipping into
+# Opt::Dep.
+my $inc_before = [ keys %INC ];
+ok ( (! grep { $_ =~ m|DBIx/Class| } @$inc_before ), 'Nothing DBIC related is yet loaded');
+
+# DBIx::Class::Optional::Dependencies queries $ENV at compile time
+# to build the optional requirements
+BEGIN {
+ $ENV{DBICTEST_PG_DSN} = '1';
+ delete $ENV{DBICTEST_ORA_DSN};
+}
+
+use_ok 'DBIx::Class::Optional::Dependencies';
+
+my $inc_after = [ keys %INC ];
+
+is_deeply (
+ [ sort @$inc_after],
+ [ sort (@$inc_before, 'DBIx/Class/Optional/Dependencies.pm') ],
+ 'Nothing loaded other than DBIx::Class::OptDeps',
+);
+
+my $sqlt_dep = DBIx::Class::Optional::Dependencies->req_list_for ('deploy');
+is_deeply (
+ [ keys %$sqlt_dep ],
+ [ 'SQL::Translator' ],
+ 'Correct deploy() dependency list',
+);
+
+# make module loading impossible, regardless of actual libpath contents
+{
+ local @INC = (sub { die('Optional Dep Test') } );
+
+ ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps missing',
+ );
+
+ like (
+ DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
+ qr/^SQL::Translator \>\= \d/,
+ 'expected missing string contents',
+ );
+
+ like (
+ DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy')->{'SQL::Translator'},
+ qr/Optional Dep Test/,
+ 'custom exception found in errorlist',
+ );
+}
+
+#make it so module appears loaded
+$INC{'SQL/Translator.pm'} = 1;
+$SQL::Translator::VERSION = 999;
+
+ok (
+ ! DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps missing cached properly',
+);
+
+#reset cache
+%DBIx::Class::Optional::Dependencies::req_availability_cache = ();
+
+
+ok (
+ DBIx::Class::Optional::Dependencies->req_ok_for ('deploy'),
+ 'deploy() deps present',
+);
+
+is (
+ DBIx::Class::Optional::Dependencies->req_missing_for ('deploy'),
+ '',
+ 'expected null missing string',
+);
+
+is_deeply (
+ DBIx::Class::Optional::Dependencies->req_errorlist_for ('deploy'),
+ {},
+ 'expected empty errorlist',
+);
+
+# test multiple times to find autovivification bugs
+for (1..2) {
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->req_list_for();
+ } qr/\Qreq_list_for() expects a requirement group name/,
+ "req_list_for without groupname throws exception on run $_";
+
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->req_list_for('');
+ } qr/\Qreq_list_for() expects a requirement group name/,
+ "req_list_for with empty groupname throws exception on run $_";
+
+ throws_ok {
+ DBIx::Class::Optional::Dependencies->req_list_for('invalid_groupname');
+ } qr/Requirement group 'invalid_groupname' does not exist/,
+ "req_list_for with invalid groupname throws exception on run $_";
+}
+
+is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for('rdbms_pg'),
+ {
+ 'DBD::Pg' => '0',
+ }, 'optional dependencies for deploying to Postgres ok');
+
+is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_pg'),
+ {
+ 'Sys::SigAction' => '0',
+ 'DBD::Pg' => '2.009002',
+ }, 'optional dependencies for testing Postgres with ENV var ok');
+
+is_deeply(
+ DBIx::Class::Optional::Dependencies->req_list_for('test_rdbms_oracle'),
+ {}, 'optional dependencies for testing Oracle without ENV var ok');
+
+done_testing;
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
+require DBIx::Class;
+unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) {
+ my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_pod');
+ $ENV{RELEASE_TESTING}
+ ? die ("Failed to load release-testing module requirements: $missing")
+ : plan skip_all => "Test needs: $missing"
+}
+
+Test::Pod::all_pod_files_ok();
use strict;
use Test::More;
-use List::Util ();
+use List::Util 'first';
use lib qw(t/lib);
use DBICTest;
-
-# Don't run tests for installs
-unless ( DBICTest::AuthorCheck->is_author || $ENV{AUTOMATED_TESTING} || $ENV{RELEASE_TESTING} ) {
- plan( skip_all => "Author tests not required for installation" );
-}
+use namespace::clean;
require DBIx::Class;
unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_podcoverage') ) {
my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_podcoverage');
- $ENV{RELEASE_TESTING} || DBICTest::AuthorCheck->is_author
+ $ENV{RELEASE_TESTING}
? die ("Failed to load release-testing module requirements: $missing")
: plan skip_all => "Test needs: $missing"
}
# of what this is doing might be in order.
# The exceptions structure below is a hash keyed by the module
# name. Any * in a name is treated like a wildcard and will behave
-# as expected. Modules are matched by longest string first, so
+# as expected. Modules are matched by longest string first, so
# A::B::C will match even if there is A::B*
# The value for each is a hash, which contains one or more
mk_classaccessor
/]
},
+ 'DBIx::Class::Carp' => {
+ ignore => [qw/
+ unimport
+ /]
+ },
'DBIx::Class::Row' => {
ignore => [qw/
MULTICREATE_DEBUG
/],
},
+ 'DBIx::Class::Storage::TxnScopeGuard' => {
+ ignore => [qw/
+ IS_BROKEN_PERL
+ /],
+ },
+ 'DBIx::Class::FilterColumn' => {
+ ignore => [qw/
+ new
+ update
+ store_column
+ get_column
+ get_columns
+ /],
+ },
'DBIx::Class::ResultSource' => {
ignore => [qw/
compare_relationship_keys
resolve_condition
resolve_join
resolve_prefetch
+ STORABLE_freeze
+ STORABLE_thaw
+ /],
+ },
+ 'DBIx::Class::ResultSet' => {
+ ignore => [qw/
+ STORABLE_freeze
+ STORABLE_thaw
/],
},
'DBIx::Class::ResultSourceHandle' => {
/]
},
+ 'DBIx::Class::Admin' => {
+ ignore => [ qw/
+ BUILD
+ /]
+ },
+
'DBIx::Class::Storage::DBI::Replicated*' => {
ignore => [ qw/
connect_call_do_sql
'DBIx::Class::Admin::*' => { skip => 1 },
'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 },
'DBIx::Class::Componentised' => { skip => 1 },
+ 'DBIx::Class::AccessorGroup' => { skip => 1 },
'DBIx::Class::Relationship::*' => { skip => 1 },
'DBIx::Class::ResultSetProxy' => { skip => 1 },
'DBIx::Class::ResultSourceProxy' => { skip => 1 },
+ 'DBIx::Class::ResultSource::*' => { skip => 1 },
'DBIx::Class::Storage::Statistics' => { skip => 1 },
'DBIx::Class::Storage::DBI::Replicated::Types' => { skip => 1 },
+ 'DBIx::Class::GlobalDestruction' => { skip => 1 },
+ 'DBIx::Class::Storage::BlockRunner' => { skip => 1 }, # temporary
# test some specific components whose parents are exempt below
'DBIx::Class::Relationship::Base' => {},
+ 'DBIx::Class::SQLMaker::LimitDialects' => {},
# internals
+ 'DBIx::Class::SQLMaker*' => { skip => 1 },
'DBIx::Class::SQLAHacks*' => { skip => 1 },
'DBIx::Class::Storage::DBI*' => { skip => 1 },
'SQL::Translator::*' => { skip => 1 },
# deprecated / backcompat stuff
+ 'DBIx::Class::Serialize::Storable' => { skip => 1 },
'DBIx::Class::CDBICompat*' => { skip => 1 },
'DBIx::Class::ResultSetManager' => { skip => 1 },
'DBIx::Class::DB' => { skip => 1 },
# skipped because the synopsis covers it clearly
'DBIx::Class::InflateColumn::File' => { skip => 1 },
+
+# internal subclass, nothing to POD
+ 'DBIx::Class::ResultSet::Pager' => { skip => 1 },
};
my $ex_lookup = {};
foreach my $module (@modules) {
SKIP: {
- my ($match) = List::Util::first
- { $module =~ $_ }
+ my ($match) =
+ first { $module =~ $_ }
(sort { length $b <=> length $a || $b cmp $a } (keys %$ex_lookup) )
;
projects / dbsrgits/DBIx-Class.git / commitdiff